From f3ea37dbd1dd2c2b916e4e79a8b48340791976ab Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Fri, 28 Apr 2023 10:34:42 +0200 Subject: [PATCH 01/86] updates to remove mct_mod and all other mct related files from share/ --- src/cpl/mct/mosart_cpl_indices.F90 | 91 ----- src/cpl/mct/mosart_import_export.F90 | 194 ---------- src/cpl/mct/rof_comp_mct.F90 | 499 -------------------------- src/riverroute/MOSART_physics_mod.F90 | 2 +- src/riverroute/RtmIO.F90 | 2 +- src/riverroute/RtmMctMod.F90 | 33 ++ src/riverroute/RtmMod.F90 | 13 +- src/riverroute/RunoffMod.F90 | 3 +- 8 files changed, 46 insertions(+), 791 deletions(-) delete mode 100644 src/cpl/mct/mosart_cpl_indices.F90 delete mode 100644 src/cpl/mct/mosart_import_export.F90 delete mode 100644 src/cpl/mct/rof_comp_mct.F90 create mode 100644 src/riverroute/RtmMctMod.F90 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/riverroute/MOSART_physics_mod.F90 b/src/riverroute/MOSART_physics_mod.F90 index a2d327f..5f9e085 100644 --- a/src/riverroute/MOSART_physics_mod.F90 +++ b/src/riverroute/MOSART_physics_mod.F90 @@ -18,7 +18,7 @@ MODULE MOSART_physics_mod 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 + use RtmMctMod implicit none private diff --git a/src/riverroute/RtmIO.F90 b/src/riverroute/RtmIO.F90 index 3e676ba..7d5162a 100644 --- a/src/riverroute/RtmIO.F90 +++ b/src/riverroute/RtmIO.F90 @@ -17,7 +17,7 @@ module RtmIO use RunoffMod , only : rtmCTL use RtmVar , only : spval, ispval, iulog use perf_mod , only : t_startf, t_stopf - use mct_mod + use RtmMctMod use pio ! !PUBLIC TYPES: diff --git a/src/riverroute/RtmMctMod.F90 b/src/riverroute/RtmMctMod.F90 new file mode 100644 index 0000000..878d91f --- /dev/null +++ b/src/riverroute/RtmMctMod.F90 @@ -0,0 +1,33 @@ +module RtmMctMod + + use m_MCTWorld , only: mct_world_init => init + + use m_AttrVect , only: mct_aVect => AttrVect + use m_AttrVect , only: mct_aVect_init => init + use m_AttrVect , only: mct_aVect_clean => clean + use m_AttrVect , only: mct_aVect_zero => zero + use m_AttrVect , only: mct_aVect_lsize => lsize + use m_AttrVect , only: mct_aVect_indexIA => indexIA + use m_AttrVect , only: mct_aVect_indexRA => indexRA + + use m_AttrVectComms , only: mct_aVect_scatter => scatter + use m_AttrVectComms , only: mct_aVect_gather => gather + + use m_MatAttrVectMul , only: mct_sMat_avMult => sMatAvMult + + use m_GlobalSegMap , only: mct_gsMap => GlobalSegMap + use m_GlobalSegMap , only: mct_gsMap_init => init + use m_GlobalSegMap , only: mct_gsMap_clean => clean + + use m_SparseMatrix , only: mct_sMat => SparseMatrix + use m_SparseMatrix , only: mct_sMat_Init => init + use m_SparseMatrix , only: mct_sMat_Clean => clean + use m_SparseMatrix , only: mct_sMat_indexIA => indexIA + use m_SparseMatrix , only: mct_sMat_indexRA => indexRA + use m_SparseMatrix , only: mct_sMat_GNumEl => GlobalNumElements + + use m_SparseMatrixPlus , only: mct_sMatP => SparseMatrixPlus + use m_SparseMatrixPlus , only: mct_sMatP_Init => init + use m_SparseMatrixPlus , only: mct_sMatP_clean => clean + +end module RtmMctMod diff --git a/src/riverroute/RtmMod.F90 b/src/riverroute/RtmMod.F90 index c597256..52b66b4 100644 --- a/src/riverroute/RtmMod.F90 +++ b/src/riverroute/RtmMod.F90 @@ -10,7 +10,8 @@ module RtmMod ! ! !USES: use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_sys_mod , only : shr_sys_flush + use shr_sys_mod , only : shr_sys_flush, 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 RtmVar , only : nt_rtm, rtm_tracers use RtmSpmd , only : masterproc, npes, iam, mpicom_rof, ROFID, mastertask, & @@ -42,7 +43,7 @@ module RtmMod use MOSART_physics_mod, only : updatestate_hillslope, updatestate_subnetwork, & updatestate_mainchannel use RtmIO - use mct_mod + use RtmMctMod use perf_mod use pio ! @@ -353,13 +354,17 @@ subroutine Rtmini 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 !------------------------------------------------------- - ! 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. & diff --git a/src/riverroute/RunoffMod.F90 b/src/riverroute/RunoffMod.F90 index 995be6c..222349c 100644 --- a/src/riverroute/RunoffMod.F90 +++ b/src/riverroute/RunoffMod.F90 @@ -10,8 +10,9 @@ 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 + use RtmMctMod ! !PUBLIC TYPES: implicit none From 0a679be87dc7e32e3a8cc8022b656e69a8096ad3 Mon Sep 17 00:00:00 2001 From: Erik Kluzek Date: Wed, 2 Aug 2023 12:06:06 -0600 Subject: [PATCH 02/86] Add more tests resolving #68 --- cime_config/testdefs/testlist_mosart.xml | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/cime_config/testdefs/testlist_mosart.xml b/cime_config/testdefs/testlist_mosart.xml index b70990a..8164e77 100644 --- a/cime_config/testdefs/testlist_mosart.xml +++ b/cime_config/testdefs/testlist_mosart.xml @@ -5,10 +5,13 @@ + + + - + @@ -17,6 +20,7 @@ + @@ -26,12 +30,13 @@ - + + @@ -69,7 +74,10 @@ + + + @@ -97,6 +105,7 @@ + @@ -106,18 +115,21 @@ + + + - + From d471166ff35623371d939d9f7f5ee0e0e43c50fa Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 11 Dec 2023 22:43:46 +0100 Subject: [PATCH 03/86] first step in removing mct --- cime_config/namelist_definition_mosart.xml | 14 - src/cpl/nuopc/rof_comp_nuopc.F90 | 7 +- src/riverroute/MOSART_physics_mod.F90 | 239 +- src/riverroute/RtmIO.F90 | 1 - src/riverroute/RtmMctMod.F90 | 33 - src/riverroute/RtmMod.F90 | 5285 +++++++++----------- src/riverroute/RtmVar.F90 | 23 +- src/riverroute/RunoffMod.F90 | 65 +- 8 files changed, 2651 insertions(+), 3016 deletions(-) delete mode 100644 src/riverroute/RtmMctMod.F90 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/src/cpl/nuopc/rof_comp_nuopc.F90 b/src/cpl/nuopc/rof_comp_nuopc.F90 index 396dff5..c7bd908 100644 --- a/src/cpl/nuopc/rof_comp_nuopc.F90 +++ b/src/cpl/nuopc/rof_comp_nuopc.F90 @@ -28,9 +28,11 @@ module rof_comp_nuopc 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 rof_comp_share , only : Emesh + 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 @@ -444,7 +446,6 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) integer, intent(out) :: rc ! local variables - type(ESMF_Mesh) :: Emesh type(ESMF_DistGrid) :: DistGrid ! esmf global index space descriptor type(ESMF_VM) :: vm integer , allocatable :: gindex(:) ! global index space on my processor diff --git a/src/riverroute/MOSART_physics_mod.F90 b/src/riverroute/MOSART_physics_mod.F90 index 5f9e085..558f954 100644 --- a/src/riverroute/MOSART_physics_mod.F90 +++ b/src/riverroute/MOSART_physics_mod.F90 @@ -2,8 +2,8 @@ ! 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. +! +! 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 @@ -13,20 +13,20 @@ MODULE MOSART_physics_mod 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 RtmVar , only : iulog, barrier_timers, nt_rtm, rtm_tracers, & + srcfield, dstfield, rh_direct, rh_eroutUp 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 RtmMctMod + use ESMF 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)) + 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 @@ -37,18 +37,21 @@ MODULE MOSART_physics_mod 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 + + ! solve the ODEs with Euler algorithm + + ! 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 @@ -69,91 +72,90 @@ subroutine Euler 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 + 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') + 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 + 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') + call t_stopf('mosartr_subnetwork') !------------------ ! upstream interactions !------------------ if (barrier_timers) then - call t_startf('mosartr_SMeroutUp_barrier') + call t_startf('mosartr_SMeroutUp_barrier') call mpi_barrier(mpicom_rof,ier) - call t_stopf('mosartr_SMeroutUp_barrier') + call t_stopf('mosartr_SMeroutUp_barrier') endif - call t_startf('mosartr_SMeroutUp') + 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) + src_eroutUp(:,:) = 0._r8 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) + avsrc_eroutUp(nt,cnt) = TRunoff%erout(iunit,nt) enddo enddo - call mct_avect_zero(avdst_eroutUp) - call mct_sMat_avMult(avsrc_eroutUp, sMatP_eroutUp, avdst_eroutUp) + call ESMF_FieldSMM(srcfield, dstField, rh_eroutUp, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) !--- 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) + TRunoff%eroutUp(iunit,nt) = dst_eroutUp(nt,cnt) enddo enddo -#endif - call t_stopf('mosartr_SMeroutUp') + + call t_stopf('mosartr_SMeroutUp') TRunoff%eroutup_avg = TRunoff%eroutup_avg + TRunoff%eroutUp TRunoff%erlat_avg = TRunoff%erlat_avg + TRunoff%erlateral @@ -162,7 +164,7 @@ subroutine Euler ! channel routing !------------------ - call t_startf('mosartr_chanroute') + call t_startf('mosartr_chanroute') do nt=1,nt_rtm if (TUnit%euler_calc(nt)) then do iunit=rtmCTL%begr,rtmCTL%endr @@ -170,13 +172,13 @@ subroutine Euler 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) + 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 + ! 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 @@ -189,7 +191,7 @@ subroutine Euler end do ! nt negchan = min(negchan, minval(TRunoff%wr(:,:))) - call t_stopf('mosartr_chanroute') + call t_stopf('mosartr_chanroute') end do ! check for negative channel storage @@ -209,17 +211,17 @@ 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 + 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) + 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)) + TRunoff%dwh(iunit,nt) = (TRunoff%qsur(iunit,nt) + TRunoff%ehout(iunit,nt)) end subroutine hillslopeRouting @@ -227,7 +229,7 @@ end subroutine hillslopeRouting subroutine subnetworkRouting(iunit,nt,theDeltaT) ! !DESCRIPTION: subnetwork channel routing - implicit none + implicit none integer, intent(in) :: iunit,nt real(r8), intent(in) :: theDeltaT @@ -258,9 +260,9 @@ end subroutine subnetworkRouting subroutine mainchannelRouting(iunit, nt, theDeltaT) ! !DESCRIPTION: main channel routing - implicit none + implicit none integer, intent(in) :: iunit, nt - real(r8), intent(in) :: theDeltaT + real(r8), intent(in) :: theDeltaT if(Tctl%RoutingMethod == 1) then call Routing_KW(iunit, nt, theDeltaT) @@ -280,10 +282,10 @@ 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 + implicit none + + integer, intent(in) :: iunit, nt + real(r8), intent(in) :: theDeltaT integer :: k real(r8) :: temp_gwl, temp_dwr, temp_gwl0 @@ -319,12 +321,12 @@ subroutine Routing_KW(iunit, nt, theDeltaT) 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,*) '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,*) ' ' @@ -339,8 +341,8 @@ subroutine Routing_KW(iunit, nt, theDeltaT) ! 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 +! stop +! end if end subroutine Routing_KW @@ -348,40 +350,40 @@ end subroutine Routing_KW subroutine Routing_MC(iunit, nt, theDeltaT) ! !DESCRIPTION: Muskingum-Cunge routing method - implicit none - integer, intent(in) :: iunit, nt + 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 + 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 + 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 + implicit none integer, intent(in) :: iunit, nt - TRunoff%yh(iunit,nt) = TRunoff%wh(iunit,nt) !/ TUnit%area(iunit) / TUnit%frac(iunit) + TRunoff%yh(iunit,nt) = TRunoff%wh(iunit,nt) !/ TUnit%area(iunit) / TUnit%frac(iunit) end subroutine updateState_hillslope @@ -389,11 +391,11 @@ end subroutine updateState_hillslope subroutine updateState_subnetwork(iunit,nt) ! !DESCRIPTION: update the state variables in subnetwork channel - implicit none + 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%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)) @@ -409,11 +411,11 @@ end subroutine updateState_subnetwork subroutine updateState_mainchannel(iunit, nt) ! !DESCRIPTION: update the state variables in main channel - implicit none + 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%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)) @@ -426,13 +428,13 @@ subroutine updateState_mainchannel(iunit, nt) 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 @@ -440,9 +442,9 @@ function CRVRMAN(slp_, n_, rr_) result(v_) else !tcraig, original code ! ftemp = 2._r8/3._r8 -! v_ = (rr_**ftemp) * sqrt(slp_) / n_ +! v_ = (rr_**ftemp) * sqrt(slp_) / n_ !tcraig, produces same answer as original in same time -! v_ = (rr_**(2._r8/3._r8)) * sqrt(slp_) / n_ +! 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_ @@ -455,13 +457,13 @@ function CRVRMAN(slp_, n_, rr_) result(v_) 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 @@ -469,9 +471,9 @@ function CRVRMAN_nosqrt(sqrtslp_, n_, rr_) result(v_) else !tcraig, original code ! ftemp = 2._r8/3._r8 -! v_ = (rr_**ftemp) * sqrtslp_ / n_ +! v_ = (rr_**ftemp) * sqrtslp_ / n_ !tcraig, produces same answer as original in same time -! v_ = (rr_**(2._r8/3._r8)) * sqrtslp_ / n_ +! 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_ @@ -490,7 +492,7 @@ function CREHT(hslp_, nh_, Gxr_, yh_) result(eht_) 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_ @@ -504,7 +506,7 @@ function CREHT_nosqrt(sqrthslp_, nh_, Gxr_, yh_) result(eht_) 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_ @@ -518,11 +520,11 @@ function GRMR(wr_, rlen_) result(mr_) 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_) @@ -530,7 +532,7 @@ function GRHT(mt_, twid_) result(ht_) 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 @@ -546,7 +548,7 @@ function GRPT(ht_, twid_) result(pt_) 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 @@ -562,7 +564,7 @@ function GRRR(mr_, pr_) result(rr_) 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 @@ -582,7 +584,7 @@ function GRHR(mr_, rwidth_, rwidth0_, rdepth_) result(hr_) 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_ @@ -605,7 +607,7 @@ function GRHR(mr_, rwidth_, rwidth0_, rdepth_) result(hr_) end if return end function GRHR - + !----------------------------------------------------------------------- function GRPR(hr_, rwidth_, rwidth0_,rdepth_) result(pr_) @@ -617,7 +619,7 @@ function GRPR(hr_, rwidth_, rwidth0_,rdepth_) result(pr_) 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. @@ -645,8 +647,8 @@ function GRPR(hr_, rwidth_, rwidth0_,rdepth_) result(pr_) end if end if return - end function GRPR - + end function GRPR + !----------------------------------------------------------------------- subroutine createFile(nio, fname) @@ -654,7 +656,7 @@ subroutine createFile(nio, fname) implicit none character(len=*), intent(in) :: fname ! file name integer, intent(in) :: nio !unit of the file to create - + integer :: ios logical :: filefound character(len=1000) :: cmd @@ -670,17 +672,17 @@ subroutine createFile(nio, fname) 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), & @@ -701,10 +703,9 @@ subroutine printTest(nio) !end if !write(unit=nio,fmt="((a10),7(e20.11))") theTime, liqWater%erlateral(ii)/(TUnit%area(ii)*TUnit%frac(ii)), liqWater%wr(ii),liqWater%mr(ii), liqWater%yr(ii), liqWater%pr(ii), liqWater%rr(ii), liqWater%flow(ii) !write(unit=nio,fmt="((a10),7(e20.11))") theTime, liqWater%yh(ii), liqWater%dwh(ii),liqWater%etin(ii), liqWater%vr(ii), liqWater%erin(ii), liqWater%erout(ii)/(TUnit%area(ii)*TUnit%frac(ii)), liqWater%flow(ii) - + end subroutine printTest !----------------------------------------------------------------------- end MODULE MOSART_physics_mod - diff --git a/src/riverroute/RtmIO.F90 b/src/riverroute/RtmIO.F90 index 7d5162a..8e685c5 100644 --- a/src/riverroute/RtmIO.F90 +++ b/src/riverroute/RtmIO.F90 @@ -746,7 +746,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 ! diff --git a/src/riverroute/RtmMctMod.F90 b/src/riverroute/RtmMctMod.F90 deleted file mode 100644 index 878d91f..0000000 --- a/src/riverroute/RtmMctMod.F90 +++ /dev/null @@ -1,33 +0,0 @@ -module RtmMctMod - - use m_MCTWorld , only: mct_world_init => init - - use m_AttrVect , only: mct_aVect => AttrVect - use m_AttrVect , only: mct_aVect_init => init - use m_AttrVect , only: mct_aVect_clean => clean - use m_AttrVect , only: mct_aVect_zero => zero - use m_AttrVect , only: mct_aVect_lsize => lsize - use m_AttrVect , only: mct_aVect_indexIA => indexIA - use m_AttrVect , only: mct_aVect_indexRA => indexRA - - use m_AttrVectComms , only: mct_aVect_scatter => scatter - use m_AttrVectComms , only: mct_aVect_gather => gather - - use m_MatAttrVectMul , only: mct_sMat_avMult => sMatAvMult - - use m_GlobalSegMap , only: mct_gsMap => GlobalSegMap - use m_GlobalSegMap , only: mct_gsMap_init => init - use m_GlobalSegMap , only: mct_gsMap_clean => clean - - use m_SparseMatrix , only: mct_sMat => SparseMatrix - use m_SparseMatrix , only: mct_sMat_Init => init - use m_SparseMatrix , only: mct_sMat_Clean => clean - use m_SparseMatrix , only: mct_sMat_indexIA => indexIA - use m_SparseMatrix , only: mct_sMat_indexRA => indexRA - use m_SparseMatrix , only: mct_sMat_GNumEl => GlobalNumElements - - use m_SparseMatrixPlus , only: mct_sMatP => SparseMatrixPlus - use m_SparseMatrixPlus , only: mct_sMatP_Init => init - use m_SparseMatrixPlus , only: mct_sMatP_clean => clean - -end module RtmMctMod diff --git a/src/riverroute/RtmMod.F90 b/src/riverroute/RtmMod.F90 index 52b66b4..5460423 100644 --- a/src/riverroute/RtmMod.F90 +++ b/src/riverroute/RtmMod.F90 @@ -1,2849 +1,2542 @@ 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, 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 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 RtmMctMod - 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 -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- + !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, 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 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, decomp_option, & + bypass_routing_option, qgwl_runoff_option, barrier_timers, & + srcfield, dstfield, rh_direct, rh_eroutUp + 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, & + use MOSART_physics_mod , only : Euler + use MOSART_physics_mod , only : updatestate_hillslope, updatestate_subnetwork, & + updatestate_mainchannel + use RtmIO + use perf_mod + use pio + use ESMF + ! + ! !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 :: 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 1d grid cell (deg) + real(r8),pointer :: rlonc(:) ! longitude of 1d grid cell (deg) + real(r8),pointer :: rlats(:) ! latitude of 1d south grid cell edge (deg) + real(r8),pointer :: rlatn(:) ! latitude of 1d north grid cell edge (deg) + real(r8),pointer :: rlonw(:) ! longitude of 1d west grid cell edge (deg) + real(r8),pointer :: rlone(:) ! longitude of 1d east grid cell edge (deg) + + logical :: do_rtmflood + + character(len=256) :: nlfilename_rof = 'mosart_in' + ! + !EOP + !----------------------------------------------------------------------- contains -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: Rtminit_namelist -! -! !INTERFACE: - subroutine Rtminit_namelist(flood_active) -! -! !DESCRIPTION: -! Read and distribute mosart namelist -! -! !USES: -! -! !ARGUMENTS: - implicit none - logical, intent(out) :: flood_active -! -! !CALLED FROM: -! subroutine initialize in module initializeMod -! -! !REVISION HISTORY: -! Author: Sam Levis -! Update: T Craig, Dec 2006 -! Update: J Edwards, Jun 2022 -! -! -! !LOCAL VARIABLES: -!EOP - integer :: i - integer :: ier ! error code - integer :: unitn ! unit for namelist file - logical :: lexist ! File exists - character(len= 7) :: runtyp(4) ! run type - character(len=*),parameter :: subname = '(Rtminit_namelist) ' -!----------------------------------------------------------------------- - - !------------------------------------------------------- - ! Read in mosart namelist - !------------------------------------------------------- - - namelist /mosart_inparm / ice_runoff, do_rtmflood, & - frivinp_rtm, finidat_rtm, nrevsn_rtm, coupling_period, & - rtmhist_ndens, rtmhist_mfilt, rtmhist_nhtfrq, & - rtmhist_fincl1, rtmhist_fincl2, rtmhist_fincl3, & - rtmhist_fexcl1, rtmhist_fexcl2, rtmhist_fexcl3, & - rtmhist_avgflag_pertape, decomp_option, & - bypass_routing_option, qgwl_runoff_option, & - smat_option, delt_mosart - - ! Preset values - do_rtmflood = .false. - ice_runoff = .true. - finidat_rtm = ' ' - nrevsn_rtm = ' ' - coupling_period = -1 - delt_mosart = 3600 - decomp_option = 'basin' - bypass_routing_option = 'direct_in_place' - qgwl_runoff_option = 'threshold' - smat_option = 'opt' - - nlfilename_rof = "mosart_in" // trim(inst_suffix) - inquire (file = trim(nlfilename_rof), exist = lexist) - if ( .not. lexist ) then - write(iulog,*) subname // ' ERROR: nlfilename_rof does NOT exist:'& - //trim(nlfilename_rof) - call shr_sys_abort(trim(subname)//' ERROR nlfilename_rof does not exist') - end if - if (masterproc) then - unitn = getavu() - write(iulog,*) 'Read in mosart_inparm namelist from: ', trim(nlfilename_rof) - open( unitn, file=trim(nlfilename_rof), status='old' ) - ier = 1 - do while ( ier /= 0 ) - read(unitn, mosart_inparm, iostat=ier) - if (ier < 0) then - call shr_sys_abort( subname//' encountered end-of-file on mosart_inparm read' ) - endif - end do - call relavu( unitn ) - end if - - call mpi_bcast (coupling_period, 1, MPI_INTEGER, 0, mpicom_rof, ier) - call mpi_bcast (delt_mosart , 1, MPI_INTEGER, 0, mpicom_rof, ier) - - call mpi_bcast (finidat_rtm , len(finidat_rtm) , MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (frivinp_rtm , len(frivinp_rtm) , MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (nrevsn_rtm , len(nrevsn_rtm) , MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (decomp_option, len(decomp_option), MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (smat_option , len(smat_option) , MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (bypass_routing_option, len(bypass_routing_option), MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (qgwl_runoff_option, len(qgwl_runoff_option), MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (do_rtmflood, 1, MPI_LOGICAL, 0, mpicom_rof, ier) - call mpi_bcast (ice_runoff, 1, MPI_LOGICAL, 0, mpicom_rof, ier) - - call mpi_bcast (rtmhist_nhtfrq, size(rtmhist_nhtfrq), MPI_INTEGER, 0, mpicom_rof, ier) - call mpi_bcast (rtmhist_mfilt , size(rtmhist_mfilt) , MPI_INTEGER, 0, mpicom_rof, ier) - call mpi_bcast (rtmhist_ndens , size(rtmhist_ndens) , MPI_INTEGER, 0, mpicom_rof, ier) - - call mpi_bcast (rtmhist_fexcl1, (max_namlen+2)*size(rtmhist_fexcl1), MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (rtmhist_fexcl2, (max_namlen+2)*size(rtmhist_fexcl2), MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (rtmhist_fexcl3, (max_namlen+2)*size(rtmhist_fexcl3), MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (rtmhist_fincl1, (max_namlen+2)*size(rtmhist_fincl1), MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (rtmhist_fincl2, (max_namlen+2)*size(rtmhist_fincl2), MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (rtmhist_fincl3, (max_namlen+2)*size(rtmhist_fincl3), MPI_CHARACTER, 0, mpicom_rof, ier) - - call mpi_bcast (rtmhist_avgflag_pertape, size(rtmhist_avgflag_pertape), MPI_CHARACTER, 0, mpicom_rof, ier) - - runtyp(:) = 'missing' - runtyp(nsrStartup + 1) = 'initial' - runtyp(nsrContinue + 1) = 'restart' - runtyp(nsrBranch + 1) = 'branch ' - - if (masterproc) then - write(iulog,*) 'define run:' - write(iulog,*) ' run type = ',runtyp(nsrest+1) - !write(iulog,*) ' case title = ',trim(ctitle) - !write(iulog,*) ' username = ',trim(username) - !write(iulog,*) ' hostname = ',trim(hostname) - write(iulog,*) ' coupling_period = ',coupling_period - write(iulog,*) ' delt_mosart = ',delt_mosart - write(iulog,*) ' decomp option = ',trim(decomp_option) - write(iulog,*) ' bypass_routing option = ',trim(bypass_routing_option) - write(iulog,*) ' qgwl runoff option = ',trim(qgwl_runoff_option) - write(iulog,*) ' smat option = ',trim(smat_option) - if (nsrest == nsrStartup .and. finidat_rtm /= ' ') then - write(iulog,*) ' MOSART initial data = ',trim(finidat_rtm) - end if - endif - - flood_active = do_rtmflood - - if (frivinp_rtm == ' ') then - call shr_sys_abort( subname//' ERROR: frivinp_rtm NOT set' ) - else - if (masterproc) then - write(iulog,*) ' MOSART river data = ',trim(frivinp_rtm) - endif - end if - - if (trim(bypass_routing_option) == 'direct_to_outlet') then - if (trim(qgwl_runoff_option) == 'threshold') then - call shr_sys_abort( subname//' ERROR: qgwl_runoff_option can NOT be threshold if bypass_routing_option==direct_to_outlet' ) - end if - else if (trim(bypass_routing_option) == 'none') then - if (trim(qgwl_runoff_option) /= 'all') then - call shr_sys_abort( subname//' ERROR: qgwl_runoff_option can only be all if bypass_routing_option==none' ) - end if - end if - - if (coupling_period <= 0) then - write(iulog,*) subname,' ERROR MOSART coupling_period invalid',coupling_period - call shr_sys_abort( subname//' ERROR: coupling_period invalid' ) - endif - - if (delt_mosart <= 0) then - write(iulog,*) subname,' ERROR MOSART delt_mosart invalid',delt_mosart - call shr_sys_abort( subname//' ERROR: delt_mosart invalid' ) - endif - - do i = 1, max_tapes - if (rtmhist_nhtfrq(i) == 0) then - rtmhist_mfilt(i) = 1 - else if (rtmhist_nhtfrq(i) < 0) then - rtmhist_nhtfrq(i) = nint(-rtmhist_nhtfrq(i)*SHR_CONST_CDAY/(24._r8*coupling_period)) - endif - end do - end subroutine Rtminit_namelist -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: Rtmini -! -! !INTERFACE: - subroutine Rtmini - -! -! !DESCRIPTION: -! Initialize MOSART grid, mask, decomp -! -! !USES: -! -! !ARGUMENTS: - implicit none -! -! !CALLED FROM: -! subroutine initialize in module initializeMod -! -! !REVISION HISTORY: -! Author: Sam Levis -! Update: T Craig, Dec 2006 -! Update: J Edwards, Jun 2022 -! -! -! !LOCAL VARIABLES: - - real(r8) :: effvel0 = 10.0_r8 ! default velocity (m/s) - real(r8) :: effvel(nt_rtm) ! downstream velocity (m/s) - integer ,pointer :: rgdc2glo(:) ! temporary for initialization - integer ,pointer :: rglo2gdc(:) ! temporary for initialization - type(file_desc_t) :: ncid ! netcdf file id - integer :: dimid ! netcdf dimension identifier - real(r8) :: lrtmarea ! tmp local sum of area - integer :: cnt, lsize, gsize ! counter - - real(r8) :: deg2rad ! pi/180 - integer :: g, n, i, j, nr, nt ! iterators - integer :: nl,nloops ! used for decomp search - character(len=256):: fnamer ! name of netcdf restart file - character(len=256):: pnamer ! full pathname of netcdf restart file - character(len=256):: locfn ! local file name - integer :: ier - real(r8),allocatable :: tempr(:,:) ! temporary buffer - integer ,allocatable :: itempr(:,:) ! temporary buffer - logical :: found ! flag - integer :: numr ! tot num of roff pts on all pes - integer :: pid,np,npmin,npmax,npint ! log loop control - integer :: nmos,nmos_chk ! number of mosart points - integer :: nout,nout_chk ! number of basin with outlets - integer :: nbas,nbas_chk ! number of basin/ocean points - integer :: nrof,nrof_chk ! num of active mosart points - integer :: maxrtm ! max num of rtms per pe for decomp - integer :: minbas,maxbas ! used for decomp search - real(r8) :: edgen ! North edge of the direction file - real(r8) :: edgee ! East edge of the direction file - real(r8) :: edges ! South edge of the direction file - real(r8) :: edgew ! West edge of the direction file - real(r8) :: dx,dx1,dx2,dx3 ! lon dist. betn grid cells (m) - real(r8) :: dy ! lat dist. betn grid cells (m) - integer :: igrow,igcol,iwgt ! mct field indices - type(mct_avect) :: avtmp, avtmpG ! temporary avects - type(mct_sMat) :: sMat ! temporary sparse matrix, needed for sMatP - character(len=16384) :: rList ! list of fields for SM multiply - integer :: baspe ! pe with min number of mosart cells - integer ,pointer :: gmask(:) ! global mask - integer ,allocatable :: idxocn(:) ! downstream ocean outlet cell - integer ,allocatable :: nupstrm(:) ! number of upstream cells including own cell - integer ,allocatable :: pocn(:) ! pe number assigned to basin - integer ,allocatable :: nop(:) ! number of gridcells on a pe - integer ,allocatable :: nba(:) ! number of basins on each pe - integer ,allocatable :: nrs(:) ! begr on each pe - integer ,allocatable :: basin(:) ! basin to mosart mapping - integer ,allocatable :: gindex(:) ! global index + !----------------------------------------------------------------------- + !BOP + ! + ! !IROUTINE: Rtminit_namelist + ! + ! !INTERFACE: + subroutine Rtminit_namelist(flood_active) + ! + ! !DESCRIPTION: + ! Read and distribute mosart namelist + ! + ! !USES: + ! + ! !ARGUMENTS: + logical, intent(out) :: flood_active + ! + ! !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, & + 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' + + 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 (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) + 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 + character(len=16384) :: rList ! list of fields for SM multiply + integer :: baspe ! pe with min number of mosart cells + integer ,pointer :: gmask(:) ! global mask + integer ,allocatable :: idxocn(:) ! downstream ocean outlet cell + integer ,allocatable :: nupstrm(:) ! number of upstream cells including own cell + integer ,allocatable :: pocn(:) ! pe number assigned to basin + integer ,allocatable :: nop(:) ! number of gridcells on a pe + integer ,allocatable :: nba(:) ! number of basins on each pe + integer ,allocatable :: nrs(:) ! begr on each pe + integer ,allocatable :: basin(:) ! basin to mosart mapping + integer ,allocatable :: gindex(:) ! global index #ifdef NDEBUG - integer,parameter :: dbug = 0 ! 0 = none, 1=normal, 2=much, 3=max + 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) ' - - !------------------------------------------------------- - ! 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 (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 + integer, allocatable :: factorIndexList(:,:) + real(r8), allocatable :: factorList + character(len=*),parameter :: subname = '(Rtmini) ' + + !------------------------------------------------------- + ! 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 (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 (eve(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 + + !------------------------------------------------------- + ! create srcfield and dstfield + !------------------------------------------------------- + + 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 + + !------------------------------------------------------- + ! Compute Sparse Matrix for direct to outlet transfer + !------------------------------------------------------- + + 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(iwgt ,cnt) = 1.0_r8 + factorIndexList(1,cnt) = rtmCTL%outletg(nr) + factorIndexList(2,cnt) = rtmCTL%gindex(nr) + else + factorList(iwgt ,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, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + + deallocate(factorList) + deallocate(factorIndexList) + + if (masterproc) write(iulog,*) subname," Done initializing rh_direct " + + !------------------------------------------------------- + ! Compute timestep and subcycling number + !------------------------------------------------------- + + call t_stopf('mosarti_vars') + + !------------------------------------------------------- + ! Initialize mosart + !------------------------------------------------------- + + call t_startf('mosarti_mosart_init') + call MOSART_init() + call t_stopf('mosarti_mosart_init') + + !------------------------------------------------------- + ! Read restart/initial info + !------------------------------------------------------- + + call t_startf('mosarti_restart') + + ! 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 ) + 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 (masterproc) write(iulog,*) subname,' done' + call t_stopf('mosarti_histinit') + + end subroutine Rtmini + + !----------------------------------------------------------------------- + !BOP + ! + ! !IROUTINE: Rtmrun + ! + ! !INTERFACE: + subroutine Rtmrun(rstwr,nlend,rdate) + ! + ! !DESCRIPTION: + ! River routing model + ! + ! !USES: + ! + ! !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 + ! + ! !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 + 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) :: 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] + real(r8), pointer :: src_direct(:,:) + real(r8), pointer :: dst_direct(:,:) + character(len=*),parameter :: subname = '(Rtmrun) ' + !----------------------------------------------------------------------- + + call t_startf('mosartr_tot') + + !----------------------------------------------------- + ! 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 + + !----------------------------------------------------- + ! Get date info + !----------------------------------------------------- + + 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) + 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 + + !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 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') + !--- copy direct transfer fields + !--- convert kg/m2s to m3/s + + !----------------------------------------------------- + !--- 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(cnt,nt) = 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, 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, 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 + 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 + + 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 + + !---- negative qsur water, remove from TRunoff --- + if (TRunoff%qsur(nr,nt) < 0._r8) then + src_direct(nt,cnt) = src_direct(nt,cnt) + TRunoff%qsur(nr,nt) + TRunoff%qsur(nr,nt) = 0._r8 + endif + + !---- water outside the basin --- + !---- *** DO NOT TURN THIS ONE OFF, conservation will fail *** --- + 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, 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. 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 + !----------------------------------- + + 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') + + 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') + + !----------------------------------- + ! accumulate local flow field + !----------------------------------- + + do nt = 1,nt_rtm + do nr = rtmCTL%begr,rtmCTL%endr + flow(nr,nt) = flow(nr,nt) + TRunoff%flow(nr,nt) + erout_prev(nr,nt) = erout_prev(nr,nt) + TRunoff%erout_prev(nr,nt) + eroutup_avg(nr,nt) = eroutup_avg(nr,nt) + TRunoff%eroutup_avg(nr,nt) + erlat_avg(nr,nt) = erlat_avg(nr,nt) + TRunoff%erlat_avg(nr,nt) + enddo + enddo + + enddo ! nsub + + !----------------------------------- + ! average flow over subcycling + !----------------------------------- + + flow = flow / float(nsub) + erout_prev = erout_prev / float(nsub) + eroutup_avg = eroutup_avg / float(nsub) + erlat_avg = erlat_avg / float(nsub) + + !----------------------------------- + ! update states when subsycling completed + !----------------------------------- + + rtmCTL%wh = TRunoff%wh + rtmCTL%wt = TRunoff%wt + rtmCTL%wr = TRunoff%wr + rtmCTL%erout = TRunoff%erout + + do nt = 1,nt_rtm + do nr = rtmCTL%begr,rtmCTL%endr + volr_init = rtmCTL%volr(nr,nt) + rtmCTL%volr(nr,nt) = (TRunoff%wt(nr,nt) + TRunoff%wr(nr,nt) + TRunoff%wh(nr,nt)*rtmCTL%area(nr)) + rtmCTL%dvolrdt(nr,nt) = (rtmCTL%volr(nr,nt) - volr_init) / delt_coupling + rtmCTL%runoff(nr,nt) = flow(nr,nt) + + rtmCTL%runofftot(nr,nt) = rtmCTL%direct(nr,nt) + if (rtmCTL%mask(nr) == 1) then + rtmCTL%runofflnd(nr,nt) = rtmCTL%runoff(nr,nt) + rtmCTL%dvolrdtlnd(nr,nt)= rtmCTL%dvolrdt(nr,nt) + elseif (rtmCTL%mask(nr) >= 2) then + rtmCTL%runoffocn(nr,nt) = rtmCTL%runoff(nr,nt) + rtmCTL%runofftot(nr,nt) = rtmCTL%runofftot(nr,nt) + rtmCTL%runoff(nr,nt) + rtmCTL%dvolrdtocn(nr,nt)= rtmCTL%dvolrdt(nr,nt) + endif + enddo + enddo + + call t_stopf('mosartr_subcycling') + + !----------------------------------- + ! BUDGET + !----------------------------------- + + ! BUDGET + ! BUDGET terms 1-10 are for volumes (m3) + ! BUDGET terms 11-30 are for flows (m3/s) + ! BUDGET only ocean runoff and direct gets out of the system + ! if (budget_check) then + call t_startf('mosartr_budget') + do nt = 1,nt_rtm + do nr = rtmCTL%begr,rtmCTL%endr + budget_terms( 2,nt) = budget_terms( 2,nt) + rtmCTL%volr(nr,nt) + budget_terms( 4,nt) = budget_terms( 4,nt) + TRunoff%wt(nr,nt) + budget_terms( 6,nt) = budget_terms( 6,nt) + TRunoff%wr(nr,nt) + budget_terms( 8,nt) = budget_terms( 8,nt) + TRunoff%wh(nr,nt)*rtmCTL%area(nr) + budget_terms(21,nt) = budget_terms(21,nt) + rtmCTL%direct(nr,nt) + if (rtmCTL%mask(nr) >= 2) then + budget_terms(18,nt) = budget_terms(18,nt) + rtmCTL%runoff(nr,nt) + budget_terms(26,nt) = budget_terms(26,nt) - erout_prev(nr,nt) + budget_terms(27,nt) = budget_terms(27,nt) + flow(nr,nt) + else + budget_terms(23,nt) = budget_terms(23,nt) - erout_prev(nr,nt) + budget_terms(24,nt) = budget_terms(24,nt) + flow(nr,nt) + endif + budget_terms(25,nt) = budget_terms(25,nt) - eroutup_avg(nr,nt) + budget_terms(28,nt) = budget_terms(28,nt) - erlat_avg(nr,nt) + budget_terms(22,nt) = budget_terms(22,nt) + rtmCTL%runoff(nr,nt) + rtmCTL%direct(nr,nt) + eroutup_avg(nr,nt) + enddo + enddo + nt = 1 + do nr = rtmCTL%begr,rtmCTL%endr + budget_terms(19,nt) = budget_terms(19,nt) + rtmCTL%flood(nr) + budget_terms(22,nt) = budget_terms(22,nt) + rtmCTL%flood(nr) + enddo + + ! accumulate the budget total over the run to make sure it's decreasing on avg + budget_accum_cnt = budget_accum_cnt + 1 + do nt = 1,nt_rtm + budget_volume = (budget_terms( 2,nt) - budget_terms( 1,nt)) / delt_coupling + budget_input = (budget_terms(13,nt) + budget_terms(14,nt) + & + budget_terms(15,nt) + budget_terms(16,nt)) + budget_output = (budget_terms(18,nt) + budget_terms(19,nt) + & + budget_terms(21,nt)) + budget_total = budget_volume - budget_input + budget_output + budget_accum(nt) = budget_accum(nt) + budget_total + budget_terms(30,nt) = budget_accum(nt)/budget_accum_cnt + enddo + call t_stopf('mosartr_budget') + + if (budget_check) then + call t_startf('mosartr_budget') + !--- check budget + + ! convert fluxes from m3/s to m3 by mult by coupling_period + budget_terms(11:30,:) = budget_terms(11:30,:) * delt_coupling + + ! convert terms from m3 to million m3 + budget_terms(:,:) = budget_terms(:,:) * 1.0e-6_r8 + + ! global sum + call shr_mpi_sum(budget_terms,budget_global,mpicom_rof,'mosart global budget',all=.false.) + + ! write budget + if (masterproc) then + write(iulog,'(2a,i10,i6)') trim(subname),' MOSART BUDGET diagnostics (million m3) for ',ymd,tod + do nt = 1,nt_rtm + budget_volume = (budget_global( 2,nt) - budget_global( 1,nt)) + budget_input = (budget_global(13,nt) + budget_global(14,nt) + & + budget_global(15,nt)) + budget_output = (budget_global(18,nt) + budget_global(19,nt) + & + budget_global(21,nt)) + budget_total = budget_volume - budget_input + budget_output + budget_euler = budget_volume - budget_global(20,nt) + budget_global(18,nt) + budget_eroutlag = budget_global(23,nt) - budget_global(24,nt) + write(iulog,'(2a,i4)') trim(subname),' tracer = ',nt + write(iulog,'(2a,i4,f22.6)') trim(subname),' volume init = ',nt,budget_global(1,nt) + write(iulog,'(2a,i4,f22.6)') trim(subname),' volume final = ',nt,budget_global(2,nt) + !write(iulog,'(2a,i4,f22.6)') trim(subname),' volumeh init = ',nt,budget_global(7,nt) + !write(iulog,'(2a,i4,f22.6)') trim(subname),' volumeh final = ',nt,budget_global(8,nt) + !write(iulog,'(2a,i4,f22.6)') trim(subname),' volumet init = ',nt,budget_global(3,nt) + !write(iulog,'(2a,i4,f22.6)') trim(subname),' volumet final = ',nt,budget_global(4,nt) + !write(iulog,'(2a,i4,f22.6)') trim(subname),' volumer init = ',nt,budget_global(5,nt) + !write(iulog,'(2a,i4,f22.6)') trim(subname),' volumer final = ',nt,budget_global(6,nt) + !write(iulog,'(2a)') trim(subname),'----------------' + write(iulog,'(2a,i4,f22.6)') trim(subname),' input surface = ',nt,budget_global(13,nt) + write(iulog,'(2a,i4,f22.6)') trim(subname),' input subsurf = ',nt,budget_global(14,nt) + write(iulog,'(2a,i4,f22.6)') trim(subname),' input gwl = ',nt,budget_global(15,nt) + write(iulog,'(2a,i4,f22.6)') trim(subname),' input irrig = ',nt,budget_global(16,nt) + write(iulog,'(2a,i4,f22.6)') trim(subname),' input total = ',nt,budget_global(17,nt) + !write(iulog,'(2a,i4,f22.6)') trim(subname),' input check = ',nt,budget_input - budget_global(17,nt) + !write(iulog,'(2a,i4,f22.6)') trim(subname),' input euler = ',nt,budget_global(20,nt) + !write(iulog,'(2a)') trim(subname),'----------------' + write(iulog,'(2a,i4,f22.6)') trim(subname),' output flow = ',nt,budget_global(18,nt) + write(iulog,'(2a,i4,f22.6)') trim(subname),' output direct = ',nt,budget_global(21,nt) + write(iulog,'(2a,i4,f22.6)') trim(subname),' output flood = ',nt,budget_global(19,nt) + write(iulog,'(2a,i4,f22.6)') trim(subname),' output total = ',nt,budget_global(22,nt) + !write(iulog,'(2a,i4,f22.6)') trim(subname),' output check = ',nt,budget_output - budget_global(22,nt) + !write(iulog,'(2a)') trim(subname),'----------------' + write(iulog,'(2a,i4,f22.6)') trim(subname),' sum input = ',nt,budget_input + write(iulog,'(2a,i4,f22.6)') trim(subname),' sum dvolume = ',nt,budget_volume + write(iulog,'(2a,i4,f22.6)') trim(subname),' sum output = ',nt,budget_output + !write(iulog,'(2a)') trim(subname),'----------------' + write(iulog,'(2a,i4,f22.6)') trim(subname),' net (dv-i+o) = ',nt,budget_total + !write(iulog,'(2a,i4,f22.6)') trim(subname),' net euler = ',nt,budget_euler + write(iulog,'(2a,i4,f22.6)') trim(subname),' eul erout lag = ',nt,budget_eroutlag + !write(iulog,'(2a,i4,f22.6)') trim(subname),' accum (dv-i+o)= ',nt,budget_global(30,nt) + !write(iulog,'(2a)') trim(subname),'----------------' + !write(iulog,'(2a,i4,f22.6)') trim(subname),' erout_prev no= ',nt,budget_global(23,nt) + !write(iulog,'(2a,i4,f22.6)') trim(subname),' erout no= ',nt,budget_global(24,nt) + !write(iulog,'(2a,i4,f22.6)') trim(subname),' eroutup_avg = ',nt,budget_global(25,nt) + !write(iulog,'(2a,i4,f22.6)') trim(subname),' erout_prev out= ',nt,budget_global(26,nt) + !write(iulog,'(2a,i4,f22.6)') trim(subname),' erout out= ',nt,budget_global(27,nt) + !write(iulog,'(2a,i4,f22.6)') trim(subname),' erlateral = ',nt,budget_global(28,nt) + !write(iulog,'(2a,i4,f22.6)') trim(subname),' euler gwl = ',nt,budget_global(29,nt) + !write(iulog,'(2a,i4,f22.6)') trim(subname),' net main chan = ',nt,& + ! budget_global(6,nt)-budget_global(5,nt)+budget_global(24,nt)& + ! -budget_global(23,nt)+budget_global(27,nt)+budget_global(28,nt)+budget_global(29,nt) + !write(iulog,'(2a)') trim(subname),'----------------' + + if ((budget_total-budget_eroutlag) > 1.0e-6) then + write(iulog,'(2a,i4)') trim(subname),' ***** BUDGET WARNING error gt 1. m3 for nt = ',nt + endif + if ((budget_total+budget_eroutlag) >= 1.0e-6) then + if ((budget_total-budget_eroutlag)/(budget_total+budget_eroutlag) > 0.001_r8) then + write(iulog,'(2a,i4)') trim(subname),' ***** BUDGET WARNING out of balance for nt = ',nt + endif + endif + enddo + write(iulog,'(a)') '----------------------------------- ' + endif + + call t_stopf('mosartr_budget') + endif ! budget_check + + !----------------------------------- + ! Write out MOSART history file + !----------------------------------- + + call t_startf('mosartr_hbuf') + call RtmHistFldsSet() + call RtmHistUpdateHbuf() + call t_stopf('mosartr_hbuf') + + call t_startf('mosartr_htapes') + call RtmHistHtapesWrapup( rstwr, nlend ) + call t_stopf('mosartr_htapes') + + !----------------------------------- + ! Write out MOSART restart file + !----------------------------------- + + if (rstwr) then + call t_startf('mosartr_rest') + filer = RtmRestFileName(rdate=rdate) + call RtmRestFileWrite( filer, rdate=rdate ) + call t_stopf('mosartr_rest') + end if + + !----------------------------------- + ! Done + !----------------------------------- + + first_call = .false. + + call shr_sys_flush(iulog) + call t_stopf('mosartr_tot') + + end subroutine Rtmrun + + !----------------------------------------------------------------------- + + subroutine RtmFloodInit(frivinp, begr, endr, fthresh, evel ) + + !----------------------------------------------------------------------- + ! Uses + + ! Input variables + character(len=*), intent(in) :: frivinp + integer , intent(in) :: begr, endr + real(r8), intent(out) :: fthresh(begr:endr) + real(r8), intent(out) :: evel(begr:endr,nt_rtm) + + ! Local variables + real(r8) , pointer :: rslope(:) + real(r8) , pointer :: max_volr(:) + integer, pointer :: compdof(:) ! computational degrees of freedom for pio + integer :: nt,n,cnt ! indices + logical :: readvar ! read variable in or not + integer :: ier ! status variable + integer :: dids(2) ! variable dimension ids + type(file_desc_t) :: ncid ! pio file desc + type(var_desc_t) :: vardesc ! pio variable desc + type(io_desc_t) :: iodesc ! pio io desc + character(len=256) :: locfn ! local file name + + !MOSART Flood variables for spatially varying celerity + real(r8) :: effvel(nt_rtm) = 0.7_r8 ! downstream velocity (m/s) + real(r8) :: min_ev(nt_rtm) = 0.35_r8 ! minimum downstream velocity (m/s) + real(r8) :: fslope = 1.0_r8 ! maximum slope for which flooding can occur + character(len=*),parameter :: subname = '(RtmFloodInit) ' + !----------------------------------------------------------------------- + + allocate(rslope(begr:endr), max_volr(begr:endr), stat=ier) + if (ier /= 0) call shr_sys_abort(subname // ' allocation ERROR') + + ! Assume that if SLOPE is on river input dataset so is MAX_VOLR and that + ! both have the same io descriptor + + call getfil(frivinp, locfn, 0 ) + call ncd_pio_openfile (ncid, trim(locfn), 0) + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + ier = pio_inq_varid(ncid, name='SLOPE', vardesc=vardesc) + if (ier /= PIO_noerr) then + if (masterproc) write(iulog,*) subname//' variable SLOPE is not on dataset' + readvar = .false. + else + readvar = .true. + end if + call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + if (readvar) then + ier = pio_inq_vardimid(ncid, vardesc, dids) + allocate(compdof(rtmCTL%lnumr)) + cnt = 0 + do n = rtmCTL%begr,rtmCTL%endr + cnt = cnt + 1 + compDOF(cnt) = rtmCTL%gindex(n) + enddo + call pio_initdecomp(pio_subsystem, pio_double, dids, compDOF, iodesc) + deallocate(compdof) + ! tcraig, there ia bug here, shouldn't use same vardesc for two different variable + call pio_read_darray(ncid, vardesc, iodesc, rslope, ier) + call pio_read_darray(ncid, vardesc, iodesc, max_volr, ier) + call pio_freedecomp(ncid, iodesc) + else + rslope(:) = 1._r8 + max_volr(:) = spval + end if + call pio_closefile(ncid) + + do nt = 1,nt_rtm + do n = rtmCTL%begr, rtmCTL%endr + fthresh(n) = 0.95*max_volr(n)*max(1._r8,rslope(n)) + ! modify velocity based on gridcell average slope (Manning eqn) + evel(n,nt) = max(min_ev(nt),effvel(nt_rtm)*sqrt(max(0._r8,rslope(n)))) + end do + end do + + deallocate(rslope, max_volr) + + end subroutine RtmFloodInit + + !----------------------------------------------------------------------- + !BOP + ! + ! !IROUTINE: + ! + ! !INTERFACE: + subroutine MOSART_init + ! + ! !REVISION HISTORY: + ! Author: Hongyi Li + + ! !DESCRIPTION: + ! initialize MOSART variables + ! + ! !USES: + ! !ARGUMENTS: + ! + ! !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 + 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 + real(r8), pointer :: src_eroutUp(:,:) + real(r8), pointer :: dst_eroutUp(:,:) + character(len=*),parameter :: subname = '(MOSART_init)' + character(len=*),parameter :: FORMI = '(2A,2i10)' + character(len=*),parameter :: FORMR = '(2A,2g15.7)' + !----------------------------------------------------------------------- + + ! 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 + + 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 - 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 + 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 + !------------------------------------------------------- + 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 - 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) + 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%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%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%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%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%nUp(begr:endr)) - TUnit%nUp = 0 + allocate(TUnit%rslpsqrt(begr:endr)) + TUnit%rslpsqrt = 0._r8 - allocate(TUnit%iUp(begr:endr,8)) - TUnit%iUp = 0 + 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%indexDown(begr:endr)) - TUnit%indexDown = 0 + 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) - ! initialize water states and fluxes - allocate (TRunoff%wh(begr:endr,nt_rtm)) - TRunoff%wh = 0._r8 + 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 (TRunoff%dwh(begr:endr,nt_rtm)) - TRunoff%dwh = 0._r8 + 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 (TRunoff%yh(begr:endr,nt_rtm)) - TRunoff%yh = 0._r8 + allocate(TUnit%nUp(begr:endr)) + TUnit%nUp = 0 - allocate (TRunoff%qsur(begr:endr,nt_rtm)) - TRunoff%qsur = 0._r8 + allocate(TUnit%iUp(begr:endr,8)) + TUnit%iUp = 0 - allocate (TRunoff%qsub(begr:endr,nt_rtm)) - TRunoff%qsub = 0._r8 + allocate(TUnit%indexDown(begr:endr)) + TUnit%indexDown = 0 - allocate (TRunoff%qgwl(begr:endr,nt_rtm)) - TRunoff%qgwl = 0._r8 + ! initialize water states and fluxes + allocate (TRunoff%wh(begr:endr,nt_rtm)) + TRunoff%wh = 0._r8 - allocate (TRunoff%ehout(begr:endr,nt_rtm)) - TRunoff%ehout = 0._r8 + allocate (TRunoff%dwh(begr:endr,nt_rtm)) + TRunoff%dwh = 0._r8 - allocate (TRunoff%tarea(begr:endr,nt_rtm)) - TRunoff%tarea = 0._r8 + allocate (TRunoff%yh(begr:endr,nt_rtm)) + TRunoff%yh = 0._r8 - allocate (TRunoff%wt(begr:endr,nt_rtm)) - TRunoff%wt= 0._r8 + allocate (TRunoff%qsur(begr:endr,nt_rtm)) + TRunoff%qsur = 0._r8 - allocate (TRunoff%dwt(begr:endr,nt_rtm)) - TRunoff%dwt = 0._r8 + allocate (TRunoff%qsub(begr:endr,nt_rtm)) + TRunoff%qsub = 0._r8 - allocate (TRunoff%yt(begr:endr,nt_rtm)) - TRunoff%yt = 0._r8 + allocate (TRunoff%qgwl(begr:endr,nt_rtm)) + TRunoff%qgwl = 0._r8 - allocate (TRunoff%mt(begr:endr,nt_rtm)) - TRunoff%mt = 0._r8 + allocate (TRunoff%ehout(begr:endr,nt_rtm)) + TRunoff%ehout = 0._r8 - allocate (TRunoff%rt(begr:endr,nt_rtm)) - TRunoff%rt = 0._r8 + allocate (TRunoff%tarea(begr:endr,nt_rtm)) + TRunoff%tarea = 0._r8 - allocate (TRunoff%pt(begr:endr,nt_rtm)) - TRunoff%pt = 0._r8 + allocate (TRunoff%wt(begr:endr,nt_rtm)) + TRunoff%wt= 0._r8 - allocate (TRunoff%vt(begr:endr,nt_rtm)) - TRunoff%vt = 0._r8 + allocate (TRunoff%dwt(begr:endr,nt_rtm)) + TRunoff%dwt = 0._r8 - allocate (TRunoff%tt(begr:endr,nt_rtm)) - TRunoff%tt = 0._r8 + allocate (TRunoff%yt(begr:endr,nt_rtm)) + TRunoff%yt = 0._r8 - allocate (TRunoff%etin(begr:endr,nt_rtm)) - TRunoff%etin = 0._r8 + allocate (TRunoff%mt(begr:endr,nt_rtm)) + TRunoff%mt = 0._r8 - allocate (TRunoff%etout(begr:endr,nt_rtm)) - TRunoff%etout = 0._r8 + allocate (TRunoff%rt(begr:endr,nt_rtm)) + TRunoff%rt = 0._r8 - allocate (TRunoff%rarea(begr:endr,nt_rtm)) - TRunoff%rarea = 0._r8 + allocate (TRunoff%pt(begr:endr,nt_rtm)) + TRunoff%pt = 0._r8 - allocate (TRunoff%wr(begr:endr,nt_rtm)) - TRunoff%wr = 0._r8 + allocate (TRunoff%vt(begr:endr,nt_rtm)) + TRunoff%vt = 0._r8 - allocate (TRunoff%dwr(begr:endr,nt_rtm)) - TRunoff%dwr = 0._r8 + allocate (TRunoff%tt(begr:endr,nt_rtm)) + TRunoff%tt = 0._r8 - allocate (TRunoff%yr(begr:endr,nt_rtm)) - TRunoff%yr = 0._r8 + allocate (TRunoff%etin(begr:endr,nt_rtm)) + TRunoff%etin = 0._r8 - allocate (TRunoff%mr(begr:endr,nt_rtm)) - TRunoff%mr = 0._r8 + allocate (TRunoff%etout(begr:endr,nt_rtm)) + TRunoff%etout = 0._r8 - allocate (TRunoff%rr(begr:endr,nt_rtm)) - TRunoff%rr = 0._r8 + allocate (TRunoff%rarea(begr:endr,nt_rtm)) + TRunoff%rarea = 0._r8 - allocate (TRunoff%pr(begr:endr,nt_rtm)) - TRunoff%pr = 0._r8 + allocate (TRunoff%wr(begr:endr,nt_rtm)) + TRunoff%wr = 0._r8 - allocate (TRunoff%vr(begr:endr,nt_rtm)) - TRunoff%vr = 0._r8 + allocate (TRunoff%dwr(begr:endr,nt_rtm)) + TRunoff%dwr = 0._r8 - allocate (TRunoff%tr(begr:endr,nt_rtm)) - TRunoff%tr = 0._r8 + allocate (TRunoff%yr(begr:endr,nt_rtm)) + TRunoff%yr = 0._r8 - allocate (TRunoff%erlg(begr:endr,nt_rtm)) - TRunoff%erlg = 0._r8 + allocate (TRunoff%mr(begr:endr,nt_rtm)) + TRunoff%mr = 0._r8 - allocate (TRunoff%erlateral(begr:endr,nt_rtm)) - TRunoff%erlateral = 0._r8 + allocate (TRunoff%rr(begr:endr,nt_rtm)) + TRunoff%rr = 0._r8 - allocate (TRunoff%erin(begr:endr,nt_rtm)) - TRunoff%erin = 0._r8 + allocate (TRunoff%pr(begr:endr,nt_rtm)) + TRunoff%pr = 0._r8 - allocate (TRunoff%erout(begr:endr,nt_rtm)) - TRunoff%erout = 0._r8 + allocate (TRunoff%vr(begr:endr,nt_rtm)) + TRunoff%vr = 0._r8 - allocate (TRunoff%erout_prev(begr:endr,nt_rtm)) - TRunoff%erout_prev = 0._r8 + allocate (TRunoff%tr(begr:endr,nt_rtm)) + TRunoff%tr = 0._r8 - allocate (TRunoff%eroutUp(begr:endr,nt_rtm)) - TRunoff%eroutUp = 0._r8 + allocate (TRunoff%erlg(begr:endr,nt_rtm)) + TRunoff%erlg = 0._r8 - allocate (TRunoff%eroutUp_avg(begr:endr,nt_rtm)) - TRunoff%eroutUp_avg = 0._r8 + allocate (TRunoff%erlateral(begr:endr,nt_rtm)) + TRunoff%erlateral = 0._r8 - allocate (TRunoff%erlat_avg(begr:endr,nt_rtm)) - TRunoff%erlat_avg = 0._r8 - - allocate (TRunoff%ergwl(begr:endr,nt_rtm)) - TRunoff%ergwl = 0._r8 - - allocate (TRunoff%flow(begr:endr,nt_rtm)) - TRunoff%flow = 0._r8 - - allocate (TPara%c_twid(begr:endr)) - TPara%c_twid = 1.0_r8 - - call pio_freedecomp(ncid, iodesc_dbl) - call pio_freedecomp(ncid, iodesc_int) - call pio_closefile(ncid) - - ! control parameters and some other derived parameters - ! estimate derived input variables - - ! add minimum value to rlen (length of main channel); rlen values can - ! be too small, leading to tlen values that are too large - - do iunit=rtmCTL%begr,rtmCTL%endr - rlen_min = sqrt(TUnit%area(iunit)) - if(TUnit%rlen(iunit) < rlen_min) then - TUnit%rlen(iunit) = rlen_min - end if - end do - - do iunit=rtmCTL%begr,rtmCTL%endr - if(TUnit%Gxr(iunit) > 0._r8) then - TUnit%rlenTotal(iunit) = TUnit%area(iunit)*TUnit%Gxr(iunit) - end if - end do - - do iunit=rtmCTL%begr,rtmCTL%endr - if(TUnit%rlen(iunit) > TUnit%rlenTotal(iunit)) then - TUnit%rlenTotal(iunit) = TUnit%rlen(iunit) - end if - end do - - do iunit=rtmCTL%begr,rtmCTL%endr - - if(TUnit%rlen(iunit) > 0._r8) then - TUnit%hlen(iunit) = TUnit%area(iunit) / TUnit%rlenTotal(iunit) / 2._r8 - - ! constrain hlen (hillslope length) values based on cell area - hlen_max = max(1000.0_r8, sqrt(TUnit%area(iunit))) - if(TUnit%hlen(iunit) > hlen_max) then - TUnit%hlen(iunit) = hlen_max ! allievate the outlier in drainag\e density estimation. TO DO - end if - - TUnit%tlen(iunit) = TUnit%area(iunit) / TUnit%rlen(iunit) / 2._r8 - TUnit%hlen(iunit) - - if(TUnit%twidth(iunit) < 0._r8) then - TUnit%twidth(iunit) = 0._r8 - end if - if(TUnit%tlen(iunit) > 0._r8 .and. (TUnit%rlenTotal(iunit)-TUnit%rlen(iunit))/TUnit%tlen(iunit) > 1._r8) then - TUnit%twidth(iunit) = TPara%c_twid(iunit)*TUnit%twidth(iunit)* & - ((TUnit%rlenTotal(iunit)-TUnit%rlen(iunit))/TUnit%tlen(iunit)) - end if - - if(TUnit%tlen(iunit) > 0._r8 .and. TUnit%twidth(iunit) <= 0._r8) then - TUnit%twidth(iunit) = 0._r8 - end if - else - TUnit%hlen(iunit) = 0._r8 - TUnit%tlen(iunit) = 0._r8 - TUnit%twidth(iunit) = 0._r8 - end if - - if(TUnit%rslp(iunit) <= 0._r8) then - TUnit%rslp(iunit) = 0.0001_r8 - end if - if(TUnit%tslp(iunit) <= 0._r8) then - TUnit%tslp(iunit) = 0.0001_r8 - end if - if(TUnit%hslp(iunit) <= 0._r8) then - TUnit%hslp(iunit) = 0.005_r8 - end if - TUnit%rslpsqrt(iunit) = sqrt(Tunit%rslp(iunit)) - TUnit%tslpsqrt(iunit) = sqrt(Tunit%tslp(iunit)) - TUnit%hslpsqrt(iunit) = sqrt(Tunit%hslp(iunit)) - end do - - lsize = rtmCTL%lnumr - gsize = rtmlon*rtmlat - - if (smat_option == 'opt') then - ! distributed smat initialization - ! mct_sMat_init must be given the number of rows and columns that - ! would be in the full matrix. Nrows= size of output vector=nb. - ! Ncols = size of input vector = na. - - cnt = 0 - do iunit=rtmCTL%begr,rtmCTL%endr - if(TUnit%dnID(iunit) > 0) cnt = cnt + 1 - enddo - - call mct_sMat_init(sMat, gsize, gsize, cnt) - igrow = mct_sMat_indexIA(sMat,'grow') - igcol = mct_sMat_indexIA(sMat,'gcol') - iwgt = mct_sMat_indexRA(sMat,'weight') - cnt = 0 - do iunit = rtmCTL%begr,rtmCTL%endr - if (TUnit%dnID(iunit) > 0) then - cnt = cnt + 1 - sMat%data%rAttr(iwgt ,cnt) = 1.0_r8 - sMat%data%iAttr(igrow,cnt) = TUnit%dnID(iunit) - sMat%data%iAttr(igcol,cnt) = TUnit%ID0(iunit) - endif - enddo - - call mct_sMatP_Init(sMatP_eroutUp, sMat, gsMap_r, gsMap_r, 0, mpicom_rof, ROFID) - - elseif (smat_option == 'Xonly' .or. smat_option == 'Yonly') then - ! root initialization - call mct_aVect_init(avtmp,rList='f1:f2',lsize=lsize) - call mct_aVect_zero(avtmp) - cnt = 0 - do iunit = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - avtmp%rAttr(1,cnt) = TUnit%ID0(iunit) - avtmp%rAttr(2,cnt) = TUnit%dnID(iunit) - enddo - call mct_avect_gather(avtmp,avtmpG,gsmap_r,mastertask,mpicom_rof) - if (masterproc) then - cnt = 0 - do n = 1,rtmlon*rtmlat - if (avtmpG%rAttr(2,n) > 0) then - cnt = cnt + 1 - endif - enddo - - call mct_sMat_init(sMat, gsize, gsize, cnt) - igrow = mct_sMat_indexIA(sMat,'grow') - igcol = mct_sMat_indexIA(sMat,'gcol') - iwgt = mct_sMat_indexRA(sMat,'weight') - - cnt = 0 - do n = 1,rtmlon*rtmlat - if (avtmpG%rAttr(2,n) > 0) then - cnt = cnt + 1 - sMat%data%rAttr(iwgt ,cnt) = 1.0_r8 - sMat%data%iAttr(igrow,cnt) = avtmpG%rAttr(2,n) - sMat%data%iAttr(igcol,cnt) = avtmpG%rAttr(1,n) - endif - enddo - call mct_avect_clean(avtmpG) - else - call mct_sMat_init(sMat,1,1,1) - endif - call mct_avect_clean(avtmp) - - call mct_sMatP_Init(sMatP_eroutUp, sMat, gsMap_r, gsMap_r, smat_option, 0, mpicom_rof, ROFID) - - else - - write(iulog,*) trim(subname),' MOSART ERROR: invalid smat_option '//trim(smat_option) - call shr_sys_abort(trim(subname)//' ERROR invald smat option') - - endif - - ! initialize the AVs to go with sMatP - write(rList,'(a,i3.3)') 'tr',1 - do nt = 2,nt_rtm - write(rList,'(a,i3.3)') trim(rList)//':tr',nt - enddo - if ( masterproc ) write(iulog,*) trim(subname),' MOSART initialize avect ',trim(rList) - call mct_aVect_init(avsrc_eroutUp,rList=rList,lsize=rtmCTL%lnumr) - call mct_aVect_init(avdst_eroutUp,rList=rList,lsize=rtmCTL%lnumr) - - lsize = mct_smat_gNumEl(sMatP_eroutUp%Matrix,mpicom_rof) - if (masterproc) write(iulog,*) subname," Done initializing SmatP_eroutUp, nElements = ",lsize - - ! keep only sMatP - call mct_sMat_clean(sMat) - - end if ! endr >= begr - - !--- compute areatot from area using dnID --- - !--- this basically advects upstream areas downstream and - !--- adds them up as it goes until all upstream areas are accounted for - - allocate(Tunit%areatotal2(rtmCTL%begr:rtmCTL%endr)) - Tunit%areatotal2 = 0._r8 - - ! initialize avdst to local area and add that to areatotal2 - cnt = 0 - call mct_avect_zero(avdst_eroutUp) - do nr = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - avdst_eroutUp%rAttr(1,cnt) = rtmCTL%area(nr) - Tunit%areatotal2(nr) = avdst_eroutUp%rAttr(1,cnt) - enddo - - tcnt = 0 - areatot_prev = -99._r8 - areatot_new = -50._r8 - do while (areatot_new /= areatot_prev .and. tcnt < rtmlon*rtmlat) - - tcnt = tcnt + 1 - - ! copy avdst to avsrc for next downstream step - cnt = 0 - call mct_avect_zero(avsrc_eroutUp) - do nr = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - avsrc_eroutUp%rAttr(1,cnt) = avdst_eroutUp%rAttr(1,cnt) - enddo - - call mct_avect_zero(avdst_eroutUp) - - call mct_sMat_avMult(avsrc_eroutUp, sMatP_eroutUp, avdst_eroutUp) - - ! add avdst to areatot and compute new global sum - cnt = 0 - areatot_prev = areatot_new - areatot_tmp = 0._r8 - do nr = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - Tunit%areatotal2(nr) = Tunit%areatotal2(nr) + avdst_eroutUp%rAttr(1,cnt) - areatot_tmp = areatot_tmp + Tunit%areatotal2(nr) - enddo - call shr_mpi_sum(areatot_tmp, areatot_new, mpicom_rof, 'areatot_new', all=.true.) - - if (masterproc) then - write(iulog,*) trim(subname),' areatot calc ',tcnt,areatot_new - endif - - enddo - - if (areatot_new /= areatot_prev) then - write(iulog,*) trim(subname),' MOSART ERROR: areatot incorrect ',areatot_new, areatot_prev - call shr_sys_abort(trim(subname)//' ERROR areatot incorrect') - endif - -! do nr = rtmCTL%begr,rtmCTL%endr -! if (TUnit%areatotal(nr) > 0._r8 .and. Tunit%areatotal2(nr) /= TUnit%areatotal(nr)) then -! write(iulog,'(2a,i12,2e16.4,f16.4)') trim(subname),' areatot diff ',nr,TUnit%areatotal(nr),Tunit%areatota!l2(nr),& -! abs(TUnit%areatotal(nr)-Tunit%areatotal2(nr))/(TUnit%areatotal(nr)) -! endif -! enddo - - - ! control parameters - Tctl%RoutingMethod = 1 - !Tctl%DATAH = rtm_nsteps*get_step_size() - !Tctl%DeltaT = 60._r8 ! - ! if(Tctl%DATAH > 0 .and. Tctl%DATAH < Tctl%DeltaT) then - ! Tctl%DeltaT = Tctl%DATAH - ! end if - Tctl%DLevelH2R = 5 - Tctl%DLevelR = 3 - call SubTimestep ! prepare for numerical computation - - call shr_mpi_max(maxval(Tunit%numDT_r),numDT_r,mpicom_rof,'numDT_r',all=.false.) - call shr_mpi_max(maxval(Tunit%numDT_t),numDT_t,mpicom_rof,'numDT_t',all=.false.) - if (masterproc) then - write(iulog,*) subname,' DLevelH2R = ',Tctl%DlevelH2R - write(iulog,*) subname,' numDT_r = ',minval(Tunit%numDT_r),maxval(Tunit%numDT_r) - write(iulog,*) subname,' numDT_r max = ',numDT_r - write(iulog,*) subname,' numDT_t = ',minval(Tunit%numDT_t),maxval(Tunit%numDT_t) - write(iulog,*) subname,' numDT_t max = ',numDT_t - endif - - !if(masterproc) then - ! fname = '/lustre/liho745/DCLM_model/ccsm_hy/run/clm_MOSART_subw2/run/test.dat' - ! call createFile(1111,fname) - !end if - - end subroutine MOSART_init - -!---------------------------------------------------------------------------- - - subroutine SubTimestep - ! !DESCRIPTION: predescribe the sub-time-steps for channel routing - implicit none - integer :: iunit !local index - character(len=*),parameter :: subname = '(SubTimestep)' - - allocate(TUnit%numDT_r(rtmCTL%begr:rtmCTL%endr),TUnit%numDT_t(rtmCTL%begr:rtmCTL%endr)) - TUnit%numDT_r = 1 - TUnit%numDT_t = 1 - allocate(TUnit%phi_r(rtmCTL%begr:rtmCTL%endr),TUnit%phi_t(rtmCTL%begr:rtmCTL%endr)) - TUnit%phi_r = 0._r8 - TUnit%phi_t = 0._r8 - - do iunit=rtmCTL%begr,rtmCTL%endr - if(TUnit%mask(iunit) > 0 .and. TUnit%rlen(iunit) > 0._r8) then - TUnit%phi_r(iunit) = TUnit%areaTotal2(iunit)*sqrt(TUnit%rslp(iunit))/(TUnit%rlen(iunit)*TUnit%rwidth(iunit)) - if(TUnit%phi_r(iunit) >= 10._r8) then - TUnit%numDT_r(iunit) = (TUnit%numDT_r(iunit)*log10(TUnit%phi_r(iunit))*Tctl%DLevelR) + 1 - else - TUnit%numDT_r(iunit) = TUnit%numDT_r(iunit)*1.0_r8*Tctl%DLevelR + 1 - end if - end if - if(TUnit%numDT_r(iunit) < 1) TUnit%numDT_r(iunit) = 1 - - if(TUnit%tlen(iunit) > 0._r8) then - TUnit%phi_t(iunit) = TUnit%area(iunit)*sqrt(TUnit%tslp(iunit))/(TUnit%tlen(iunit)*TUnit%twidth(iunit)) - if(TUnit%phi_t(iunit) >= 10._r8) then - TUnit%numDT_t(iunit) = (TUnit%numDT_t(iunit)*log10(TUnit%phi_t(iunit))*Tctl%DLevelR) + 1 - else - TUnit%numDT_t(iunit) = (TUnit%numDT_t(iunit)*1.0*Tctl%DLevelR) + 1 - end if - end if - if(TUnit%numDT_t(iunit) < 1) TUnit%numDT_t(iunit) = 1 - end do - end subroutine SubTimestep - -!----------------------------------------------------------------------- + allocate (TRunoff%erin(begr:endr,nt_rtm)) + TRunoff%erin = 0._r8 -end module RtmMod + allocate (TRunoff%erout(begr:endr,nt_rtm)) + TRunoff%erout = 0._r8 + + allocate (TRunoff%erout_prev(begr:endr,nt_rtm)) + TRunoff%erout_prev = 0._r8 + allocate (TRunoff%eroutUp(begr:endr,nt_rtm)) + TRunoff%eroutUp = 0._r8 + + allocate (TRunoff%eroutUp_avg(begr:endr,nt_rtm)) + TRunoff%eroutUp_avg = 0._r8 + + allocate (TRunoff%erlat_avg(begr:endr,nt_rtm)) + TRunoff%erlat_avg = 0._r8 + + allocate (TRunoff%ergwl(begr:endr,nt_rtm)) + TRunoff%ergwl = 0._r8 + + allocate (TRunoff%flow(begr:endr,nt_rtm)) + TRunoff%flow = 0._r8 + + allocate (TPara%c_twid(begr:endr)) + TPara%c_twid = 1.0_r8 + + call pio_freedecomp(ncid, iodesc_dbl) + call pio_freedecomp(ncid, iodesc_int) + call pio_closefile(ncid) + + ! control parameters and some other derived parameters + ! estimate derived input variables + + ! add minimum value to rlen (length of main channel); rlen values can + ! be too small, leading to tlen values that are too large + + do iunit=rtmCTL%begr,rtmCTL%endr + rlen_min = sqrt(TUnit%area(iunit)) + if(TUnit%rlen(iunit) < rlen_min) then + TUnit%rlen(iunit) = rlen_min + end if + end do + + do iunit=rtmCTL%begr,rtmCTL%endr + if(TUnit%Gxr(iunit) > 0._r8) then + TUnit%rlenTotal(iunit) = TUnit%area(iunit)*TUnit%Gxr(iunit) + end if + end do + + do iunit=rtmCTL%begr,rtmCTL%endr + if(TUnit%rlen(iunit) > TUnit%rlenTotal(iunit)) then + TUnit%rlenTotal(iunit) = TUnit%rlen(iunit) + end if + end do + + do iunit=rtmCTL%begr,rtmCTL%endr + + if(TUnit%rlen(iunit) > 0._r8) then + TUnit%hlen(iunit) = TUnit%area(iunit) / TUnit%rlenTotal(iunit) / 2._r8 + + ! constrain hlen (hillslope length) values based on cell area + hlen_max = max(1000.0_r8, sqrt(TUnit%area(iunit))) + if(TUnit%hlen(iunit) > hlen_max) then + TUnit%hlen(iunit) = hlen_max ! allievate the outlier in drainag\e density estimation. TO DO + end if + + TUnit%tlen(iunit) = TUnit%area(iunit) / TUnit%rlen(iunit) / 2._r8 - TUnit%hlen(iunit) + + if(TUnit%twidth(iunit) < 0._r8) then + TUnit%twidth(iunit) = 0._r8 + end if + if(TUnit%tlen(iunit) > 0._r8 .and. (TUnit%rlenTotal(iunit)-TUnit%rlen(iunit))/TUnit%tlen(iunit) > 1._r8) then + TUnit%twidth(iunit) = TPara%c_twid(iunit)*TUnit%twidth(iunit)* & + ((TUnit%rlenTotal(iunit)-TUnit%rlen(iunit))/TUnit%tlen(iunit)) + end if + + if(TUnit%tlen(iunit) > 0._r8 .and. TUnit%twidth(iunit) <= 0._r8) then + TUnit%twidth(iunit) = 0._r8 + end if + else + TUnit%hlen(iunit) = 0._r8 + TUnit%tlen(iunit) = 0._r8 + TUnit%twidth(iunit) = 0._r8 + end if + + if(TUnit%rslp(iunit) <= 0._r8) then + TUnit%rslp(iunit) = 0.0001_r8 + end if + if(TUnit%tslp(iunit) <= 0._r8) then + TUnit%tslp(iunit) = 0.0001_r8 + end if + if(TUnit%hslp(iunit) <= 0._r8) then + TUnit%hslp(iunit) = 0.005_r8 + end if + TUnit%rslpsqrt(iunit) = sqrt(Tunit%rslp(iunit)) + TUnit%tslpsqrt(iunit) = sqrt(Tunit%tslp(iunit)) + TUnit%hslpsqrt(iunit) = sqrt(Tunit%hslp(iunit)) + end do + + lsize = rtmCTL%lnumr + gsize = rtmlon*rtmlat + + cnt = 0 + do iunit=rtmCTL%begr,rtmCTL%endr + if(TUnit%dnID(iunit) > 0) cnt = cnt + 1 + enddo + + 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%dnID(iunit) + factorIndexList(2,cnt) = TUnit%ID0(iunit) + endif + enddo + if (masterproc) write(iulog,*) subname," Done initializing rh_eroutUp" + + call ESMF_FieldSMMStore(srcfield, dstfield, rh_eroutUp, factorList, factorIndexList, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + + deallocate(factorList) + deallocate(factorIndexList) + + 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 + 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 avdst to avsrc 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 + + call ESMF_FieldSMM(srcfield, dstField, rh_eroutUp, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + + ! 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(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 + + ! predescribe the sub-time-steps for channel routing + + integer :: iunit !local index + character(len=*),parameter :: subname = '(SubTimestep)' + + allocate(TUnit%numDT_r(rtmCTL%begr:rtmCTL%endr),TUnit%numDT_t(rtmCTL%begr:rtmCTL%endr)) + TUnit%numDT_r = 1 + TUnit%numDT_t = 1 + allocate(TUnit%phi_r(rtmCTL%begr:rtmCTL%endr),TUnit%phi_t(rtmCTL%begr:rtmCTL%endr)) + TUnit%phi_r = 0._r8 + TUnit%phi_t = 0._r8 + + do iunit=rtmCTL%begr,rtmCTL%endr + if(TUnit%mask(iunit) > 0 .and. TUnit%rlen(iunit) > 0._r8) then + TUnit%phi_r(iunit) = TUnit%areaTotal2(iunit)*sqrt(TUnit%rslp(iunit))/(TUnit%rlen(iunit)*TUnit%rwidth(iunit)) + if(TUnit%phi_r(iunit) >= 10._r8) then + TUnit%numDT_r(iunit) = (TUnit%numDT_r(iunit)*log10(TUnit%phi_r(iunit))*Tctl%DLevelR) + 1 + else + TUnit%numDT_r(iunit) = TUnit%numDT_r(iunit)*1.0_r8*Tctl%DLevelR + 1 + end if + end if + if(TUnit%numDT_r(iunit) < 1) TUnit%numDT_r(iunit) = 1 + + if(TUnit%tlen(iunit) > 0._r8) then + TUnit%phi_t(iunit) = TUnit%area(iunit)*sqrt(TUnit%tslp(iunit))/(TUnit%tlen(iunit)*TUnit%twidth(iunit)) + if(TUnit%phi_t(iunit) >= 10._r8) then + TUnit%numDT_t(iunit) = (TUnit%numDT_t(iunit)*log10(TUnit%phi_t(iunit))*Tctl%DLevelR) + 1 + else + TUnit%numDT_t(iunit) = (TUnit%numDT_t(iunit)*1.0*Tctl%DLevelR) + 1 + end if + end if + if(TUnit%numDT_t(iunit) < 1) TUnit%numDT_t(iunit) = 1 + end do + end subroutine SubTimestep + + !----------------------------------------------------------------------- + +end module RtmMod diff --git a/src/riverroute/RtmVar.F90 b/src/riverroute/RtmVar.F90 index 744cf01..3ab9dcf 100644 --- a/src/riverroute/RtmVar.F90 +++ b/src/riverroute/RtmVar.F90 @@ -4,6 +4,7 @@ module RtmVar use shr_const_mod, only : SHR_CONST_CDAY,SHR_CONST_REARTH use shr_sys_mod , only : shr_sys_abort use RtmSpmd , only : masterproc + 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 !================================================================================ @@ -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 222349c..6acea7c 100644 --- a/src/riverroute/RunoffMod.F90 +++ b/src/riverroute/RunoffMod.F90 @@ -12,26 +12,11 @@ module RunoffMod 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 RtmMctMod ! !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 @@ -42,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 @@ -107,9 +92,9 @@ module RunoffMod 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 @@ -117,17 +102,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 @@ -138,16 +123,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] @@ -160,23 +145,23 @@ module RunoffMod ! 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] @@ -184,9 +169,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 @@ -231,7 +216,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] @@ -264,14 +249,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 @@ -335,7 +320,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), & From cf7467f6ee0488ac34dd91087fbc812ec4464018 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 12 Dec 2023 14:18:57 +0100 Subject: [PATCH 04/86] first set of changes that compile and run --- src/cpl/nuopc/rof_comp_nuopc.F90 | 39 +- src/riverroute/MOSART_physics_mod.F90 | 1431 +++++++++++++------------ src/riverroute/RtmDateTime.F90 | 94 +- src/riverroute/RtmFileUtils.F90 | 284 +++-- src/riverroute/RtmIO.F90 | 10 +- src/riverroute/RtmMod.F90 | 489 +++------ src/riverroute/RtmRestFile.F90 | 908 ++++++++-------- 7 files changed, 1529 insertions(+), 1726 deletions(-) diff --git a/src/cpl/nuopc/rof_comp_nuopc.F90 b/src/cpl/nuopc/rof_comp_nuopc.F90 index c7bd908..23400fe 100644 --- a/src/cpl/nuopc/rof_comp_nuopc.F90 +++ b/src/cpl/nuopc/rof_comp_nuopc.F90 @@ -18,17 +18,17 @@ 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 RtmVar , only : srcfield, dstfield use RtmSpmd , only : RtmSpmdInit, masterproc, mpicom_rof, ROFID, iam, npes use RunoffMod , only : rtmCTL - use RtmMod , only : Rtminit_namelist, Rtmini, Rtmrun + use RtmMod , only : Rtminit_namelist, Rtmini, MOSART_init, Rtmrun use RtmTimeManager , only : timemgr_setup, get_curr_date, get_step_size, advance_timestep use perf_mod , only : t_startf, t_stopf, t_barrierf use rof_import_export , only : advertise_fields, realize_fields use rof_import_export , only : import_fields, export_fields - use rof_comp_share , only : Emesh 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 @@ -446,6 +446,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) integer, intent(out) :: rc ! local variables + type(ESMF_Mesh) :: Emesh type(ESMF_DistGrid) :: DistGrid ! esmf global index space descriptor type(ESMF_VM) :: vm integer , allocatable :: gindex(:) ! global index space on my processor @@ -496,7 +497,10 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call memmon_dump_fort('memmon.out','rof_comp_nuopc_InitializeRealize:start::',lbnum) endif #endif - call Rtmini() + + call Rtmini(rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + !-------------------------------- ! generate the mesh and realize fields !-------------------------------- @@ -532,6 +536,28 @@ 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 + !------------------------------------------------------- + + call t_startf('mosarti_mosart_init') + call MOSART_init(rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call t_stopf('mosarti_mosart_init') + !-------------------------------- ! Create MOSART export state !-------------------------------- @@ -692,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 Rtmrun(rstwr, nlend, rdate, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return !-------------------------------- ! Pack export state to mediator @@ -700,10 +727,8 @@ 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') !-------------------------------- diff --git a/src/riverroute/MOSART_physics_mod.F90 b/src/riverroute/MOSART_physics_mod.F90 index 558f954..f53a9c1 100644 --- a/src/riverroute/MOSART_physics_mod.F90 +++ b/src/riverroute/MOSART_physics_mod.F90 @@ -1,711 +1,730 @@ -!----------------------------------------------------------------------- -! 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, & - srcfield, dstfield, rh_direct, rh_eroutUp - use RunoffMod , only : Tctl, TUnit, TRunoff, TPara, rtmCTL - use RtmSpmd , only : masterproc, mpicom_rof - use perf_mod , only: t_startf, t_stopf - use ESMF - - 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 - - ! solve the ODEs with Euler algorithm - - ! 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 - !------------------ - - 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') - TRunoff%eroutUp = 0._r8 - - !--- copy erout into avsrc_eroutUp --- - src_eroutUp(:,:) = 0._r8 - cnt = 0 - do iunit = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - do nt = 1,nt_rtm - avsrc_eroutUp(nt,cnt) = TRunoff%erout(iunit,nt) - enddo - enddo - - call ESMF_FieldSMM(srcfield, dstField, rh_eroutUp, rc=rc) - if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - - !--- 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) = 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 - ! 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 + + !----------------------------------------------------------------------- + ! 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, & + srcfield, dstfield, rh_eroutUp + use RunoffMod , only : Tctl, TUnit, TRunoff, TPara, rtmCTL + use RtmSpmd , only : masterproc, mpicom_rof + 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 + + 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, 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 + ! 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) + ! 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(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) + ! subnetwork channel routing + + ! Arguments + 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) + ! 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 + + ! 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 + + ! 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) + ! 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 + !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. + + ! 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 + !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 + + ! 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_**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 + + ! 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/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) + ! 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 - -!----------------------------------------------------------------------- + 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) + ! 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..a82ed1a 100644 --- a/src/riverroute/RtmDateTime.F90 +++ b/src/riverroute/RtmDateTime.F90 @@ -1,58 +1,48 @@ 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, masterproc, MPI_CHARACTER + ! + ! 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 (masterproc) then + call date_and_time (date, time, zone, values) + + cdate(1:2) = date(5:6) + cdate(3:3) = '/' + cdate(4:5) = date(7:8) + cdate(6:6) = '/' + cdate(7:8) = date(3:4) + + ctime(1:2) = time(1:2) + ctime(3:3) = ':' + ctime(4:5) = time(3:4) + ctime(6:6) = ':' + ctime(7:8) = time(5:6) + endif + + call mpi_bcast (cdate,len(cdate),MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (ctime,len(ctime),MPI_CHARACTER, 0, mpicom_rof, ier) + + end subroutine getdatetime end module RtmDateTime diff --git a/src/riverroute/RtmFileUtils.F90 b/src/riverroute/RtmFileUtils.F90 index 3a01acf..97d2e56 100644 --- a/src/riverroute/RtmFileUtils.F90 +++ b/src/riverroute/RtmFileUtils.F90 @@ -1,181 +1,141 @@ 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 : masterproc + use RtmVar , only : iulog + ! + ! !PUBLIC TYPES: + implicit none + private + ! + ! !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 + ! + !----------------------------------------------------------------------- contains -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- + character(len=256) function get_filename (fulpath) - character(len=256) function get_filename (fulpath) + ! !DESCRIPTION: + ! Returns filename given full pathname + ! + ! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: fulpath !full pathname + ! + ! !LOCAL VARIABLES: + integer i !loop index + integer klen !length of fulpath character string + !---------------------------------------------------------- - ! !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 + integer klen !length of fulpath character string + logical lexist !true if local file exists + !-------------------------------------------------- + + ! get local file name from full name + locfn = get_filename( fulpath ) + if (len_trim(locfn) == 0) then + if (masterproc) write(iulog,*)'(GETFIL): local filename has zero length' + call shr_sys_abort() + else + if (masterproc) write(iulog,*)'(GETFIL): attempting to find local file ', & + trim(locfn) + endif + + ! first check if file is in current working directory. + inquire (file=locfn,exist=lexist) + if (lexist) then + if (masterproc) write(iulog,*) '(GETFIL): using ',trim(locfn), & + ' in current working directory' + RETURN + endif + + ! second check for full pathname on disk + locfn = fulpath + + inquire (file=fulpath,exist=lexist) + if (lexist) then + if (masterproc) write(iulog,*) '(GETFIL): using ',trim(fulpath) + RETURN + else + if (masterproc) write(iulog,*)'(GETFIL): failed getting file from full path: ', fulpath + if (iflag==0) then + call shr_sys_abort ('GETFIL: FAILED to get '//trim(fulpath)) + else + RETURN + endif + endif end subroutine getfil -!------------------------------------------------------------------------ - - subroutine opnfil (locfn, iun, form) - - ! !DESCRIPTION: - ! Open file locfn in unformatted or formatted form on unit iun - ! - ! !ARGUMENTS: - implicit none - character(len=*), intent(in):: locfn !file name - integer, intent(in):: iun !fortran unit number - character(len=1), intent(in):: form !file format: u = unformatted, - - ! !LOCAL VARIABLES: - integer ioe !error return from fortran open - character(len=11) ft !format type: formatted. unformatted - !----------------------------------------------------------- - - if (len_trim(locfn) == 0) then - write(iulog,*)'(OPNFIL): local filename has zero length' - call shr_sys_abort() - endif - if (form=='u' .or. form=='U') then - ft = 'unformatted' - else - ft = 'formatted ' - end if - open (unit=iun,file=locfn,status='unknown',form=ft,iostat=ioe) - if (ioe /= 0) then - write(iulog,*)'(OPNFIL): failed to open file ',trim(locfn), & - & ' on unit ',iun,' ierr=',ioe - call shr_sys_abort() - else if ( masterproc )then - write(iulog,*)'(OPNFIL): Successfully opened file ',trim(locfn), & - & ' on unit= ',iun - end if + !------------------------------------------------------------------------ + + subroutine opnfil (locfn, form, iun) + + ! Open file locfn in unformatted or formatted form on unit iun + ! + ! arguments + character(len=*), intent(in):: locfn !file name + character(len=1), intent(in):: form !file format: u = unformatted, + integer, intent(out) :: iun !fortran unit number + + ! 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 (newunit=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/RtmIO.F90 b/src/riverroute/RtmIO.F90 index 8e685c5..e35f306 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 RunoffMod , only : rtmCTL use RtmVar , only : spval, ispval, iulog use perf_mod , only : t_startf, t_stopf - use RtmMctMod 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 diff --git a/src/riverroute/RtmMod.F90 b/src/riverroute/RtmMod.F90 index 5460423..cc21c19 100644 --- a/src/riverroute/RtmMod.F90 +++ b/src/riverroute/RtmMod.F90 @@ -1,16 +1,11 @@ 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, shr_sys_abort + 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 RtmVar , only : nt_rtm, rtm_tracers @@ -22,7 +17,7 @@ module RtmMod 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, getavu, relavu + 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, & @@ -33,12 +28,12 @@ module RtmMod 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 : Euler + use RunoffMod , only : RunoffInit, rtmCTL, Tctl, Tunit, TRunoff, Tpara use MOSART_physics_mod , only : updatestate_hillslope, updatestate_subnetwork, & - updatestate_mainchannel + updatestate_mainchannel, Euler + use perf_mod , only : t_startf, t_stopf + use nuopc_shr_methods , only : chkerr use RtmIO - use perf_mod use pio use ESMF ! @@ -47,17 +42,14 @@ module RtmMod 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 + public :: Rtminit_namelist ! Initialize MOSART grid + public :: Rtmini ! Initialize MOSART grid + public :: MOSART_init + public :: Rtmrun ! River routing model ! ! !PRIVATE MEMBER FUNCTIONS: private :: RtmFloodInit - - ! !PRIVATE TYPES: + private :: SubTimestep ! MOSART tracers character(len=256) :: rtm_trstr ! tracer string @@ -70,13 +62,13 @@ module RtmMod 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) + ! 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) + ! 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) @@ -92,37 +84,23 @@ module RtmMod real(r8),pointer :: rlone(:) ! longitude of 1d east grid cell edge (deg) logical :: do_rtmflood - character(len=256) :: nlfilename_rof = 'mosart_in' - ! - !EOP + 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: + ! arguments logical, intent(out) :: flood_active ! - ! !REVISION HISTORY: - ! Author: Sam Levis - ! Update: T Craig, Dec 2006 - ! Update: J Edwards, Jun 2022 - ! - ! !LOCAL VARIABLES: - !EOP + ! local variables integer :: i integer :: ier ! error code integer :: unitn ! unit for namelist file @@ -158,14 +136,12 @@ subroutine Rtminit_namelist(flood_active) 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) + 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' ) + 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) @@ -173,18 +149,19 @@ subroutine Rtminit_namelist(flood_active) call shr_sys_abort( subname//' encountered end-of-file on mosart_inparm read' ) endif end do - call relavu( unitn ) + 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 (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) @@ -209,9 +186,6 @@ subroutine Rtminit_namelist(flood_active) 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) @@ -234,11 +208,13 @@ subroutine Rtminit_namelist(flood_active) 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' ) + 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' ) + call shr_sys_abort( subname//' ERROR: qgwl_runoff_option & + can only be all if bypass_routing_option==none' ) end if end if @@ -259,35 +235,20 @@ subroutine Rtminit_namelist(flood_active) 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: + subroutine Rtmini(rc) + + !------------------------------------------------- ! Initialize MOSART grid, mask, decomp ! - ! !USES: - ! - ! !ARGUMENTS: - implicit none - ! - ! !CALLED FROM: - ! subroutine initialize in module initializeMod + ! Arguments + integer, intent(out) :: rc ! - ! !REVISION HISTORY: - ! Author: Sam Levis - ! Update: T Craig, Dec 2006 - ! Update: J Edwards, Jun 2022 - ! - ! - ! !LOCAL VARIABLES: - + ! 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 @@ -295,11 +256,9 @@ subroutine Rtmini 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 @@ -321,7 +280,6 @@ subroutine Rtmini 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 - 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 @@ -337,9 +295,10 @@ subroutine Rtmini #else integer,parameter :: dbug = 3 ! 0 = none, 1=normal, 2=much, 3=max #endif - integer, allocatable :: factorIndexList(:,:) - real(r8), allocatable :: factorList character(len=*),parameter :: subname = '(Rtmini) ' + !------------------------------------------------- + + rc = ESMF_SUCCESS !------------------------------------------------------- ! Intiialize MOSART pio @@ -389,7 +348,6 @@ subroutine Rtmini 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) @@ -401,26 +359,22 @@ subroutine Rtmini 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) + 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) + 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') @@ -898,11 +852,9 @@ subroutine Rtmini 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 @@ -932,7 +884,6 @@ subroutine Rtmini ' endr = ',rtmCTL%endr, & ' numr = ',rtmCTL%lnumr endif - call shr_sys_flush(iulog) call mpi_barrier(mpicom_rof,ier) enddo @@ -942,14 +893,12 @@ subroutine Rtmini ! Allocate local flux variables !------------------------------------------------------- - call t_startf('mosarti_vars') - - allocate (eve(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) + 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') @@ -1012,7 +961,6 @@ subroutine Rtmini ! 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)) @@ -1037,7 +985,6 @@ subroutine Rtmini 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 @@ -1054,126 +1001,20 @@ subroutine Rtmini call shr_sys_abort(subname//' ERROR rtmCTL mask') endif - !------------------------------------------------------- - ! create srcfield and dstfield - !------------------------------------------------------- - - 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 - - !------------------------------------------------------- - ! Compute Sparse Matrix for direct to outlet transfer - !------------------------------------------------------- - - 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(iwgt ,cnt) = 1.0_r8 - factorIndexList(1,cnt) = rtmCTL%outletg(nr) - factorIndexList(2,cnt) = rtmCTL%gindex(nr) - else - factorList(iwgt ,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, rc=rc) - if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - - deallocate(factorList) - deallocate(factorIndexList) - - if (masterproc) write(iulog,*) subname," Done initializing rh_direct " - - !------------------------------------------------------- - ! Compute timestep and subcycling number - !------------------------------------------------------- - - call t_stopf('mosarti_vars') - - !------------------------------------------------------- - ! Initialize mosart - !------------------------------------------------------- - - call t_startf('mosarti_mosart_init') - call MOSART_init() - call t_stopf('mosarti_mosart_init') - - !------------------------------------------------------- - ! Read restart/initial info - !------------------------------------------------------- - - call t_startf('mosarti_restart') - - ! 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 ) - 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 (masterproc) write(iulog,*) subname,' done' - call t_stopf('mosarti_histinit') - end subroutine Rtmini !----------------------------------------------------------------------- - !BOP - ! - ! !IROUTINE: Rtmrun - ! - ! !INTERFACE: - subroutine Rtmrun(rstwr,nlend,rdate) + subroutine Rtmrun(rstwr, nlend, rdate, rc) ! - ! !DESCRIPTION: ! River routing model ! - ! !USES: - ! - ! !ARGUMENTS: + ! 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 ! - ! !REVISION HISTORY: - ! Author: Sam Levis - ! - ! !LOCAL VARIABLES: - !EOP + ! 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) @@ -1210,6 +1051,8 @@ subroutine Rtmrun(rstwr,nlend,rdate) call t_startf('mosartr_tot') + rc = ESMF_SUCCESS + !----------------------------------------------------- ! Set up pointer arrays into srcfield and dstfield !----------------------------------------------------- @@ -1388,7 +1231,7 @@ subroutine Rtmrun(rstwr,nlend,rdate) cnt = 0 do nr = rtmCTL%begr,rtmCTL%endr cnt = cnt + 1 - src_direct(cnt,nt) = TRunoff%qsur(nr,nt) + TRunoff%qsub(nr,nt) + TRunoff%qgwl(nr,nt) + 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 @@ -1585,8 +1428,7 @@ subroutine Rtmrun(rstwr,nlend,rdate) Tctl%DeltaT = delt !----------------------------------- - ! mosart euler solver - ! --- convert TRunoff fields from m3/s to m/s before calling Euler + ! MOSART euler solver !----------------------------------- call t_startf('mosartr_budget') @@ -1600,6 +1442,7 @@ subroutine Rtmrun(rstwr,nlend,rdate) 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) @@ -1611,7 +1454,8 @@ subroutine Rtmrun(rstwr,nlend,rdate) do ns = 1,nsub call t_startf('mosartr_euler') - call Euler() + call Euler(rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return call t_stopf('mosartr_euler') !----------------------------------- @@ -1833,7 +1677,6 @@ subroutine Rtmrun(rstwr,nlend,rdate) first_call = .false. - call shr_sys_flush(iulog) call t_stopf('mosartr_tot') end subroutine Rtmrun @@ -1843,28 +1686,26 @@ 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) + 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 + 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 + ! 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 @@ -1921,27 +1762,16 @@ subroutine RtmFloodInit(frivinp, begr, endr, fthresh, evel ) end subroutine RtmFloodInit !----------------------------------------------------------------------- - !BOP - ! - ! !IROUTINE: - ! - ! !INTERFACE: - subroutine MOSART_init - ! - ! !REVISION HISTORY: - ! Author: Hongyi Li + subroutine MOSART_init(rc) - ! !DESCRIPTION: + !----------------------------------------------------------------------- ! initialize MOSART variables - ! - ! !USES: - ! !ARGUMENTS: - ! - ! !REVISION HISTORY: ! Author: Hongyi Li ! - ! !OTHER LOCAL VARIABLES: - !EOP + ! 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 @@ -1952,7 +1782,6 @@ subroutine MOSART_init 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 real(r8) :: areatot_prev, areatot_tmp, areatot_new real(r8) :: hlen_max, rlen_min @@ -1961,16 +1790,47 @@ subroutine MOSART_init character(len=1000) :: fname real(r8), pointer :: src_eroutUp(:,:) real(r8), pointer :: dst_eroutUp(:,:) + integer ,allocatable :: factorIndexList(:,:) + real(r8),allocatable :: factorList(:) character(len=*),parameter :: subname = '(MOSART_init)' character(len=*),parameter :: FORMI = '(2A,2i10)' character(len=*),parameter :: FORMR = '(2A,2g15.7)' !----------------------------------------------------------------------- + rc = ESMF_SUCCESS + + ! Calculate map for direct to outlet mapping + 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%outletg(nr) + factorIndexList(2,cnt) = rtmCTL%gindex(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, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + deallocate(factorList) + deallocate(factorIndexList) + + if (masterproc) write(iulog,*) subname," Done initializing rh_direct " + ! 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 @@ -2005,8 +1865,9 @@ subroutine MOSART_init 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) + if (masterproc) 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 @@ -2015,8 +1876,9 @@ subroutine MOSART_init 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) + if (masterproc) then + write(iulog,FORMI) 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 @@ -2042,13 +1904,11 @@ subroutine MOSART_init 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 @@ -2070,7 +1930,6 @@ subroutine MOSART_init 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) @@ -2084,7 +1943,6 @@ subroutine MOSART_init 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 @@ -2093,13 +1951,11 @@ subroutine MOSART_init 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 @@ -2108,7 +1964,6 @@ subroutine MOSART_init 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 @@ -2117,7 +1972,6 @@ subroutine MOSART_init 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 @@ -2129,7 +1983,7 @@ subroutine MOSART_init 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) @@ -2138,19 +1992,16 @@ subroutine MOSART_init 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 @@ -2159,147 +2010,104 @@ subroutine MOSART_init ier = pio_inq_varid(ncid, name='rwid', vardesc=vardesc) call pio_read_darray(ncid, vardesc, iodesc_dbl, TUnit%rwidth, ier) if (masterproc) write(iulog,FORMR) trim(subname),' read rwidth ',minval(Tunit%rwidth),maxval(Tunit%rwidth) - call shr_sys_flush(iulog) allocate(TUnit%rwidth0(begr:endr)) ier = pio_inq_varid(ncid, name='rwid0', vardesc=vardesc) call pio_read_darray(ncid, vardesc, iodesc_dbl, TUnit%rwidth0, ier) if (masterproc) write(iulog,FORMR) trim(subname),' read rwidth0 ',minval(Tunit%rwidth0),maxval(Tunit%rwidth0) - call shr_sys_flush(iulog) allocate(TUnit%rdepth(begr:endr)) ier = pio_inq_varid(ncid, name='rdep', vardesc=vardesc) call pio_read_darray(ncid, vardesc, iodesc_dbl, TUnit%rdepth, ier) if (masterproc) write(iulog,FORMR) trim(subname),' read rdepth ',minval(Tunit%rdepth),maxval(Tunit%rdepth) - call shr_sys_flush(iulog) allocate(TUnit%nr(begr:endr)) ier = pio_inq_varid(ncid, name='nr', vardesc=vardesc) call pio_read_darray(ncid, vardesc, iodesc_dbl, TUnit%nr, ier) if (masterproc) write(iulog,FORMR) trim(subname),' read nr ',minval(Tunit%nr),maxval(Tunit%nr) - call shr_sys_flush(iulog) allocate(TUnit%nUp(begr:endr)) TUnit%nUp = 0 - allocate(TUnit%iUp(begr:endr,8)) TUnit%iUp = 0 - allocate(TUnit%indexDown(begr:endr)) TUnit%indexDown = 0 ! initialize water states and fluxes allocate (TRunoff%wh(begr:endr,nt_rtm)) TRunoff%wh = 0._r8 - allocate (TRunoff%dwh(begr:endr,nt_rtm)) TRunoff%dwh = 0._r8 - allocate (TRunoff%yh(begr:endr,nt_rtm)) TRunoff%yh = 0._r8 - allocate (TRunoff%qsur(begr:endr,nt_rtm)) TRunoff%qsur = 0._r8 - allocate (TRunoff%qsub(begr:endr,nt_rtm)) TRunoff%qsub = 0._r8 - allocate (TRunoff%qgwl(begr:endr,nt_rtm)) TRunoff%qgwl = 0._r8 - allocate (TRunoff%ehout(begr:endr,nt_rtm)) TRunoff%ehout = 0._r8 - allocate (TRunoff%tarea(begr:endr,nt_rtm)) TRunoff%tarea = 0._r8 - allocate (TRunoff%wt(begr:endr,nt_rtm)) TRunoff%wt= 0._r8 - allocate (TRunoff%dwt(begr:endr,nt_rtm)) TRunoff%dwt = 0._r8 - allocate (TRunoff%yt(begr:endr,nt_rtm)) TRunoff%yt = 0._r8 - allocate (TRunoff%mt(begr:endr,nt_rtm)) TRunoff%mt = 0._r8 - allocate (TRunoff%rt(begr:endr,nt_rtm)) TRunoff%rt = 0._r8 - allocate (TRunoff%pt(begr:endr,nt_rtm)) TRunoff%pt = 0._r8 - allocate (TRunoff%vt(begr:endr,nt_rtm)) TRunoff%vt = 0._r8 - allocate (TRunoff%tt(begr:endr,nt_rtm)) TRunoff%tt = 0._r8 - allocate (TRunoff%etin(begr:endr,nt_rtm)) TRunoff%etin = 0._r8 - allocate (TRunoff%etout(begr:endr,nt_rtm)) TRunoff%etout = 0._r8 - allocate (TRunoff%rarea(begr:endr,nt_rtm)) TRunoff%rarea = 0._r8 - allocate (TRunoff%wr(begr:endr,nt_rtm)) TRunoff%wr = 0._r8 - allocate (TRunoff%dwr(begr:endr,nt_rtm)) TRunoff%dwr = 0._r8 - allocate (TRunoff%yr(begr:endr,nt_rtm)) TRunoff%yr = 0._r8 - allocate (TRunoff%mr(begr:endr,nt_rtm)) TRunoff%mr = 0._r8 - allocate (TRunoff%rr(begr:endr,nt_rtm)) TRunoff%rr = 0._r8 - allocate (TRunoff%pr(begr:endr,nt_rtm)) TRunoff%pr = 0._r8 - allocate (TRunoff%vr(begr:endr,nt_rtm)) TRunoff%vr = 0._r8 - allocate (TRunoff%tr(begr:endr,nt_rtm)) TRunoff%tr = 0._r8 - allocate (TRunoff%erlg(begr:endr,nt_rtm)) TRunoff%erlg = 0._r8 - allocate (TRunoff%erlateral(begr:endr,nt_rtm)) TRunoff%erlateral = 0._r8 - allocate (TRunoff%erin(begr:endr,nt_rtm)) TRunoff%erin = 0._r8 - allocate (TRunoff%erout(begr:endr,nt_rtm)) TRunoff%erout = 0._r8 - allocate (TRunoff%erout_prev(begr:endr,nt_rtm)) TRunoff%erout_prev = 0._r8 - allocate (TRunoff%eroutUp(begr:endr,nt_rtm)) TRunoff%eroutUp = 0._r8 - allocate (TRunoff%eroutUp_avg(begr:endr,nt_rtm)) TRunoff%eroutUp_avg = 0._r8 - allocate (TRunoff%erlat_avg(begr:endr,nt_rtm)) TRunoff%erlat_avg = 0._r8 - allocate (TRunoff%ergwl(begr:endr,nt_rtm)) TRunoff%ergwl = 0._r8 - allocate (TRunoff%flow(begr:endr,nt_rtm)) TRunoff%flow = 0._r8 - allocate (TPara%c_twid(begr:endr)) TPara%c_twid = 1.0_r8 @@ -2376,9 +2184,6 @@ subroutine MOSART_init TUnit%hslpsqrt(iunit) = sqrt(Tunit%hslp(iunit)) end do - lsize = rtmCTL%lnumr - gsize = rtmlon*rtmlat - cnt = 0 do iunit=rtmCTL%begr,rtmCTL%endr if(TUnit%dnID(iunit) > 0) cnt = cnt + 1 @@ -2412,7 +2217,7 @@ subroutine MOSART_init allocate(Tunit%areatotal2(rtmCTL%begr:rtmCTL%endr)) Tunit%areatotal2 = 0._r8 - ! initialize avdst to local area and add that to areatotal2 + ! initialize dst_eroutUp to local area and add that to areatotal2 cnt = 0 do nr = rtmCTL%begr,rtmCTL%endr cnt = cnt + 1 @@ -2427,7 +2232,7 @@ subroutine MOSART_init tcnt = tcnt + 1 - ! copy avdst to avsrc for next downstream step + ! copy dst_eroutUp to src_eroutUp for next downstream step src_eroutUp(:,:) = 0._r8 cnt = 0 do nr = rtmCTL%begr,rtmCTL%endr @@ -2438,13 +2243,13 @@ subroutine MOSART_init call ESMF_FieldSMM(srcfield, dstField, rh_eroutUp, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - ! add avdst to areatot and compute new global sum + ! 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) + avdst_eroutUp(1,cnt) + 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.) @@ -2491,6 +2296,44 @@ subroutine MOSART_init 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 (masterproc) write(iulog,*) subname,' done' + call t_stopf('mosarti_histinit') + !if(masterproc) then ! fname = '/lustre/liho745/DCLM_model/ccsm_hy/run/clm_MOSART_subw2/run/test.dat' ! call createFile(1111,fname) @@ -2537,6 +2380,4 @@ subroutine SubTimestep end do end subroutine SubTimestep - !----------------------------------------------------------------------- - end module RtmMod diff --git a/src/riverroute/RtmRestFile.F90 b/src/riverroute/RtmRestFile.F90 index 19c593c..9bf3b2f 100644 --- a/src/riverroute/RtmRestFile.F90 +++ b/src/riverroute/RtmRestFile.F90 @@ -1,471 +1,447 @@ 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 : 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 : 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 + 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 + ! + ! !REVISION HISTORY: + ! Author: Mariana Vertenstein + !----------------------------------------------------------------------- + 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 (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 ) + + !------------------------------------- + ! 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 (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 ) + + !------------------------------------- + ! 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 (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 ) + + !------------------------------------- + ! 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 :: 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 + + locfn = './'// trim(rpntfil)//trim(inst_suffix) + call opnfil (locfn, 'f', nio) + read (nio,'(a256)') pnamer + close(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 ) + + !------------------------------------- + ! Open restart pointer file. Write names of current netcdf restart file. + ! + ! !ARGUMENTS: + 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 + filename= './'// trim(rpntfil)//trim(inst_suffix) + call opnfil( filename, 'f', nio) + 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 (masterproc) 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 From f168435926baae2f168b7a5a52322389425ed1a7 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 12 Dec 2023 16:30:38 +0100 Subject: [PATCH 05/86] fixes to get only roundoff level errors --- src/riverroute/RtmMod.F90 | 34 ++++++++++++++++++++++------------ 1 file changed, 22 insertions(+), 12 deletions(-) diff --git a/src/riverroute/RtmMod.F90 b/src/riverroute/RtmMod.F90 index cc21c19..bfc113d 100644 --- a/src/riverroute/RtmMod.F90 +++ b/src/riverroute/RtmMod.F90 @@ -1762,6 +1762,7 @@ subroutine RtmFloodInit(frivinp, begr, endr, fthresh, evel ) end subroutine RtmFloodInit !----------------------------------------------------------------------- + subroutine MOSART_init(rc) !----------------------------------------------------------------------- @@ -1800,6 +1801,7 @@ subroutine MOSART_init(rc) rc = ESMF_SUCCESS ! Calculate map for direct to outlet mapping + ! The route handle rh_direct will then be used in Rtmrun cnt = rtmCTL%endr - rtmCTL%begr + 1 allocate(factorList(cnt)) allocate(factorIndexList(2,cnt)) @@ -1808,8 +1810,8 @@ subroutine MOSART_init(rc) cnt = cnt + 1 if (rtmCTL%outletg(nr) > 0) then factorList(cnt) = 1.0_r8 - factorIndexList(1,cnt) = rtmCTL%outletg(nr) - factorIndexList(2,cnt) = rtmCTL%gindex(nr) + factorIndexList(1,cnt) = rtmCTL%gindex(nr) + factorIndexList(2,cnt) = rtmCTL%outletg(nr) else factorList(cnt) = 1.0_r8 factorIndexList(1,cnt) = rtmCTL%gindex(nr) @@ -1825,19 +1827,15 @@ subroutine MOSART_init(rc) if (masterproc) write(iulog,*) subname," Done initializing rh_direct " - ! 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 + ! --------------------------------------- + ! 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) @@ -2189,6 +2187,10 @@ subroutine MOSART_init(rc) if(TUnit%dnID(iunit) > 0) cnt = cnt + 1 enddo + ! -------------------------------------------------- + ! Compute route handle rh_eroutUp + ! -------------------------------------------------- + allocate(factorList(cnt)) allocate(factorIndexList(2,cnt)) cnt = 0 @@ -2196,8 +2198,8 @@ subroutine MOSART_init(rc) if (TUnit%dnID(iunit) > 0) then cnt = cnt + 1 factorList(cnt) = 1.0_r8 - factorIndexList(1,cnt) = TUnit%dnID(iunit) - factorIndexList(2,cnt) = TUnit%ID0(iunit) + factorIndexList(1,cnt) = TUnit%ID0(iunit) + factorIndexList(2,cnt) = TUnit%dnID(iunit) endif enddo if (masterproc) write(iulog,*) subname," Done initializing rh_eroutUp" @@ -2210,6 +2212,12 @@ subroutine MOSART_init(rc) 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 + !--- 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 @@ -2219,6 +2227,7 @@ subroutine MOSART_init(rc) ! 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) @@ -2240,6 +2249,7 @@ subroutine MOSART_init(rc) src_eroutUp(1,cnt) = dst_eroutUp(1,cnt) enddo + dst_eroutUp(:,:) = 0._r8 call ESMF_FieldSMM(srcfield, dstField, rh_eroutUp, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) From 628974560846cb75a9fd51a0883648b702ca511b Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 12 Dec 2023 20:23:27 +0100 Subject: [PATCH 06/86] changes to clean things up - but results are still not reproducible from run to run --- src/riverroute/RtmMod.F90 | 89 +++++++++++++++++++++++---------------- 1 file changed, 53 insertions(+), 36 deletions(-) diff --git a/src/riverroute/RtmMod.F90 b/src/riverroute/RtmMod.F90 index bfc113d..8e2a237 100644 --- a/src/riverroute/RtmMod.F90 +++ b/src/riverroute/RtmMod.F90 @@ -1039,13 +1039,13 @@ subroutine Rtmrun(rstwr, nlend, rdate, rc) 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] - real(r8), pointer :: src_direct(:,:) - real(r8), pointer :: dst_direct(:,:) character(len=*),parameter :: subname = '(Rtmrun) ' !----------------------------------------------------------------------- @@ -1053,15 +1053,6 @@ subroutine Rtmrun(rstwr, nlend, rdate, rc) 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 - !----------------------------------------------------- ! Get date info !----------------------------------------------------- @@ -1077,7 +1068,7 @@ subroutine Rtmrun(rstwr, nlend, rdate, rc) if (first_call) then budget_accum = 0._r8 budget_accum_cnt = 0 - delt_save = delt_mosart + delt_save = delt_mosart if (masterproc) write(iulog,'(2a,g20.12)') trim(subname),' MOSART coupling period ',delt_coupling end if @@ -1217,6 +1208,15 @@ subroutine Rtmrun(rstwr, nlend, rdate, rc) !--- copy direct transfer fields !--- convert kg/m2s to m3/s + !----------------------------------------------------- + ! 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 !----------------------------------------------------- @@ -1789,10 +1789,12 @@ subroutine MOSART_init(rc) integer :: tcnt character(len=16384) :: rList ! list of fields for SM multiply character(len=1000) :: fname + real(r8), pointer :: src_direct(:,:) + real(r8), pointer :: dst_direct(:,:) real(r8), pointer :: src_eroutUp(:,:) real(r8), pointer :: dst_eroutUp(:,:) - integer ,allocatable :: factorIndexList(:,:) real(r8),allocatable :: factorList(:) + integer ,allocatable :: factorIndexList(:,:) character(len=*),parameter :: subname = '(MOSART_init)' character(len=*),parameter :: FORMI = '(2A,2i10)' character(len=*),parameter :: FORMR = '(2A,2g15.7)' @@ -1800,6 +1802,14 @@ subroutine MOSART_init(rc) 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 Rtmrun cnt = rtmCTL%endr - rtmCTL%begr + 1 @@ -2187,29 +2197,8 @@ subroutine MOSART_init(rc) if(TUnit%dnID(iunit) > 0) cnt = cnt + 1 enddo - ! -------------------------------------------------- - ! Compute route handle rh_eroutUp - ! -------------------------------------------------- - - 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 (masterproc) write(iulog,*) subname," Done initializing rh_eroutUp" - - call ESMF_FieldSMMStore(srcfield, dstfield, rh_eroutUp, factorList, factorIndexList, rc=rc) - if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - - deallocate(factorList) - deallocate(factorIndexList) - + else + write(6,*)'DEBUG: endr < begr' end if ! endr >= begr ! Set up pointer arrays into srcfield and dstfield @@ -2217,6 +2206,34 @@ subroutine MOSART_init(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 (masterproc) write(iulog,*) subname," Done initializing rh_eroutUp" + + call ESMF_FieldSMMStore(srcfield, dstfield, rh_eroutUp, factorList, factorIndexList, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + + deallocate(factorList) + deallocate(factorIndexList) !--- compute areatot from area using dnID --- !--- this basically advects upstream areas downstream and From 01598e5c9efba01aad4f12056bab44d41394b392 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 13 Dec 2023 16:46:02 +0100 Subject: [PATCH 07/86] fixes to mapping generaiton --- src/riverroute/RtmMod.F90 | 29 ++++++++++++++++++++++------- 1 file changed, 22 insertions(+), 7 deletions(-) diff --git a/src/riverroute/RtmMod.F90 b/src/riverroute/RtmMod.F90 index 8e2a237..76970ab 100644 --- a/src/riverroute/RtmMod.F90 +++ b/src/riverroute/RtmMod.F90 @@ -1237,7 +1237,7 @@ subroutine Rtmrun(rstwr, nlend, rdate, rc) TRunoff%qgwl(nr,nt) = 0._r8 enddo - call ESMF_FieldSMM(srcfield, dstfield, rh_direct, rc=rc) + 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 @@ -1273,7 +1273,7 @@ subroutine Rtmrun(rstwr, nlend, rdate, rc) endif enddo - call ESMF_FieldSMM(srcfield, dstfield, rh_direct, rc=rc) + 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 --- @@ -1385,7 +1385,7 @@ subroutine Rtmrun(rstwr, nlend, rdate, rc) enddo enddo - call ESMF_FieldSMM(srcfield, dstfield, rh_direct, rc=rc) + 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 --- @@ -1785,6 +1785,7 @@ subroutine MOSART_init(rc) integer :: numDT_r, numDT_t integer :: igrow, igcol, iwgt real(r8) :: areatot_prev, areatot_tmp, areatot_new + real(r8) :: areatot_tmp2, areatot_new2 real(r8) :: hlen_max, rlen_min integer :: tcnt character(len=16384) :: rList ! list of fields for SM multiply @@ -1795,6 +1796,7 @@ subroutine MOSART_init(rc) real(r8), pointer :: dst_eroutUp(:,:) real(r8),allocatable :: factorList(:) integer ,allocatable :: factorIndexList(:,:) + integer :: srcTermProcessing_Value = 0 character(len=*),parameter :: subname = '(MOSART_init)' character(len=*),parameter :: FORMI = '(2A,2i10)' character(len=*),parameter :: FORMR = '(2A,2g15.7)' @@ -1829,7 +1831,8 @@ subroutine MOSART_init(rc) endif enddo - call ESMF_FieldSMMStore(srcField, dstField, rh_direct, factorList, factorIndexList, rc=rc) + 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) @@ -2229,7 +2232,8 @@ subroutine MOSART_init(rc) enddo if (masterproc) write(iulog,*) subname," Done initializing rh_eroutUp" - call ESMF_FieldSMMStore(srcfield, dstfield, rh_eroutUp, factorList, factorIndexList, rc=rc) + call ESMF_FieldSMMStore(srcfield, dstfield, rh_eroutUp, factorList, factorIndexList, & + ignoreUnmatchedIndices=.true., srcTermProcessing=srcTermProcessing_Value, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) deallocate(factorList) @@ -2267,24 +2271,35 @@ subroutine MOSART_init(rc) enddo dst_eroutUp(:,:) = 0._r8 - call ESMF_FieldSMM(srcfield, dstField, rh_eroutUp, rc=rc) - if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + 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 + areatot_tmp2 = 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) + areatot_tmp2 = areatot_tmp2 + dst_eroutUp(1,cnt) enddo call shr_mpi_sum(areatot_tmp, areatot_new, mpicom_rof, 'areatot_new', all=.true.) + call shr_mpi_sum(areatot_tmp2, areatot_new2, mpicom_rof, 'areatot_new2', all=.true.) if (masterproc) then write(iulog,*) trim(subname),' areatot calc ',tcnt,areatot_new + write(iulog,*) trim(subname),' areatot calc2 ',tcnt,areatot_new2 endif + cnt = 0 + do nr = rtmCTL%begr,rtmCTL%endr + cnt = cnt + 1 + if (dst_eroutUp(1,cnt) /= 0._r8) then + write(6,'(a,i8,2x,i8,2x,i8,2x,d25.16)')' DEBUG: iam , cnt, nr, dst_eroutUp(1,cnt= ',iam,cnt,nr,dst_eroutUp(1,cnt) + end if + end do enddo if (areatot_new /= areatot_prev) then From cf390417e356d72610dfff1012bd2cc56b535fb0 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 13 Dec 2023 19:00:58 +0100 Subject: [PATCH 08/86] fixes to get model reproducible --- src/cpl/nuopc/rof_comp_nuopc.F90 | 19 +- src/riverroute/MOSART_physics_mod.F90 | 4 +- src/riverroute/RtmMod.F90 | 2388 ++++++++++++------------- src/riverroute/RunoffMod.F90 | 2 - 4 files changed, 1201 insertions(+), 1212 deletions(-) diff --git a/src/cpl/nuopc/rof_comp_nuopc.F90 b/src/cpl/nuopc/rof_comp_nuopc.F90 index 23400fe..3a029bc 100644 --- a/src/cpl/nuopc/rof_comp_nuopc.F90 +++ b/src/cpl/nuopc/rof_comp_nuopc.F90 @@ -24,7 +24,7 @@ module rof_comp_nuopc use RtmVar , only : srcfield, dstfield use RtmSpmd , only : RtmSpmdInit, masterproc, mpicom_rof, ROFID, iam, npes use RunoffMod , only : rtmCTL - use RtmMod , only : Rtminit_namelist, Rtmini, MOSART_init, 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 @@ -56,7 +56,7 @@ module rof_comp_nuopc integer :: flds_scalar_index_ny = 0 integer :: flds_scalar_index_nextsw_cday = 0._r8 - logical :: do_rtmflood + logical :: do_flood integer :: nthrds integer , parameter :: debug = 1 @@ -282,7 +282,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 !---------------------- @@ -416,13 +416,13 @@ 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_flood) !---------------------------------------------------------------------------- ! Now advertise fields !---------------------------------------------------------------------------- - call advertise_fields(gcomp, flds_scalar_name, do_rtmflood, rc) + call advertise_fields(gcomp, flds_scalar_name, do_flood, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---------------------------------------------------------------------------- @@ -498,7 +498,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) endif #endif - call Rtmini(rc) + call MOSART_init1(rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !-------------------------------- @@ -550,11 +550,12 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) !------------------------------------------------------- - ! Initialize mosart + ! Initialize mosart maps and restart + ! This must be called after the ESMF mesh is read in !------------------------------------------------------- call t_startf('mosarti_mosart_init') - call MOSART_init(rc) + call MOSART_init2(rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call t_stopf('mosarti_mosart_init') @@ -718,7 +719,7 @@ 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, rc) + call MOSART_run(rstwr, nlend, rdate, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !-------------------------------- diff --git a/src/riverroute/MOSART_physics_mod.F90 b/src/riverroute/MOSART_physics_mod.F90 index f53a9c1..df849ef 100644 --- a/src/riverroute/MOSART_physics_mod.F90 +++ b/src/riverroute/MOSART_physics_mod.F90 @@ -22,7 +22,7 @@ MODULE MOSART_physics_mod 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_SUCCESS, ESMF_END_ABORT, ESMF_TERMORDER_SRCSEQ implicit none private @@ -152,7 +152,7 @@ subroutine Euler(rc) enddo ! --- map src_eroutUp to dst_eroutUp - call ESMF_FieldSMM(srcfield, dstField, rh_eroutUp, rc=rc) + 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 --- diff --git a/src/riverroute/RtmMod.F90 b/src/riverroute/RtmMod.F90 index 76970ab..acb3f2f 100644 --- a/src/riverroute/RtmMod.F90 +++ b/src/riverroute/RtmMod.F90 @@ -42,14 +42,14 @@ module RtmMod private ! ! !PUBLIC MEMBER FUNCTIONS: - public :: Rtminit_namelist ! Initialize MOSART grid - public :: Rtmini ! Initialize MOSART grid - public :: MOSART_init - public :: Rtmrun ! River routing model + 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 :: RtmFloodInit - private :: SubTimestep + private :: MOSART_FloodInit + private :: MOSART_SubTimestep ! MOSART tracers character(len=256) :: rtm_trstr ! tracer string @@ -93,7 +93,7 @@ module RtmMod contains !----------------------------------------------------------------------- - subroutine Rtminit_namelist(flood_active) + subroutine MOSART_read_namelist(flood_active) ! ! Read and distribute mosart namelist ! @@ -106,7 +106,7 @@ subroutine Rtminit_namelist(flood_active) integer :: unitn ! unit for namelist file logical :: lexist ! File exists character(len= 7) :: runtyp(4) ! run type - character(len=*),parameter :: subname = '(Rtminit_namelist) ' + character(len=*),parameter :: subname = '(MOSART_read_namelist) ' !----------------------------------------------------------------------- !------------------------------------------------------- @@ -236,11 +236,11 @@ subroutine Rtminit_namelist(flood_active) endif end do - end subroutine Rtminit_namelist + end subroutine MOSART_read_namelist !----------------------------------------------------------------------- - subroutine Rtmini(rc) + subroutine MOSART_init1(rc) !------------------------------------------------- ! Initialize MOSART grid, mask, decomp @@ -295,7 +295,7 @@ subroutine Rtmini(rc) #else integer,parameter :: dbug = 3 ! 0 = none, 1=normal, 2=much, 3=max #endif - character(len=*),parameter :: subname = '(Rtmini) ' + character(len=*),parameter :: subname = '(MOSART_init1) ' !------------------------------------------------- rc = ESMF_SUCCESS @@ -921,7 +921,7 @@ subroutine Rtmini(rc) 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) + call MOSART_FloodInit (frivinp_rtm, rtmCTL%begr, rtmCTL%endr, rtmCTL%fthresh, evel) else effvel(:) = effvel0 ! downstream velocity (m/s) rtmCTL%fthresh(:) = abs(spval) @@ -1001,1391 +1001,1380 @@ subroutine Rtmini(rc) call shr_sys_abort(subname//' ERROR rtmCTL mask') endif - end subroutine Rtmini + end subroutine MOSART_init1 !----------------------------------------------------------------------- - subroutine Rtmrun(rstwr, nlend, rdate, rc) - ! - ! River routing model + + subroutine MOSART_init2(rc) + + ! initialize MOSART variables + ! Author: Hongyi Li ! ! 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 + 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) :: 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 - 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 = '(Rtmrun) ' + 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 :: igrow, igcol, iwgt + 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 + 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)' !----------------------------------------------------------------------- - 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. 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) - 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 - - !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 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') - !--- copy direct transfer fields - !--- convert kg/m2s to m3/s - - !----------------------------------------------------- ! 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. - + ! Calculate map for direct to outlet mapping + ! The route handle rh_direct will then be used in Rtmrun + cnt = rtmCTL%endr - rtmCTL%begr + 1 + allocate(factorList(cnt)) + allocate(factorIndexList(2,cnt)) 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 + 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_FieldSMM(srcfield, dstfield, rh_direct, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) + call ESMF_FieldSMMStore(srcField, dstField, rh_direct, factorList, factorIndexList, & + ignoreUnmatchedIndices=.true., srcTermProcessing=srcTermProcessing_Value, 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 + deallocate(factorList) + deallocate(factorIndexList) - !----------------------------------------------------- - !--- direct to outlet qgwl - !----------------------------------------------------- + if (masterproc) write(iulog,*) subname," Done initializing rh_direct " - !-- liquid runoff components - if (trim(bypass_routing_option) == 'direct_to_outlet') then + ! --------------------------------------- + ! Read in data from frivinp_rtm + ! --------------------------------------- - nt = 1 - src_direct(:,:) = 0._r8 - dst_direct(:,:) = 0._r8 + begr = rtmCTL%begr + endr = rtmCTL%endr - !--- 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 + if(endr >= begr) then - call ESMF_FieldSMM(srcfield, dstfield, rh_direct, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + ! routing parameters + call ncd_pio_openfile (ncid, trim(frivinp_rtm), 0) + call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) - !--- copy direct transfer water to output field --- + allocate(compdof(rtmCTL%lnumr)) cnt = 0 - do nr = rtmCTL%begr,rtmCTL%endr + do n = rtmCTL%begr,rtmCTL%endr cnt = cnt + 1 - rtmCTL%direct(nr,nt) = rtmCTL%direct(nr,nt) + dst_direct(nt,cnt) + compDOF(cnt) = rtmCTL%gindex(n) enddo - endif - !----------------------------------------------------- - !--- direct in place qgwl - !----------------------------------------------------- + ! 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) - if (trim(bypass_routing_option) == 'direct_in_place') then + allocate(TUnit%euler_calc(nt_rtm)) + Tunit%euler_calc = .true. - nt = 1 - do nr = rtmCTL%begr,rtmCTL%endr + 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) then + write(iulog,FORMR) trim(subname),' read frac ',minval(Tunit%frac),maxval(Tunit%frac) + end if - 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) + ! read fdir, convert to mask + ! fdir <0 ocean, 0=outlet, >0 land + ! tunit mask is 0=ocean, 1=land, 2=outlet for mosart calcs - ! 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 + 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) then + write(iulog,FORMI) 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 - endif - !------------------------------------------------------- - !--- add other direct terms, e.g. inputs outside of - !--- mosart mask, negative qsur - !------------------------------------------------------- + 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) - if (trim(bypass_routing_option) == 'direct_in_place') then - do nt = 1,nt_rtm - do nr = rtmCTL%begr,rtmCTL%endr + 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) - 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 + !------------------------------------------------------- + ! 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 - 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(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) - 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 + 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 - endif - if (trim(bypass_routing_option) == 'direct_to_outlet') then + 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) - src_direct(:,:) = 0._r8 - dst_direct(:,:) = 0._r8 + allocate(TUnit%rlenTotal(begr:endr)) + TUnit%rlenTotal = 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(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) - !---- 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(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) - !---- 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 + allocate(TUnit%hslpsqrt(begr:endr)) + TUnit%hslpsqrt = 0._r8 - call ESMF_FieldSMM(srcfield, dstfield, rh_direct, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + 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) - !--- 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') + allocate(TUnit%hlen(begr:endr)) + TUnit%hlen = 0._r8 - !----------------------------------- - ! MOSART Subcycling - !----------------------------------- + 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 t_startf('mosartr_subcycling') + allocate(TUnit%tslpsqrt(begr:endr)) + TUnit%tslpsqrt = 0._r8 - 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 + allocate(TUnit%tlen(begr:endr)) + TUnit%tlen = 0._r8 - 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 + 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) - nsub_save = nsub - delt_save = delt - Tctl%DeltaT = delt + ! save twidth before adjusted below + allocate(TUnit%twidth0(begr:endr)) + TUnit%twidth0(begr:endr)=TUnit%twidth(begr:endr) - !----------------------------------- - ! MOSART euler solver - !----------------------------------- + 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 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') + 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) - ! 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 + 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) - do ns = 1,nsub + allocate(TUnit%rslpsqrt(begr:endr)) + TUnit%rslpsqrt = 0._r8 - call t_startf('mosartr_euler') - call Euler(rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call t_stopf('mosartr_euler') + 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) - !----------------------------------- - ! accumulate local flow field - !----------------------------------- + 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) - 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 + 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) - enddo ! nsub + 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) - !----------------------------------- - ! average flow over subcycling - !----------------------------------- + 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 - flow = flow / float(nsub) - erout_prev = erout_prev / float(nsub) - eroutup_avg = eroutup_avg / float(nsub) - erlat_avg = erlat_avg / float(nsub) + ! 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 - !----------------------------------- - ! update states when subsycling completed - !----------------------------------- + call pio_freedecomp(ncid, iodesc_dbl) + call pio_freedecomp(ncid, iodesc_int) + call pio_closefile(ncid) - rtmCTL%wh = TRunoff%wh - rtmCTL%wt = TRunoff%wt - rtmCTL%wr = TRunoff%wr - rtmCTL%erout = TRunoff%erout + ! control parameters and some other derived parameters + ! estimate derived input variables - 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) + ! add minimum value to rlen (length of main channel); rlen values can + ! be too small, leading to tlen values that are too large - 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 + 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 - call t_stopf('mosartr_subcycling') + 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 - !----------------------------------- - ! BUDGET - !----------------------------------- + do iunit=rtmCTL%begr,rtmCTL%endr + if(TUnit%rlen(iunit) > TUnit%rlenTotal(iunit)) then + TUnit%rlenTotal(iunit) = TUnit%rlen(iunit) + end if + end do - ! 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 + do iunit=rtmCTL%begr,rtmCTL%endr - ! 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(TUnit%rlen(iunit) > 0._r8) then + TUnit%hlen(iunit) = TUnit%area(iunit) / TUnit%rlenTotal(iunit) / 2._r8 - if (budget_check) then - call t_startf('mosartr_budget') - !--- check budget + ! 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 - ! convert fluxes from m3/s to m3 by mult by coupling_period - budget_terms(11:30,:) = budget_terms(11:30,:) * delt_coupling + TUnit%tlen(iunit) = TUnit%area(iunit) / TUnit%rlen(iunit) / 2._r8 - TUnit%hlen(iunit) - ! convert terms from m3 to million m3 - budget_terms(:,:) = budget_terms(:,:) * 1.0e-6_r8 + 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 - ! global sum - call shr_mpi_sum(budget_terms,budget_global,mpicom_rof,'mosart global budget',all=.false.) + 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 - ! 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(TUnit%rslp(iunit) <= 0._r8) then + TUnit%rslp(iunit) = 0.0001_r8 + end if - 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 + if(TUnit%tslp(iunit) <= 0._r8) then + TUnit%tslp(iunit) = 0.0001_r8 + end if - call t_stopf('mosartr_budget') - endif ! budget_check + if(TUnit%hslp(iunit) <= 0._r8) then + TUnit%hslp(iunit) = 0.005_r8 + end if - !----------------------------------- - ! Write out MOSART history file - !----------------------------------- + TUnit%rslpsqrt(iunit) = sqrt(Tunit%rslp(iunit)) + TUnit%tslpsqrt(iunit) = sqrt(Tunit%tslp(iunit)) + TUnit%hslpsqrt(iunit) = sqrt(Tunit%hslp(iunit)) - call t_startf('mosartr_hbuf') - call RtmHistFldsSet() - call RtmHistUpdateHbuf() - call t_stopf('mosartr_hbuf') + end do - call t_startf('mosartr_htapes') - call RtmHistHtapesWrapup( rstwr, nlend ) - call t_stopf('mosartr_htapes') + cnt = 0 + do iunit=rtmCTL%begr,rtmCTL%endr + if(TUnit%dnID(iunit) > 0) cnt = cnt + 1 + enddo - !----------------------------------- - ! Write out MOSART restart file - !----------------------------------- + end if ! endr >= begr - if (rstwr) then - call t_startf('mosartr_rest') - filer = RtmRestFileName(rdate=rdate) - call RtmRestFileWrite( filer, rdate=rdate ) - call t_stopf('mosartr_rest') - end if + ! 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 - !----------------------------------- - ! Done - !----------------------------------- + ! 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 (masterproc) write(iulog,*) subname," Done initializing rh_eroutUp" - first_call = .false. + call ESMF_FieldSMMStore(srcfield, dstfield, rh_eroutUp, factorList, factorIndexList, & + ignoreUnmatchedIndices=.true., srcTermProcessing=srcTermProcessing_Value, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - call t_stopf('mosartr_tot') + deallocate(factorList) + deallocate(factorIndexList) - end subroutine Rtmrun + !--- 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 - subroutine RtmFloodInit(frivinp, begr, endr, fthresh, evel ) + ! 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 - !----------------------------------------------------------------------- - ! 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) + tcnt = 0 + areatot_prev = -99._r8 + areatot_new = -50._r8 + do while (areatot_new /= areatot_prev .and. tcnt < rtmlon*rtmlat) - ! 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 + tcnt = tcnt + 1 - ! 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) ' - !----------------------------------------------------------------------- + ! 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 - allocate(rslope(begr:endr), max_volr(begr:endr), stat=ier) - if (ier /= 0) call shr_sys_abort(subname // ' allocation ERROR') + 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 - ! Assume that if SLOPE is on river input dataset so is MAX_VOLR and that - ! both have the same io descriptor + ! 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.) - 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) + if (masterproc) then + write(iulog,*) trim(subname),' areatot calc ',tcnt,areatot_new + endif + enddo - 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 + 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 - deallocate(rslope, max_volr) + ! 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 - end subroutine RtmFloodInit + ! 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 - subroutine MOSART_init(rc) + Tctl%DLevelH2R = 5 + Tctl%DLevelR = 3 + call MOSART_SubTimestep ! prepare for numerical computation - !----------------------------------------------------------------------- - ! initialize MOSART variables - ! 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, iunit, nn, n, cnt, nr, nt - integer :: numDT_r, numDT_t - integer :: igrow, igcol, iwgt - real(r8) :: areatot_prev, areatot_tmp, areatot_new - real(r8) :: areatot_tmp2, areatot_new2 - real(r8) :: hlen_max, rlen_min - integer :: tcnt - character(len=16384) :: rList ! list of fields for SM multiply - character(len=1000) :: fname - 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 :: subname = '(MOSART_init)' - character(len=*),parameter :: FORMI = '(2A,2i10)' - character(len=*),parameter :: FORMR = '(2A,2g15.7)' - !----------------------------------------------------------------------- + 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 - rc = ESMF_SUCCESS + !------------------------------------------------------- + ! Read restart/initial info + !------------------------------------------------------- - ! 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 + 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 - ! Calculate map for direct to outlet mapping - ! The route handle rh_direct will then be used in Rtmrun - 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 + 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') - 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) + !------------------------------------------------------- + ! Initialize mosart history handler and fields + !------------------------------------------------------- - if (masterproc) write(iulog,*) subname," Done initializing rh_direct " + call t_startf('mosarti_histinit') + call RtmHistFldsInit() + if (nsrest==nsrStartup .or. nsrest==nsrBranch) then + call RtmHistHtapesBuild() + end if + call RtmHistFldsSet() + if (masterproc) write(iulog,*) subname,' done' + call t_stopf('mosarti_histinit') - ! --------------------------------------- - ! Read in data from frivinp_rtm - ! --------------------------------------- + !if(masterproc) then + ! fname = '/lustre/liho745/DCLM_model/ccsm_hy/run/clm_MOSART_subw2/run/test.dat' + ! call createFile(1111,fname) + !end if - begr = rtmCTL%begr - endr = rtmCTL%endr + end subroutine MOSART_init2 - if(endr >= begr) then + !----------------------------------------------------------------------- - ! routing parameters - call ncd_pio_openfile (ncid, trim(frivinp_rtm), 0) - call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + subroutine MOSART_run(rstwr, nlend, rdate, rc) - allocate(compdof(rtmCTL%lnumr)) - cnt = 0 - do n = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - compDOF(cnt) = rtmCTL%gindex(n) - enddo + ! 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) :: 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 + real(r8), pointer :: src_direct(:,:) + real(r8), pointer :: dst_direct(:,:) - ! 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) + ! 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) ' + !----------------------------------------------------------------------- - allocate(TUnit%euler_calc(nt_rtm)) - Tunit%euler_calc = .true. + call t_startf('mosartr_tot') - 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) then - write(iulog,FORMR) trim(subname),' read frac ',minval(Tunit%frac),maxval(Tunit%frac) - end if + rc = ESMF_SUCCESS - ! read fdir, convert to mask - ! fdir <0 ocean, 0=outlet, >0 land - ! tunit mask is 0=ocean, 1=land, 2=outlet for mosart calcs + !----------------------------------------------------- + ! Get date info + !----------------------------------------------------- - 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) then - write(iulog,FORMI) trim(subname),' read fdir mask ',minval(Tunit%mask),maxval(Tunit%mask) - end if + 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 - 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 + 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 - 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) + budget_check = .false. + if (day == 1 .and. mon == 1) budget_check = .true. + if (tod == 0) budget_check = .true. + budget_terms = 0._r8 - 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) + 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 - !------------------------------------------------------- - ! 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 + ! 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') - 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) - - 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 + ! 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 - 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) + !----------------------------------- + ! 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 + !----------------------------------- - allocate(TUnit%rlenTotal(begr:endr)) - TUnit%rlenTotal = 0._r8 + call t_startf('mosartr_irrig') + nt = 1 + rtmCTL%qirrig_actual = 0._r8 + do nr = rtmCTL%begr,rtmCTL%endr - 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) + ! calculate volume of irrigation flux during timestep + irrig_volume = -rtmCTL%qirrig(nr) * coupling_period - 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) + ! 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 - allocate(TUnit%hslpsqrt(begr:endr)) - TUnit%hslpsqrt = 0._r8 + !scs: how to deal with sink points / river outlets? + ! if (rtmCTL%mask(nr) == 1) then - 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) + ! 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 - allocate(TUnit%hlen(begr:endr)) - TUnit%hlen = 0._r8 + ! remove irrigation from wr (main channel) + TRunoff%wr(nr,nt) = TRunoff%wr(nr,nt) - irrig_volume - 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) + !scs endif + enddo + call t_stopf('mosartr_irrig') - allocate(TUnit%tslpsqrt(begr:endr)) - TUnit%tslpsqrt = 0._r8 + !----------------------------------- + ! 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 + !----------------------------------- - allocate(TUnit%tlen(begr:endr)) - TUnit%tlen = 0._r8 + 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) - 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) + ! 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') - ! save twidth before adjusted below - allocate(TUnit%twidth0(begr:endr)) - TUnit%twidth0(begr:endr)=TUnit%twidth(begr:endr) + !----------------------------------------------------- + ! DIRECT transfer to outlet point + ! Remember to subtract water from TRunoff forcing + !----------------------------------------------------- - 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) + if (barrier_timers) then + call t_startf('mosartr_SMdirect_barrier') + call mpi_barrier(mpicom_rof,ier) + call t_stopf ('mosartr_SMdirect_barrier') + endif - 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 t_startf('mosartr_SMdirect') + !--- copy direct transfer fields + !--- convert kg/m2s to m3/s - 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) + !----------------------------------------------------- + ! Set up pointer arrays into srcfield and dstfield + !----------------------------------------------------- - allocate(TUnit%rslpsqrt(begr:endr)) - TUnit%rslpsqrt = 0._r8 + 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 - 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) + !----------------------------------------------------- + !--- all frozen runoff passed direct to outlet + !----------------------------------------------------- - 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) + nt = 2 + src_direct(:,:) = 0._r8 + dst_direct(:,:) = 0._r8 - 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) + ! set euler_calc = false for frozen runoff + TUnit%euler_calc(nt) = .false. - 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) + 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 - 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 + call ESMF_FieldSMM(srcfield, dstfield, rh_direct, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return - ! 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 + ! 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 - call pio_freedecomp(ncid, iodesc_dbl) - call pio_freedecomp(ncid, iodesc_int) - call pio_closefile(ncid) + !----------------------------------------------------- + !--- direct to outlet qgwl + !----------------------------------------------------- - ! control parameters and some other derived parameters - ! estimate derived input variables + !-- liquid runoff components + if (trim(bypass_routing_option) == 'direct_to_outlet') then - ! add minimum value to rlen (length of main channel); rlen values can - ! be too small, leading to tlen values that are too large + nt = 1 + src_direct(:,:) = 0._r8 + dst_direct(:,:) = 0._r8 - 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 + !--- 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 - 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 + call ESMF_FieldSMM(srcfield, dstfield, rh_direct, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return - do iunit=rtmCTL%begr,rtmCTL%endr - if(TUnit%rlen(iunit) > TUnit%rlenTotal(iunit)) then - TUnit%rlenTotal(iunit) = TUnit%rlen(iunit) - end if - end do + !--- 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 - do iunit=rtmCTL%begr,rtmCTL%endr + !----------------------------------------------------- + !--- direct in place qgwl + !----------------------------------------------------- - if(TUnit%rlen(iunit) > 0._r8) then - TUnit%hlen(iunit) = TUnit%area(iunit) / TUnit%rlenTotal(iunit) / 2._r8 + if (trim(bypass_routing_option) == 'direct_in_place') then - ! 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 + nt = 1 + do nr = rtmCTL%begr,rtmCTL%endr - TUnit%tlen(iunit) = TUnit%area(iunit) / TUnit%rlen(iunit) / 2._r8 - TUnit%hlen(iunit) + 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(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 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 - 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 + !------------------------------------------------------- + !--- add other direct terms, e.g. inputs outside of + !--- mosart mask, negative qsur + !------------------------------------------------------- - 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 + if (trim(bypass_routing_option) == 'direct_in_place') then + do nt = 1,nt_rtm + do nr = rtmCTL%begr,rtmCTL%endr - cnt = 0 - do iunit=rtmCTL%begr,rtmCTL%endr - if(TUnit%dnID(iunit) > 0) cnt = cnt + 1 + 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 - else - write(6,*)'DEBUG: endr < begr' - end if ! endr >= begr + if (trim(bypass_routing_option) == 'direct_to_outlet') then - ! 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 + 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 + + !---- negative qsur water, remove from TRunoff --- + if (TRunoff%qsur(nr,nt) < 0._r8) then + src_direct(nt,cnt) = src_direct(nt,cnt) + TRunoff%qsur(nr,nt) + TRunoff%qsur(nr,nt) = 0._r8 + endif + + !---- water outside the basin --- + !---- *** DO NOT TURN THIS ONE OFF, conservation will fail *** --- + 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. 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 + !----------------------------------- + + 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 + ! 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),'----------------' - ! 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) + 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 - enddo - if (masterproc) write(iulog,*) subname," Done initializing rh_eroutUp" - - call ESMF_FieldSMMStore(srcfield, dstfield, rh_eroutUp, factorList, factorIndexList, & - ignoreUnmatchedIndices=.true., srcTermProcessing=srcTermProcessing_Value, rc=rc) - if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - 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 + call t_stopf('mosartr_budget') + endif ! budget_check - ! 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 + !----------------------------------- + ! Write out MOSART history file + !----------------------------------- - tcnt = 0 - areatot_prev = -99._r8 - areatot_new = -50._r8 - do while (areatot_new /= areatot_prev .and. tcnt < rtmlon*rtmlat) + call t_startf('mosartr_hbuf') + call RtmHistFldsSet() + call RtmHistUpdateHbuf() + call t_stopf('mosartr_hbuf') - tcnt = tcnt + 1 + call t_startf('mosartr_htapes') + call RtmHistHtapesWrapup( rstwr, nlend ) + call t_stopf('mosartr_htapes') - ! 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 + !----------------------------------- + ! Write out MOSART restart file + !----------------------------------- - 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 + if (rstwr) then + call t_startf('mosartr_rest') + filer = RtmRestFileName(rdate=rdate) + call RtmRestFileWrite( filer, rdate=rdate ) + call t_stopf('mosartr_rest') + end if - ! add dst_eroutUp to areatot and compute new global sum - cnt = 0 - areatot_prev = areatot_new - areatot_tmp = 0._r8 - areatot_tmp2 = 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) - areatot_tmp2 = areatot_tmp2 + dst_eroutUp(1,cnt) - enddo - call shr_mpi_sum(areatot_tmp, areatot_new, mpicom_rof, 'areatot_new', all=.true.) - call shr_mpi_sum(areatot_tmp2, areatot_new2, mpicom_rof, 'areatot_new2', all=.true.) + !----------------------------------- + ! Done + !----------------------------------- - if (masterproc) then - write(iulog,*) trim(subname),' areatot calc ',tcnt,areatot_new - write(iulog,*) trim(subname),' areatot calc2 ',tcnt,areatot_new2 - endif + first_call = .false. - cnt = 0 - do nr = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - if (dst_eroutUp(1,cnt) /= 0._r8) then - write(6,'(a,i8,2x,i8,2x,i8,2x,d25.16)')' DEBUG: iam , cnt, nr, dst_eroutUp(1,cnt= ',iam,cnt,nr,dst_eroutUp(1,cnt) - end if - end do - enddo + call t_stopf('mosartr_tot') - 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 + end subroutine MOSART_run - ! 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 + subroutine MOSART_FloodInit(frivinp, begr, endr, fthresh, evel ) - ! 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 + ! Arguments + 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) - Tctl%DLevelH2R = 5 - Tctl%DLevelR = 3 - call SubTimestep ! prepare for numerical computation + ! 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 - 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 + ! 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 = '(MOSART_FloodInit) ' + !----------------------------------------------------------------------- - !------------------------------------------------------- - ! Read restart/initial info - !------------------------------------------------------- + allocate(rslope(begr:endr), max_volr(begr:endr), stat=ier) + if (ier /= 0) call shr_sys_abort(subname // ' allocation ERROR') - 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 + ! Assume that if SLOPE is on river input dataset so is MAX_VOLR and that + ! both have the same io descriptor - 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)) + 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 - 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() + 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 RtmHistFldsSet() - if (masterproc) write(iulog,*) subname,' done' - call t_stopf('mosarti_histinit') + call pio_closefile(ncid) - !if(masterproc) then - ! fname = '/lustre/liho745/DCLM_model/ccsm_hy/run/clm_MOSART_subw2/run/test.dat' - ! call createFile(1111,fname) - !end if + 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 MOSART_init + end subroutine MOSART_FloodInit !---------------------------------------------------------------------------- - subroutine SubTimestep + subroutine MOSART_SubTimestep ! predescribe the sub-time-steps for channel routing @@ -2420,6 +2409,7 @@ subroutine SubTimestep 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/RunoffMod.F90 b/src/riverroute/RunoffMod.F90 index 6acea7c..a404bff 100644 --- a/src/riverroute/RunoffMod.F90 +++ b/src/riverroute/RunoffMod.F90 @@ -89,7 +89,6 @@ module RunoffMod real(r8), pointer :: qsub_nt2(:) real(r8), pointer :: qgwl_nt1(:) real(r8), pointer :: qgwl_nt2(:) - end type runoff_flow @@ -143,7 +142,6 @@ 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 :: hslp(:) ! slope of hillslope, [-] From 1bb3382c8c378af75afc271ba28555e6cb6d8a69 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 13 Dec 2023 20:11:07 +0100 Subject: [PATCH 09/86] more cleanup --- src/cpl/nuopc/rof_comp_nuopc.F90 | 6 +-- src/riverroute/RtmMod.F90 | 82 ++++++++++++++------------------ src/riverroute/RtmSpmd.F90 | 15 ++---- 3 files changed, 45 insertions(+), 58 deletions(-) diff --git a/src/cpl/nuopc/rof_comp_nuopc.F90 b/src/cpl/nuopc/rof_comp_nuopc.F90 index 3a029bc..bfd74c8 100644 --- a/src/cpl/nuopc/rof_comp_nuopc.F90 +++ b/src/cpl/nuopc/rof_comp_nuopc.F90 @@ -203,7 +203,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 @@ -498,8 +498,8 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) endif #endif - call MOSART_init1(rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! Call first phase of MOSART initialization (set decomp, grid) + call MOSART_init1() !-------------------------------- ! generate the mesh and realize fields diff --git a/src/riverroute/RtmMod.F90 b/src/riverroute/RtmMod.F90 index acb3f2f..6b221e2 100644 --- a/src/riverroute/RtmMod.F90 +++ b/src/riverroute/RtmMod.F90 @@ -33,9 +33,10 @@ module RtmMod 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 ESMF ! ! !PUBLIC TYPES: implicit none @@ -240,14 +241,11 @@ end subroutine MOSART_read_namelist !----------------------------------------------------------------------- - subroutine MOSART_init1(rc) + subroutine MOSART_init1() !------------------------------------------------- ! Initialize MOSART grid, mask, decomp ! - ! Arguments - integer, intent(out) :: rc - ! ! Local variables real(r8) :: effvel0 = 10.0_r8 ! default velocity (m/s) real(r8) :: effvel(nt_rtm) ! downstream velocity (m/s) @@ -279,7 +277,6 @@ subroutine MOSART_init1(rc) 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 integer :: baspe ! pe with min number of mosart cells integer ,pointer :: gmask(:) ! global mask integer ,allocatable :: idxocn(:) ! downstream ocean outlet cell @@ -298,8 +295,6 @@ subroutine MOSART_init1(rc) character(len=*),parameter :: subname = '(MOSART_init1) ' !------------------------------------------------- - rc = ESMF_SUCCESS - !------------------------------------------------------- ! Intiialize MOSART pio !------------------------------------------------------- @@ -794,8 +789,7 @@ subroutine MOSART_init1(rc) endif enddo - allocate(rglo2gdc(rtmlon*rtmlat), & !global mosart array - nrs(0:npes-1)) + allocate(rglo2gdc(rtmlon*rtmlat), nrs(0:npes-1)) !global mosart array nrs = 0 rglo2gdc = 0 @@ -988,26 +982,31 @@ subroutine MOSART_init1(rc) 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 + 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 (masterproc) 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) - ! initialize MOSART variables + ! Second phyas of MOSART initialization, including ESMF Mapping ! Author: Hongyi Li ! ! Arguments @@ -1022,14 +1021,12 @@ subroutine MOSART_init2(rc) 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 :: begr, endr + integer :: iunit, nn, n, cnt, nr, nt integer :: numDT_r, numDT_t - integer :: igrow, igcol, iwgt 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 real(r8), pointer :: src_direct(:,:) real(r8), pointer :: dst_direct(:,:) real(r8), pointer :: src_eroutUp(:,:) @@ -1128,7 +1125,7 @@ subroutine MOSART_init2(rc) ier = pio_inq_varid(ncid, name='fdir', vardesc=vardesc) call pio_read_darray(ncid, vardesc, iodesc_int, TUnit%mask, ier) if (masterproc) then - write(iulog,FORMI) trim(subname),' read fdir mask ',minval(Tunit%mask),maxval(Tunit%mask) + write(iulog,'(2A,2i10)') trim(subname),' read fdir mask ',minval(Tunit%mask),maxval(Tunit%mask) end if do n = rtmCtl%begr, rtmCTL%endr @@ -1154,12 +1151,12 @@ subroutine MOSART_init2(rc) 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) + if (masterproc) 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 (masterproc) write(iulog,FORMI) trim(subname),' read dnID ',minval(Tunit%dnID),maxval(Tunit%dnID) + if (masterproc) 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 @@ -1477,7 +1474,7 @@ subroutine MOSART_init2(rc) call ESMF_FieldSMMStore(srcfield, dstfield, rh_eroutUp, factorList, factorIndexList, & ignoreUnmatchedIndices=.true., srcTermProcessing=srcTermProcessing_Value, rc=rc) - if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + if (chkerr(rc,__LINE__,u_FILE_u)) return deallocate(factorList) deallocate(factorIndexList) @@ -1607,11 +1604,6 @@ subroutine MOSART_init2(rc) if (masterproc) write(iulog,*) subname,' done' call t_stopf('mosarti_histinit') - !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_init2 !----------------------------------------------------------------------- @@ -1621,10 +1613,10 @@ 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 + 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 @@ -1637,10 +1629,8 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) 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 + 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 @@ -1769,6 +1759,7 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) TRunoff%wr(nr,nt) = TRunoff%wr(nr,nt) - irrig_volume !scs endif + enddo call t_stopf('mosartr_irrig') @@ -1817,8 +1808,6 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) endif call t_startf('mosartr_SMdirect') - !--- copy direct transfer fields - !--- convert kg/m2s to m3/s !----------------------------------------------------- ! Set up pointer arrays into srcfield and dstfield @@ -1928,6 +1917,7 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) endif endif enddo + endif !------------------------------------------------------- @@ -2132,7 +2122,7 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) ! 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 @@ -2199,7 +2189,7 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) 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)') 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) @@ -2374,16 +2364,18 @@ end subroutine MOSART_FloodInit !---------------------------------------------------------------------------- - subroutine MOSART_SubTimestep + subroutine MOSART_SubTimestep() ! predescribe the sub-time-steps for channel routing + ! Local variables integer :: iunit !local index - character(len=*),parameter :: subname = '(SubTimestep)' + character(len=*),parameter :: subname = '(MOSART_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 diff --git a/src/riverroute/RtmSpmd.F90 b/src/riverroute/RtmSpmd.F90 index 99a0938..c94195b 100644 --- a/src/riverroute/RtmSpmd.F90 +++ b/src/riverroute/RtmSpmd.F90 @@ -17,18 +17,16 @@ module RtmSpmd implicit none private -#include +#include - save ! This statement won't be needed once all compilers we support are compliant with FORTRAN-2008 - - ! Default settings valid even if there is no spmd + ! Default settings valid even if there is no spmd logical, public :: masterproc ! proc 0 logical for printing msgs integer, public :: iam ! processor number integer, public :: npes ! number of processors for rtm integer, public :: mpicom_rof ! communicator group for rtm - integer, public :: ROFID ! mct compid - integer, public, parameter :: MASTERTASK=0 ! the value of iam which is assigned + integer, public :: ROFID ! component id needed for PIO + integer, public, parameter :: MASTERTASK=0 ! the value of iam which is assigned ! the masterproc duties ! @@ -50,7 +48,6 @@ module RtmSpmd public :: MPI_ANY_SOURCE public :: MPI_CHARACTER public :: MPI_COMM_WORLD - public :: MPI_MAX_PROCESSOR_NAME contains @@ -63,7 +60,6 @@ subroutine RtmSpmdInit(mpicom) ! MPI initialization (number of processes, etc) ! ! !ARGUMENTS: - implicit none integer, intent(in) :: mpicom ! ! !LOCAL VARIABLES: @@ -77,14 +73,13 @@ subroutine RtmSpmdInit(mpicom) ! Get my processor id call mpi_comm_rank(mpicom_rof, iam, ier) - if (iam == MASTERTASK) then + 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 From 0de8ed046cc74b664d662c30ada3e74e3c1cdcff Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 13 Dec 2023 20:57:26 +0100 Subject: [PATCH 10/86] masterproc -> mainproc --- src/cpl/nuopc/rof_comp_nuopc.F90 | 22 ++--- src/cpl/nuopc/rof_import_export.F90 | 9 +- src/riverroute/MOSART_physics_mod.F90 | 2 +- src/riverroute/RtmDateTime.F90 | 4 +- src/riverroute/RtmFileUtils.F90 | 54 ++---------- src/riverroute/RtmHistFile.F90 | 30 +++---- src/riverroute/RtmIO.F90 | 26 +++--- src/riverroute/RtmMod.F90 | 118 +++++++++++++------------- src/riverroute/RtmRestFile.F90 | 87 ++++++++++--------- src/riverroute/RtmSpmd.F90 | 117 ++++++++++--------------- src/riverroute/RtmTimeManager.F90 | 70 ++++++++------- src/riverroute/RtmVar.F90 | 4 +- 12 files changed, 238 insertions(+), 305 deletions(-) diff --git a/src/cpl/nuopc/rof_comp_nuopc.F90 b/src/cpl/nuopc/rof_comp_nuopc.F90 index bfd74c8..5e75433 100644 --- a/src/cpl/nuopc/rof_comp_nuopc.F90 +++ b/src/cpl/nuopc/rof_comp_nuopc.F90 @@ -22,7 +22,7 @@ module rof_comp_nuopc use RtmVar , only : nsrStartup, nsrContinue, nsrBranch use RtmVar , only : inst_index, inst_suffix, inst_name, RtmVarSet use RtmVar , only : srcfield, dstfield - use RtmSpmd , only : RtmSpmdInit, masterproc, mpicom_rof, ROFID, iam, npes + use RtmSpmd , only : RtmSpmdInit, mainproc, mpicom_rof, ROFID, iam, npes use RunoffMod , only : rtmCTL 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 @@ -221,7 +221,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 !---------------------------------------------------------------------------- @@ -368,7 +368,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 @@ -492,7 +492,7 @@ 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 @@ -522,7 +522,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 @@ -592,7 +592,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) @@ -645,7 +645,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 @@ -733,7 +733,7 @@ subroutine ModelAdvance(gcomp, rc) 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() @@ -745,7 +745,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 !-------------------------------- @@ -770,7 +770,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() @@ -923,7 +923,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..606ca3c 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 @@ -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 df849ef..ed0d21c 100644 --- a/src/riverroute/MOSART_physics_mod.F90 +++ b/src/riverroute/MOSART_physics_mod.F90 @@ -15,10 +15,10 @@ MODULE MOSART_physics_mod 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 use RunoffMod , only : Tctl, TUnit, TRunoff, TPara, rtmCTL - use RtmSpmd , only : masterproc, mpicom_rof use perf_mod , only : t_startf, t_stopf use nuopc_shr_methods , only : chkerr use ESMF , only : ESMF_FieldGet, ESMF_FieldSMM, ESMF_Finalize, & diff --git a/src/riverroute/RtmDateTime.F90 b/src/riverroute/RtmDateTime.F90 index a82ed1a..8d0568e 100644 --- a/src/riverroute/RtmDateTime.F90 +++ b/src/riverroute/RtmDateTime.F90 @@ -10,7 +10,7 @@ subroutine getdatetime (cdate, ctime) ! ! A generic Date and Time routine ! - use RtmSpmd, only : mpicom_rof, masterproc, MPI_CHARACTER + use RtmSpmd, only : mpicom_rof, mainproc, MPI_CHARACTER ! ! Arguments character(len=8), intent(out) :: cdate !current date @@ -24,7 +24,7 @@ subroutine getdatetime (cdate, ctime) integer :: ier !MPI error code !----------------------------------------------------------------------- - if (masterproc) then + if (mainproc) then call date_and_time (date, time, zone, values) cdate(1:2) = date(5:6) diff --git a/src/riverroute/RtmFileUtils.F90 b/src/riverroute/RtmFileUtils.F90 index 97d2e56..3f645d3 100644 --- a/src/riverroute/RtmFileUtils.F90 +++ b/src/riverroute/RtmFileUtils.F90 @@ -5,7 +5,7 @@ module RtmFileUtils ! ! !USES: use shr_sys_mod , only : shr_sys_abort - use RtmSpmd , only : masterproc + use RtmSpmd , only : mainproc use RtmVar , only : iulog ! ! !PUBLIC TYPES: @@ -14,7 +14,6 @@ module RtmFileUtils ! ! !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 ! !----------------------------------------------------------------------- @@ -28,7 +27,6 @@ character(len=256) function get_filename (fulpath) ! Returns filename given full pathname ! ! !ARGUMENTS: - implicit none character(len=*), intent(in) :: fulpath !full pathname ! ! !LOCAL VARIABLES: @@ -61,25 +59,22 @@ subroutine getfil (fulpath, locfn, iflag) ! !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' + if (mainproc) 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) + 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 (masterproc) write(iulog,*) '(GETFIL): using ',trim(locfn), & - ' in current working directory' + if (mainproc) write(iulog,*) '(GETFIL): using ',trim(locfn),' in current working directory' RETURN endif @@ -88,10 +83,10 @@ subroutine getfil (fulpath, locfn, iflag) inquire (file=fulpath,exist=lexist) if (lexist) then - if (masterproc) write(iulog,*) '(GETFIL): using ',trim(fulpath) + if (mainproc) write(iulog,*) '(GETFIL): using ',trim(fulpath) RETURN else - if (masterproc) write(iulog,*)'(GETFIL): failed getting file from full path: ', fulpath + 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 @@ -101,41 +96,4 @@ subroutine getfil (fulpath, locfn, iflag) end subroutine getfil - !------------------------------------------------------------------------ - - subroutine opnfil (locfn, form, iun) - - ! Open file locfn in unformatted or formatted form on unit iun - ! - ! arguments - character(len=*), intent(in):: locfn !file name - character(len=1), intent(in):: form !file format: u = unformatted, - integer, intent(out) :: iun !fortran unit number - - ! 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 (newunit=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 - 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 e35f306..2dab656 100644 --- a/src/riverroute/RtmIO.F90 +++ b/src/riverroute/RtmIO.F90 @@ -12,7 +12,7 @@ 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 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 @@ -170,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 @@ -219,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 @@ -257,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) @@ -477,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. @@ -722,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 @@ -1529,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 @@ -1584,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 @@ -1632,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 @@ -1700,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 @@ -1747,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 @@ -1805,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 @@ -1895,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 6b221e2..9359868 100644 --- a/src/riverroute/RtmMod.F90 +++ b/src/riverroute/RtmMod.F90 @@ -8,10 +8,10 @@ module RtmMod 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 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, & + use RtmSpmd , only : mainproc, npes, iam, mpicom_rof, ROFID, & + MPI_REAL8, MPI_INTEGER, MPI_CHARACTER, MPI_LOGICAL, MPI_MAX + 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, & @@ -140,7 +140,7 @@ subroutine MOSART_read_namelist(flood_active) 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 + if (mainproc) then write(iulog,*) 'Reading mosart_inparm namelist from: ', trim(nlfilename_rof) open( newunit=unitn, file=trim(nlfilename_rof), status='old' ) ier = 1 @@ -184,7 +184,7 @@ subroutine MOSART_read_namelist(flood_active) runtyp(nsrContinue + 1) = 'restart' runtyp(nsrBranch + 1) = 'branch ' - if (masterproc) then + if (mainproc) then write(iulog,*) 'define run:' write(iulog,*) ' run type = ',runtyp(nsrest+1) write(iulog,*) ' coupling_period = ',coupling_period @@ -202,7 +202,7 @@ subroutine MOSART_read_namelist(flood_active) if (frivinp_rtm == ' ') then call shr_sys_abort( subname//' ERROR: frivinp_rtm NOT set' ) else - if (masterproc) then + if (mainproc) then write(iulog,*) ' MOSART river data = ',trim(frivinp_rtm) endif end if @@ -327,7 +327,7 @@ subroutine MOSART_init1() do n = 2,nt_rtm rtm_trstr = trim(rtm_trstr)//':'//trim(rtm_tracers(n)) enddo - if (masterproc) then + if (mainproc) then write(iulog,*)'MOSART tracers = ',nt_rtm,trim(rtm_trstr) end if @@ -341,7 +341,7 @@ subroutine MOSART_init1() call t_startf('mosarti_grid') call getfil(frivinp_rtm, locfn, 0 ) - if (masterproc) then + if (mainproc) then write(iulog,*) 'Read in MOSART file name: ',trim(frivinp_rtm) endif @@ -351,7 +351,7 @@ subroutine MOSART_init1() call ncd_inqdid(ncid,'lat',dimid) call ncd_inqdlen(ncid,dimid,rtmlat) - if (masterproc) then + if (mainproc) then write(iulog,*) 'Values for rtmlon/rtmlat: ',rtmlon,rtmlat write(iulog,*) 'Successfully read MOSART dimensions' endif @@ -380,54 +380,54 @@ subroutine MOSART_init1() 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) + 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 (masterproc) write(iulog,*) 'rlonc ',minval(rlonc),maxval(rlonc) + 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 (masterproc) write(iulog,*) 'Read latixy ',minval(tempr),maxval(tempr) + 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 (masterproc) write(iulog,*) 'rlatc ',minval(rlatc),maxval(rlatc) + 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 (masterproc) write(iulog,*) 'Read area ',minval(tempr),maxval(tempr) + 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 (masterproc) write(iulog,*) 'area ',minval(tempr),maxval(tempr) + 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 (masterproc) write(iulog,*) 'Read ID ',minval(itempr),maxval(itempr) + 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 (masterproc) write(iulog,*) 'ID ',minval(itempr),maxval(itempr) + 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 (masterproc) write(iulog,*) 'Read dnID ',minval(itempr),maxval(itempr) + 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 (masterproc) write(iulog,*) 'dnID ',minval(itempr),maxval(itempr) + if (mainproc) write(iulog,*) 'dnID ',minval(itempr),maxval(itempr) deallocate(tempr) deallocate(itempr) @@ -486,16 +486,16 @@ subroutine MOSART_init1() edgew = minval(rlonc) - 0.5*abs(rlonc(1) - rlonc(2)) if ( edgen .ne. 90._r8 )then - if ( masterproc ) write(iulog,*) 'Regional grid: edgen = ', edgen + if ( mainproc ) write(iulog,*) 'Regional grid: edgen = ', edgen end if if ( edges .ne. -90._r8 )then - if ( masterproc ) write(iulog,*) 'Regional grid: edges = ', edges + if ( mainproc ) write(iulog,*) 'Regional grid: edges = ', edges end if if ( edgee .ne. 180._r8 )then - if ( masterproc ) write(iulog,*) 'Regional grid: edgee = ', edgee + if ( mainproc ) write(iulog,*) 'Regional grid: edgee = ', edgee end if if ( edgew .ne.-180._r8 )then - if ( masterproc ) write(iulog,*) 'Regional grid: edgew = ', edgew + if ( mainproc ) write(iulog,*) 'Regional grid: edgew = ', edgew end if ! Set edge latitudes (assumes latitudes are constant for a given longitude) @@ -573,7 +573,7 @@ subroutine MOSART_init1() nrof = nrof + 1 endif enddo - if (masterproc) then + if (mainproc) then write(iulog,*) 'Number of outlet basins = ',nout write(iulog,*) 'Number of total basins = ',nbas write(iulog,*) 'Number of mosart points = ',nmos @@ -635,7 +635,7 @@ subroutine MOSART_init1() 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 (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) @@ -762,7 +762,7 @@ subroutine MOSART_init1() call shr_sys_abort(subname//' ERROR pocn lnd') endif ! decomp_option - if (masterproc) then + 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) @@ -832,7 +832,7 @@ subroutine MOSART_init1() 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 + 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 @@ -846,7 +846,7 @@ subroutine MOSART_init1() call t_startf('mosarti_print') - if (masterproc) then + if (mainproc) then write(iulog,*) 'total runoff cells numr = ',rtmCTL%numr endif call mpi_barrier(mpicom_rof,ier) @@ -995,7 +995,7 @@ subroutine MOSART_init1() deallocate(idxocn) call shr_mpi_sum(lrtmarea, rtmCTL%totarea, mpicom_rof, 'mosart totarea', all=.true.) - if (masterproc) then + 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 @@ -1075,7 +1075,7 @@ subroutine MOSART_init2(rc) deallocate(factorList) deallocate(factorIndexList) - if (masterproc) write(iulog,*) subname," Done initializing rh_direct " + if (mainproc) write(iulog,*) subname," Done initializing rh_direct " ! --------------------------------------- ! Read in data from frivinp_rtm @@ -1113,7 +1113,7 @@ subroutine MOSART_init2(rc) 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) then + if (mainproc) then write(iulog,FORMR) trim(subname),' read frac ',minval(Tunit%frac),maxval(Tunit%frac) end if @@ -1124,7 +1124,7 @@ subroutine MOSART_init2(rc) 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) then + if (mainproc) then write(iulog,'(2A,2i10)') trim(subname),' read fdir mask ',minval(Tunit%mask),maxval(Tunit%mask) end if @@ -1151,12 +1151,12 @@ subroutine MOSART_init2(rc) 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,'(2A,2i10)') trim(subname),' read ID0 ',minval(Tunit%ID0),maxval(Tunit%ID0) + 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 (masterproc) write(iulog,'(2A,2i10)') trim(subname),' read dnID ',minval(Tunit%dnID),maxval(Tunit%dnID) + 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 @@ -1177,7 +1177,7 @@ subroutine MOSART_init2(rc) 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) + 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) @@ -1190,7 +1190,7 @@ subroutine MOSART_init2(rc) 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) + if (mainproc) write(iulog,FORMR) trim(subname),' read areaTotal ',minval(Tunit%areaTotal),maxval(Tunit%areaTotal) allocate(TUnit%rlenTotal(begr:endr)) TUnit%rlenTotal = 0._r8 @@ -1198,12 +1198,12 @@ subroutine MOSART_init2(rc) 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) + 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 (masterproc) write(iulog,FORMR) trim(subname),' read hslp ',minval(Tunit%hslp),maxval(Tunit%hslp) + if (mainproc) write(iulog,FORMR) trim(subname),' read hslp ',minval(Tunit%hslp),maxval(Tunit%hslp) allocate(TUnit%hslpsqrt(begr:endr)) TUnit%hslpsqrt = 0._r8 @@ -1211,7 +1211,7 @@ subroutine MOSART_init2(rc) 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) + if (mainproc) write(iulog,FORMR) trim(subname),' read gxr ',minval(Tunit%gxr),maxval(Tunit%gxr) allocate(TUnit%hlen(begr:endr)) TUnit%hlen = 0._r8 @@ -1219,7 +1219,7 @@ subroutine MOSART_init2(rc) 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) + if (mainproc) write(iulog,FORMR) trim(subname),' read tslp ',minval(Tunit%tslp),maxval(Tunit%tslp) allocate(TUnit%tslpsqrt(begr:endr)) TUnit%tslpsqrt = 0._r8 @@ -1230,7 +1230,7 @@ subroutine MOSART_init2(rc) 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) + 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)) @@ -1239,17 +1239,17 @@ subroutine MOSART_init2(rc) 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) + 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 (masterproc) write(iulog,FORMR) trim(subname),' read rlen ',minval(Tunit%rlen),maxval(Tunit%rlen) + 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 (masterproc) write(iulog,FORMR) trim(subname),' read rslp ',minval(Tunit%rslp),maxval(Tunit%rslp) + if (mainproc) write(iulog,FORMR) trim(subname),' read rslp ',minval(Tunit%rslp),maxval(Tunit%rslp) allocate(TUnit%rslpsqrt(begr:endr)) TUnit%rslpsqrt = 0._r8 @@ -1257,22 +1257,22 @@ subroutine MOSART_init2(rc) 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) + 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 (masterproc) write(iulog,FORMR) trim(subname),' read rwidth0 ',minval(Tunit%rwidth0),maxval(Tunit%rwidth0) + 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 (masterproc) write(iulog,FORMR) trim(subname),' read rdepth ',minval(Tunit%rdepth),maxval(Tunit%rdepth) + 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 (masterproc) write(iulog,FORMR) trim(subname),' read nr ',minval(Tunit%nr),maxval(Tunit%nr) + if (mainproc) write(iulog,FORMR) trim(subname),' read nr ',minval(Tunit%nr),maxval(Tunit%nr) allocate(TUnit%nUp(begr:endr)) TUnit%nUp = 0 @@ -1470,7 +1470,7 @@ subroutine MOSART_init2(rc) factorIndexList(2,cnt) = TUnit%dnID(iunit) endif enddo - if (masterproc) write(iulog,*) subname," Done initializing rh_eroutUp" + 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) @@ -1525,7 +1525,7 @@ subroutine MOSART_init2(rc) enddo call shr_mpi_sum(areatot_tmp, areatot_new, mpicom_rof, 'areatot_new', all=.true.) - if (masterproc) then + if (mainproc) then write(iulog,*) trim(subname),' areatot calc ',tcnt,areatot_new endif enddo @@ -1558,7 +1558,7 @@ subroutine MOSART_init2(rc) 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 + 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 @@ -1601,7 +1601,7 @@ subroutine MOSART_init2(rc) call RtmHistHtapesBuild() end if call RtmHistFldsSet() - if (masterproc) write(iulog,*) subname,' done' + if (mainproc) write(iulog,*) subname,' done' call t_stopf('mosarti_histinit') end subroutine MOSART_init2 @@ -1661,7 +1661,7 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) call get_curr_date(yr, mon, day, tod) ymd = yr*10000 + mon*100 + day - if (tod == 0 .and. masterproc) then + if (tod == 0 .and. mainproc) then write(iulog,*) ' ' write(iulog,'(2a,i10,i6)') trim(subname),' model date is',ymd,tod endif @@ -1671,7 +1671,7 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) 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 + if (mainproc) write(iulog,'(2a,g20.12)') trim(subname),' MOSART coupling period ',delt_coupling end if budget_check = .false. @@ -2007,7 +2007,7 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) call t_startf('mosartr_subcycling') - if (first_call .and. masterproc) then + 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 @@ -2019,7 +2019,7 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) end if delt = delt_coupling/float(nsub) if (delt /= delt_save) then - if (masterproc) 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 @@ -2178,7 +2178,7 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) call shr_mpi_sum(budget_terms,budget_global,mpicom_rof,'mosart global budget',all=.false.) ! write budget - if (masterproc) then + 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)) @@ -2324,7 +2324,7 @@ subroutine MOSART_FloodInit(frivinp, begr, endr, fthresh, evel ) 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' + if (mainproc) write(iulog,*) subname//' variable SLOPE is not on dataset' readvar = .false. else readvar = .true. diff --git a/src/riverroute/RtmRestFile.F90 b/src/riverroute/RtmRestFile.F90 index 9bf3b2f..8139272 100644 --- a/src/riverroute/RtmRestFile.F90 +++ b/src/riverroute/RtmRestFile.F90 @@ -6,7 +6,7 @@ module RtmRestFile ! !USES: use shr_kind_mod , only : r8 => shr_kind_r8 use shr_sys_mod , only : shr_sys_abort - use RtmSpmd , only : masterproc + use RtmSpmd , only : mainproc use RtmVar , only : rtmlon, rtmlat, iulog, inst_suffix, rpntfil, & caseid, nsrest, brnch_retain_casename, & finidat_rtm, nrevsn_rtm, spval, & @@ -14,7 +14,7 @@ module RtmRestFile ctitle, version, username, hostname, conventions, source, & nt_rtm, nt_rtm, rtm_tracers use RtmHistFile , only : RtmHistRestart - use RtmFileUtils , only : opnfil, getfil + use RtmFileUtils , only : getfil use RtmTimeManager, only : timemgr_restart, get_nstep, get_curr_date, is_last_step use RunoffMod , only : rtmCTL use RtmIO @@ -36,9 +36,6 @@ module RtmRestFile private :: restFile_read_pfile private :: restFile_write_pfile ! Writes restart pointer file private :: restFile_dimset - ! - ! !REVISION HISTORY: - ! Author: Mariana Vertenstein !----------------------------------------------------------------------- contains @@ -49,11 +46,11 @@ subroutine RtmRestFileWrite( file, rdate ) !------------------------------------- ! Read/write MOSART restart file. - ! !ARGUMENTS: + ! Arguments: character(len=*) , intent(in) :: file ! output netcdf restart file character(len=*) , intent(in) :: rdate ! restart file time stamp for name - ! !LOCAL VARIABLES: + ! Local variables type(file_desc_t) :: ncid ! netcdf id integer :: i ! index logical :: ptrfile ! write out the restart pointer file @@ -61,7 +58,7 @@ subroutine RtmRestFileWrite( file, rdate ) ! Define dimensions and variables - if (masterproc) then + if (mainproc) then write(iulog,*) write(iulog,*)'restFile_open: writing MOSART restart dataset ' write(iulog,*) @@ -79,7 +76,7 @@ subroutine RtmRestFileWrite( file, rdate ) call timemgr_restart( ncid, flag='write' ) call ncd_pio_closefile(ncid) - if (masterproc) then + if (mainproc) then write(iulog,*) 'Successfully wrote local restart file ',trim(file) write(iulog,'(72a1)') ("-",i=1,60) write(iulog,*) @@ -90,7 +87,7 @@ subroutine RtmRestFileWrite( file, rdate ) ! Write out diagnostic info - if (masterproc) then + if (mainproc) then write(iulog,*) 'Successfully wrote out restart data at nstep = ',get_nstep() write(iulog,'(72a1)') ("-",i=1,60) end if @@ -104,23 +101,23 @@ subroutine RtmRestFileRead( file ) !------------------------------------- ! Read a MOSART restart file. ! - ! !ARGUMENTS: + ! Arguments character(len=*), intent(in) :: file ! output netcdf restart file ! - ! !LOCAL VARIABLES: + ! Local variables type(file_desc_t) :: ncid ! netcdf id integer :: i ! index !------------------------------------- ! Read file - if (masterproc) write(iulog,*) 'Reading restart dataset' + 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 (masterproc) then + if (mainproc) then write(iulog,'(72a1)') ("-",i=1,60) write(iulog,*) 'Successfully read restart data for restart run' write(iulog,*) @@ -135,22 +132,22 @@ subroutine RtmRestTimeManager( file ) !------------------------------------- ! Read a MOSART restart file. ! - ! !ARGUMENTS: + ! Arguments character(len=*), intent(in) :: file ! output netcdf restart file ! - ! !LOCAL VARIABLES: + ! Local Variables: type(file_desc_t) :: ncid ! netcdf id integer :: i ! index !------------------------------------- ! Read file - if (masterproc) write(iulog,*) 'Reading restart Timemanger' + 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 (masterproc) then + if (mainproc) then write(iulog,'(72a1)') ("-",i=1,60) write(iulog,*) 'Successfully read restart data for restart run' write(iulog,*) @@ -165,7 +162,7 @@ subroutine RtmRestGetfile( file, path ) !------------------------------------- ! Determine and obtain netcdf restart file - ! ARGUMENTS: + ! Arguments: character(len=*), intent(out) :: file ! name of netcdf restart file character(len=*), intent(out) :: path ! full pathname of netcdf restart file @@ -222,14 +219,14 @@ subroutine restFile_read_pfile( pnamer ) !------------------------------------- ! Setup restart file and perform necessary consistency checks - ! !ARGUMENTS: + ! Arguments 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 + ! 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. @@ -238,17 +235,19 @@ subroutine restFile_read_pfile( pnamer ) ! [nrevsn_rtm] contains the full pathname of the restart file. ! New history files are always created for branch runs. - if (masterproc) then + if (mainproc) then write(iulog,*) 'Reading restart pointer file....' endif - locfn = './'// trim(rpntfil)//trim(inst_suffix) - call opnfil (locfn, 'f', nio) + 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 (masterproc) then - write(iulog,*) 'Reading restart data.....' + if (mainproc) then + write(iulog,'(a)') 'Reading restart data.....' write(iulog,'(72a1)') ("-",i=1,60) end if @@ -261,18 +260,22 @@ subroutine restFile_write_pfile( fnamer ) !------------------------------------- ! Open restart pointer file. Write names of current netcdf restart file. ! - ! !ARGUMENTS: + ! Arguments character(len=*), intent(in) :: fnamer ! - ! !LOCAL VARIABLES: - integer :: m ! index - integer :: nio ! restart pointer file + ! Local variables + integer :: nio ! restart pointer file unit number + integer :: ier ! error return from fortran open character(len=256) :: filename ! local file name !------------------------------------- - if (masterproc) then + if (mainproc) then filename= './'// trim(rpntfil)//trim(inst_suffix) - call opnfil( filename, 'f', nio) + 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' @@ -288,7 +291,7 @@ character(len=256) function RtmRestFileName( rdate ) 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 + if (mainproc) then write(iulog,*)'writing restart file ',trim(RtmRestFileName),' for model date = ',rdate end if @@ -301,10 +304,10 @@ subroutine restFile_dimset( ncid ) !------------------------------------- ! Read/Write initial data from/to netCDF instantaneous initial data file - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(inout) :: ncid - ! !LOCAL VARIABLES: + ! Local Variables: integer :: dimid ! netCDF dimension id integer :: ier ! error status character(len= 8) :: curdate ! current date @@ -343,11 +346,11 @@ subroutine RtmRestart(ncid, flag) !------------------------------------- ! Read/write MOSART restart data. ! - ! ARGUMENTS: + ! Arguments: type(file_desc_t), intent(inout) :: ncid ! netcdf id character(len=*) , intent(in) :: flag ! 'read' or 'write' - ! LOCAL VARIABLES: + ! Local variables logical :: readvar ! determine if variable is on initial file integer :: nt,nv,n ! indices real(r8) , pointer :: dfld(:) ! temporary array diff --git a/src/riverroute/RtmSpmd.F90 b/src/riverroute/RtmSpmd.F90 index c94195b..5261780 100644 --- a/src/riverroute/RtmSpmd.F90 +++ b/src/riverroute/RtmSpmd.F90 @@ -1,87 +1,64 @@ - module RtmSpmd -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: RtmSpmd -! -! !DESCRIPTION: -! RTM SPMD initialization -! -! !REVISION HISTORY: -! Author: Mariana Vertenstein -! -!EOP -!----------------------------------------------------------------------- - implicit none - private + ! SPMD initialization + + implicit none + private #include - ! Default settings valid even if there is no spmd - - logical, public :: masterproc ! proc 0 logical for printing msgs - integer, public :: iam ! processor number - integer, public :: npes ! number of processors for rtm - integer, public :: mpicom_rof ! communicator group for rtm - integer, public :: ROFID ! component id needed for PIO - integer, public, parameter :: MASTERTASK=0 ! the value of iam which is assigned - ! the masterproc duties - - ! - ! Public methods - ! - public :: RtmSpmdInit ! Initialization - - ! - ! Values from mpif.h that can be used - ! - public :: MPI_INTEGER - public :: MPI_REAL8 - public :: MPI_LOGICAL - public :: MPI_SUM - public :: MPI_MIN - public :: MPI_MAX - public :: MPI_LOR - public :: MPI_STATUS_SIZE - public :: MPI_ANY_SOURCE - public :: MPI_CHARACTER - public :: MPI_COMM_WORLD + ! Default settings valid even if there is no mpi -contains + 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 + integer, public, parameter :: MAINTASK=0 ! the value of iam which is assigned + ! the mainproc duties -!----------------------------------------------------------------------- + ! Public methods + public :: RtmSpmdInit ! Initialization - subroutine RtmSpmdInit(mpicom) + ! Values from mpif.h that can be used + public :: MPI_INTEGER + public :: MPI_REAL8 + public :: MPI_LOGICAL + public :: MPI_CHARACTER + public :: MPI_SUM + public :: MPI_MIN + public :: MPI_MAX + +contains - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! MPI initialization (number of processes, etc) - ! - ! !ARGUMENTS: - integer, intent(in) :: mpicom - ! - ! !LOCAL VARIABLES: - integer :: ier ! return error status - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- - ! Initialize mpi communicator group + subroutine RtmSpmdInit(mpicom) - mpicom_rof = mpicom + !----------------------------------------------------------------------- + ! MPI initialization (number of processes, etc) + ! + ! Arguments + integer, intent(in) :: mpicom + ! + ! Local variables + integer :: ier ! return error status + !----------------------------------------------------------------------- - ! Get my processor id + ! Initialize mpi communicator group + mpicom_rof = mpicom - call mpi_comm_rank(mpicom_rof, iam, ier) - if (iam == MASTERTASK) then - masterproc = .true. - else - masterproc = .false. - end if + ! Get my processor id + call mpi_comm_rank(mpicom_rof, iam, ier) + if (iam == MAINTASK) then + mainproc = .true. + else + mainproc = .false. + end if - ! Get number of processors - call mpi_comm_size(mpicom_rof, npes, ier) + ! Get number of processors + call mpi_comm_size(mpicom_rof, npes, ier) - end subroutine RtmSpmdInit + end subroutine RtmSpmdInit end module RtmSpmd diff --git a/src/riverroute/RtmTimeManager.F90 b/src/riverroute/RtmTimeManager.F90 index 45e24ba..6361219 100644 --- a/src/riverroute/RtmTimeManager.F90 +++ b/src/riverroute/RtmTimeManager.F90 @@ -2,16 +2,15 @@ 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, MPI_INTEGER, MPI_CHARACTER, mainproc use RtmVar , only: isecspday, iulog, nsrest, nsrContinue use RtmIO use ESMF - implicit none private -! Public methods + ! Public methods public ::& timemgr_setup, &! setup startup values @@ -39,7 +38,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 +62,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 +144,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 +188,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 +212,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 +322,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 +393,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 +509,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 +547,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 +565,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 +696,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 +731,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 +768,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 +776,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 +956,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 +1055,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 3ab9dcf..75dc480 100644 --- a/src/riverroute/RtmVar.F90 +++ b/src/riverroute/RtmVar.F90 @@ -3,7 +3,7 @@ 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 @@ -111,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 From 422491acb6771e3dae16c161add07e1aac158ce3 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 13 Dec 2023 21:22:45 +0100 Subject: [PATCH 11/86] changed comment to refer to MOSART rather than RTM --- src/riverroute/RtmMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/riverroute/RtmMod.F90 b/src/riverroute/RtmMod.F90 index 9359868..99ea6c7 100644 --- a/src/riverroute/RtmMod.F90 +++ b/src/riverroute/RtmMod.F90 @@ -1050,7 +1050,7 @@ subroutine MOSART_init2(rc) dst_direct(:,:) = 0._r8 ! Calculate map for direct to outlet mapping - ! The route handle rh_direct will then be used in Rtmrun + ! 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)) From 79f2df3c7cc3b65b809e20b92f233fe79e43f1c2 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Fri, 15 Dec 2023 10:44:43 +0100 Subject: [PATCH 12/86] removed commented code and changed PIO_BCAST_ERROR to PIO_INTERNAL_ERROR in RtmMod.F90 --- src/riverroute/MOSART_physics_mod.F90 | 64 +----------------------- src/riverroute/RtmMod.F90 | 72 +++------------------------ 2 files changed, 8 insertions(+), 128 deletions(-) diff --git a/src/riverroute/MOSART_physics_mod.F90 b/src/riverroute/MOSART_physics_mod.F90 index ed0d21c..e7349d4 100644 --- a/src/riverroute/MOSART_physics_mod.F90 +++ b/src/riverroute/MOSART_physics_mod.F90 @@ -1,4 +1,4 @@ -MODULE MOSART_physics_mod +module MOSART_physics_mod !----------------------------------------------------------------------- ! Description: core code of MOSART. Can be incoporated within any @@ -184,10 +184,6 @@ subroutine Euler(rc) 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) ! erout here might be inflow to some downstream subbasin, so treat it differently than erlateral temp_erout = temp_erout + TRunoff%erout(iunit,nt) @@ -225,7 +221,6 @@ subroutine hillslopeRouting(iunit, nt, theDeltaT) 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 @@ -244,11 +239,9 @@ subroutine subnetworkRouting(iunit,nt,theDeltaT) 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 @@ -260,11 +253,6 @@ subroutine subnetworkRouting(iunit,nt,theDeltaT) 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 !----------------------------------------------------------------------- @@ -303,12 +291,6 @@ subroutine Routing_KW(iunit, nt, theDeltaT) ! 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 @@ -319,7 +301,6 @@ subroutine Routing_KW(iunit, nt, theDeltaT) 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) + & @@ -343,21 +324,8 @@ subroutine Routing_KW(iunit, nt, theDeltaT) 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 !----------------------------------------------------------------------- @@ -460,19 +428,8 @@ function CRVRMAN(slp_, n_, rr_) result(v_) 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 !----------------------------------------------------------------------- @@ -489,20 +446,8 @@ function CRVRMAN_nosqrt(sqrtslp_, n_, rr_) result(v_) 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 !----------------------------------------------------------------------- @@ -627,12 +572,10 @@ function GRHR(mr_, rwidth_, rwidth0_, rdepth_) result(hr_) 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 !----------------------------------------------------------------------- @@ -666,7 +609,6 @@ function GRPR(hr_, rwidth_, rwidth0_,rdepth_) result(pr_) 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))) @@ -691,8 +633,6 @@ subroutine createFile(nio, fname) 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) @@ -727,4 +667,4 @@ subroutine printTest(nio) end subroutine printTest -end MODULE MOSART_physics_mod +end module MOSART_physics_mod diff --git a/src/riverroute/RtmMod.F90 b/src/riverroute/RtmMod.F90 index 99ea6c7..6edd817 100644 --- a/src/riverroute/RtmMod.F90 +++ b/src/riverroute/RtmMod.F90 @@ -37,18 +37,17 @@ module RtmMod ESMF_TERMORDER_SRCSEQ use RtmIO use pio - ! - ! !PUBLIC TYPES: + implicit none private - ! - ! !PUBLIC MEMBER FUNCTIONS: + + ! 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 member functions private :: MOSART_FloodInit private :: MOSART_SubTimestep @@ -677,17 +676,8 @@ subroutine MOSART_init1() 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 @@ -1105,7 +1095,6 @@ subroutine MOSART_init2(rc) 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. @@ -1535,23 +1524,8 @@ subroutine MOSART_init2(rc) 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 MOSART_SubTimestep ! prepare for numerical computation @@ -1747,9 +1721,6 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) 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 @@ -1758,8 +1729,6 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) ! remove irrigation from wr (main channel) TRunoff%wr(nr,nt) = TRunoff%wr(nr,nt) - irrig_volume - !scs endif - enddo call t_stopf('mosartr_irrig') @@ -1777,8 +1746,7 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) ! 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 + ! 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 @@ -2192,48 +2160,20 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) write(iulog,'(2a,i4)') trim(subname),' tracer = ',nt write(iulog,'(2a,i4,f22.6)') trim(subname),' volume init = ',nt,budget_global(1,nt) write(iulog,'(2a,i4,f22.6)') trim(subname),' volume final = ',nt,budget_global(2,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' volumeh init = ',nt,budget_global(7,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' volumeh final = ',nt,budget_global(8,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' volumet init = ',nt,budget_global(3,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' volumet final = ',nt,budget_global(4,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' volumer init = ',nt,budget_global(5,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' volumer final = ',nt,budget_global(6,nt) - !write(iulog,'(2a)') trim(subname),'----------------' write(iulog,'(2a,i4,f22.6)') trim(subname),' input surface = ',nt,budget_global(13,nt) write(iulog,'(2a,i4,f22.6)') trim(subname),' input subsurf = ',nt,budget_global(14,nt) write(iulog,'(2a,i4,f22.6)') trim(subname),' input gwl = ',nt,budget_global(15,nt) write(iulog,'(2a,i4,f22.6)') trim(subname),' input irrig = ',nt,budget_global(16,nt) write(iulog,'(2a,i4,f22.6)') trim(subname),' input total = ',nt,budget_global(17,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' input check = ',nt,budget_input - budget_global(17,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' input euler = ',nt,budget_global(20,nt) - !write(iulog,'(2a)') trim(subname),'----------------' write(iulog,'(2a,i4,f22.6)') trim(subname),' output flow = ',nt,budget_global(18,nt) write(iulog,'(2a,i4,f22.6)') trim(subname),' output direct = ',nt,budget_global(21,nt) write(iulog,'(2a,i4,f22.6)') trim(subname),' output flood = ',nt,budget_global(19,nt) write(iulog,'(2a,i4,f22.6)') trim(subname),' output total = ',nt,budget_global(22,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' output check = ',nt,budget_output - budget_global(22,nt) - !write(iulog,'(2a)') trim(subname),'----------------' write(iulog,'(2a,i4,f22.6)') trim(subname),' sum input = ',nt,budget_input write(iulog,'(2a,i4,f22.6)') trim(subname),' sum dvolume = ',nt,budget_volume write(iulog,'(2a,i4,f22.6)') trim(subname),' sum output = ',nt,budget_output - !write(iulog,'(2a)') trim(subname),'----------------' write(iulog,'(2a,i4,f22.6)') trim(subname),' net (dv-i+o) = ',nt,budget_total - !write(iulog,'(2a,i4,f22.6)') trim(subname),' net euler = ',nt,budget_euler write(iulog,'(2a,i4,f22.6)') trim(subname),' eul erout lag = ',nt,budget_eroutlag - !write(iulog,'(2a,i4,f22.6)') trim(subname),' accum (dv-i+o)= ',nt,budget_global(30,nt) - !write(iulog,'(2a)') trim(subname),'----------------' - !write(iulog,'(2a,i4,f22.6)') trim(subname),' erout_prev no= ',nt,budget_global(23,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' erout no= ',nt,budget_global(24,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' eroutup_avg = ',nt,budget_global(25,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' erout_prev out= ',nt,budget_global(26,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' erout out= ',nt,budget_global(27,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' erlateral = ',nt,budget_global(28,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' euler gwl = ',nt,budget_global(29,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' net main chan = ',nt,& - ! budget_global(6,nt)-budget_global(5,nt)+budget_global(24,nt)& - ! -budget_global(23,nt)+budget_global(27,nt)+budget_global(28,nt)+budget_global(29,nt) - !write(iulog,'(2a)') trim(subname),'----------------' - if ((budget_total-budget_eroutlag) > 1.0e-6) then write(iulog,'(2a,i4)') trim(subname),' ***** BUDGET WARNING error gt 1. m3 for nt = ',nt endif From 5223cb40fd0285e91b81550d6e9dad13c70dd1ba Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Fri, 15 Dec 2023 11:13:32 +0100 Subject: [PATCH 13/86] fix compilation issues --- src/riverroute/RtmDateTime.F90 | 9 +++++---- src/riverroute/RtmMod.F90 | 4 ++-- src/riverroute/RtmSpmd.F90 | 15 +-------------- src/riverroute/RtmTimeManager.F90 | 3 ++- 4 files changed, 10 insertions(+), 21 deletions(-) diff --git a/src/riverroute/RtmDateTime.F90 b/src/riverroute/RtmDateTime.F90 index 8d0568e..0afd6f7 100644 --- a/src/riverroute/RtmDateTime.F90 +++ b/src/riverroute/RtmDateTime.F90 @@ -10,16 +10,17 @@ subroutine getdatetime (cdate, ctime) ! ! A generic Date and Time routine ! - use RtmSpmd, only : mpicom_rof, mainproc, MPI_CHARACTER + 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 + 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 !----------------------------------------------------------------------- diff --git a/src/riverroute/RtmMod.F90 b/src/riverroute/RtmMod.F90 index 6edd817..889706d 100644 --- a/src/riverroute/RtmMod.F90 +++ b/src/riverroute/RtmMod.F90 @@ -8,8 +8,7 @@ module RtmMod 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, & - MPI_REAL8, MPI_INTEGER, MPI_CHARACTER, MPI_LOGICAL, MPI_MAX + 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, & @@ -37,6 +36,7 @@ module RtmMod ESMF_TERMORDER_SRCSEQ use RtmIO use pio + use mpi implicit none private diff --git a/src/riverroute/RtmSpmd.F90 b/src/riverroute/RtmSpmd.F90 index 5261780..9e172f3 100644 --- a/src/riverroute/RtmSpmd.F90 +++ b/src/riverroute/RtmSpmd.F90 @@ -5,8 +5,6 @@ module RtmSpmd implicit none private -#include - ! Default settings valid even if there is no mpi logical, public :: mainproc ! proc 0 logical for printing msgs @@ -14,21 +12,10 @@ module RtmSpmd integer, public :: npes ! number of processors for rtm integer, public :: mpicom_rof ! communicator group for rtm integer, public :: ROFID ! component id needed for PIO - integer, public, parameter :: MAINTASK=0 ! the value of iam which is assigned - ! the mainproc duties ! Public methods public :: RtmSpmdInit ! Initialization - ! Values from mpif.h that can be used - public :: MPI_INTEGER - public :: MPI_REAL8 - public :: MPI_LOGICAL - public :: MPI_CHARACTER - public :: MPI_SUM - public :: MPI_MIN - public :: MPI_MAX - contains !----------------------------------------------------------------------- @@ -50,7 +37,7 @@ subroutine RtmSpmdInit(mpicom) ! Get my processor id call mpi_comm_rank(mpicom_rof, iam, ier) - if (iam == MAINTASK) then + if (iam == 0) then mainproc = .true. else mainproc = .false. diff --git a/src/riverroute/RtmTimeManager.F90 b/src/riverroute/RtmTimeManager.F90 index 6361219..a19c52f 100644 --- a/src/riverroute/RtmTimeManager.F90 +++ b/src/riverroute/RtmTimeManager.F90 @@ -2,10 +2,11 @@ module RtmTimeManager use shr_kind_mod, only: r8 => shr_kind_r8 use shr_sys_mod , only: shr_sys_abort - use RtmSpmd , only: mpicom_rof, MPI_INTEGER, MPI_CHARACTER, mainproc + use RtmSpmd , only: mpicom_rof, mainproc use RtmVar , only: isecspday, iulog, nsrest, nsrContinue use RtmIO use ESMF + use mpi implicit none private From a446c514eff92b00fa4d5b0fe0cfc5d30e3ccf2d Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Fri, 15 Dec 2023 20:07:21 +0100 Subject: [PATCH 14/86] addressed comment in PR --- src/riverroute/RtmSpmd.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/riverroute/RtmSpmd.F90 b/src/riverroute/RtmSpmd.F90 index 9e172f3..2be21a9 100644 --- a/src/riverroute/RtmSpmd.F90 +++ b/src/riverroute/RtmSpmd.F90 @@ -30,6 +30,7 @@ subroutine RtmSpmdInit(mpicom) ! ! Local variables integer :: ier ! return error status + integer :: maintask !----------------------------------------------------------------------- ! Initialize mpi communicator group @@ -37,7 +38,8 @@ subroutine RtmSpmdInit(mpicom) ! Get my processor id call mpi_comm_rank(mpicom_rof, iam, ier) - if (iam == 0) then + maintask = 0 + if (iam == maintask) then mainproc = .true. else mainproc = .false. From dd93319d02bde8c7be64f8ddbb8aae57ef53a304 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Fri, 15 Dec 2023 20:10:13 +0100 Subject: [PATCH 15/86] added center to description of lon/lat of gridcells --- src/riverroute/RtmMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/riverroute/RtmMod.F90 b/src/riverroute/RtmMod.F90 index 889706d..9b4f897 100644 --- a/src/riverroute/RtmMod.F90 +++ b/src/riverroute/RtmMod.F90 @@ -76,8 +76,8 @@ module RtmMod real(r8), 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 :: 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) From 4e66eb612f79b5abf67a416e0e3b9bbcca0e7043 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sun, 31 Dec 2023 14:24:17 +0100 Subject: [PATCH 16/86] moved files to new name --- src/riverroute/RtmSpmd.F90 | 53 ------------------- ...{RunoffMod.F90 => mosart_control_type.F90} | 0 .../{RtmDateTime.F90 => mosart_datetime.F90} | 0 ...{RtmFileUtils.F90 => mosart_fileutils.F90} | 0 .../{RtmHistFile.F90 => mosart_histfile.F90} | 0 .../{RtmHistFlds.F90 => mosart_histflds.F90} | 0 src/riverroute/{RtmIO.F90 => mosart_io.F90} | 0 src/riverroute/{RtmMod.F90 => mosart_mod.F90} | 0 ...physics_mod.F90 => mosart_physics_mod.F90} | 0 .../{RtmRestFile.F90 => mosart_restfile.F90} | 0 ...TimeManager.F90 => mosart_timemanager.F90} | 0 .../{RtmVar.F90 => mosart_vars.F90} | 0 12 files changed, 53 deletions(-) delete mode 100644 src/riverroute/RtmSpmd.F90 rename src/riverroute/{RunoffMod.F90 => mosart_control_type.F90} (100%) rename src/riverroute/{RtmDateTime.F90 => mosart_datetime.F90} (100%) rename src/riverroute/{RtmFileUtils.F90 => mosart_fileutils.F90} (100%) rename src/riverroute/{RtmHistFile.F90 => mosart_histfile.F90} (100%) rename src/riverroute/{RtmHistFlds.F90 => mosart_histflds.F90} (100%) rename src/riverroute/{RtmIO.F90 => mosart_io.F90} (100%) rename src/riverroute/{RtmMod.F90 => mosart_mod.F90} (100%) rename src/riverroute/{MOSART_physics_mod.F90 => mosart_physics_mod.F90} (100%) rename src/riverroute/{RtmRestFile.F90 => mosart_restfile.F90} (100%) rename src/riverroute/{RtmTimeManager.F90 => mosart_timemanager.F90} (100%) rename src/riverroute/{RtmVar.F90 => mosart_vars.F90} (100%) diff --git a/src/riverroute/RtmSpmd.F90 b/src/riverroute/RtmSpmd.F90 deleted file mode 100644 index 2be21a9..0000000 --- a/src/riverroute/RtmSpmd.F90 +++ /dev/null @@ -1,53 +0,0 @@ -module RtmSpmd - - ! SPMD initialization - - implicit none - private - - ! Default settings valid even if there is no mpi - - 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 - - ! Public methods - public :: RtmSpmdInit ! Initialization - -contains - - !----------------------------------------------------------------------- - - 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/RunoffMod.F90 b/src/riverroute/mosart_control_type.F90 similarity index 100% rename from src/riverroute/RunoffMod.F90 rename to src/riverroute/mosart_control_type.F90 diff --git a/src/riverroute/RtmDateTime.F90 b/src/riverroute/mosart_datetime.F90 similarity index 100% rename from src/riverroute/RtmDateTime.F90 rename to src/riverroute/mosart_datetime.F90 diff --git a/src/riverroute/RtmFileUtils.F90 b/src/riverroute/mosart_fileutils.F90 similarity index 100% rename from src/riverroute/RtmFileUtils.F90 rename to src/riverroute/mosart_fileutils.F90 diff --git a/src/riverroute/RtmHistFile.F90 b/src/riverroute/mosart_histfile.F90 similarity index 100% rename from src/riverroute/RtmHistFile.F90 rename to src/riverroute/mosart_histfile.F90 diff --git a/src/riverroute/RtmHistFlds.F90 b/src/riverroute/mosart_histflds.F90 similarity index 100% rename from src/riverroute/RtmHistFlds.F90 rename to src/riverroute/mosart_histflds.F90 diff --git a/src/riverroute/RtmIO.F90 b/src/riverroute/mosart_io.F90 similarity index 100% rename from src/riverroute/RtmIO.F90 rename to src/riverroute/mosart_io.F90 diff --git a/src/riverroute/RtmMod.F90 b/src/riverroute/mosart_mod.F90 similarity index 100% rename from src/riverroute/RtmMod.F90 rename to src/riverroute/mosart_mod.F90 diff --git a/src/riverroute/MOSART_physics_mod.F90 b/src/riverroute/mosart_physics_mod.F90 similarity index 100% rename from src/riverroute/MOSART_physics_mod.F90 rename to src/riverroute/mosart_physics_mod.F90 diff --git a/src/riverroute/RtmRestFile.F90 b/src/riverroute/mosart_restfile.F90 similarity index 100% rename from src/riverroute/RtmRestFile.F90 rename to src/riverroute/mosart_restfile.F90 diff --git a/src/riverroute/RtmTimeManager.F90 b/src/riverroute/mosart_timemanager.F90 similarity index 100% rename from src/riverroute/RtmTimeManager.F90 rename to src/riverroute/mosart_timemanager.F90 diff --git a/src/riverroute/RtmVar.F90 b/src/riverroute/mosart_vars.F90 similarity index 100% rename from src/riverroute/RtmVar.F90 rename to src/riverroute/mosart_vars.F90 From cdd878de4cff9dc562093978e44aeb7122237983 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sun, 31 Dec 2023 14:28:20 +0100 Subject: [PATCH 17/86] major refactor of mosart code --- cime_config/buildnml | 20 +- cime_config/namelist_definition_mosart.xml | 56 +- .../mosart/default/user_nl_mosart | 8 +- src/cpl/nuopc/rof_comp_nuopc.F90 | 218 +- src/cpl/nuopc/rof_import_export.F90 | 156 +- src/riverroute/mosart_control_type.F90 | 1421 ++++-- src/riverroute/mosart_data.F90 | 19 + src/riverroute/mosart_datetime.F90 | 49 - src/riverroute/mosart_fileutils.F90 | 20 +- src/riverroute/mosart_histfile.F90 | 3459 +++++++-------- src/riverroute/mosart_histflds.F90 | 337 +- src/riverroute/mosart_io.F90 | 3861 ++++++++--------- src/riverroute/mosart_mod.F90 | 2028 ++------- src/riverroute/mosart_physics_mod.F90 | 404 +- src/riverroute/mosart_restfile.F90 | 209 +- src/riverroute/mosart_tctl_type.F90 | 30 + src/riverroute/mosart_timemanager.F90 | 1773 ++++---- src/riverroute/mosart_tparameter_type.F90 | 33 + src/riverroute/mosart_tspatialunit_type.F90 | 658 +++ src/riverroute/mosart_tstatusflux_type.F90 | 166 + src/riverroute/mosart_vars.F90 | 193 +- 21 files changed, 7421 insertions(+), 7697 deletions(-) create mode 100644 src/riverroute/mosart_data.F90 delete mode 100644 src/riverroute/mosart_datetime.F90 create mode 100644 src/riverroute/mosart_tctl_type.F90 create mode 100644 src/riverroute/mosart_tparameter_type.F90 create mode 100644 src/riverroute/mosart_tspatialunit_type.F90 create mode 100644 src/riverroute/mosart_tstatusflux_type.F90 diff --git a/cime_config/buildnml b/cime_config/buildnml index 56c8cb7..68dbebc 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -79,7 +79,7 @@ def _create_namelists(case, confdir, inst_string, infile, nmlgen, data_list_path #---------------------------------------------------- run_type = case.get_value("RUN_TYPE") - finidat_rtm = str(nmlgen.get_value("finidat_rtm")) + finidat = str(nmlgen.get_value("finidat")) if run_type == 'branch' or run_type == 'hybrid': run_refcase = case.get_value("RUN_REFCASE") run_refdate = case.get_value("RUN_REFDATE") @@ -90,17 +90,17 @@ def _create_namelists(case, confdir, inst_string, infile, nmlgen, data_list_path filename = "%s.mosart.r.%s-%s.nc" %(run_refcase, run_refdate, run_tod) if run_type == "hybrid": - nmlgen.add_default("finidat_rtm", value=filename, ignore_abs_path=True) + nmlgen.add_default("finidat", value=filename, ignore_abs_path=True) else: - nmlgen.add_default("nrevsn_rtm", value=filename) - elif finidat_rtm.strip() == '': - nmlgen.set_value('finidat_rtm', value=' ') + nmlgen.add_default("nrevsn", value=filename) + elif finidat.strip() == '': + nmlgen.set_value('finidat', value=' ') else: - if nmlgen.get_default('finidat_rtm') == 'UNSET': - nmlgen.add_default('finidat_rtm', value=' ', ignore_abs_path=True) + if nmlgen.get_default('finidat') == 'UNSET': + nmlgen.add_default('finidat', value=' ', ignore_abs_path=True) else: - nmlgen.add_default("finidat_rtm") + nmlgen.add_default("finidat") ncpl_base_period = case.get_value('NCPL_BASE_PERIOD') if ncpl_base_period == 'hour': @@ -131,8 +131,8 @@ def _create_namelists(case, confdir, inst_string, infile, nmlgen, data_list_path coupling_period = basedt // mosart_ncpl nmlgen.set_value("coupling_period", value=coupling_period) - if ( nmlgen.get_value("frivinp_rtm") == "UNSET" and config["mosart_mode"] != "NULL" ): - raise SystemExit("ERROR: Direction file is NOT set and is required when MOSART is active: frivinp_rtm") + if ( nmlgen.get_value("frivinp") == "UNSET" and config["mosart_mode"] != "NULL" ): + raise SystemExit("ERROR: Direction file is NOT set and is required when MOSART is active: frivinp") bypass_routing_option = nmlgen.get_value("bypass_routing_option") qgwl_runoff_option = nmlgen.get_value("qgwl_runoff_option") diff --git a/cime_config/namelist_definition_mosart.xml b/cime_config/namelist_definition_mosart.xml index f8843ef..eca45b8 100644 --- a/cime_config/namelist_definition_mosart.xml +++ b/cime_config/namelist_definition_mosart.xml @@ -8,20 +8,6 @@ - - logical - mosart - mosart_inparm - - .true. - .false. - - - If .true., turn on mosart flooding back to clm - Note that mosart flood is not supported in CESM1.1 - - - logical mosart @@ -74,6 +60,20 @@ + + logical + mosart + mosart_inparm + + .false. + + + If true, add capability to have halo option for mosart fields. + In particarul these can be used to create derivatives using halo values + from neighboring cells. + + + char mosart @@ -101,7 +101,7 @@ - + char mosart mosart_inparm @@ -110,11 +110,11 @@ UNSET - Full pathname of initial rtm file + Full pathname of initialfile - + char mosart mosart_inparm @@ -126,7 +126,7 @@ - + char mosart abs @@ -138,11 +138,11 @@ $DIN_LOC_ROOT/rof/mosart/MOSART_routing_0.125nldas2_cdf5_c200727.nc - Full pathname of input datafile for RTM. + Full pathname of input mosart datafile - + char(1000) history mosart_inparm @@ -154,7 +154,7 @@ - + char(1000) history mosart_inparm @@ -166,7 +166,7 @@ - + char(1000) history mosart_inparm @@ -178,7 +178,7 @@ - + char(1000) history mosart_inparm @@ -190,7 +190,7 @@ - + char(1000) history mosart_inparm @@ -202,7 +202,7 @@ - + char(1000) history mosart_inparm @@ -214,7 +214,7 @@ - + integer(6) history mosart_inparm @@ -226,7 +226,7 @@ - + integer(6) history mosart_inparm @@ -240,7 +240,7 @@ - + integer(6) history mosart_inparm diff --git a/cime_config/testdefs/testmods_dirs/mosart/default/user_nl_mosart b/cime_config/testdefs/testmods_dirs/mosart/default/user_nl_mosart index d60ef17..6dad334 100644 --- a/cime_config/testdefs/testmods_dirs/mosart/default/user_nl_mosart +++ b/cime_config/testdefs/testmods_dirs/mosart/default/user_nl_mosart @@ -1,4 +1,4 @@ -! ice_runoff = .true. - rtmhist_ndens = 1,1,1 - rtmhist_nhtfrq =-24,-8 - rtmhist_mfilt = 1,1 +! ice_runoff = .true. + ndens = 1,1,1 + nhtfrq =-24,-8 + mfilt = 1,1 diff --git a/src/cpl/nuopc/rof_comp_nuopc.F90 b/src/cpl/nuopc/rof_comp_nuopc.F90 index 5e75433..1be1b4c 100644 --- a/src/cpl/nuopc/rof_comp_nuopc.F90 +++ b/src/cpl/nuopc/rof_comp_nuopc.F90 @@ -5,33 +5,33 @@ module rof_comp_nuopc !---------------------------------------------------------------------------- use ESMF - use NUOPC , only : NUOPC_CompDerive, NUOPC_CompSetEntryPoint, NUOPC_CompSpecialize - use NUOPC , only : NUOPC_CompFilterPhaseMap, NUOPC_CompAttributeGet, NUOPC_CompAttributeSet - use NUOPC_Model , only : model_routine_SS => SetServices - use NUOPC_Model , only : SetVM - use NUOPC_Model , only : model_label_Advance => label_Advance - use NUOPC_Model , only : model_label_DataInitialize => label_DataInitialize - use NUOPC_Model , only : model_label_SetRunClock => label_SetRunClock - use NUOPC_Model , only : model_label_Finalize => label_Finalize - use NUOPC_Model , only : NUOPC_ModelGet - use shr_kind_mod , only : R8=>SHR_KIND_R8, CL=>SHR_KIND_CL - use shr_sys_mod , only : shr_sys_abort - use shr_file_mod , only : shr_file_getlogunit, shr_file_setlogunit - use shr_cal_mod , only : shr_cal_noleap, shr_cal_gregorian, shr_cal_ymd2date - use RtmVar , only : rtmlon, rtmlat, iulog, nt_rtm - use RtmVar , only : nsrStartup, nsrContinue, nsrBranch - use RtmVar , only : inst_index, inst_suffix, inst_name, RtmVarSet - use RtmVar , only : srcfield, dstfield - use RtmSpmd , only : RtmSpmdInit, mainproc, mpicom_rof, ROFID, iam, npes - use RunoffMod , only : rtmCTL - 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 omp_lib , only : omp_set_num_threads + use NUOPC , only : NUOPC_CompDerive, NUOPC_CompSetEntryPoint, NUOPC_CompSpecialize + use NUOPC , only : NUOPC_CompFilterPhaseMap, NUOPC_CompAttributeGet, NUOPC_CompAttributeSet + use NUOPC_Model , only : model_routine_SS => SetServices + use NUOPC_Model , only : SetVM + use NUOPC_Model , only : model_label_Advance => label_Advance + use NUOPC_Model , only : model_label_DataInitialize => label_DataInitialize + use NUOPC_Model , only : model_label_SetRunClock => label_SetRunClock + use NUOPC_Model , only : model_label_Finalize => label_Finalize + use NUOPC_Model , only : NUOPC_ModelGet + use shr_kind_mod , only : R8=>SHR_KIND_R8, CL=>SHR_KIND_CL + use shr_sys_mod , only : shr_sys_abort + use shr_file_mod , only : shr_file_getlogunit, shr_file_setlogunit + use shr_cal_mod , only : shr_cal_noleap, shr_cal_gregorian, shr_cal_ymd2date + use mosart_vars , only : nsrStartup, nsrContinue, nsrBranch + use mosart_vars , only : inst_index, inst_suffix, inst_name + use mosart_vars , only : mainproc, mpicom_rof, iam, npes, iulog + use mosart_vars , only : nsrest, caseid, ctitle, version, hostname, username + use mosart_data , only : ctl + use mosart_mod , only : mosart_read_namelist, mosart_init1, mosart_init2, mosart_run + use mosart_timemanager , only : timemgr_setup, get_curr_date, get_step_size, advance_timestep + use mosart_io , only : ncd_pio_init + use mosart_restfile , only : brnch_retain_casename + use rof_import_export , only : 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 perf_mod , only : t_startf, t_stopf, t_barrierf implicit none private ! except @@ -55,8 +55,6 @@ module rof_comp_nuopc integer :: flds_scalar_index_nx = 0 integer :: flds_scalar_index_ny = 0 integer :: flds_scalar_index_nextsw_cday = 0._r8 - - logical :: do_flood integer :: nthrds integer , parameter :: debug = 1 @@ -152,9 +150,6 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) type(ESMF_TimeInterval) :: timeStep ! Model timestep type(ESMF_CalKind_Flag) :: esmf_caltype ! esmf calendar type type(ESMF_VM) :: vm ! esmf virtual machine - integer :: mpicom - character(CL) :: cvalue - character(len=CL) :: logmsg integer :: ref_ymd ! reference date (YYYYMMDD) integer :: ref_tod ! reference time of day (sec) integer :: yy,mm,dd ! Temporaries for time query @@ -164,21 +159,13 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) integer :: stop_tod ! stop time of day (sec) integer :: curr_ymd ! Start date (YYYYMMDD) integer :: curr_tod ! Start time of day (sec) - logical :: flood_present ! flag - logical :: rof_prognostic ! flag integer :: shrlogunit ! original log unit - integer :: n,ni ! indices - integer :: nsrest ! restart type + integer :: n ! indices character(CL) :: calendar ! calendar type name - character(CL) :: username ! user name - character(CL) :: caseid ! case identifier name - character(CL) :: ctitle ! case description title - character(CL) :: hostname ! hostname of machine running on - character(CL) :: model_version ! model version character(CL) :: starttype ! start-type (startup, continue, branch, hybrid) - character(CL) :: stdname, shortname ! needed for advertise - logical :: brnch_retain_casename ! flag if should retain the case name on a branch start type logical :: isPresent, isSet + character(CL) :: cvalue + character(len=CL) :: logmsg character(len=*), parameter :: subname=trim(modName)//':(InitializeAdvertise) ' character(len=*), parameter :: format = "('("//trim(subname)//") :',A)" !------------------------------------------------------------------------------- @@ -193,20 +180,10 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_VMGet(vm, mpiCommunicator=mpicom, rc=rc) + call ESMF_VMGet(vm, mpiCommunicator=mpicom_rof, peCount=npes, localPet=iam, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - !---------------------------------------------------------------------------- - ! initialize MOSART MPI communicator - !---------------------------------------------------------------------------- - - ! The following call initializees the module variable mpicom_rof in RtmSpmd - call RtmSpmdInit(mpicom) - - ! Set ROFID - call NUOPC_CompAttributeGet(gcomp, name='MCTID', value=cvalue, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) ROFID ! convert from string to integer + mainproc = (iam == 0) !---------------------------------------------------------------------------- ! determine instance information @@ -282,7 +259,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 MOSART here to determine if do_flood is true in order to + ! Need to run the initial phase of mosart here in order to ! get the advertise phase correct !---------------------- @@ -302,9 +279,19 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return read(cvalue,*) starttype + if ( trim(starttype) == trim('startup')) then + nsrest = nsrStartup + else if (trim(starttype) == trim('continue') ) then + nsrest = nsrContinue + else if (trim(starttype) == trim('branch')) then + nsrest = nsrBranch + else + call shr_sys_abort( subname//' ERROR: unknown starttype' ) + end if + call NUOPC_CompAttributeGet(gcomp, name='model_version', value=cvalue, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) model_version + read(cvalue,*) version call NUOPC_CompAttributeGet(gcomp, name='hostname', value=cvalue, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -375,54 +362,17 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) write(iulog,*) ' inst_name = ',trim(inst_name) endif - ! Initialize RtmVar module variables - ! TODO: the following strings must not be hard-wired - must have module variables - ! like seq_infodata_start_type_type - maybe another entry in seq_flds_mod? - if ( trim(starttype) == trim('startup')) then - nsrest = nsrStartup - else if (trim(starttype) == trim('continue') ) then - nsrest = nsrContinue - else if (trim(starttype) == trim('branch')) then - nsrest = nsrBranch - else - call shr_sys_abort( subname//' ERROR: unknown starttype' ) - end if - - call RtmVarSet(& - caseid_in=caseid, & - ctitle_in=ctitle, & - brnch_retain_casename_in=brnch_retain_casename, & - nsrest_in=nsrest, & - version_in=model_version, & - hostname_in=hostname, & - username_in=username) - !---------------------- - ! Initialize Mosart + ! Read in mosart namelist !---------------------- - ! - Read in mosart namelist - ! - Initialize mosart time manager - ! - Initialize number of mosart tracers - ! - Read input data (river direction file) (global) - ! - Deriver gridbox edges (global) - ! - Determine mosart ocn/land mask (global) - ! - Compute total number of basins and runoff ponts - ! - Compute river basins, actually compute ocean outlet gridcell - ! - Allocate basins to pes - ! - Count and distribute cells to rglo2gdc (determine rtmCTL%begr, rtmCTL%endr) - ! - Adjust area estimation from DRT algorithm for those outlet grids - ! - useful for grid-based representation only - ! - need to compute areas where they are not defined in input file - ! - Initialize runoff datatype (rtmCTL) - - call MOSART_read_namelist(do_flood) + call mosart_read_namelist() !---------------------------------------------------------------------------- ! Now advertise fields !---------------------------------------------------------------------------- - call advertise_fields(gcomp, flds_scalar_name, do_flood, rc) + call advertise_fields(gcomp, flds_scalar_name, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---------------------------------------------------------------------------- @@ -447,7 +397,6 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ! local variables type(ESMF_Mesh) :: Emesh - type(ESMF_DistGrid) :: DistGrid ! esmf global index space descriptor type(ESMF_VM) :: vm integer , allocatable :: gindex(:) ! global index space on my processor integer :: lbnum ! input to memory diagnostic @@ -457,6 +406,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) integer :: n,ni integer :: localPet integer :: localPeCount + integer :: rofid ! component id for pio character(len=*), parameter :: subname=trim(modName)//':(InitializeRealize) ' !--------------------------------------------------------------------------- @@ -489,7 +439,6 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) else nthrds = localPeCount endif - !$ call omp_set_num_threads(nthrds) #if (defined _MEMTRACE) if (mainproc) then @@ -498,24 +447,51 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) endif #endif - ! Call first phase of MOSART initialization (set decomp, grid) - call MOSART_init1() + !------------------------------------------------------- + ! Initialize mosart pio + !------------------------------------------------------- + + call NUOPC_CompAttributeGet(gcomp, name='MCTID', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) rofid ! convert from string to integer + + call ncd_pio_init(rofid) + + !------------------------------------------------------- + ! Call first phase of mosart initialization (set decomp, grid) + !------------------------------------------------------- + + ! - Initialize mosart time manager + ! - Initialize number of mosart tracers + ! - Read input data (river direction file) (global) + ! - Deriver gridbox edges (global) + ! - Determine mosart ocn/land mask (global) + ! - Compute total number of basins and runoff ponts + ! - Compute river basins, actually compute ocean outlet gridcell + ! - Allocate basins to pes + ! - Count and distribute cells to rglo2gdc (determine ctl%begr, ctl%endr) + ! - Adjust area estimation from DRT algorithm for those outlet grids + ! - useful for grid-based representation only + ! - need to compute areas where they are not defined in input file + + call mosart_init1(rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return !-------------------------------- ! generate the mesh and realize fields !-------------------------------- ! determine global index array - lsize = rtmCTL%endr - rtmCTL%begr + 1 + lsize = ctl%endr - ctl%begr + 1 allocate(gindex(lsize)) ni = 0 - do n = rtmCTL%begr,rtmCTL%endr + do n = ctl%begr,ctl%endr ni = ni + 1 - gindex(ni) = rtmCTL%gindex(n) + gindex(ni) = ctl%gindex(n) end do ! create distGrid from global index array - DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) + ctl%DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return deallocate(gindex) @@ -526,7 +502,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) write(iulog,*)'mesh file for domain is ',trim(cvalue) end if - EMesh = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, elementDistgrid=Distgrid, rc=rc) + EMesh = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, elementDistgrid=ctl%Distgrid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !-------------------------------- @@ -536,26 +512,13 @@ 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) + call mosart_init2(Emesh, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call t_stopf('mosarti_mosart_init') @@ -563,15 +526,15 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ! Create MOSART export state !-------------------------------- - call export_fields(gcomp, rc) + call export_fields(gcomp, ctl%begr, ctl%endr, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! Set global grid size scalars in export state - call State_SetScalar(dble(rtmlon), flds_scalar_index_nx, exportState, & + call State_SetScalar(dble(ctl%nlon), flds_scalar_index_nx, exportState, & flds_scalar_name, flds_scalar_num, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call State_SetScalar(dble(rtmlat), flds_scalar_index_ny, exportState, & + call State_SetScalar(dble(ctl%nlat), flds_scalar_index_ny, exportState, & flds_scalar_name, flds_scalar_num, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -696,7 +659,7 @@ subroutine ModelAdvance(gcomp, rc) call t_startf ('lc_mosart_import') - call import_fields(gcomp, rc) + call import_fields(gcomp, ctl%begr, ctl%endr, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call t_stopf ('lc_mosart_import') @@ -717,18 +680,17 @@ subroutine ModelAdvance(gcomp, rc) call shr_cal_ymd2date(yr_sync, mon_sync, day_sync, ymd_sync) write(rdate,'(i4.4,"-",i2.2,"-",i2.2,"-",i5.5)') yr_sync, mon_sync, day_sync, tod_sync - ! Advance mosart time step then run MOSART (export data is in rtmCTL and Trunoff data types) + ! Advance mosart time step then run MOSART (export data is in ctl and Trunoff data types) call advance_timestep() - call MOSART_run(rstwr, nlend, rdate, rc) + call mosart_run(ctl%begr, ctl%endr, ctl%ntracers, rstwr, nlend, rdate, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !-------------------------------- ! Pack export state to mediator !-------------------------------- - ! (input is rtmCTL%runoff, output is r2x) call t_startf ('lc_rof_export') - call export_fields(gcomp, rc) + call export_fields(gcomp, ctl%begr, ctl%endr, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call t_stopf ('lc_rof_export') diff --git a/src/cpl/nuopc/rof_import_export.F90 b/src/cpl/nuopc/rof_import_export.F90 index 606ca3c..9cb67db 100644 --- a/src/cpl/nuopc/rof_import_export.F90 +++ b/src/cpl/nuopc/rof_import_export.F90 @@ -1,19 +1,18 @@ module rof_import_export - use ESMF , only : ESMF_GridComp, ESMF_State, ESMF_Mesh, ESMF_StateGet - use ESMF , only : ESMF_KIND_R8, ESMF_SUCCESS, ESMF_MAXSTR, ESMF_LOGMSG_INFO - use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_ERROR, ESMF_LogFoundError - use ESMF , only : ESMF_STATEITEM_NOTFOUND, ESMF_StateItem_Flag - use ESMF , only : operator(/=), operator(==) - use NUOPC , only : NUOPC_CompAttributeGet, NUOPC_Advertise, NUOPC_IsConnected - use NUOPC_Model , only : NUOPC_ModelGet - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_sys_mod , only : shr_sys_abort - use RunoffMod , only : rtmCTL, TRunoff, TUnit - use RtmVar , only : iulog, nt_rtm, rtm_tracers - use RtmSpmd , only : mainproc, mpicom_rof - use RtmTimeManager , only : get_nstep - use nuopc_shr_methods , only : chkerr + use ESMF , only : ESMF_GridComp, ESMF_State, ESMF_Mesh, ESMF_StateGet + use ESMF , only : ESMF_KIND_R8, ESMF_SUCCESS, ESMF_MAXSTR, ESMF_LOGMSG_INFO + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_ERROR, ESMF_LogFoundError + use ESMF , only : ESMF_STATEITEM_NOTFOUND, ESMF_StateItem_Flag + use ESMF , only : operator(/=), operator(==) + use NUOPC , only : NUOPC_CompAttributeGet, NUOPC_Advertise, NUOPC_IsConnected + use NUOPC_Model , only : NUOPC_ModelGet + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_sys_mod , only : shr_sys_abort + use mosart_vars , only : iulog, mainproc, mpicom_rof, ice_runoff + use mosart_data , only : ctl, TRunoff, TUnit + use mosart_timemanager , only : get_nstep + use nuopc_shr_methods , only : chkerr implicit none private ! except @@ -44,7 +43,6 @@ module rof_import_export real(r8), allocatable :: mod2med_areacor(:) real(r8), allocatable :: med2mod_areacor(:) - integer ,parameter :: debug = 0 ! internal debug level character(*),parameter :: F01 = "('(mosart_import_export) ',a,i5,2x,i8,2x,d21.14)" character(*),parameter :: u_FILE_u = & __FILE__ @@ -53,18 +51,16 @@ module rof_import_export contains !=============================================================================== - subroutine advertise_fields(gcomp, flds_scalar_name, do_rtmflood, rc) + subroutine advertise_fields(gcomp, flds_scalar_name, rc) ! input/output variables type(ESMF_GridComp) :: gcomp character(len=*) , intent(in) :: flds_scalar_name - logical , intent(in) :: do_rtmflood integer , intent(out) :: rc ! local variables type(ESMF_State) :: importState type(ESMF_State) :: exportState - character(ESMF_MAXSTR) :: stdname character(ESMF_MAXSTR) :: cvalue ! Character string read from driver attribute logical :: isPresent ! Atribute is present logical :: isSet ! Atribute is set @@ -201,9 +197,9 @@ subroutine realize_fields(gcomp, Emesh, flds_scalar_name, flds_scalar_num, rc) allocate(mod2med_areacor(numOwnedElements)) allocate(med2mod_areacor(numOwnedElements)) n = 0 - do g = rtmCTL%begr,rtmCTL%endr + do g = ctl%begr,ctl%endr n = n + 1 - model_areas(n) = rtmCTL%area(g)*1.0e-6_r8/(re*re) + model_areas(n) = ctl%area(g)*1.0e-6_r8/(re*re) mod2med_areacor(n) = model_areas(n) / mesh_areas(n) med2mod_areacor(n) = mesh_areas(n) / model_areas(n) end do @@ -229,7 +225,7 @@ subroutine realize_fields(gcomp, Emesh, flds_scalar_name, flds_scalar_num, rc) end subroutine realize_fields !=============================================================================== - subroutine import_fields( gcomp, rc ) + subroutine import_fields( gcomp, begr, endr, rc ) !--------------------------------------------------------------------------- ! Obtain the runoff input from the mediator and convert from kg/m2s to m3/s @@ -237,12 +233,12 @@ subroutine import_fields( gcomp, rc ) ! input/output variables type(ESMF_GridComp) :: gcomp + integer, intent(in) :: begr, endr integer, intent(out) :: rc ! Local variables type(ESMF_State) :: importState integer :: n,nt - integer :: begr, endr integer :: nliq, nfrz character(len=*), parameter :: subname='(rof_import_export:import_fields)' !--------------------------------------------------------------------------- @@ -257,73 +253,67 @@ subroutine import_fields( gcomp, rc ) ! Set tracers nliq = 0 nfrz = 0 - do nt = 1,nt_rtm - if (trim(rtm_tracers(nt)) == 'LIQ') nliq = nt - if (trim(rtm_tracers(nt)) == 'ICE') nfrz = nt + do nt = 1,ctl%ntracers + if (trim(ctl%tracer_names(nt)) == 'LIQ') nliq = nt + if (trim(ctl%tracer_names(nt)) == 'ICE') nfrz = nt enddo if (nliq == 0 .or. nfrz == 0) then - write(iulog,*) trim(subname),': ERROR in rtm_tracers LIQ ICE ',nliq,nfrz,rtm_tracers + write(iulog,*) trim(subname),': ERROR in tracers LIQ ICE ',nliq,nfrz,ctl%tracer_names(:) call shr_sys_abort() endif - begr = rtmCTL%begr - endr = rtmCTL%endr - ! determine output array and scale by unit convertsion ! NOTE: the call to state_getimport will convert from input kg/m2s to m3/s - call state_getimport(importState, 'Flrl_rofsur', begr, endr, rtmCTL%area, output=rtmCTL%qsur(:,nliq), & + call state_getimport(importState, 'Flrl_rofsur', begr, endr, ctl%area, output=ctl%qsur(:,nliq), & do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'Flrl_rofsub', begr, endr, rtmCTL%area, output=rtmCTL%qsub(:,nliq), & + call state_getimport(importState, 'Flrl_rofsub', begr, endr, ctl%area, output=ctl%qsub(:,nliq), & do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'Flrl_rofgwl', begr, endr, rtmCTL%area, output=rtmCTL%qgwl(:,nliq), & + call state_getimport(importState, 'Flrl_rofgwl', begr, endr, ctl%area, output=ctl%qgwl(:,nliq), & do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'Flrl_rofi', begr, endr, rtmCTL%area, output=rtmCTL%qsur(:,nfrz), & + call state_getimport(importState, 'Flrl_rofi', begr, endr, ctl%area, output=ctl%qsur(:,nfrz), & do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'Flrl_irrig', begr, endr, rtmCTL%area, output=rtmCTL%qirrig(:), & + call state_getimport(importState, 'Flrl_irrig', begr, endr, ctl%area, output=ctl%qirrig(:), & do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - rtmCTL%qsub(begr:endr, nfrz) = 0.0_r8 - rtmCTL%qgwl(begr:endr, nfrz) = 0.0_r8 + ctl%qsub(begr:endr, nfrz) = 0.0_r8 + ctl%qgwl(begr:endr, nfrz) = 0.0_r8 end subroutine import_fields !==================================================================================== - subroutine export_fields (gcomp, rc) + subroutine export_fields (gcomp, begr, endr, rc) !--------------------------------------------------------------------------- ! Send the runoff model export state to the mediator and convert from m3/s to kg/m2s !--------------------------------------------------------------------------- - ! uses - use RtmVar, only : ice_runoff - ! input/output/variables type(ESMF_GridComp) :: gcomp + integer, intent(in) :: begr, endr integer, intent(out) :: rc ! Local variables - type(ESMF_State) :: exportState - integer :: n,nt - integer :: begr,endr - integer :: nliq, nfrz - real(r8), pointer :: rofl(:) - real(r8), pointer :: rofi(:) - real(r8), pointer :: flood(:) - real(r8), pointer :: volr(:) - real(r8), pointer :: volrmch(:) - real(r8), pointer :: tdepth(:) - real(r8), pointer :: tdepth_max(:) - logical, save :: first_time = .true. + type(ESMF_State) :: exportState + integer :: n,nt + integer :: nliq, nfrz + real(r8) :: rofl(begr:endr) + real(r8) :: rofi(begr:endr) + real(r8) :: flood(begr:endr) + real(r8) :: volr(begr:endr) + real(r8) :: volrmch(begr:endr) + real(r8) :: tdepth(begr:endr) + real(r8) :: tdepth_max(begr:endr) + logical, save :: first_time = .true. character(len=*), parameter :: subname='(rof_import_export:export_fields)' !--------------------------------------------------------------------------- @@ -337,12 +327,12 @@ subroutine export_fields (gcomp, rc) ! Set tracers nliq = 0 nfrz = 0 - do nt = 1,nt_rtm - if (trim(rtm_tracers(nt)) == 'LIQ') nliq = nt - if (trim(rtm_tracers(nt)) == 'ICE') nfrz = nt + do nt = 1,ctl%ntracers + if (trim(ctl%tracer_names(nt)) == 'LIQ') nliq = nt + if (trim(ctl%tracer_names(nt)) == 'ICE') nfrz = nt enddo if (nliq == 0 .or. nfrz == 0) then - write(iulog,*) trim(subname),': ERROR in rtm_tracers LIQ ICE ',nliq,nfrz,rtm_tracers + write(iulog,*) trim(subname),': ERROR in tracers LIQ ICE ',nliq,nfrz,ctl%tracer_names(:) call shr_sys_abort() endif @@ -357,36 +347,23 @@ subroutine export_fields (gcomp, rc) first_time = .false. end if - begr = rtmCTL%begr - endr = rtmCTL%endr - - allocate(rofl(begr:endr)) - allocate(rofi(begr:endr)) - allocate(flood(begr:endr)) - allocate(volr(begr:endr)) - allocate(volrmch(begr:endr)) - if ( flds_r2l_stream_channel_depths )then - allocate(tdepth(begr:endr)) - allocate(tdepth_max(begr:endr)) - end if - if ( ice_runoff )then ! separate liquid and ice runoff do n = begr,endr - rofl(n) = rtmCTL%direct(n,nliq) / (rtmCTL%area(n)*0.001_r8) - rofi(n) = rtmCTL%direct(n,nfrz) / (rtmCTL%area(n)*0.001_r8) - if (rtmCTL%mask(n) >= 2) then + rofl(n) = ctl%direct(n,nliq) / (ctl%area(n)*0.001_r8) + rofi(n) = ctl%direct(n,nfrz) / (ctl%area(n)*0.001_r8) + if (ctl%mask(n) >= 2) then ! liquid and ice runoff are treated separately - this is what goes to the ocean - rofl(n) = rofl(n) + rtmCTL%runoff(n,nliq) / (rtmCTL%area(n)*0.001_r8) - rofi(n) = rofi(n) + rtmCTL%runoff(n,nfrz) / (rtmCTL%area(n)*0.001_r8) + rofl(n) = rofl(n) + ctl%runoff(n,nliq) / (ctl%area(n)*0.001_r8) + rofi(n) = rofi(n) + ctl%runoff(n,nfrz) / (ctl%area(n)*0.001_r8) end if end do else ! liquid and ice runoff added to liquid runoff, ice runoff is zero do n = begr,endr - rofl(n) = (rtmCTL%direct(n,nfrz) + rtmCTL%direct(n,nliq)) / (rtmCTL%area(n)*0.001_r8) - if (rtmCTL%mask(n) >= 2) then - rofl(n) = rofl(n) + (rtmCTL%runoff(n,nfrz) + rtmCTL%runoff(n,nliq)) / (rtmCTL%area(n)*0.001_r8) + rofl(n) = (ctl%direct(n,nfrz) + ctl%direct(n,nliq)) / (ctl%area(n)*0.001_r8) + if (ctl%mask(n) >= 2) then + rofl(n) = rofl(n) + (ctl%runoff(n,nfrz) + ctl%runoff(n,nliq)) / (ctl%area(n)*0.001_r8) endif rofi(n) = 0._r8 end do @@ -395,12 +372,12 @@ subroutine export_fields (gcomp, rc) ! Flooding back to land, sign convention is positive in land->rof direction ! so if water is sent from rof to land, the flux must be negative. ! scs: is there a reason for the wr+wt rather than volr (wr+wt+wh)? - ! volr(n) = (Trunoff%wr(n,nliq) + Trunoff%wt(n,nliq)) / rtmCTL%area(n) + ! volr(n) = (Trunoff%wr(n,nliq) + Trunoff%wt(n,nliq)) / ctl%area(n) do n = begr, endr - flood(n) = -rtmCTL%flood(n) / (rtmCTL%area(n)*0.001_r8) - volr(n) = rtmCTL%volr(n,nliq)/ rtmCTL%area(n) - volrmch(n) = Trunoff%wr(n,nliq) / rtmCTL%area(n) + flood(n) = -ctl%flood(n) / (ctl%area(n)*0.001_r8) + volr(n) = ctl%volr(n,nliq)/ ctl%area(n) + volrmch(n) = Trunoff%wr(n,nliq) / ctl%area(n) if ( flds_r2l_stream_channel_depths )then tdepth(n) = Trunoff%yt(n,nliq) ! assume height to width ratio is the same for tributaries and main channel @@ -431,21 +408,6 @@ subroutine export_fields (gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - 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) - write(iulog,F01)'export: nstep, n, Flrr_volrmch = ',get_nstep(), n, volrmch(n) - write(iulog,F01)'export: nstep, n, Forr_rofl = ',get_nstep() ,n, rofl(n) - write(iulog,F01)'export: nstep, n, Forr_rofi = ',get_nstep() ,n, rofi(n) - end do - end if - - deallocate(rofl, rofi, flood, volr, volrmch) - if ( flds_r2l_stream_channel_depths ) then - deallocate(tdepth, tdepth_max) - end if - end subroutine export_fields !=============================================================================== @@ -670,7 +632,7 @@ subroutine check_for_nans(array, fname, begg) use shr_infnan_mod, only : isnan => shr_infnan_isnan ! input/output variables - real(r8), pointer :: array(:) + real(r8) , pointer :: array(:) character(len=*) , intent(in) :: fname integer , intent(in) :: begg diff --git a/src/riverroute/mosart_control_type.F90 b/src/riverroute/mosart_control_type.F90 index a404bff..4b037be 100644 --- a/src/riverroute/mosart_control_type.F90 +++ b/src/riverroute/mosart_control_type.F90 @@ -1,352 +1,1075 @@ -module RunoffMod - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: RunoffMod -! -! !DESCRIPTION: -! Module containing utilities for history file and coupler runoff data -! -! !USES: - use shr_kind_mod, only : r8 => shr_kind_r8 - use shr_sys_mod , only : shr_sys_abort - use RtmVar , only : iulog, spval, nt_rtm - -! !PUBLIC TYPES: - implicit none - private - - public :: runoff_flow - type runoff_flow - ! - local initialization - real(r8), pointer :: lonc(:) ! lon of cell - real(r8), pointer :: latc(:) ! lat of cell - real(r8), pointer :: area(:) ! area of cell - integer , pointer :: gindex(:) ! global index consistent with map file - integer , pointer :: dsig(:) ! downstream index, global index - integer , pointer :: outletg(:) ! outlet index, global index - - ! - global - integer , pointer :: mask(:) ! general mask of cell 1=land, 2=ocean, 3=outlet - real(r8), pointer :: rlon(:) ! rtm longitude list, 1d - real(r8), pointer :: rlat(:) ! rtm latitude list, 1d - real(r8) :: totarea ! global area - integer :: numr ! rtm gdc global number of cells - - ! - local - integer :: begr,endr ! local start/stop indices - integer :: lnumr ! local number of cells - - ! - local - real(r8), pointer :: runofflnd(:,:) ! runoff masked for land (m3 H2O/s) - real(r8), pointer :: runoffocn(:,:) ! runoff masked for ocn (m3 H2O/s) - real(r8), pointer :: runofftot(:,:) ! total runoff masked for ocn (m3 H2O/s) - real(r8), pointer :: dvolrdt(:,:) ! RTM change in storage (mm/s) - real(r8), pointer :: dvolrdtlnd(:,:) ! dvolrdt masked for land (mm/s) - real(r8), pointer :: dvolrdtocn(:,:) ! dvolrdt masked for ocn (mm/s) - real(r8), pointer :: volr(:,:) ! RTM storage (m3) - real(r8), pointer :: fthresh(:) ! RTM water flood threshold - - ! - restarts - real(r8), pointer :: wh(:,:) ! MOSART hillslope surface water storage (m) - real(r8), pointer :: wt(:,:) ! MOSART sub-network water storage (m3) - real(r8), pointer :: wr(:,:) ! MOSART main channel water storage (m3) - real(r8), pointer :: erout(:,:) ! MOSART flow out of the main channel, instantaneous (m3/s) - - ! inputs - real(r8), pointer :: qsur(:,:) ! coupler surface forcing [m3/s] - real(r8), pointer :: qsub(:,:) ! coupler subsurface forcing [m3/s] - real(r8), pointer :: qgwl(:,:) ! coupler glacier/wetland/lake forcing [m3/s] - - ! - outputs - real(r8), pointer :: flood(:) ! coupler return flood water sent back to clm [m3/s] - real(r8), pointer :: runoff(:,:) ! coupler return mosart basin derived flow [m3/s] - real(r8), pointer :: direct(:,:) ! coupler return direct flow [m3/s] - - real(r8), pointer :: qirrig(:) ! coupler irrigation [m3/s] - real(r8), pointer :: qirrig_actual(:) ! minimum of irrigation and available main channel storage - - ! - history (currently needed) - real(r8), pointer :: runofflnd_nt1(:) - real(r8), pointer :: runofflnd_nt2(:) - real(r8), pointer :: runoffocn_nt1(:) - real(r8), pointer :: runoffocn_nt2(:) - real(r8), pointer :: runofftot_nt1(:) - real(r8), pointer :: runofftot_nt2(:) - real(r8), pointer :: runoffdir_nt1(:) - real(r8), pointer :: runoffdir_nt2(:) - real(r8), pointer :: dvolrdtlnd_nt1(:) - real(r8), pointer :: dvolrdtlnd_nt2(:) - real(r8), pointer :: dvolrdtocn_nt1(:) - real(r8), pointer :: dvolrdtocn_nt2(:) - real(r8), pointer :: volr_nt1(:) - real(r8), pointer :: volr_nt2(:) - real(r8), pointer :: volr_mch(:) - real(r8), pointer :: qsur_nt1(:) - real(r8), pointer :: qsur_nt2(:) - real(r8), pointer :: qsub_nt1(:) - real(r8), pointer :: qsub_nt2(:) - real(r8), pointer :: qgwl_nt1(:) - real(r8), pointer :: qgwl_nt2(:) - end type runoff_flow - - - !== Hongyi - ! constrol information - public :: Tcontrol - type Tcontrol - integer :: NUnit ! numer of Grides in the model domain, which is equal to the number of cells, nrows*ncols - integer :: NSTART ! the # of the time step to start the routing. Previous NSTART - 1 steps will be passed over. - integer :: NSTEPS ! number of time steps specified in the modeling - integer :: NWARMUP ! time steps for model warming up - real(r8) :: DATAH ! time step of runoff generation in second provided by the user - integer :: Num_dt ! number of sub-steps within the current step interval, - ! i.e., if the time step of the incoming runoff data is 3-hr, and num_dt is set to 10, - ! then deltaT = 3*3600/10 = 1080 seconds - real(r8) :: DeltaT ! Time step in seconds - integer :: DLevelH2R ! The base number of channel routing sub-time-steps within one hillslope routing step. - ! Usually channel routing requires small time steps than hillslope routing. - integer :: DLevelR ! The number of channel routing sub-time-steps at a higher level within one channel routing step at a lower level. - integer :: Restart ! flag, Restart=1 means starting from the state of last run, =0 means starting from model-inset initial state. - integer :: RoutingMethod ! Flag for routing methods. 1 --> variable storage method from SWAT model; 2 --> Muskingum method? - integer :: RoutingFlag ! Flag for whether including hillslope and sub-network routing. 1--> include routing through hillslope, sub-network and main channel; 0--> main channel routing only. - - character(len=100) :: baseName ! name of the case study, e.g., columbia - character(len=200) :: ctlFile ! the name of the control file - character(len=100) :: ctlPath ! the path of the control file - character(len=200) :: paraFile ! the path of the parameter files - character(len=100) :: paraPath ! the path of the parameter files - character(len=100) :: runoffPath ! the path of the runoff data - character(len=100) :: outPath ! the path of the output file(s) - integer :: numStation ! number of basins to be simulated - character(len=200) :: staListFile ! name of the file containing station list - integer, pointer :: out_ID(:) ! the indices of the outlet subbasins whether the stations are located - character(len=80), pointer :: out_name(:) ! the name of the outlets - character(len=80) :: curOutlet ! the name of the current outlet - end type Tcontrol - - ! --- Topographic and geometric properties, applicable for both grid- and subbasin-based representations - public :: Tspatialunit - type Tspatialunit - ! grid properties - integer , pointer :: mask(:) ! mosart mask of mosart cell, 0=null, 1=land with dnID, 2=outlet - integer , pointer :: ID0(:) - real(r8), pointer :: lat(:) ! latitude of the centroid of the cell - real(r8), pointer :: lon(:) ! longitude of the centroid of the cell - real(r8), pointer :: area(:) ! area of local cell, [m2] - real(r8), pointer :: areaTotal(:) ! total upstream drainage area, [m2] - real(r8), pointer :: areaTotal2(:)! computed total upstream drainage area, [m2] - real(r8), pointer :: rlenTotal(:) ! length of all reaches, [m] - real(r8), pointer :: Gxr(:) ! drainage density within the cell, [1/m] - real(r8), pointer :: frac(:) ! fraction of cell included in the study area, [-] - logical , pointer :: euler_calc(:) ! flag for calculating tracers in euler - - ! hillslope properties - real(r8), pointer :: nh(:) ! manning's roughness of the hillslope (channel network excluded) - real(r8), pointer :: hslp(:) ! slope of hillslope, [-] - real(r8), pointer :: hslpsqrt(:) ! sqrt of slope of hillslope, [-] - real(r8), pointer :: hlen(:) ! length of hillslope within the cell, [m] - - ! subnetwork channel properties - real(r8), pointer :: tslp(:) ! average slope of tributaries, [-] - real(r8), pointer :: tslpsqrt(:) ! sqrt of average slope of tributaries, [-] - real(r8), pointer :: tlen(:) ! length of all sub-network reach within the cell, [m] - real(r8), pointer :: twidth(:) ! bankfull width of the sub-reach, [m] - real(r8), pointer :: twidth0(:) ! unadjusted twidth - real(r8), pointer :: nt(:) ! manning's roughness of the subnetwork at hillslope - - ! main channel properties - real(r8), pointer :: rlen(:) ! length of main river reach, [m] - real(r8), pointer :: rslp(:) ! slope of main river reach, [-] - real(r8), pointer :: rslpsqrt(:) ! sqrt of slope of main river reach, [-] - real(r8), pointer :: rwidth(:) ! bankfull width of main reach, [m] - real(r8), pointer :: rwidth0(:) ! total width of the flood plain, [m] - real(r8), pointer :: rdepth(:) ! bankfull depth of river cross section, [m] - real(r8), pointer :: nr(:) ! manning's roughness of the main reach - integer , pointer :: dnID(:) ! IDs of the downstream units, corresponding to the subbasin ID in the input table - integer , pointer :: nUp(:) ! number of upstream units, maximum 8 - integer , pointer :: iUp(:,:) ! IDs of upstream units, corresponding to the subbasin ID in the input table - - integer , pointer :: indexDown(:) ! indices of the downstream units in the ID array. sometimes subbasins IDs may not be continuous - - integer , pointer :: numDT_r(:) ! for a main reach, the number of sub-time-steps needed for numerical stability - integer , pointer :: numDT_t(:) ! for a subnetwork reach, the number of sub-time-steps needed for numerical stability - real(r8), pointer :: phi_r(:) ! the indicator used to define numDT_r - real(r8), pointer :: phi_t(:) ! the indicator used to define numDT_t - end type Tspatialunit - - ! status and flux variables - public :: TstatusFlux - type TstatusFlux - ! hillsloope - !! states - real(r8), pointer :: wh(:,:) ! storage of surface water, [m] - real(r8), pointer :: dwh(:,:) ! change of water storage, [m/s] - real(r8), pointer :: yh(:,:) ! depth of surface water, [m] - real(r8), pointer :: wsat(:,:) ! storage of surface water within saturated area at hillslope [m] - real(r8), pointer :: wunsat(:,:) ! storage of surface water within unsaturated area at hillslope [m] - real(r8), pointer :: qhorton(:,:) ! Infiltration excess runoff generated from hillslope, [m/s] - real(r8), pointer :: qdunne(:,:) ! Saturation excess runoff generated from hillslope, [m/s] - real(r8), pointer :: qsur(:,:) ! Surface runoff generated from hillslope, [m/s] - real(r8), pointer :: qsub(:,:) ! Subsurface runoff generated from hillslope, [m/s] - real(r8), pointer :: qgwl(:,:) ! gwl runoff term from glacier, wetlands and lakes, [m/s] - !! fluxes - real(r8), pointer :: ehout(:,:) ! overland flow from hillslope into the sub-channel, [m/s] - real(r8), pointer :: asat(:,:) ! saturated area fraction from hillslope, [-] - real(r8), pointer :: esat(:,:) ! evaporation from saturated area fraction at hillslope, [m/s] - - ! subnetwork channel - !! states - real(r8), pointer :: tarea(:,:) ! area of channel water surface, [m2] - real(r8), pointer :: wt(:,:) ! storage of surface water, [m3] - real(r8), pointer :: dwt(:,:) ! change of water storage, [m3] - real(r8), pointer :: yt(:,:) ! water depth, [m] - real(r8), pointer :: mt(:,:) ! cross section area, [m2] - real(r8), pointer :: rt(:,:) ! hydraulic radii, [m] - real(r8), pointer :: pt(:,:) ! wetness perimeter, [m] - real(r8), pointer :: vt(:,:) ! flow velocity, [m/s] - real(r8), pointer :: tt(:,:) ! mean travel time of the water within the channel, [s] - !! fluxes - real(r8), pointer :: tevap(:,:) ! evaporation, [m/s] - real(r8), pointer :: etin(:,:) ! lateral inflow from hillslope, including surface and subsurface runoff generation components, [m3/s] - real(r8), pointer :: etout(:,:) ! discharge from sub-network into the main reach, [m3/s] - - ! main channel - !! states - real(r8), pointer :: rarea(:,:) ! area of channel water surface, [m2] - real(r8), pointer :: wr(:,:) ! storage of surface water, [m3] - real(r8), pointer :: dwr(:,:) ! change of water storage, [m3] - real(r8), pointer :: yr(:,:) ! water depth. [m] - real(r8), pointer :: mr(:,:) ! cross section area, [m2] - real(r8), pointer :: rr(:,:) ! hydraulic radius, [m] - real(r8), pointer :: pr(:,:) ! wetness perimeter, [m] - real(r8), pointer :: vr(:,:) ! flow velocity, [m/s] - real(r8), pointer :: tr(:,:) ! mean travel time of the water within the channel, [s] - !! exchange fluxes - real(r8), pointer :: erlg(:,:) ! evaporation, [m/s] - real(r8), pointer :: erlateral(:,:) ! lateral flow from hillslope, including surface and subsurface runoff generation components, [m3/s] - real(r8), pointer :: erin(:,:) ! inflow from upstream links, [m3/s] - real(r8), pointer :: erout(:,:) ! outflow into downstream links, [m3/s] - real(r8), pointer :: erout_prev(:,:) ! outflow into downstream links from previous timestep, [m3/s] - real(r8), pointer :: eroutUp(:,:) ! outflow sum of upstream gridcells, instantaneous (m3/s) - real(r8), pointer :: eroutUp_avg(:,:) ! outflow sum of upstream gridcells, average [m3/s] - real(r8), pointer :: erlat_avg(:,:) ! erlateral average [m3/s] - real(r8), pointer :: flow(:,:) ! streamflow from the outlet of the reach, [m3/s] - real(r8), pointer :: erin1(:,:) ! inflow from upstream links during previous step, used for Muskingum method, [m3/s] - real(r8), pointer :: erin2(:,:) ! inflow from upstream links during current step, used for Muskingum method, [m3/s] - real(r8), pointer :: ergwl(:,:) ! flux item for the adjustment of water balance residual in glacie, wetlands and lakes dynamics [m3/s] - - !! for Runge-Kutta algorithm - real(r8), pointer :: wrtemp(:,:) ! temporary storage item, for 4th order Runge-Kutta algorithm; - real(r8), pointer :: erintemp(:,:) - real(r8), pointer :: erouttemp(:,:) - real(r8), pointer :: k1(:,:) - real(r8), pointer :: k2(:,:) - real(r8), pointer :: k3(:,:) - real(r8), pointer :: k4(:,:) - end type TstatusFlux - !== Hongyi - - ! parameters to be calibrated. Ideally, these parameters are supposed to be uniform for one region - public :: Tparameter - type Tparameter - real(r8), pointer :: c_nr(:) ! coefficient to adjust the manning's roughness of channels - real(r8), pointer :: c_nh(:) ! coefficient to adjust the manning's roughness of overland flow across hillslopes - real(r8), pointer :: c_twid(:) ! coefficient to adjust the width of sub-reach channel - end type Tparameter - - !== Hongyi - type (Tcontrol) , public :: Tctl - type (Tspatialunit), public :: TUnit - type (TstatusFlux) , public :: TRunoff - type (Tparameter) , public :: TPara - !== Hongyi - - type (runoff_flow) , public :: rtmCTL - - public :: RunoffInit +module mosart_control_type + use shr_kind_mod, only : r8 => shr_kind_r8, CL => SHR_KIND_CL + use shr_sys_mod, only : shr_sys_abort + use shr_const_mod, only : shr_const_pi + use shr_mpi_mod, only : shr_mpi_sum, shr_mpi_max + use mosart_io, only : ncd_io, ncd_pio_openfile, ncd_pio_closefile + use mosart_vars, only : mainproc, iam, npes, mpicom_rof, iulog, spval, re + use pio, only : file_desc_t, PIO_BCAST_ERROR, pio_seterrorhandling + use perf_mod, only : t_startf, t_stopf + use ESMF + use nuopc_shr_methods , only : chkerr + + implicit none + private + + type control_type + + ! grid sizes + integer :: lnumr ! local number of cells + integer :: numr ! global number of cells + integer :: nlon = -999 ! number of longitudes + integer :: nlat = -999 ! number of latitudes + + ! tracers + integer :: ntracers = -999 ! number of tracers + character(len=3), allocatable :: tracer_names(:)! tracer names + + ! decomp info + integer :: begr ! local start index + integer :: endr ! local stop indices + integer , pointer :: gindex(:) => null() ! global index consistent with map file + type(ESMF_DistGrid) :: distgrid ! esmf global index space descriptor + + ! grid + real(r8), pointer :: rlon(:) => null() ! longitude list, 1d + real(r8), pointer :: rlat(:) => null() ! latitude list, 1d + real(r8), pointer :: lonc(:) => null() ! lon of cell + real(r8), pointer :: latc(:) => null() ! lat of cell + integer , pointer :: dsig(:) => null() ! downstream index, global index + integer , pointer :: outletg(:) => null() ! outlet index, global index + real(r8), pointer :: area(:) => null() ! area of cell + integer , pointer :: mask(:) => null() ! general mask of cell 1=land, 2=ocean, 3=outlet + real(r8) :: totarea ! global area + + ! inputs to MOSART + real(r8), pointer :: qsur(:,:) => null() ! coupler surface forcing [m3/s] + real(r8), pointer :: qsub(:,:) => null() ! coupler subsurface forcing [m3/s] + real(r8), pointer :: qgwl(:,:) => null() ! coupler glacier/wetland/lake forcing [m3/s] + + ! outputs from MOSART + real(r8), pointer :: flood(:) => null() ! coupler return flood water sent back to clm [m3/s] + real(r8), pointer :: runoff(:,:) => null() ! coupler return mosart basin derived flow [m3/s] + real(r8), pointer :: direct(:,:) => null() ! coupler return direct flow [m3/s] + real(r8), pointer :: qirrig(:) => null() ! coupler irrigation [m3/s] + real(r8), pointer :: qirrig_actual(:) => null() ! minimum of irrigation and available main channel storage + + ! storage, runoff + real(r8), pointer :: runofflnd(:,:) => null() ! runoff masked for land (m3 H2O/s) + real(r8), pointer :: runoffocn(:,:) => null() ! runoff masked for ocn (m3 H2O/s) + real(r8), pointer :: runofftot(:,:) => null() ! total runoff masked for ocn (m3 H2O/s) + real(r8), pointer :: dvolrdt(:,:) => null() ! change in storage (mm/s) + real(r8), pointer :: dvolrdtlnd(:,:) => null() ! dvolrdt masked for land (mm/s) + real(r8), pointer :: dvolrdtocn(:,:) => null() ! dvolrdt masked for ocn (mm/s) + real(r8), pointer :: volr(:,:) => null() ! storage (m3) + real(r8), pointer :: fthresh(:) => null() ! water flood threshold + + ! flux variables + real(r8), pointer :: flow(:,:) => null() ! mosart flow (m3/s) + real(r8), pointer :: evel(:,:) => null() ! effective tracer velocity (m/s) + real(r8), pointer :: erout_prev(:,:) => null() ! erout previous timestep (m3/s) + real(r8), pointer :: eroutup_avg(:,:) => null() ! eroutup average over coupling period (m3/s) + real(r8), pointer :: erlat_avg(:,:) => null() ! erlateral average over coupling period (m3/s) + real(r8), pointer :: effvel(:) => null() + + ! halo operations + type(ESMF_Array) :: haloArray + type(ESMF_RouteHandle) :: haloHandle + real(r8), pointer :: halo_arrayptr(:) => null() ! preallocated memory for exclusive region plus halo + integer , pointer :: halo_arrayptr_index(:,:) ! index into halo_arrayptr that corresponds to a halo point + + contains + + procedure, public :: Init + procedure, private :: init_decomp + procedure, private :: test_halo + + end type control_type + public :: control_type + + private :: init_decomp + +#ifdef NDEBUG + integer,parameter :: dbug = 0 ! 0 = none, 1=normal, 2=much, 3=max +#else + integer,parameter :: dbug = 3 ! 0 = none, 1=normal, 2=much, 3=max +#endif + + integer :: max_num_halo = 8 + integer :: halo_sw = 1 + integer :: halo_s = 2 + integer :: halo_se = 3 + integer :: halo_e = 4 + integer :: halo_ne = 5 + integer :: halo_n = 6 + integer :: halo_nw = 7 + integer :: halo_w = 8 + + character(*), parameter :: u_FILE_u = & + __FILE__ + +!======================================================================== contains +!======================================================================== + + subroutine Init(this, locfn, decomp_option, use_halo_option, IDkey, rc) + + ! Arguments + class(control_type) :: this + character(len=*) , intent(in) :: locfn + character(len=*) , intent(in) :: decomp_option ! decomposition option + logical , intent(in) :: use_halo_option ! create ESMF array and route handle for halos + integer , intent(out) :: IDkey(:) ! translation key from ID to gindex + integer , intent(out) :: rc + + ! Local variables + real(r8) :: area_global(this%nlon*this%nlat) ! area + real(r8) :: tempr(this%nlon,this%nlat) ! temporary buffer + real(r8) :: rlats(this%nlat) ! latitude of 1d south grid cell edge (deg) + real(r8) :: rlatn(this%nlat) ! latitude of 1d north grid cell edge (deg) + real(r8) :: rlonw(this%nlon) ! longitude of 1d west grid cell edge (deg) + real(r8) :: rlone(this%nlon) ! longitude of 1d east grid cell edge (deg) + real(r8) :: larea ! tmp local sum of area + real(r8) :: deg2rad ! pi/180 + integer :: g, n, i, j, nr, nt ! iterators + real(r8) :: edgen ! North edge of the direction file + real(r8) :: edgee ! East edge of the direction file + real(r8) :: edges ! South edge of the direction file + real(r8) :: edgew ! West edge of the direction file + real(r8) :: dx ! lon dist. betn grid cells (m) + real(r8) :: dy ! lat dist. betn grid cells (m) + type(file_desc_t) :: ncid ! pio file desc + logical :: found ! flag + integer :: ntracers ! used to simplify code + integer :: begr, endr ! used to simplify code + integer :: ier ! error status + integer :: nlon,nlat + real(r8) :: effvel0 = 10.0_r8 ! default velocity (m/s) + character(len=*),parameter :: subname = '(mosart_control_type: Init)' + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + nlon = this%nlon + nlat = this%nlat + + !--------------------------------------- + ! Read the routing parameters + !--------------------------------------- + + call ncd_pio_openfile (ncid, trim(locfn), 0) + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + + call ncd_io(ncid=ncid, varname='longxy', flag='read', data=tempr, readvar=found) + if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart longitudes') + if (mainproc) write(iulog,*) 'Read longxy ',minval(tempr),maxval(tempr) + allocate(this%rlon(this%nlon)) + do i=1,nlon + this%rlon(i) = tempr(i,1) + enddo + if (mainproc) write(iulog,*) 'rlon center ',minval(this%rlon),maxval(this%rlon) + + call ncd_io(ncid=ncid, varname='latixy', flag='read', data=tempr, readvar=found) + if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart latitudes') + if (mainproc) write(iulog,*) 'Read latixy ',minval(tempr),maxval(tempr) + allocate(this%rlat(this%nlat)) + do j=1,this%nlat + this%rlat(j) = tempr(1,j) + end do + if (mainproc) write(iulog,*) 'rlat center ',minval(this%rlat),maxval(this%rlat) + + call ncd_io(ncid=ncid, varname='area', flag='read', data=tempr, readvar=found) + if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart area') + if (mainproc) write(iulog,*) 'Read area ',minval(tempr),maxval(tempr) + do j=1,this%nlat + do i=1,nlon + n = (j-1)*nlon + i + area_global(n) = tempr(i,j) + end do + end do + if (mainproc) write(iulog,*) 'area ',minval(area_global),maxval(area_global) + call ncd_pio_closefile(ncid) + + !------------------------------------------------------- + ! adjust area estimation from DRT algorithm for those outlet grids + ! useful for grid-based representation only + ! need to compute areas where they are not defined in input file + !------------------------------------------------------- + + ! Derive gridbox edges + ! assuming equispaced grid, calculate edges from nlat/nlon + ! w/o assuming a global grid + edgen = maxval(this%rlat) + 0.5*abs(this%rlat(1) - this%rlat(2)) + edges = minval(this%rlat) - 0.5*abs(this%rlat(1) - this%rlat(2)) + edgee = maxval(this%rlon) + 0.5*abs(this%rlon(1) - this%rlon(2)) + edgew = minval(this%rlon) - 0.5*abs(this%rlon(1) - this%rlon(2)) + if (edgen .ne. 90._r8)then + if (mainproc ) write(iulog,*) 'Regional grid: edgen = ', edgen + end if + if (edges .ne. -90._r8)then + if (mainproc ) write(iulog,*) 'Regional grid: edges = ', edges + end if + if (edgee .ne. 180._r8)then + if (mainproc ) write(iulog,*) 'Regional grid: edgee = ', edgee + end if + if (edgew .ne.-180._r8)then + if ( mainproc ) write(iulog,*) 'Regional grid: edgew = ', edgew + end if + + ! Set edge latitudes (assumes latitudes are constant for a given longitude) + rlats(:) = edges + rlatn(:) = edgen + do j = 2, nlat + if (this%rlat(2) > this%rlat(1)) then ! South to North grid + rlats(j) = (this%rlat(j-1) + this%rlat(j)) / 2._r8 + rlatn(j-1) = rlats(j) + else ! North to South grid + rlatn(j) = (this%rlat(j-1) + this%rlat(j)) / 2._r8 + rlats(j-1) = rlatn(j) + end if + end do + + ! Set edge longitudes + rlonw(:) = edgew + rlone(:) = edgee + dx = (edgee - edgew) / nlon + do i = 2, nlon + rlonw(i) = rlonw(i) + (i-1)*dx + rlone(i-1) = rlonw(i) + end do + + ! adjust area estimation from DRT algorithm for those outlet grids + deg2rad = shr_const_pi / 180._r8 + do n=1,nlon*nlat + if (area_global(n) <= 0._r8) then + i = mod(n-1,nlon) + 1 + j = (n-1)/nlon + 1 + dx = (rlone(i) - rlonw(i)) * deg2rad + dy = sin(rlatn(j)*deg2rad) - sin(rlats(j)*deg2rad) + area_global(n) = abs(1.e6_r8 * dx*dy*re*re) + if (mainproc .and. area_global(n) <= 0) then + write(iulog,*) 'Warning! Zero area for unit ', n, area_global(n),dx,dy,re + end if + end if + end do + + ! --------------------------------------------- + ! Determine decomposition + ! --------------------------------------------- + + ! memory for this%gindex, this%mask and this%dsig is allocated in init_decomp + + call t_startf('mosarti_decomp') + call this%init_decomp(locfn, decomp_option, use_halo_option, & + nlon, nlat, this%begr, this%endr, this%lnumr, this%numr, IDkey, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call t_stopf('mosarti_decomp') + + ! --------------------------------------------- + ! Allocate and initialize remaining variables + ! --------------------------------------------- + + begr = this%begr + endr = this%endr + ntracers = this%ntracers + + allocate(this%area(begr:endr), & + ! + this%volr(begr:endr,ntracers), & + this%dvolrdt(begr:endr,ntracers), & + this%dvolrdtlnd(begr:endr,ntracers), & + this%dvolrdtocn(begr:endr,ntracers), & + ! + this%runoff(begr:endr,ntracers), & + this%runofflnd(begr:endr,ntracers), & + this%runoffocn(begr:endr,ntracers), & + this%runofftot(begr:endr,ntracers), & + ! + this%fthresh(begr:endr), & + this%flood(begr:endr), & + ! + this%direct(begr:endr,ntracers), & + this%qsur(begr:endr,ntracers), & + this%qsub(begr:endr,ntracers), & + this%qgwl(begr:endr,ntracers), & + this%qirrig(begr:endr), & + this%qirrig_actual(begr:endr), & + ! + this%evel(begr:endr,ntracers), & + this%flow(begr:endr,ntracers), & + this%erout_prev(begr:endr,ntracers), & + this%eroutup_avg(begr:endr,ntracers),& + this%erlat_avg(begr:endr,ntracers), & + ! + this%effvel(ntracers), & + stat=ier) + if (ier /= 0) then + write(iulog,*)'mosarart_control_type allocation error' + call shr_sys_abort + end if + + this%runoff(:,:) = 0._r8 + this%runofflnd(:,:) = spval + this%runoffocn(:,:) = spval + this%runofftot(:,:) = spval + this%dvolrdt(:,:) = 0._r8 + this%dvolrdtlnd(:,:) = spval + this%dvolrdtocn(:,:) = spval + this%volr(:,:) = 0._r8 + this%flood(:) = 0._r8 + this%direct(:,:) = 0._r8 + this%qirrig(:) = 0._r8 + this%qirrig_actual(:) = 0._r8 + this%qsur(:,:) = 0._r8 + this%qsub(:,:) = 0._r8 + this%qgwl(:,:) = 0._r8 + ! + this%fthresh(:) = abs(spval) + this%flow(:,:) = 0._r8 + this%erout_prev(:,:) = 0._r8 + this%eroutup_avg(:,:) = 0._r8 + this%erlat_avg(:,:) = 0._r8 + + this%effvel(:) = effvel0 ! downstream velocity (m/s) + do nt = 1,ntracers + do nr = begr,endr + this%evel(nr,nt) = this%effvel(nt) + enddo + enddo + + do nr = begr,endr + n = this%gindex(nr) + i = mod(n-1,nlon) + 1 + j = (n-1)/nlon + 1 + this%lonc(nr) = this%rlon(i) + this%latc(nr) = this%rlat(j) + this%area(nr) = area_global(n) + enddo + + larea = 0.0_r8 + do nr = begr,endr + larea = larea + this%area(nr) + end do + if (minval(this%mask) < 1) then + write(iulog,*) subname,'ERROR this mask lt 1 ',minval(this%mask),maxval(this%mask) + call shr_sys_abort(subname//' ERROR this mask') + endif + call shr_mpi_sum(larea, this%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 ',this%totarea + end if + + end subroutine Init + + !======================================================================== + subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & + nlon, nlat, begr, endr, lnumr, numr, IDkey, rc) + + ! Arguments + class(control_type) :: this + character(len=*) , intent(in) :: locfn ! local routing filename + character(len=*) , intent(in) :: decomp_option + logical , intent(in) :: use_halo_option + integer , intent(in) :: nlon + integer , intent(in) :: nlat + integer , intent(out) :: begr + integer , intent(out) :: endr + integer , intent(out) :: lnumr + integer , intent(out) :: numr + integer , intent(out) :: IDkey(:) ! translation key from ID to gindex + integer , intent(out) :: rc + + ! Local variables + integer :: n, nr, i, j, g ! indices + integer :: nl,nloops ! used for decomp search + integer :: itempr(nlon,nlat) ! global temporary buffer + integer :: gmask(nlon*nlat) ! global mask + integer :: gdc2glo(nlon*nlat) ! temporary for initialization + integer :: glo2gdc(nlon*nlat) ! temporary for initialization + integer :: ID0_global(nlon*nlat) ! global (local) ID index + integer :: dnID_global(nlon*nlat) ! global downstream ID based on ID0 + integer :: idxocn(nlon*nlat) ! downstream ocean outlet cell + integer :: nupstrm(nlon*nlat) ! number of upstream cells including own cell + integer :: pocn(nlon*nlat) ! pe number assigned to basin + integer :: nop(0:npes-1) ! number of gridcells on a pe + integer :: nba(0:npes-1) ! number of basins on each pe + integer :: nrs(0:npes-1) ! begr on each pe + integer :: maxgcells_per_pe ! max num of points per pe for decomp + integer :: minbas,maxbas ! used for decomp search + integer :: pid,np,npmin,npmax,npint ! log loop control + integer :: nmos ! number of mosart points + integer :: nout ! number of basin with outlets + integer :: nbas ! number of basin/ocean points + integer :: nrof ! num of active mosart points + integer :: baspe ! pe with min number of mosart cells + logical :: found ! flag + integer :: ier ! error status + type(file_desc_t) :: ncid ! pio file desc + integer :: procid + integer :: im1,ip1 + integer :: jm1,jp1 + integer :: n_sw, n_s, n_se + integer :: n_nw, n_n, n_ne + integer :: n_e, n_w + integer :: num_halo + integer, pointer :: halo_list(:) + integer, pointer :: seqlist(:) + integer, allocatable :: store_halo_index(:) + integer :: nglob + character(len=*),parameter :: subname = '(mosart_control_type: init_decomp) ' + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + !------------------------------------------------------- + ! Read ID and DnID from routing file + !------------------------------------------------------- + + call ncd_pio_openfile(ncid, trim(locfn), 0) + + 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,nlat + do i=1,nlon + n = (j-1)*nlon + 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,nlat + do i=1,nlon + n = (j-1)*nlon + i + dnID_global(n) = itempr(i,j) + end do + end do + if (mainproc) write(iulog,*) 'dnID ',minval(itempr),maxval(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 nlon*nlat is upper right. + ! ID0 is the "key", modify dnID based on that. keep the IDkey around + ! for as long as needed. This is a key that translates the ID0 value + ! to the gindex value. compute the key, then apply the key to dnID_global. + ! As part of this, check that each value of ID0 is unique and within + ! the range of 1 to nlon*nlat. + !------------------------------------------------------- + + IDkey = 0 + do n=1,nlon*nlat + if (ID0_global(n) < 0 .or. ID0_global(n) > nlon*nlat) 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,nlon*nlat + if (dnID_global(n) > 0 .and. dnID_global(n) <= nlon*nlat) then + if (IDkey(dnID_global(n)) > 0 .and. IDkey(dnID_global(n)) <= nlon*nlat) then + dnID_global(n) = IDkey(dnID_global(n)) + else + write(iulog,*) subname,' ERROR bad IDkey',n,dnID_global(n),IDkey(dnID_global(n)) + call shr_sys_abort(subname//' ERROR bad IDkey') + endif + endif + enddo + + !------------------------------------------------------- + ! Determine mosart ocn/land mask (global, all procs) + !------------------------------------------------------- + + ! 1=land, 2=ocean, 3=ocean outlet from land + + gmask(:) = 2 ! assume ocean point + do n=1,nlon*nlat ! mark all downstream points as outlet + nr = dnID_global(n) + if ((nr > 0) .and. (nr <= nlon*nlat)) then + gmask(nr) = 3 ! <- nr + end if + enddo + do n=1,nlon*nlat ! now mark all points with downstream points as land + nr = dnID_global(n) + if ((nr > 0) .and. (nr <= nlon*nlat)) then + gmask(n) = 1 ! <- n + end if + enddo + + !------------------------------------------------------- + ! Compute total number of basins and runoff points + !------------------------------------------------------- + + nbas = 0 + nrof = 0 + nout = 0 + nmos = 0 + do nr=1,nlon*nlat + if (gmask(nr) == 3) then + nout = nout + 1 + nbas = nbas + 1 + nmos = nmos + 1 + nrof = nrof + 1 + elseif (gmask(nr) == 2) then + nbas = nbas + 1 + nrof = nrof + 1 + elseif (gmask(nr) == 1) then + nmos = nmos + 1 + nrof = nrof + 1 + endif + enddo + if (mainproc) then + write(iulog,*) 'Number of outlet basins = ',nout + write(iulog,*) 'Number of total basins = ',nbas + write(iulog,*) 'Number of mosart points = ',nmos + write(iulog,*) 'Number of runoff points = ',nrof + endif + + !------------------------------------------------------- + ! Compute river basins, actually compute ocean outlet gridcell + !------------------------------------------------------- + + ! idxocn = final downstream cell, index is global 1d ocean gridcell + ! nupstrm = number of source gridcells upstream including self + + idxocn(:) = 0 + nupstrm(:) = 0 + do nr=1,nlon*nlat + n = nr + if (abs(gmask(n)) == 1) then ! land + g = 0 + do while (abs(gmask(n)) == 1 .and. g < nlon*nlat) ! follow downstream + nupstrm(n) = nupstrm(n) + 1 + n = dnID_global(n) + g = g + 1 + end do + if (gmask(n) == 3) then ! found ocean outlet + nupstrm(n) = nupstrm(n) + 1 ! one more land cell for n + idxocn(nr) = n ! set ocean outlet or nr to n + elseif (abs(gmask(n)) == 1) then ! no ocean outlet, warn user, ignore cell + write(iulog,*) subname,' ERROR closed basin found', & + g,nr,gmask(nr),dnID_global(nr), & + n,gmask(n),dnID_global(n) + call shr_sys_abort(subname//' ERROR closed basin found') + elseif (gmask(n) == 2) then + write(iulog,*) subname,' ERROR found invalid ocean cell ',nr + call shr_sys_abort(subname//' ERROR found invalid ocean cell') + else + write(iulog,*) subname,' ERROR downstream cell is unknown', & + g,nr,gmask(nr),dnID_global(nr), & + n,gmask(n),dnID_global(n) + call shr_sys_abort(subname//' ERROR downstream cell is unknown') + endif + elseif (gmask(n) >= 2) then ! ocean, give to self + nupstrm(n) = nupstrm(n) + 1 + idxocn(nr) = n + endif + enddo + + !------------------------------------------------------- + !--- Now allocate those basins to pes + !------------------------------------------------------- + + ! this is the heart of the decomp, need to set pocn and nop by the end of this + ! pocn is the pe that gets the basin associated with ocean outlet nr + ! nop is a running count of the number of mosart cells/pe + + pocn(:) = -99 + nop(0:npes-1) = 0 + if (trim(decomp_option) == 'basin') then + + baspe = 0 + maxgcells_per_pe = int(float(nrof)/float(npes)*0.445) + 1 + nloops = 3 + minbas = nrof + do nl=1,nloops + maxbas = minbas - 1 + minbas = maxval(nupstrm)/(2**nl) + if (nl == nloops) minbas = min(minbas,1) + do nr=1,nlon*nlat + if (gmask(nr) >= 2 .and. nupstrm(nr) > 0 .and. nupstrm(nr) >= minbas .and. nupstrm(nr) <= maxbas) then + ! Decomp options + ! find min pe (implemented but scales poorly) + ! use increasing thresholds (implemented, ok load balance for l2r or calc) + ! distribute basins using above methods but work from max to min basin size + ! find next pe below maxgcells_per_pe threshhold and increment + do while (nop(baspe) > maxgcells_per_pe) + baspe = baspe + 1 + if (baspe > npes-1) then + baspe = 0 + ! 3 loop, .445 and 1.5 chosen carefully + maxgcells_per_pe = max(maxgcells_per_pe*1.5, maxgcells_per_pe+1.0) + endif + enddo + if (baspe > npes-1 .or. baspe < 0) then + write(iulog,*) 'ERROR in decomp for mosart ',nr,npes,baspe + call shr_sys_abort('ERROR mosart decomp') + endif + nop(baspe) = nop(baspe) + nupstrm(nr) + pocn(nr) = baspe + endif + enddo ! nr + enddo ! nl + + ! set pocn for land cells, was set for ocean above + do nr=1,nlon*nlat + if (idxocn(nr) > 0) then + pocn(nr) = pocn(idxocn(nr)) + if (pocn(nr) < 0 .or. pocn(nr) > npes-1) then + write(iulog,*) subname,' ERROR pocn lnd setting ',& + nr,idxocn(nr),idxocn(idxocn(nr)),pocn(idxocn(nr)),pocn(nr),npes + call shr_sys_abort(subname//' ERROR pocn lnd') + endif + endif + enddo + + elseif (trim(decomp_option) == '1d') then + + ! distribute active points in 1d fashion to pes + ! baspe is the pe assignment + ! maxgcells_per_pe is the maximum number of points to assign to each pe + baspe = 0 + maxgcells_per_pe = (nrof-1)/npes + 1 + do nr=1,nlon*nlat + if (gmask(nr) >= 1) then + pocn(nr) = baspe + nop(baspe) = nop(baspe) + 1 + if (nop(baspe) >= maxgcells_per_pe) then + baspe = (mod(baspe+1,npes)) + if (baspe < 0 .or. baspe > npes-1) then + write(iulog,*) subname,' ERROR basepe ',baspe,npes + call shr_sys_abort(subname//' ERROR pocn lnd') + endif + endif + endif + enddo + + elseif (trim(decomp_option) == 'roundrobin') then + + ! distribute active points in roundrobin fashion to pes + ! baspe is the pe assignment + ! maxgcells_per_pe is the maximum number of points to assign to each pe + baspe = 0 + do nr=1,nlon*nlat + 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 + do nr = 1,nlon*nlat + if (pocn(nr) < 0) then + write(6,*)'WARNING: nr,pocn(nr) is < 0',nr,pocn(nr) + end if + end do + + else + write(iulog,*) subname,' ERROR decomp option unknown ',trim(decomp_option) + call shr_sys_abort(subname//' ERROR pocn lnd') + endif ! decomp_option + + if (mainproc) then + write(iulog,*) 'mosart cells and basins total = ',nrof,nbas + write(iulog,*) 'mosart cells per basin avg/max = ',nrof/nbas,maxval(nupstrm) + write(iulog,*) 'mosart cells per pe min/max = ',minval(nop),maxval(nop) + write(iulog,*) 'mosart basins per pe min/max = ',minval(nba),maxval(nba) + endif + + !------------------------------------------------------- + ! Determine begr, endr, numr and lnumr + !------------------------------------------------------- + + numr = 0 + do n = 0,npes-1 + if (iam == n) then + begr = numr + 1 + endr = begr + nop(n) - 1 + endif + numr = numr + nop(n) + enddo + lnumr = endr - begr + 1 + + !------------------------------------------------------- + ! Determine glo2gdc (global to local) and gdc2glo (local to global) + !------------------------------------------------------- + + ! pocn(nlon*nlat) pe number assigned to basin + ! nop(0:npes-1) number of gridcells on a pe + ! nba(0:npes-1) number of basins on each pe + ! nrs(0:npes-1) begr on each pe + + ! Determine glo2gdc + ! nrs is begr on each pe + ! reuse nba for nop-like counter here, pocn -99 is unused cell + + nrs(:) = 0 + nrs(0) = 1 + do n = 1,npes-1 + ! nop is number of cells per pe + ! so loop through the pes and determine begr on each pe + nrs(n) = nrs(n-1) + nop(n-1) + enddo + + glo2gdc(:) = 0 + nba(:) = 0 + do nr = 1,nlon*nlat + procid = pocn(nr) + if (procid >= 0) then + glo2gdc(nr) = nrs(procid) + nba(procid) + nba(procid) = nba(procid) + 1 + endif + enddo + do n = 0,npes-1 + if (nba(n) /= nop(n)) then + write(iulog,*) subname,' ERROR mosart cell count ',n,nba(n),nop(n) + call shr_sys_abort(subname//' ERROR mosart cell count') + endif + enddo + + ! Determine gdc2glo - local to global index space + do j = 1,nlat + do i = 1,nlon + n = (j-1)*nlon + i + nr = glo2gdc(n) + if (nr > 0) then + gdc2glo(nr) = n + endif + end do + end do + + !------------------------------------------------------- + ! Determine gindex + !------------------------------------------------------- + + allocate(this%gindex(begr:endr)) + do nr = begr,endr + this%gindex(nr) = gdc2glo(nr) + n = this%gindex(nr) + if (n <= 0 .or. n > nlon*nlat) then + write(iulog,*) subname,' ERROR in gindex, nr,ng= ',nr,n + call shr_sys_abort(subname//' ERROR gindex values values') + endif + if (dnID_global(n) > 0) then + if (glo2gdc(dnID_global(n)) == 0) then + write(iulog,*) subname,' ERROR glo2gdc dnID_global ',& + nr,n,dnID_global(n),glo2gdc(dnID_global(n)) + call shr_sys_abort(subname//' ERROT glo2gdc dnID_global') + end if + end if + end do + + !------------------------------------------------------- + ! Create distGrid from global index array + !------------------------------------------------------- + + allocate(seqlist(endr-begr+1)) + n = 0 + do nr = begr,endr + n = n + 1 + seqlist(n) = this%gindex(nr) + end do + this%DistGrid = ESMF_DistGridCreate(arbSeqIndexList=seqlist, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + deallocate(seqlist) + + !------------------------------------------------------- + ! Determine local lonc and latc + !------------------------------------------------------- + + allocate(this%lonc(begr:endr), this%latc(begr:endr)) + do nr = begr,endr + n = gdc2glo(nr) + i = mod(n-1,nlon) + 1 + j = (n-1)/nlon + 1 + this%lonc(nr) = this%rlon(i) + this%latc(nr) = this%rlat(j) + end do + + !------------------------------------------------------- + ! Determine halo points and create halo route handle + !------------------------------------------------------- + + ! each note that for each gridcell below there are 4 extra elements that need to be allocated + ! Need to keep track of the global index of each halo point + ! temporary allocatable array store_halo_index = size((endr-begr+1)*nhalo) (nhalo is the number of halo points) + ! + ! Allocate halo_arrayptr_index - local index (starting at 1) into this%halo_arrayptr on my pe + allocate(this%halo_arrayptr_index(endr-begr+1,max_num_halo)) + this%halo_arrayptr_index(:,:) = -999 + + allocate(store_halo_index((endr-begr+1)*max_num_halo)) + store_halo_index(:) = 0 + + do nr = begr,endr + n = gdc2glo(nr) + i = mod(n-1,nlon) + 1 + j = (n-1)/nlon + 1 + jm1 = j-1 + jp1 = j+1 + im1 = i-1 + ip1 = i+1 + if (i == 1) im1 = 1 + if (j == 1) jm1 = 1 + if (i == nlon) ip1 = nlon + if (j == nlat) jp1 = nlat + n_sw = (jm1-1)*nlon + im1 + n_s = (jm1-1)*nlon + i + n_se = (jm1-1)*nlon + ip1 + n_e = ( j-1)*nlon + ip1 + n_ne = (jp1-1)*nlon + ip1 + n_n = (jp1-1)*nlon + i + n_nw = (jp1-1)*nlon + im1 + n_w = ( j-1)*nlon + im1 + call set_halo_index(n_sw, halo_sw, glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_s , halo_s , glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_se, halo_se, glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_e , halo_e , glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_ne, halo_ne, glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_n , halo_n , glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_nw, halo_nw, glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_w , halo_w , glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + end do + + ! Allocate halo_list - global indices of the halo points on my pe + num_halo = count(store_halo_index /= 0) + allocate(halo_list(num_halo)) + halo_list(1:num_halo) = store_halo_index(1:num_halo) + + ! Create halo route handle using predefined allocatable memory + allocate(this%halo_arrayptr(endr-begr+1+num_halo)) + this%halo_arrayptr(:) = 0. + this%haloArray = ESMF_ArrayCreate(this%distgrid, this%halo_arrayptr, haloSeqIndexList=halo_list, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_ArrayHaloStore(this%haloArray, routehandle=this%haloHandle, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + deallocate(halo_list) + deallocate(store_halo_index) + + ! Now do a test of the halo operation + call this%test_halo(rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !------------------------------------------------------- + ! Determine mask, outletg and dsig + !------------------------------------------------------- + + allocate(this%mask(begr:endr), this%outletg(begr:endr), this%dsig(begr:endr)) + do nr = begr,endr + n = this%gindex(nr) + this%mask(nr) = gmask(n) + this%outletg(nr) = idxocn(n) + if (dnID_global(n) <= 0) then + this%dsig(nr) = 0 + else + this%dsig(nr) = dnID_global(n) + endif + end do + + !------------------------------------------------------- + ! Write per-processor runoff bounds depending on dbug level + !------------------------------------------------------- + + if (mainproc) then + write(iulog,*) 'total runoff cells numr = ',numr + endif + call mpi_barrier(mpicom_rof,ier) + npmin = 0 + npmax = npes-1 + npint = 1 + if (dbug == 0) then + npmax = 0 + elseif (dbug == 1) then + npmax = min(npes-1,4) + elseif (dbug == 2) then + npint = npes/8 + elseif (dbug == 3) then + npint = 1 + endif + do np = npmin,npmax,npint + pid = np + if (dbug == 1) then + if (np == 2) pid=npes/2-1 + if (np == 3) pid=npes-2 + if (np == 4) pid=npes-1 + endif + pid = max(pid,0) + pid = min(pid,npes-1) + if (iam == pid) then + write(iulog,'(2a,i9,a,i9,a,i9,a,i9)')' mosart decomp info',& + ' proc = ',iam,' begr = ',begr,' endr = ',endr,' numr = ',lnumr + endif + call mpi_barrier(mpicom_rof,ier) + enddo + + end subroutine init_decomp + + !======================================================================== + + subroutine set_halo_index(global_index, halo_index, glo2gdc, nr, begr, endr, pocn, store_halo_index, halo_arrayptr_index) + + ! Arguments + integer, intent(in) :: global_index + integer, intent(in) :: halo_index + integer, intent(in) :: glo2gdc(:) + integer, intent(in) :: nr + integer, intent(in) :: begr, endr + integer, intent(in) :: pocn(:) + integer, intent(inout) :: store_halo_index(:) + integer, intent(inout) :: halo_arrayptr_index(:,:) + + ! Local variables + integer :: n + logical :: found_index + integer :: nsize + integer :: num_halo + !----------------------------------------------------------------------- + + nsize = endr-begr+1 + if (pocn(global_index) /= iam) then + found_index = .false. + do n = 1,size(store_halo_index) + if (store_halo_index(n) == global_index) then + num_halo = n + found_index = .true. + exit + else if (store_halo_index(n) == 0) then + store_halo_index(n) = global_index + num_halo = n + found_index = .true. + exit + end if + end do + if (.not. found_index) then + call shr_sys_abort('ERROR: global halo index not found') + end if + halo_arrayptr_index(nr-begr+1,halo_index) = nsize + num_halo + else + halo_arrayptr_index(nr-begr+1,halo_index) = glo2gdc(global_index) - begr + 1 + end if + + end subroutine set_halo_index + + !======================================================================== + subroutine test_halo(this, rc) + + ! Arguments + class(control_type) :: this + integer, intent(out) :: rc + + ! Local variables + integer :: i,j + integer :: n, nr + integer :: nglob + integer :: halo_value + integer :: valid_value + real(r8) :: lon, lon_p1, lon_m1 + real(r8) :: lat, lat_p1, lat_m1 + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + n = 0 + do nr = this%begr,this%endr + n = n + 1 + this%halo_arrayptr(n) = this%latc(nr)*10. + this%lonc(nr)/100. + end do + + call ESMF_ArrayHalo(this%haloArray, routehandle=this%haloHandle, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + n = 0 + do nr = this%begr,this%endr + n = n+1 + nglob = this%gindex(nr) + i = mod(nglob-1,this%nlon) + 1 + j = (nglob-1)/this%nlon + 1 + if (j== 1) then + lat_m1 = this%rlat(1) + else + lat_m1 = this%rlat(j-1) + end if + if (j == this%nlat) then + lat_p1 = this%rlat(this%nlat) + else + lat_p1 = this%rlat(j+1) + end if + lat = this%rlat(j) + if (i == 1) then + lon_m1 = this%rlon(1) + else + lon_m1 = this%rlon(i-1) + end if + if (i == this%nlon) then + lon_p1 = this%rlon(this%nlon) + else + lon_p1 = this%rlon(i+1) + end if + lon = this%rlon(i) + ! + halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_sw)) + valid_value = lat_m1*10 + lon_m1/100. + if (halo_value /= valid_value) then + write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + ! + halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_s)) + valid_value = lat_m1*10 + lon/100. + if (halo_value /= valid_value) then + write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + ! + halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_se)) + valid_value = lat_m1*10 + lon_p1/100. + if (halo_value /= valid_value) then + write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + ! + halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_e)) + valid_value = lat*10 + lon_p1/100. + if (halo_value /= valid_value) then + write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + ! + halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_ne)) + valid_value = lat_p1*10 + lon_p1/100. + if (halo_value /= valid_value) then + write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + ! + halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_nw)) + valid_value = lat_p1*10 + lon_m1/100. + if (halo_value /= valid_value) then + write(6,*)'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + end do + + end subroutine test_halo - subroutine RunoffInit(begr, endr, numr) - - integer, intent(in) :: begr, endr, numr - - integer :: ier - - allocate(rtmCTL%runoff(begr:endr,nt_rtm), & - rtmCTL%dvolrdt(begr:endr,nt_rtm), & - rtmCTL%runofflnd(begr:endr,nt_rtm), & - rtmCTL%dvolrdtlnd(begr:endr,nt_rtm), & - rtmCTL%runoffocn(begr:endr,nt_rtm), & - rtmCTL%dvolrdtocn(begr:endr,nt_rtm), & - rtmCTL%runofftot(begr:endr,nt_rtm), & - rtmCTL%area(begr:endr), & - rtmCTL%volr(begr:endr,nt_rtm), & - rtmCTL%lonc(begr:endr), & - rtmCTL%latc(begr:endr), & - rtmCTL%dsig(begr:endr), & - rtmCTL%outletg(begr:endr), & - rtmCTL%runofflnd_nt1(begr:endr), & - rtmCTL%runofflnd_nt2(begr:endr), & - rtmCTL%runoffocn_nt1(begr:endr), & - rtmCTL%runoffocn_nt2(begr:endr), & - rtmCTL%runofftot_nt1(begr:endr), & - rtmCTL%runofftot_nt2(begr:endr), & - rtmCTL%runoffdir_nt1(begr:endr), & - rtmCTL%runoffdir_nt2(begr:endr), & - rtmCTL%volr_nt1(begr:endr), & - rtmCTL%volr_nt2(begr:endr), & - rtmCTL%volr_mch(begr:endr), & - rtmCTL%dvolrdtlnd_nt1(begr:endr), & - rtmCTL%dvolrdtlnd_nt2(begr:endr), & - rtmCTL%dvolrdtocn_nt1(begr:endr), & - rtmCTL%dvolrdtocn_nt2(begr:endr), & - rtmCTL%qsur_nt1(begr:endr), & - rtmCTL%qsur_nt2(begr:endr), & - rtmCTL%qsub_nt1(begr:endr), & - rtmCTL%qsub_nt2(begr:endr), & - rtmCTL%qgwl_nt1(begr:endr), & - rtmCTL%qgwl_nt2(begr:endr), & - rtmCTL%mask(begr:endr), & - rtmCTL%gindex(begr:endr), & - rtmCTL%fthresh(begr:endr), & - rtmCTL%flood(begr:endr), & - rtmCTL%direct(begr:endr,nt_rtm), & - rtmCTL%wh(begr:endr,nt_rtm), & - rtmCTL%wt(begr:endr,nt_rtm), & - rtmCTL%wr(begr:endr,nt_rtm), & - rtmCTL%erout(begr:endr,nt_rtm), & - rtmCTL%qsur(begr:endr,nt_rtm), & - rtmCTL%qsub(begr:endr,nt_rtm), & - rtmCTL%qgwl(begr:endr,nt_rtm), & - rtmCTL%qirrig(begr:endr), & - rtmCTL%qirrig_actual(begr:endr), & - stat=ier) - if (ier /= 0) then - write(iulog,*)'Rtmini ERROR allocation of runoff local arrays' - call shr_sys_abort - end if - - rtmCTL%runoff(:,:) = 0._r8 - rtmCTL%runofflnd(:,:) = spval - rtmCTL%runoffocn(:,:) = spval - rtmCTL%runofftot(:,:) = spval - rtmCTL%dvolrdt(:,:) = 0._r8 - rtmCTL%dvolrdtlnd(:,:) = spval - rtmCTL%dvolrdtocn(:,:) = spval - rtmCTL%volr(:,:) = 0._r8 - rtmCTL%flood(:) = 0._r8 - rtmCTL%direct(:,:) = 0._r8 - rtmCTL%qirrig(:) = 0._r8 - rtmCTL%qirrig_actual(:)= 0._r8 - rtmCTL%volr_mch(:) = 0._r8 - - rtmCTL%qsur(:,:) = 0._r8 - rtmCTL%qsub(:,:) = 0._r8 - rtmCTL%qgwl(:,:) = 0._r8 - - end subroutine RunoffInit - -end module RunoffMod +end module mosart_control_type diff --git a/src/riverroute/mosart_data.F90 b/src/riverroute/mosart_data.F90 new file mode 100644 index 0000000..5650e2c --- /dev/null +++ b/src/riverroute/mosart_data.F90 @@ -0,0 +1,19 @@ +module mosart_data + + use mosart_control_type, only : control_type + use mosart_tctl_type, only : tctl_type + use mosart_tspatialunit_type, only : tspatialunit_type + use mosart_tstatusflux_type, only : tstatusflux_type + use mosart_tparameter_type, only : tparameter_type + + implicit none + private + + ! Derived types + type(Tctl_type), public :: Tctl + type(Tspatialunit_type), public :: TUnit + type(TstatusFlux_type), public :: TRunoff + type(Tparameter_type), public :: TPara + type(control_type), public :: ctl + +end module mosart_data diff --git a/src/riverroute/mosart_datetime.F90 b/src/riverroute/mosart_datetime.F90 deleted file mode 100644 index 0afd6f7..0000000 --- a/src/riverroute/mosart_datetime.F90 +++ /dev/null @@ -1,49 +0,0 @@ -module RtmDateTime - - implicit none - public - -contains - - !----------------------------------------------------------------------- - 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/mosart_fileutils.F90 b/src/riverroute/mosart_fileutils.F90 index 3f645d3..743f4c8 100644 --- a/src/riverroute/mosart_fileutils.F90 +++ b/src/riverroute/mosart_fileutils.F90 @@ -1,21 +1,16 @@ -module RtmFileUtils +module mosart_fileutils - !----------------------------------------------------------------------- ! 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: + use mosart_vars , only : iulog, mainproc + implicit none private - ! + ! !PUBLIC MEMBER FUNCTIONS: public :: get_filename !Returns filename given full pathname public :: getfil !Obtain local copy of file - ! !----------------------------------------------------------------------- contains @@ -23,7 +18,6 @@ module RtmFileUtils !----------------------------------------------------------------------- character(len=256) function get_filename (fulpath) - ! !DESCRIPTION: ! Returns filename given full pathname ! ! !ARGUMENTS: @@ -47,12 +41,10 @@ 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 @@ -96,4 +88,4 @@ subroutine getfil (fulpath, locfn, iflag) end subroutine getfil -end module RtmFileUtils +end module mosart_fileutils diff --git a/src/riverroute/mosart_histfile.F90 b/src/riverroute/mosart_histfile.F90 index 6ae4245..c1ee1a6 100644 --- a/src/riverroute/mosart_histfile.F90 +++ b/src/riverroute/mosart_histfile.F90 @@ -1,1798 +1,1711 @@ -module RtmHistFile -!----------------------------------------------------------------------- -! !MODULE: RtmHistFileMod -! -! !DESCRIPTION: -! Module containing methods to for MOSART history file handling. -! -! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_sys_mod , only : shr_sys_flush, shr_sys_abort - use shr_log_mod , only : errMsg => shr_log_errMsg - use RunoffMod , only : rtmCTL, Tunit - use RtmVar , only : rtmlon, rtmlat, spval, ispval, secspday, frivinp_rtm, & - iulog, nsrest, caseid, inst_suffix, nsrStartup, nsrBranch, & - ctitle, version, hostname, username, conventions, source, & - model_doi_url - use RtmFileUtils , only : get_filename, getfil - use RtmTimeManager, only : get_nstep, get_curr_date, get_curr_time, get_ref_date, & - get_prev_time, get_prev_date, is_last_step, get_step_size - use RtmSpmd , only : mainproc - use RtmIO - use RtmDateTime - - implicit none - private -! -! !PUBLIC TYPES: -! -! Constants -! - integer , public, parameter :: max_tapes = 3 ! max number of history tapes - integer , public, parameter :: max_flds = 1500 ! max number of history fields - integer , public, parameter :: max_namlen = 32 ! maximum number of characters for field name -! -! Counters -! - integer , public :: ntapes = 0 ! index of max history file requested -! -! Namelist -! - integer :: ni - integer, public :: & - rtmhist_ndens(max_tapes) = 1 ! namelist: output density of netcdf history files - integer, public :: & - rtmhist_mfilt(max_tapes) = 30 ! namelist: number of time samples per tape - integer, public :: & - rtmhist_nhtfrq(max_tapes) = (/0, -24, -24/) ! namelist: history write freq(0=monthly) - character(len=1), public :: & - rtmhist_avgflag_pertape(max_tapes) = (/(' ',ni=1,max_tapes)/) ! namelist: per tape averaging flag - - ! list of fields to add - character(len=max_namlen+2), public :: rtmhist_fincl1(max_flds) = ' ' - character(len=max_namlen+2), public :: rtmhist_fincl2(max_flds) = ' ' - character(len=max_namlen+2), public :: rtmhist_fincl3(max_flds) = ' ' - ! - ! time_period_freq variable - ! - character(len=max_namlen+2), public :: time_period_freq = ' ' - - ! list of fields to remove - character(len=max_namlen+2), public :: rtmhist_fexcl1(max_flds) = ' ' - character(len=max_namlen+2), public :: rtmhist_fexcl2(max_flds) = ' ' - character(len=max_namlen+2), public :: rtmhist_fexcl3(max_flds) = ' ' - - ! equivalence list of fields to add/remove - character(len=max_namlen+2), public :: fexcl(max_flds,max_tapes) - character(len=max_namlen+2), public :: fincl(max_flds,max_tapes) - -!! Restart -! - logical, private :: if_close(max_tapes) ! true => save history file -! -! !PUBLIC MEMBER FUNCTIONS: - public :: RtmHistAddfld ! Add a field to the master field list - public :: RtmHistPrintflds ! Print summary of master field list - public :: RtmHistHtapesBuild ! Initialize history file handler for initial or continue run - public :: RtmHistUpdateHbuf ! Updates history buffer for all fields and tapes - public :: RtmHistHtapesWrapup ! Write history tape(s) - public :: RtmHistRestart ! Read/write history file restart data -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -! !PRIVATE MEMBER FUNCTIONS: - private :: htapes_fieldlist ! Define the contents of each history file based on namelist - private :: htape_addfld ! Add a field to the active list for a history tape - private :: htape_create ! Define contents of history file t - private :: htape_timeconst ! Write time constant values to history tape - private :: set_hist_filename ! Determine history dataset filenames - private :: list_index ! Find index of field in exclude list - private :: getname ! Retrieve name portion of input "inname" - private :: getflag ! Retrieve flag - private :: max_nFields ! The max number of fields on any tape - -! !PRIVATE TYPES: -! Constants -! - integer, parameter :: max_length_filename = 255 ! max length of a filename. on most linux systems this - ! is 255. But this can't be increased until all hard - ! coded values throughout the i/o stack are updated. - integer, parameter :: max_chars = 255 ! max chars for char variables -! -! Subscript dimensions -! - integer, parameter :: max_subs = 100 ! max number of subscripts - character(len=32) :: subs_name(max_subs) ! name of subscript - integer :: subs_dim(max_subs) ! dimension of subscript -! -! Derived types -! - type field_info - character(len=max_namlen) :: name ! field name - character(len=max_chars) :: long_name ! long name - character(len=max_chars) :: units ! units - integer :: hpindex ! history pointer index - end type field_info - - type master_entry - type (field_info) :: field ! field information - logical :: actflag(max_tapes) ! active/inactive flag - character(len=1) :: avgflag(max_tapes) ! time averaging flag ("X","A","M" or "I",) - end type master_entry - - type history_entry - type (field_info) :: field ! field information - character(len=1) :: avgflag ! time averaging flag - real(r8), pointer :: hbuf(:) ! history buffer (dimensions: dim1d x 1) - integer , pointer :: nacs(:) ! accumulation counter (dimensions: dim1d x 1) - end type history_entry - - type history_tape - integer :: nflds ! number of active fields on tape - integer :: ntimes ! current number of time samples on tape - integer :: mfilt ! maximum number of time samples per tape - integer :: nhtfrq ! number of time samples per tape - integer :: ncprec ! netcdf output precision - logical :: is_endhist ! true => current time step is end of history interval - real(r8) :: begtime ! time at beginning of history averaging interval - type (history_entry) :: hlist(max_flds) ! array of active history tape entries - end type history_tape - - type rtmpoint ! Pointer to real scalar data (1D) - real(r8), pointer :: ptr(:) - end type rtmpoint -!EOP -! -! Pointers -! - integer, parameter :: max_mapflds = 1500 ! Maximum number of fields to track - type (rtmpoint) :: rtmptr(max_mapflds) ! Real scalar data (1D) -! -! Master list: an array of master_entry entities -! - type (master_entry) :: masterlist(max_flds) ! master field list -! -! History tape: an array of history_tape entities (only active fields) -! - type (history_tape) :: tape(max_tapes) ! array history tapes -! -! Namelist input -! -! Counters -! - integer :: nfmaster = 0 ! number of fields in master field list -! -! Other variables -! - character(len=max_length_filename) :: locfnh(max_tapes) ! local history file names - character(len=max_chars) :: locfnhr(max_tapes) ! local history restart file names - logical :: htapes_defined = .false. ! flag indicates history contents have been defined -! -! NetCDF Id's -! - type(file_desc_t), target :: nfid(max_tapes) ! file ids - type(file_desc_t), target :: ncid_hist(max_tapes) ! file ids for history restart files - integer :: time_dimid ! time dimension id - integer :: hist_interval_dimid ! time bounds dimension id - integer :: strlen_dimid ! string dimension id -!----------------------------------------------------------------------- +module mosart_histfile + + ! Module containing methods to for MOSART history file handling. + + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_sys_mod , only : shr_sys_abort + use shr_log_mod , only : errMsg => shr_log_errMsg + use mosart_vars , only : spval, ispval, secspday, frivinp, & + iulog, nsrest, caseid, inst_suffix, nsrStartup, nsrBranch, & + ctitle, version, hostname, username, conventions, source, & + model_doi_url, mainproc, isecspday + use mosart_data , only : ctl, Tunit + use mosart_fileutils, only : get_filename, getfil + use mosart_timemanager, only : get_nstep, get_curr_date, get_curr_time, get_ref_date, & + get_prev_time, get_prev_date, get_step_size, & + get_calendar, NO_LEAP_C, GREGORIAN_C + use mosart_io + + implicit none + private + + ! Constants + integer , public, parameter :: max_tapes = 3 ! max number of history tapes + integer , public, parameter :: max_flds = 1500 ! max number of history fields + integer , public, parameter :: max_namlen = 32 ! maximum number of characters for field name + + ! Counters + integer , public :: ntapes = 0 ! index of max history file requested + + ! Namelist + integer :: ni + integer, public :: ndens(max_tapes) = 1 ! namelist: output density of netcdf history files + integer, public :: mfilt(max_tapes) = 30 ! namelist: number of time samples per tape + integer, public :: nhtfrq(max_tapes) = (/0, -24, -24/) ! namelist: history write freq(0=monthly) + character(len=1), public :: avgflag_pertape(max_tapes) = (/(' ',ni=1,max_tapes)/) ! namelist: per tape averaging flag + + ! list of fields to add + character(len=max_namlen+2), public :: fincl1(max_flds) = ' ' + character(len=max_namlen+2), public :: fincl2(max_flds) = ' ' + character(len=max_namlen+2), public :: fincl3(max_flds) = ' ' + + ! time_period_freq variable + character(len=max_namlen+2), public :: time_period_freq = ' ' + + ! list of fields to remove + character(len=max_namlen+2), public :: fexcl1(max_flds) = ' ' + character(len=max_namlen+2), public :: fexcl2(max_flds) = ' ' + character(len=max_namlen+2), public :: fexcl3(max_flds) = ' ' + + ! equivalence list of fields to add/remove + character(len=max_namlen+2), public :: fexcl(max_flds,max_tapes) + character(len=max_namlen+2), public :: fincl(max_flds,max_tapes) + + ! Restart + logical, private :: if_close(max_tapes) ! true => save history file + + ! public member functions: + public :: mosart_hist_Addfld ! Add a field to the master field list + public :: mosart_hist_Printflds ! Print summary of master field list + public :: mosart_hist_HtapesBuild ! Initialize history file handler for initial or continue run + public :: mosart_hist_UpdateHbuf ! Updates history buffer for all fields and tapes + public :: mosart_hist_HtapesWrapup ! Write history tape(s) + public :: mosart_hist_Restart ! read/write history file restart data + + ! private member functions: + private :: htapes_fieldlist ! Define the contents of each history file based on namelist + private :: htape_addfld ! Add a field to the active list for a history tape + private :: htape_create ! Define contents of history file t + private :: htape_timeconst ! Write time constant values to history tape + private :: set_hist_filename ! Determine history dataset filenames + private :: list_index ! Find index of field in exclude list + private :: getname ! Retrieve name portion of input "inname" + private :: getflag ! Retrieve flag + private :: max_nFields ! The max number of fields on any tape + + ! !PRIVATE TYPES: + ! Constants + ! + integer, parameter :: max_length_filename = 255 ! max length of a filename. on most linux systems this + ! is 255. But this can't be increased until all hard + ! coded values throughout the i/o stack are updated. + integer, parameter :: max_chars = 255 ! max chars for char variables + ! + ! Subscript dimensions + ! + integer, parameter :: max_subs = 100 ! max number of subscripts + character(len=32) :: subs_name(max_subs) ! name of subscript + integer :: subs_dim(max_subs) ! dimension of subscript + ! + ! Derived types + ! + type field_info + character(len=max_namlen) :: name ! field name + character(len=max_chars) :: long_name ! long name + character(len=max_chars) :: units ! units + integer :: hpindex ! history pointer index + end type field_info + + type master_entry + type (field_info) :: field ! field information + logical :: actflag(max_tapes) ! active/inactive flag + character(len=1) :: avgflag(max_tapes) ! time averaging flag ("X","A","M" or "I",) + end type master_entry + + type history_entry + type (field_info) :: field ! field information + character(len=1) :: avgflag ! time averaging flag + real(r8), pointer :: hbuf(:) ! history buffer (dimensions: dim1d x 1) + integer , pointer :: nacs(:) ! accumulation counter (dimensions: dim1d x 1) + end type history_entry + + type history_tape + integer :: nflds ! number of active fields on tape + integer :: ntimes ! current number of time samples on tape + integer :: mfilt ! maximum number of time samples per tape + integer :: nhtfrq ! number of time samples per tape + integer :: ncprec ! netcdf output precision + logical :: is_endhist ! true => current time step is end of history interval + real(r8) :: begtime ! time at beginning of history averaging interval + type (history_entry) :: hlist(max_flds) ! array of active history tape entries + end type history_tape + + type mosart_pointer ! Pointer to real scalar data (1D) + real(r8), pointer :: ptr(:) + end type mosart_pointer + + ! Pointers + integer, parameter :: max_mapflds = 1500 ! Maximum number of fields to track + type (mosart_pointer) :: ptr(max_mapflds) ! Real scalar data (1D) + + ! Master list: an array of master_entry entities + type (master_entry) :: masterlist(max_flds) ! master field list + + ! History tape: an array of history_tape entities (only active fields) + type (history_tape) :: tape(max_tapes) ! array history tapes + + ! Namelist input + + ! Counters + integer :: nfmaster = 0 ! number of fields in master field list + + ! Other variables + character(len=max_length_filename) :: locfnh(max_tapes) ! local history file names + character(len=max_chars) :: locfnhr(max_tapes) ! local history restart file names + logical :: htapes_defined = .false. ! flag indicates history contents have been defined + + ! NetCDF Id's + type(file_desc_t), target :: nfid(max_tapes) ! file ids + type(file_desc_t), target :: ncid_hist(max_tapes) ! file ids for history restart files + integer :: time_dimid ! time dimension id + integer :: hist_interval_dimid ! time bounds dimension id + integer :: strlen_dimid ! string dimension id + !----------------------------------------------------------------------- contains -!----------------------------------------------------------------------- - - subroutine RtmHistPrintflds() - - ! DESCRIPTION: - ! Print summary of master field list. - - ! !ARGUMENTS: - implicit none - - ! !LOCAL VARIABLES: - integer nf - character(len=*),parameter :: subname = 'RTM_hist_printflds' - - if (mainproc) then - write(iulog,*) trim(subname),' : number of master fields = ',nfmaster - write(iulog,*)' ******* MASTER FIELD LIST *******' - do nf = 1,nfmaster - write(iulog,9000)nf, masterlist(nf)%field%name, masterlist(nf)%field%units -9000 format (i5,1x,a32,1x,a16) - end do - call shr_sys_flush(iulog) - end if - - end subroutine RtmHistPrintflds - -!----------------------------------------------------------------------- - - subroutine RtmHistHtapesBuild () - - ! !DESCRIPTION: - ! Initialize ntapes history file for initial or branch run. - - ! !ARGUMENTS: - implicit none - - ! !LOCAL VARIABLES: - integer :: i ! index - integer :: ier ! error code - integer :: t, f ! tape, field indices - integer :: day, sec ! day and seconds from base date - character(len=1) :: avgflag ! lcl equiv of rtmhist_avgflag_pertape(t) - character(len=*),parameter :: subname = 'hist_htapes_build' - !---------------------------------------------------------- - - if (mainproc) then - write(iulog,*) trim(subname),' Initializing MOSART history files' - write(iulog,'(72a1)') ("-",i=1,60) - call shr_sys_flush(iulog) - endif - - ! Override averaging flag for all fields on a particular tape - ! if namelist input so specifies - - do t=1,max_tapes - if (rtmhist_avgflag_pertape(t) /= ' ') then - avgflag = rtmhist_avgflag_pertape(t) - do f = 1,nfmaster - select case (avgflag) - case ('A') - masterlist(f)%avgflag(t) = avgflag - case ('I') - masterlist(f)%avgflag(t) = avgflag - case ('X') - masterlist(f)%avgflag(t) = avgflag - case ('M') - masterlist(f)%avgflag(t) = avgflag - case default - write(iulog,*) trim(subname),' ERROR: unknown avgflag=',avgflag - call shr_sys_abort () - end select - end do - end if - end do - - fincl(:,1) = rtmhist_fincl1(:) - fincl(:,2) = rtmhist_fincl2(:) - fincl(:,3) = rtmhist_fincl3(:) - - fexcl(:,1) = rtmhist_fexcl1(:) - fexcl(:,2) = rtmhist_fexcl2(:) - fexcl(:,3) = rtmhist_fexcl3(:) - - ! Define field list information for all history files. - ! Update ntapes to reflect number of active history files - ! Note - branch runs can have additional auxiliary history files declared - - call htapes_fieldlist() - - ! Set number of time samples in each history file and - ! Note - the following entries will be overwritten by history restart - ! Note - with netcdf, only 1 (ncd_double) and 2 (ncd_float) are allowed - - do t=1,ntapes - tape(t)%ntimes = 0 - tape(t)%nhtfrq = rtmhist_nhtfrq(t) - tape(t)%mfilt = rtmhist_mfilt(t) - if (rtmhist_ndens(t) == 1) then - tape(t)%ncprec = ncd_double - else - tape(t)%ncprec = ncd_float - endif - end do - - ! Set time of beginning of current averaging interval - ! First etermine elapased time since reference date - call get_prev_time(day, sec) - do t=1,ntapes - tape(t)%begtime = day + sec/secspday - end do - - if (mainproc) then - write(iulog,*) trim(subname),' Successfully initialized MOSART history files' - write(iulog,'(72a1)') ("-",i=1,60) - call shr_sys_flush(iulog) - endif - - end subroutine RtmHistHtapesBuild - -!----------------------------------------------------------------------- - - subroutine htapes_fieldlist() - - ! !DESCRIPTION: - ! Define the contents of each history file based on namelist - ! input for initial or branch run, and restart data if a restart run. - ! Use arrays fincl and fexcl to modify default history tape contents. - ! Then sort the result alphanumerically. - - ! !ARGUMENTS: - implicit none - ! - ! !LOCAL VARIABLES: - integer :: t, f ! tape, field indices - integer :: ff ! index into include, exclude and fprec list - character(len=max_namlen) :: name ! field name portion of fincl (i.e. no avgflag separator) - character(len=max_namlen) :: mastername ! name from masterlist field - character(len=1) :: avgflag ! averaging flag - character(len=1) :: prec_acc ! history buffer precision flag - character(len=1) :: prec_wrt ! history buffer write precision flag - type (history_entry) :: tmp ! temporary used for swapping - character(len=*),parameter :: subname = 'htapes_fieldlist' - !--------------------------------------------------------- - - ! First ensure contents of fincl and fexcl are valid names - do t = 1,max_tapes - f = 1 - do while (f < max_flds .and. fincl(f,t) /= ' ') - name = getname (fincl(f,t)) !namelist - do ff = 1,nfmaster - mastername = masterlist(ff)%field%name - if (name == mastername) exit - end do - if (name /= mastername) then - write(iulog,*) trim(subname),' ERROR: ', trim(name), ' in fincl(', f, ') ',& - 'for history tape ',t,' not found' - call shr_sys_abort() - end if - f = f + 1 - end do - - f = 1 - do while (f < max_flds .and. fexcl(f,t) /= ' ') - do ff = 1,nfmaster - mastername = masterlist(ff)%field%name - if (fexcl(f,t) == mastername) exit - end do - if (fexcl(f,t) /= mastername) then - write(iulog,*) trim(subname),' ERROR: ', fexcl(f,t), ' in fexcl(', f, ') ', & - 'for history tape ',t,' not found' - call shr_sys_abort() - end if - f = f + 1 - end do - end do - - tape(:)%nflds = 0 - do t = 1,max_tapes - - ! Loop through the masterlist set of field names and determine if any of those - ! are in the FINCL or FEXCL arrays - ! The call to list_index determines the index in the FINCL or FEXCL arrays - ! that the masterlist field corresponds to - ! Add the field to the tape if specified via namelist (FINCL[1-max_tapes]), - ! or if it is on by default and was not excluded via namelist (FEXCL[1-max_tapes]). - - do f = 1,nfmaster - mastername = masterlist(f)%field%name - call list_index (fincl(1,t), mastername, ff) - if (ff > 0) then - ! if field is in include list, ff > 0 and htape_addfld - ! will not be called for field - avgflag = getflag (fincl(ff,t)) - call htape_addfld (t, f, avgflag) - else - ! find index of field in exclude list - call list_index (fexcl(1,t), mastername, ff) - - ! if field is in exclude list, ff > 0 and htape_addfld - ! will not be called for field - ! if field is not in exclude list, ff =0 and htape_addfld - ! will be called for field (note that htape_addfld will be - ! called below only if field is not in exclude list OR in - ! include list - if (ff == 0 .and. masterlist(f)%actflag(t)) then - call htape_addfld (t, f, ' ') - end if - end if - end do - - ! Specification of tape contents now complete. - ! Sort each list of active entries - - do f = tape(t)%nflds-1,1,-1 - do ff = 1,f - if (tape(t)%hlist(ff)%field%name > tape(t)%hlist(ff+1)%field%name) then - tmp = tape(t)%hlist(ff) - tape(t)%hlist(ff ) = tape(t)%hlist(ff+1) - tape(t)%hlist(ff+1) = tmp - else if (tape(t)%hlist(ff)%field%name == tape(t)%hlist(ff+1)%field%name) then - write(iulog,*) trim(subname),' ERROR: Duplicate field ', & - tape(t)%hlist(ff)%field%name, & - 't,ff,name=',t,ff,tape(t)%hlist(ff+1)%field%name - call shr_sys_abort() - end if - end do - end do - - if (mainproc) then - if (tape(t)%nflds > 0) then - write(iulog,*) trim(subname),' : Included fields tape ',t,'=',tape(t)%nflds - end if - do f = 1,tape(t)%nflds - write(iulog,*) f,' ',tape(t)%hlist(f)%field%name,' ',tape(t)%hlist(f)%avgflag - end do - call shr_sys_flush(iulog) - end if - end do - - ! Determine total number of active history tapes - - ntapes = 0 - do t = max_tapes,1,-1 - if (tape(t)%nflds > 0) then - ntapes = t - exit - end if - end do - - ! Ensure there are no "holes" in tape specification, i.e. empty tapes. - ! Enabling holes should not be difficult if necessary. - - do t = 1,ntapes - if (tape(t)%nflds == 0) then - write(iulog,*) trim(subname),' ERROR: Tape ',t,' is empty' - call shr_sys_abort() - end if - end do - - ! Check that the number of history files declared does not exceed - ! the maximum allowed. - - if (ntapes > max_tapes) then - write(iulog,*) trim(subname),' ERROR: Too many history files declared, max_tapes=',max_tapes - call shr_sys_abort() - end if - - if (mainproc) then - write(iulog,*) 'There will be a total of ',ntapes,'MOSART history tapes' - do t=1,ntapes - write(iulog,*) - if (rtmhist_nhtfrq(t) == 0) then - write(iulog,*)'MOSART History tape ',t,' write frequency is MONTHLY' - else - write(iulog,*)'MOSART History tape ',t,' write frequency = ',rtmhist_nhtfrq(t) - endif - write(iulog,*)'Number of time samples on MOSART history tape ',t,' is ',rtmhist_mfilt(t) - write(iulog,*)'Output precision on MOSART history tape ',t,'=',rtmhist_ndens(t) - write(iulog,*) - end do - call shr_sys_flush(iulog) - end if - - ! Set flag indicating h-tape contents are now defined - - htapes_defined = .true. - - end subroutine htapes_fieldlist - -!----------------------------------------------------------------------- - - subroutine htape_addfld (t, f, avgflag) - - ! !DESCRIPTION: - ! Add a field to the active list for a history tape. Copy the data from - ! the master field list to the active list for the tape. - - ! !ARGUMENTS: - implicit none - integer, intent(in) :: t ! history tape index - integer, intent(in) :: f ! field index from master field list - character(len=1), intent(in) :: avgflag ! time averaging flag - - ! !LOCAL VARIABLES: - integer :: n ! field index on defined tape - integer :: begrof ! per-proc beginning land runoff index - integer :: endrof ! per-proc ending land runoff index - integer :: numrtm ! total number of rtm cells on all procs - character(len=*),parameter :: subname = 'htape_addfld' - !------------------------------------------------------- - - ! Ensure that it is not to late to add a field to the history tape - if (htapes_defined) then - write(iulog,*) trim(subname),' ERROR: attempt to add field ', & - masterlist(f)%field%name, ' after history files are set' - call shr_sys_abort() - end if - - ! Determine bounds - begrof = rtmCTL%begr - endrof = rtmCTL%endr - numrtm = rtmCTL%numr - - tape(t)%nflds = tape(t)%nflds + 1 - n = tape(t)%nflds - tape(t)%hlist(n)%field = masterlist(f)%field - allocate (tape(t)%hlist(n)%hbuf(begrof:endrof)) - allocate (tape(t)%hlist(n)%nacs(begrof:endrof)) - tape(t)%hlist(n)%hbuf(:) = 0._r8 - tape(t)%hlist(n)%nacs(:) = 0 - - ! Set time averaging flag based on masterlist setting or - ! override the default averaging flag with namelist setting - select case (avgflag) - case (' ') - tape(t)%hlist(n)%avgflag = masterlist(f)%avgflag(t) - case ('A','I','X','M') - tape(t)%hlist(n)%avgflag = avgflag - case default - write(iulog,*) trim(subname),' ERROR: unknown avgflag=', avgflag - call shr_sys_abort() - end select - - end subroutine htape_addfld - -!----------------------------------------------------------------------- - - subroutine RtmHistUpdateHbuf() - - ! !DESCRIPTION: - ! Accumulate (or take min, max, etc. as appropriate) input field - ! into its history buffer for appropriate tapes. - - ! !ARGUMENTS: - implicit none - - ! !LOCAL VARIABLES: - integer :: t ! tape index - integer :: f ! field index - integer :: k ! index - integer :: hpindex ! history pointer index - integer :: begrof,endrof ! beginning and ending indices - character(len=1) :: avgflag ! time averaging flag - real(r8), pointer :: hbuf(:) ! history buffer - integer , pointer :: nacs(:) ! accumulation counter - real(r8), pointer :: field(:) ! 1d pointer field - integer j - character(len=*),parameter :: subname = 'RtmHistUpdateHbuf' - !---------------------------------------------------------- - - begrof = rtmCTL%begr - endrof = rtmCTL%endr - - do t = 1,ntapes - do f = 1,tape(t)%nflds - avgflag = tape(t)%hlist(f)%avgflag - nacs => tape(t)%hlist(f)%nacs - hbuf => tape(t)%hlist(f)%hbuf - hpindex = tape(t)%hlist(f)%field%hpindex - field => rtmptr(hpindex)%ptr - - select case (avgflag) - case ('I') ! Instantaneous - do k = begrof,endrof - if (field(k) /= spval) then - hbuf(k) = field(k) - else - hbuf(k) = spval - end if - nacs(k) = 1 - end do - case ('A') ! Time average - do k = begrof,endrof - if (field(k) /= spval) then - if (nacs(k) == 0) hbuf(k) = 0._r8 - hbuf(k) = hbuf(k) + field(k) - nacs(k) = nacs(k) + 1 - else - if (nacs(k) == 0) hbuf(k) = spval - end if - end do - case ('X') ! Maximum over time - do k = begrof,endrof - if (field(k) /= spval) then - if (nacs(k) == 0) hbuf(k) = -1.e50_r8 - hbuf(k) = max( hbuf(k), field(k) ) - else - if (nacs(k) == 0) hbuf(k) = spval - end if - nacs(k) = 1 - end do - case ('M') ! Minimum over time - do k = begrof,endrof - if (field(k) /= spval) then - if (nacs(k) == 0) hbuf(k) = +1.e50_r8 - hbuf(k) = min( hbuf(k), field(k) ) - else - if (nacs(k) == 0) hbuf(k) = spval - end if - nacs(k) = 1 - end do - case default - write(iulog,*) trim(subname),' ERROR: invalid time averaging flag ', avgflag - call shr_sys_abort() - end select - end do - end do - - end subroutine RtmHistUpdateHbuf - -!----------------------------------------------------------------------- - - subroutine htape_create (t, histrest) - - ! !DESCRIPTION: - ! Define contents of history file t. Issue the required netcdf - ! wrapper calls to define the history file contents. - ! - ! !USES: - use RtmVar , only: isecspday - - ! !ARGUMENTS: - implicit none - integer, intent(in) :: t ! tape index - logical, intent(in), optional :: histrest ! if creating the history restart file - - ! !LOCAL VARIABLES: - integer :: f ! field index - integer :: p,c,l,n ! indices - integer :: ier ! error code - integer :: dimid ! dimension id temporary - integer :: dim1id(1) ! netCDF dimension id - integer :: dim2id(2) ! netCDF dimension id - integer :: ndims ! dimension counter - integer :: omode ! returned mode from netCDF call - integer :: ncprec ! output netCDF write precision - integer :: ret ! netCDF error status - integer :: numrtm ! total number of rtm cells on all procs - integer :: dtime ! timestep size - integer :: sec_hist_nhtfrq ! rtmhist_nhtfrq converted to seconds - logical :: lhistrest ! local history restart flag - type(file_desc_t), pointer :: lnfid ! local file id - character(len= 8) :: curdate ! current date - character(len= 8) :: curtime ! current time - character(len=256) :: name ! name of attribute - character(len=256) :: units ! units of attribute - character(len=256) :: str ! global attribute string - character(len= 1) :: avgflag ! time averaging flag - character(len=*),parameter :: subname = 'htape_create' - !----------------------------------------------------- - - if ( present(histrest) )then - lhistrest = histrest - else - lhistrest = .false. - end if - - ! Define output write precsion for tape - ncprec = tape(t)%ncprec - if (lhistrest) then - lnfid => ncid_hist(t) - else - lnfid => nfid(t) - endif - - ! Create new netCDF file. It will be in define mode - if ( .not. lhistrest )then - if (mainproc) then - write(iulog,*) trim(subname),' : Opening netcdf htape ', & - trim(locfnh(t)) - call shr_sys_flush(iulog) - end if - call ncd_pio_createfile(lnfid, trim(locfnh(t))) - call ncd_putatt(lnfid, ncd_global, 'title', 'MOSART History file information' ) - call ncd_putatt(lnfid, ncd_global, 'comment', & - "NOTE: None of the variables are weighted by land fraction!" ) - else - if (mainproc) then - write(iulog,*) trim(subname),' : Opening netcdf rhtape ', & - trim(locfnhr(t)) - call shr_sys_flush(iulog) - end if - call ncd_pio_createfile(lnfid, trim(locfnhr(t))) - call ncd_putatt(lnfid, ncd_global, 'title', & - 'MOSART Restart History information, required to continue a simulation' ) - call ncd_putatt(lnfid, ncd_global, 'comment', & - "This entire file NOT needed for startup or branch simulations") - end if - - ! Create global attributes. Attributes are used to store information - ! about the data set. Global attributes are information about the - ! data set as a whole, as opposed to a single variable - - call ncd_putatt(lnfid, ncd_global, 'Conventions', trim(conventions)) - call getdatetime(curdate, curtime) - str = 'created on ' // curdate // ' ' // curtime - call ncd_putatt(lnfid, ncd_global, 'history' , trim(str)) - call ncd_putatt(lnfid, ncd_global, 'source' , trim(source)) - call ncd_putatt(lnfid, ncd_global, 'hostname' , trim(hostname)) - call ncd_putatt(lnfid, ncd_global, 'username' , trim(username)) - call ncd_putatt(lnfid, ncd_global, 'version' , trim(version)) - call ncd_putatt(lnfid, ncd_global, 'model_doi_url', trim(model_doi_url)) - - call ncd_putatt(lnfid, ncd_global, 'case_title', trim(ctitle)) - call ncd_putatt(lnfid, ncd_global, 'case_id', trim(caseid)) - - str = get_filename(frivinp_rtm) - call ncd_putatt(lnfid, ncd_global, 'RTM_input_dataset', trim(str)) - - ! - ! add global attribute time_period_freq - ! - if (rtmhist_nhtfrq(t) < 0) then !hour need to convert to seconds - sec_hist_nhtfrq = abs(rtmhist_nhtfrq(t))*3600 - else - sec_hist_nhtfrq = rtmhist_nhtfrq(t) - end if - - dtime = get_step_size() - if (sec_hist_nhtfrq == 0) then !month - time_period_freq = 'month_1' - else if (mod(sec_hist_nhtfrq*dtime,isecspday) == 0) then ! day - write(time_period_freq,999) 'day_',sec_hist_nhtfrq*dtime/isecspday - else if (mod(sec_hist_nhtfrq*dtime,3600) == 0) then ! hour - write(time_period_freq,999) 'hour_',(sec_hist_nhtfrq*dtime)/3600 - else if (mod(sec_hist_nhtfrq*dtime,60) == 0) then ! minute - write(time_period_freq,999) 'minute_',(sec_hist_nhtfrq*dtime)/60 - else ! second - write(time_period_freq,999) 'second_',sec_hist_nhtfrq*dtime - end if -999 format(a,i0) - - call ncd_putatt(lnfid, ncd_global, 'time_period_freq', trim(time_period_freq)) - - ! Define dimensions. - ! Time is an unlimited dimension. Character string is treated as an array of characters. - - ! Global uncompressed dimensions (including non-land points) - numrtm = rtmCTL%numr - call ncd_defdim( lnfid, 'lon', rtmlon , dimid) - call ncd_defdim( lnfid, 'lat', rtmlat , dimid) - call ncd_defdim( lnfid, 'allrof', numrtm , dimid) - - call ncd_defdim(lnfid, 'string_length', 8, strlen_dimid) - - if ( .not. lhistrest )then - call ncd_defdim(lnfid, 'hist_interval', 2, hist_interval_dimid) - call ncd_defdim(lnfid, 'time', ncd_unlimited, time_dimid) - if (mainproc)then - write(iulog,*) trim(subname), & - ' : Successfully defined netcdf history file ',t - call shr_sys_flush(iulog) - end if - else - if (mainproc)then - write(iulog,*) trim(subname), & - ' : Successfully defined netcdf restart history file ',t - call shr_sys_flush(iulog) - end if - end if - - end subroutine htape_create - -!----------------------------------------------------------------------- - - subroutine htape_timeconst(t, mode) - - ! !DESCRIPTION: - ! Write time constant values to primary history tape. - ! !USES: - use RtmTimeManager, only : get_calendar, NO_LEAP_C, GREGORIAN_C - - ! !ARGUMENTS: - implicit none - integer, intent(in) :: t ! tape index - character(len=*), intent(in) :: mode ! 'define' or 'write' - - ! !LOCAL VARIABLES: - integer :: vid,n,i,j,m ! indices - integer :: nstep ! current step - integer :: mcsec ! seconds of current date - integer :: mdcur ! current day - integer :: mscur ! seconds of current day - integer :: mcdate ! current date - integer :: dtime ! timestep size - integer :: yr,mon,day,nbsec ! year,month,day,seconds components of a date - integer :: hours,minutes,secs ! hours,minutes,seconds of hh:mm:ss - character(len= 10) :: basedate ! base date (yyyymmdd) - character(len= 8) :: basesec ! base seconds - character(len= 8) :: cdate ! system date - character(len= 8) :: ctime ! system time - real(r8):: time ! current time - real(r8):: timedata(2) ! time interval boundaries - integer :: dim1id(1) ! netCDF dimension id - integer :: dim2id(2) ! netCDF dimension id - integer :: varid ! netCDF variable id - type(Var_desc_t) :: vardesc ! netCDF variable description - character(len=max_chars) :: long_name ! variable long name - character(len=max_namlen):: varname ! variable name - character(len=max_namlen):: units ! variable units - character(len=max_namlen):: cal ! calendar type from time-manager - character(len=max_namlen):: caldesc ! calendar description to put on file - character(len=256):: str ! global attribute string - integer :: status - character(len=*),parameter :: subname = 'htape_timeconst' - !-------------------------------------------------------- - - ! For define mode -- only do this for first time-sample - if (mode == 'define' .and. tape(t)%ntimes == 1) then - - call get_ref_date(yr, mon, day, nbsec) - nstep = get_nstep() - hours = nbsec / 3600 - minutes = (nbsec - hours*3600) / 60 - secs = (nbsec - hours*3600 - minutes*60) - write(basedate,80) yr,mon,day -80 format(i4.4,'-',i2.2,'-',i2.2) - write(basesec ,90) hours, minutes, secs -90 format(i2.2,':',i2.2,':',i2.2) - - dim1id(1) = time_dimid - str = 'days since ' // basedate // " " // basesec - call ncd_defvar(nfid(t), 'time', tape(t)%ncprec, 1, dim1id, varid, & - long_name='time',units=str) - cal = get_calendar() - if ( trim(cal) == NO_LEAP_C )then - caldesc = "noleap" - else if ( trim(cal) == GREGORIAN_C )then - caldesc = "gregorian" - end if - call ncd_putatt(nfid(t), varid, 'calendar', caldesc) - call ncd_putatt(nfid(t), varid, 'bounds', 'time_bounds') - - dim1id(1) = time_dimid - call ncd_defvar(nfid(t) , 'mcdate', ncd_int, 1, dim1id , varid, & - long_name = 'current date (YYYYMMDD)') - call ncd_defvar(nfid(t) , 'mcsec' , ncd_int, 1, dim1id , varid, & - long_name = 'current seconds of current date', units='s') - call ncd_defvar(nfid(t) , 'mdcur' , ncd_int, 1, dim1id , varid, & - long_name = 'current day (from base day)') - call ncd_defvar(nfid(t) , 'mscur' , ncd_int, 1, dim1id , varid, & - long_name = 'current seconds of current day') - call ncd_defvar(nfid(t) , 'nstep' , ncd_int, 1, dim1id , varid, & - long_name = 'time step') - - dim2id(1) = hist_interval_dimid; dim2id(2) = time_dimid - call ncd_defvar(nfid(t), 'time_bounds', ncd_double, 2, dim2id, varid, & - long_name = 'history time interval endpoints') - - dim2id(1) = strlen_dimid; dim2id(2) = time_dimid - call ncd_defvar(nfid(t), 'date_written', ncd_char, 2, dim2id, varid) - call ncd_defvar(nfid(t), 'time_written', ncd_char, 2, dim2id, varid) - - call ncd_defvar(varname='lon', xtype=tape(t)%ncprec, dim1name='lon', & - long_name='runoff coordinate longitude', units='degrees_east', ncid=nfid(t)) - call ncd_defvar(varname='lat', xtype=tape(t)%ncprec, dim1name='lat', & - long_name='runoff coordinate latitude', units='degrees_north', ncid=nfid(t)) - call ncd_defvar(varname='mask', xtype=ncd_int, dim1name='lon', dim2name='lat', & - long_name='runoff mask', units='unitless', ncid=nfid(t), ifill_value=ispval) - call ncd_defvar(varname='area', xtype=tape(t)%ncprec, dim1name='lon', dim2name='lat', & - long_name='runoff grid area', units='m2', ncid=nfid(t), fill_value=spval) - call ncd_defvar(varname='areatotal', xtype=tape(t)%ncprec, dim1name='lon', dim2name='lat', & - long_name='basin upstream areatotal', units='m2', ncid=nfid(t), fill_value=spval) - call ncd_defvar(varname='areatotal2', xtype=tape(t)%ncprec, dim1name='lon', dim2name='lat', & - long_name='computed basin upstream areatotal', units='m2', ncid=nfid(t), fill_value=spval) - - else if (mode == 'write') then - - call get_curr_time (mdcur, mscur) - call get_curr_date (yr, mon, day, mcsec) - mcdate = yr*10000 + mon*100 + day - nstep = get_nstep() - - call ncd_io('mcdate', mcdate, 'write', nfid(t), nt=tape(t)%ntimes) - call ncd_io('mcsec' , mcsec , 'write', nfid(t), nt=tape(t)%ntimes) - call ncd_io('mdcur' , mdcur , 'write', nfid(t), nt=tape(t)%ntimes) - call ncd_io('mscur' , mscur , 'write', nfid(t), nt=tape(t)%ntimes) - call ncd_io('nstep' , nstep , 'write', nfid(t), nt=tape(t)%ntimes) - - time = mdcur + mscur/secspday - call ncd_io('time' , time , 'write', nfid(t), nt=tape(t)%ntimes) - - timedata(1) = tape(t)%begtime - timedata(2) = time - call ncd_io('time_bounds', timedata, 'write', nfid(t), nt=tape(t)%ntimes) - - call getdatetime (cdate, ctime) - call ncd_io('date_written', cdate, 'write', nfid(t), nt=tape(t)%ntimes) - - call ncd_io('time_written', ctime, 'write', nfid(t), nt=tape(t)%ntimes) - - call ncd_io(varname='lon', data=rtmCTL%rlon, ncid=nfid(t), flag='write') - call ncd_io(varname='lat', data=rtmCTL%rlat, ncid=nfid(t), flag='write') - call ncd_io(flag='write', varname='mask', dim1name='allrof', & - data=rtmCTL%mask, ncid=nfid(t)) - call ncd_io(flag='write', varname='area', dim1name='allrof', & - data=rtmCTL%area, ncid=nfid(t)) - call ncd_io(flag='write', varname='areatotal', dim1name='allrof', & - data=Tunit%areatotal, ncid=nfid(t)) - call ncd_io(flag='write', varname='areatotal2', dim1name='allrof', & - data=Tunit%areatotal2, ncid=nfid(t)) - - endif - - end subroutine htape_timeconst - -!----------------------------------------------------------------------- - - subroutine RtmHistHtapesWrapup( rstwr, nlend ) - - ! DESCRIPTION: - ! Write history tape(s) - ! Determine if next time step is beginning of history interval and if so: - ! increment the current time sample counter, open a new history file - ! and if needed (i.e., when ntim = 1), write history data to current - ! history file, reset field accumulation counters to zero. - ! If primary history file is full or at the last time step of the simulation, - ! write restart dataset and close all history fiels. - ! If history file is full or at the last time step of the simulation: - ! close history file - ! and reset time sample counter to zero if file is full. - ! Daily-averaged data for the first day in September are written on - ! date = 00/09/02 with mscur = 0. - ! Daily-averaged data for the first day in month mm are written on - ! date = yyyy/mm/02 with mscur = 0. - ! Daily-averaged data for the 30th day (last day in September) are written - ! on date = 0000/10/01 mscur = 0. - ! Daily-averaged data for the last day in month mm are written on - ! date = yyyy/mm+1/01 with mscur = 0. - - - ! !ARGUMENTS: - implicit none - logical, intent(in) :: rstwr ! true => write restart file this step - logical, intent(in) :: nlend ! true => end of run on this step - - ! !LOCAL VARIABLES: - integer :: begrof, endrof ! beg and end rof indices - integer :: t,f,k,nt ! indices - integer :: nstep ! current step - integer :: day ! current day (1 -> 31) - integer :: mon ! current month (1 -> 12) - integer :: yr ! current year (0 -> ...) - integer :: mdcur ! current day - integer :: mscur ! seconds of current day - integer :: mcsec ! current time of day [seconds] - integer :: daym1 ! nstep-1 day (1 -> 31) - integer :: monm1 ! nstep-1 month (1 -> 12) - integer :: yrm1 ! nstep-1 year (0 -> ...) - integer :: mcsecm1 ! nstep-1 time of day [seconds] - real(r8):: time ! current time - character(len=256):: str ! global attribute string - character(len=1) :: avgflag ! averaging flag - real(r8), pointer :: histo(:) ! temporary - real(r8), pointer :: hbuf(:) ! history buffer - integer , pointer :: nacs(:) ! accumulation counter - character(len=32) :: avgstr ! time averaging type - character(len=max_chars) :: long_name ! long name - character(len=max_chars) :: units ! units - character(len=max_namlen):: varname ! variable name - character(len=*),parameter :: subname = 'hist_htapes_wrapup' - !----------------------------------------------------------- - - begrof = rtmCTL%begr - endrof = rtmCTL%endr - - ! get current step - nstep = get_nstep() - - ! Set calendar for current time step - call get_curr_date (yr, mon, day, mcsec) - call get_curr_time (mdcur, mscur) - time = mdcur + mscur/secspday - - ! Set calendar for current for previous time step - call get_prev_date (yrm1, monm1, daym1, mcsecm1) - - ! Loop over active history tapes, create new history files if necessary - ! and write data to history files if end of history interval. - do t = 1, ntapes - - ! Skip nstep=0 if monthly average - if (nstep==0 .and. tape(t)%nhtfrq==0) cycle - - ! Determine if end of history interval - tape(t)%is_endhist = .false. - if (tape(t)%nhtfrq==0) then !monthly average - if (mon /= monm1) then - tape(t)%is_endhist = .true. - end if - else - if (mod(nstep,tape(t)%nhtfrq) == 0) then - tape(t)%is_endhist = .true. - end if - end if - - ! If end of history interval - if (tape(t)%is_endhist) then - - ! Normalize by number of accumulations for time averaged case - do f = 1,tape(t)%nflds - avgflag = tape(t)%hlist(f)%avgflag - nacs => tape(t)%hlist(f)%nacs - hbuf => tape(t)%hlist(f)%hbuf - do k = begrof, endrof - if ((avgflag == 'A') .and. nacs(k) /= 0) then - hbuf(k) = hbuf(k) / float(nacs(k)) - end if - end do - end do - - ! Increment current time sample counter. - tape(t)%ntimes = tape(t)%ntimes + 1 - - ! Create history file if appropriate and build time comment - - ! If first time sample, generate unique history file name, open file, - ! define dims, vars, etc. - - if (tape(t)%ntimes == 1) then - locfnh(t) = set_hist_filename (hist_freq=tape(t)%nhtfrq, & - rtmhist_mfilt=tape(t)%mfilt, hist_file=t) - if (mainproc) then - write(iulog,*) trim(subname),' : Creating history file ', trim(locfnh(t)), & - ' at nstep = ',get_nstep() - write(iulog,*)'calling htape_create for file t = ',t - endif - call htape_create (t) - - ! Define time-constant field variables - call htape_timeconst(t, mode='define') - - ! Define model field variables - - do f = 1,tape(t)%nflds - varname = tape(t)%hlist(f)%field%name - long_name = tape(t)%hlist(f)%field%long_name - units = tape(t)%hlist(f)%field%units - avgflag = tape(t)%hlist(f)%avgflag - - select case (avgflag) - case ('A') - avgstr = 'mean' - case ('I') - avgstr = 'instantaneous' - case ('X') - avgstr = 'maximum' - case ('M') - avgstr = 'minimum' - case default - write(iulog,*) trim(subname),& - ' ERROR: unknown time averaging flag (avgflag)=',avgflag - call shr_sys_abort() - end select - call ncd_defvar(ncid=nfid(t), varname=varname, xtype=tape(t)%ncprec, & - dim1name='lon', dim2name='lat', dim3name='time', & - long_name=long_name, units=units, cell_method=avgstr, & - missing_value=spval, fill_value=spval) - end do - - ! Exit define model - call ncd_enddef(nfid(t)) - - endif - - ! Write time constant history variables - call htape_timeconst(t, mode='write') - - if (mainproc) then - write(iulog,*) - write(iulog,*) trim(subname),' : Writing current time sample to local history file ', & - trim(locfnh(t)),' at nstep = ',get_nstep(), & - ' for history time interval beginning at ', tape(t)%begtime, & - ' and ending at ',time - write(iulog,*) - call shr_sys_flush(iulog) - endif - - ! Update beginning time of next interval - tape(t)%begtime = time - - ! Write history time slice - do f = 1,tape(t)%nflds - varname = tape(t)%hlist(f)%field%name - nt = tape(t)%ntimes - histo => tape(t)%hlist(f)%hbuf - call ncd_io(flag='write', varname=varname, dim1name='allrof', & - data=histo, ncid=nfid(t), nt=nt) - end do - - ! Zero necessary history buffers - do f = 1,tape(t)%nflds - tape(t)%hlist(f)%hbuf(:) = 0._r8 - tape(t)%hlist(f)%nacs(:) = 0 - end do - - end if - - end do ! end loop over history tapes - - ! Close open history files - ! Auxilary files may have been closed and saved off without being full, - ! must reopen the files - - do t = 1, ntapes - if (nlend) then - if_close(t) = .true. - else if (rstwr) then - if_close(t) = .true. - else - if (tape(t)%ntimes == tape(t)%mfilt) then - if_close(t) = .true. - else - if_close(t) = .false. - end if - endif - if (if_close(t)) then - if (tape(t)%ntimes /= 0) then - if (mainproc) then - write(iulog,*) - write(iulog,*) trim(subname),' : Closing local history file ',& - trim(locfnh(t)),' at nstep = ', get_nstep() - write(iulog,*) - endif - call ncd_pio_closefile(nfid(t)) - if ((.not.nlend) .and. (tape(t)%ntimes/=tape(t)%mfilt)) then - call ncd_pio_openfile (nfid(t), trim(locfnh(t)), ncd_write) - end if - else - if (mainproc) then - write(iulog,*) trim(subname),' : history tape ',t,': no open file to close' - end if - endif - if (tape(t)%ntimes==tape(t)%mfilt) then - tape(t)%ntimes = 0 - end if - endif - end do - - end subroutine RtmHistHtapesWrapup - -!----------------------------------------------------------------------- - - subroutine RtmHistRestart (ncid, flag, rdate) - ! !DESCRIPTION: - ! Read/write history file restart data. - ! If the current history file(s) are not full, file(s) are opened - ! so that subsequent time samples are added until the file is full. - ! A new history file is used on a branch run. - - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file - character(len=*) , intent(in) :: flag !'read' or 'write' - character(len=*) , intent(in), optional :: rdate ! restart file time stamp for name - - ! !LOCAL VARIABLES: - integer :: max_nflds ! max number of fields - integer :: begrof ! per-proc beginning ocean runoff index - integer :: endrof ! per-proc ending ocean runoff index - character(len=max_namlen) :: name ! variable name - character(len=max_namlen) :: name_acc ! accumulator variable name - character(len=max_namlen) :: long_name ! long name of variable - character(len=max_chars) :: long_name_acc ! long name for accumulator - character(len=max_chars) :: units ! units of variable - character(len=max_chars) :: units_acc ! accumulator units - character(len=max_chars) :: fname ! full name of history file - character(len=max_chars) :: locrest(max_tapes) ! local history restart file names - character(len=1) :: hnum ! history file index - type(var_desc_t) :: name_desc ! variable descriptor for name - type(var_desc_t) :: longname_desc ! variable descriptor for long_name - type(var_desc_t) :: units_desc ! variable descriptor for units - type(var_desc_t) :: avgflag_desc ! variable descriptor for avgflag - integer :: status ! error status - integer :: dimid ! dimension ID - integer :: start(2) ! Start array index - integer :: k ! 1d index - integer :: t ! tape index - integer :: f ! field index - integer :: varid ! variable id - integer, allocatable :: itemp2d(:,:) ! 2D temporary - real(r8), pointer :: hbuf(:) ! history buffer - integer , pointer :: nacs(:) ! accumulation counter - character(len=*),parameter :: subname = 'hist_restart_ncd' - !--------------------------------------------------------- - - ! If branch run, initialize file times and return - - if (flag == 'read') then - if (nsrest == nsrBranch) then - do t = 1,ntapes - tape(t)%ntimes = 0 - end do - RETURN - end if - ! If startup run just return - if (nsrest == nsrStartup) then - RETURN - end if - endif - - ! Read history file data only for restart run (not for branch run) - - ! First when writing out and in define mode, create files and define all variables - !================================================ - if (flag == 'define') then - !================================================ - - if (.not. present(rdate)) then - call shr_sys_abort('variable rdate must be present for writing restart files') - end if - - ! - ! On master restart file add ntapes/max_chars dimension - ! and then add the history and history restart filenames - ! - call ncd_defdim( ncid, 'ntapes' , ntapes , dimid) - call ncd_defdim( ncid, 'max_chars' , max_chars , dimid) - - call ncd_defvar(ncid=ncid, varname='locfnh', xtype=ncd_char, & - long_name="History filename", & - comment="This variable NOT needed for startup or branch simulations", & - dim1name='max_chars', dim2name="ntapes" ) - call ncd_defvar(ncid=ncid, varname='locfnhr', xtype=ncd_char, & - long_name="Restart history filename", & - comment="This variable NOT needed for startup or branch simulations", & - dim1name='max_chars', dim2name="ntapes" ) - - ! max_nflds is the maximum number of fields on any tape - ! max_flds is the maximum number possible number of fields - max_nflds = max_nFields() - - ! Loop over tapes - write out namelist information to each restart-history tape - ! only read/write accumulators and counters if needed - - do t = 1,ntapes - ! - ! Create the restart history filename and open it - ! - write(hnum,'(i1.1)') t-1 - locfnhr(t) = "./" // trim(caseid) //".mosart"// trim(inst_suffix) & - // ".rh" // hnum //"."// trim(rdate) //".nc" - call htape_create( t, histrest=.true. ) - ! - ! Add read/write accumultators and counters if needed - ! - if (.not. tape(t)%is_endhist) then - do f = 1,tape(t)%nflds - name = tape(t)%hlist(f)%field%name - long_name = tape(t)%hlist(f)%field%long_name - units = tape(t)%hlist(f)%field%units - name_acc = trim(name) // "_acc" - units_acc = "unitless positive integer" - long_name_acc = trim(long_name) // " accumulator number of samples" - nacs => tape(t)%hlist(f)%nacs - hbuf => tape(t)%hlist(f)%hbuf - - call ncd_defvar(ncid=ncid_hist(t), varname=trim(name), xtype=ncd_double, & - dim1name='lon', dim2name='lat', & - long_name=trim(long_name), units=trim(units)) - call ncd_defvar(ncid=ncid_hist(t), varname=trim(name_acc), xtype=ncd_int, & - dim1name='lon', dim2name='lat', & - long_name=trim(long_name_acc), units=trim(units_acc)) - end do - endif - - ! - ! Add namelist information to each restart history tape - ! - call ncd_defdim( ncid_hist(t), 'fname_lenp2' , max_namlen+2, dimid) - call ncd_defdim( ncid_hist(t), 'fname_len' , max_namlen , dimid) - call ncd_defdim( ncid_hist(t), 'len1' , 1 , dimid) - call ncd_defdim( ncid_hist(t), 'scalar' , 1 , dimid) - call ncd_defdim( ncid_hist(t), 'max_chars' , max_chars , dimid) - call ncd_defdim( ncid_hist(t), 'max_nflds' , max_nflds , dimid) - call ncd_defdim( ncid_hist(t), 'max_flds' , max_flds , dimid) - - call ncd_defvar(ncid=ncid_hist(t), varname='nhtfrq', xtype=ncd_int, & - long_name="Frequency of history writes", & - comment="Namelist item", & - units="absolute value of negative is in hours, 0=monthly, positive is time-steps", & - dim1name='scalar') - call ncd_defvar(ncid=ncid_hist(t), varname='mfilt', xtype=ncd_int, & - long_name="Number of history time samples on a file", units="unitless", & - comment="Namelist item", & - dim1name='scalar') - call ncd_defvar(ncid=ncid_hist(t), varname='ncprec', xtype=ncd_int, & - long_name="Flag for data precision", flag_values=(/1,2/), & - comment="Namelist item", & - nvalid_range=(/1,2/), & - flag_meanings=(/"single-precision", "double-precision"/), & - dim1name='scalar') - call ncd_defvar(ncid=ncid_hist(t), varname='fincl', xtype=ncd_char, & - comment="Namelist item", & - long_name="Fieldnames to include", & - dim1name='fname_lenp2', dim2name='max_flds' ) - call ncd_defvar(ncid=ncid_hist(t), varname='fexcl', xtype=ncd_char, & - comment="Namelist item", & - long_name="Fieldnames to exclude", & - dim1name='fname_lenp2', dim2name='max_flds' ) - - call ncd_defvar(ncid=ncid_hist(t), varname='nflds', xtype=ncd_int, & - long_name="Number of fields on file", units="unitless", & - dim1name='scalar') - call ncd_defvar(ncid=ncid_hist(t), varname='ntimes', xtype=ncd_int, & - long_name="Number of time steps on file", units="time-step", & - dim1name='scalar') - call ncd_defvar(ncid=ncid_hist(t), varname='is_endhist', xtype=ncd_log, & - long_name="End of history file", dim1name='scalar') - call ncd_defvar(ncid=ncid_hist(t), varname='begtime', xtype=ncd_double, & - long_name="Beginning time", units="time units", & - dim1name='scalar') - - call ncd_defvar(ncid=ncid_hist(t), varname='hpindex', xtype=ncd_int, & - long_name="History pointer index", units="unitless", & - dim1name='max_nflds' ) - - call ncd_defvar(ncid=ncid_hist(t), varname='avgflag', xtype=ncd_char, & - long_name="Averaging flag", & - units="A=Average, X=Maximum, M=Minimum, I=Instantaneous", & - dim1name='len1', dim2name='max_nflds' ) - call ncd_defvar(ncid=ncid_hist(t), varname='name', xtype=ncd_char, & - long_name="Fieldnames", & - dim1name='fname_len', dim2name='max_nflds' ) - call ncd_defvar(ncid=ncid_hist(t), varname='long_name', xtype=ncd_char, & - long_name="Long descriptive names for fields", & - dim1name='max_chars', dim2name='max_nflds' ) - call ncd_defvar(ncid=ncid_hist(t), varname='units', xtype=ncd_char, & - long_name="Units for each history field output", & - dim1name='max_chars', dim2name='max_nflds' ) - call ncd_enddef(ncid_hist(t)) - - end do ! end of ntapes loop - - RETURN - - !================================================ - else if (flag == 'write') then - !================================================ - ! Add history filenames to master restart file - do t = 1,ntapes - call ncd_io('locfnh', locfnh(t), 'write', ncid, nt=t) - call ncd_io('locfnhr', locfnhr(t), 'write', ncid, nt=t) - end do - - fincl(:,1) = rtmhist_fincl1(:) - fincl(:,2) = rtmhist_fincl2(:) - fincl(:,3) = rtmhist_fincl3(:) - - fexcl(:,1) = rtmhist_fexcl1(:) - fexcl(:,2) = rtmhist_fexcl2(:) - fexcl(:,3) = rtmhist_fexcl3(:) - - max_nflds = max_nFields() - - start(1)=1 - - - ! Add history namelist data to each history restart tape - allocate(itemp2d(max_nflds,ntapes)) - do t = 1,ntapes - call ncd_inqvid(ncid_hist(t), 'name', varid, name_desc) - call ncd_inqvid(ncid_hist(t), 'long_name', varid, longname_desc) - call ncd_inqvid(ncid_hist(t), 'units', varid, units_desc) - call ncd_inqvid(ncid_hist(t), 'avgflag', varid, avgflag_desc) - - call ncd_io(varname='fincl' , data=fincl(:,t) , ncid=ncid_hist(t), flag='write') - call ncd_io(varname='fexcl' , data=fexcl(:,t) , ncid=ncid_hist(t), flag='write') - call ncd_io(varname='is_endhist', data=tape(t)%is_endhist, ncid=ncid_hist(t), flag='write') - - itemp2d(:,:) = 0 - do f=1,tape(t)%nflds - itemp2d(f,t) = tape(t)%hlist(f)%field%hpindex - end do - call ncd_io(varname='hpindex', data=itemp2d(:,t), ncid=ncid_hist(t), flag='write') - - call ncd_io('nflds' , tape(t)%nflds, 'write', ncid_hist(t)) - call ncd_io('ntimes', tape(t)%ntimes, 'write', ncid_hist(t)) - call ncd_io('nhtfrq', tape(t)%nhtfrq, 'write', ncid_hist(t)) - call ncd_io('mfilt' , tape(t)%mfilt, 'write', ncid_hist(t)) - call ncd_io('ncprec', tape(t)%ncprec, 'write', ncid_hist(t)) - call ncd_io('begtime', tape(t)%begtime, 'write', ncid_hist(t)) - do f=1,tape(t)%nflds - start(2) = f - call ncd_io( name_desc, tape(t)%hlist(f)%field%name, & - 'write', ncid_hist(t), start ) - call ncd_io( longname_desc, tape(t)%hlist(f)%field%long_name, & - 'write', ncid_hist(t), start ) - call ncd_io( units_desc, tape(t)%hlist(f)%field%units, & - 'write', ncid_hist(t), start ) - call ncd_io( avgflag_desc, tape(t)%hlist(f)%avgflag, & - 'write', ncid_hist(t), start ) - end do - end do - deallocate(itemp2d) - - !================================================ - else if (flag == 'read') then - !================================================ - - call ncd_inqdlen(ncid,dimid,ntapes, name='ntapes') - call ncd_io('locfnh', locfnh(1:ntapes), 'read', ncid ) - call ncd_io('locfnhr', locrest(1:ntapes), 'read', ncid ) - do t = 1,ntapes - call strip_null(locrest(t)) - call strip_null(locfnh(t)) - end do - - ! Determine necessary indices - the following is needed if model decomposition - ! is different on restart - begrof = rtmCTL%begr - endrof = rtmCTL%endr - - start(1)=1 - do t = 1,ntapes - call getfil( locrest(t), locfnhr(t), 0 ) - call ncd_pio_openfile (ncid_hist(t), trim(locfnhr(t)), ncd_nowrite) - - if ( t == 1 )then - call ncd_inqdlen(ncid_hist(1),dimid,max_nflds,name='max_nflds') - allocate(itemp2d(max_nflds,ntapes)) - end if - - call ncd_inqvid(ncid_hist(t), 'name', varid, name_desc) - call ncd_inqvid(ncid_hist(t), 'long_name', varid, longname_desc) - call ncd_inqvid(ncid_hist(t), 'units', varid, units_desc) - call ncd_inqvid(ncid_hist(t), 'avgflag', varid, avgflag_desc) - - call ncd_io(varname='fincl', data=fincl(:,t), ncid=ncid_hist(t), flag='read') - call ncd_io(varname='fexcl', data=fexcl(:,t), ncid=ncid_hist(t), flag='read') - - call ncd_io('nflds', tape(t)%nflds, 'read', ncid_hist(t) ) - call ncd_io('ntimes', tape(t)%ntimes, 'read', ncid_hist(t) ) - call ncd_io('nhtfrq', tape(t)%nhtfrq, 'read', ncid_hist(t) ) - call ncd_io('mfilt', tape(t)%mfilt, 'read', ncid_hist(t) ) - call ncd_io('ncprec', tape(t)%ncprec, 'read', ncid_hist(t) ) - call ncd_io('begtime', tape(t)%begtime,'read', ncid_hist(t) ) - - call ncd_io(varname='is_endhist', data=tape(t)%is_endhist, ncid=ncid_hist(t), flag='read') - call ncd_io(varname='hpindex' , data=itemp2d(:,t) , ncid=ncid_hist(t), flag='read') - do f=1,tape(t)%nflds - tape(t)%hlist(f)%field%hpindex = itemp2d(f,t) - end do - - do f=1,tape(t)%nflds - start(2) = f - call ncd_io( name_desc, tape(t)%hlist(f)%field%name, & - 'read', ncid_hist(t), start ) - call ncd_io( longname_desc, tape(t)%hlist(f)%field%long_name, & - 'read', ncid_hist(t), start ) - call ncd_io( units_desc, tape(t)%hlist(f)%field%units, & - 'read', ncid_hist(t), start ) - call ncd_io( avgflag_desc, tape(t)%hlist(f)%avgflag, & - 'read', ncid_hist(t), start ) - call strip_null(tape(t)%hlist(f)%field%name) - call strip_null(tape(t)%hlist(f)%field%long_name) - call strip_null(tape(t)%hlist(f)%field%units) - call strip_null(tape(t)%hlist(f)%avgflag) - - allocate (tape(t)%hlist(f)%hbuf(begrof:endrof), & - tape(t)%hlist(f)%nacs(begrof:endrof), stat=status) - if (status /= 0) then - write(iulog,*) trim(subname),' ERROR: allocation error for hbuf,nacs at t,f=',t,f - call shr_sys_abort() - endif - tape(t)%hlist(f)%hbuf(:) = 0._r8 - tape(t)%hlist(f)%nacs(:) = 0 - end do ! end of flds loop - - ! If history file is not full, open it - - if (tape(t)%ntimes /= 0) then - call ncd_pio_openfile (nfid(t), trim(locfnh(t)), ncd_write) - end if - - end do ! end of tapes loop - - rtmhist_fincl1(:) = fincl(:,1) - rtmhist_fincl2(:) = fincl(:,2) - rtmhist_fincl3(:) = fincl(:,3) - - rtmhist_fexcl1(:) = fexcl(:,1) - rtmhist_fexcl2(:) = fexcl(:,2) - rtmhist_fexcl3(:) = fexcl(:,3) - - if ( allocated(itemp2d) ) deallocate(itemp2d) - - end if - - ! Read/write history file restart data. - ! If the current history file(s) are not full, file(s) are opened - ! so that subsequent time samples are added until the file is full. - ! A new history file is used on a branch run. - - if (flag == 'write') then - - do t = 1,ntapes - if (.not. tape(t)%is_endhist) then - do f = 1,tape(t)%nflds - name = tape(t)%hlist(f)%field%name - name_acc = trim(name) // "_acc" - nacs => tape(t)%hlist(f)%nacs - hbuf => tape(t)%hlist(f)%hbuf - - call ncd_io(ncid=ncid_hist(t), flag='write', varname=trim(name), & - dim1name='allrof', data=hbuf) - call ncd_io(ncid=ncid_hist(t), flag='write', varname=trim(name_acc), & - dim1name='allrof', data=nacs) - end do - end if ! end of is_endhist block - call ncd_pio_closefile(ncid_hist(t)) - end do ! end of ntapes loop - - else if (flag == 'read') then - - ! Read history restart information if history files are not full - do t = 1,ntapes - if (.not. tape(t)%is_endhist) then - do f = 1,tape(t)%nflds - name = tape(t)%hlist(f)%field%name - name_acc = trim(name) // "_acc" - nacs => tape(t)%hlist(f)%nacs - hbuf => tape(t)%hlist(f)%hbuf - - call ncd_io(ncid=ncid_hist(t), flag='read', varname=trim(name), & - dim1name='allrof', data=hbuf) - call ncd_io(ncid=ncid_hist(t), flag='read', varname=trim(name_acc), & - dim1name='allrof', data=nacs) - end do - end if - call ncd_pio_closefile(ncid_hist(t)) - end do - - end if - - end subroutine RtmHistRestart - -!----------------------------------------------------------------------- - - integer function max_nFields() - - ! DESCRIPTION: - ! Get the maximum number of fields on all tapes. - - ! ARGUMENTS: - implicit none - - ! LOCAL VARIABLES: - integer :: t ! index - character(len=*),parameter :: subname = 'max_nFields' - - max_nFields = 0 - do t = 1,ntapes - max_nFields = max(max_nFields, tape(t)%nflds) - end do + !----------------------------------------------------------------------- + + subroutine mosart_hist_Printflds() + + ! Print summary of master field list. + + ! !LOCAL VARIABLES: + integer nf + character(len=*),parameter :: subname = 'mosart_hist_printflds' + + if (mainproc) then + write(iulog,*) trim(subname),' : number of master fields = ',nfmaster + write(iulog,*)' ******* MASTER FIELD LIST *******' + do nf = 1,nfmaster + write(iulog,9000)nf, masterlist(nf)%field%name, masterlist(nf)%field%units +9000 format (i5,1x,a32,1x,a16) + end do + end if + + end subroutine mosart_hist_Printflds + + !----------------------------------------------------------------------- + + subroutine mosart_hist_HtapesBuild () + + ! Initialize ntapes history file for initial or branch run. + + ! !LOCAL VARIABLES: + integer :: i ! index + integer :: ier ! error code + integer :: t, f ! tape, field indices + integer :: day, sec ! day and seconds from base date + character(len=1) :: avgflag ! lcl equiv of avgflag_pertape(t) + character(len=*),parameter :: subname = 'hist_htapes_build' + !---------------------------------------------------------- + + if (mainproc) then + write(iulog,*) trim(subname),' Initializing MOSART history files' + write(iulog,'(72a1)') ("-",i=1,60) + endif + + ! Override averaging flag for all fields on a particular tape + ! if namelist input so specifies + + do t=1,max_tapes + if (avgflag_pertape(t) /= ' ') then + avgflag = avgflag_pertape(t) + do f = 1,nfmaster + select case (avgflag) + case ('A') + masterlist(f)%avgflag(t) = avgflag + case ('I') + masterlist(f)%avgflag(t) = avgflag + case ('X') + masterlist(f)%avgflag(t) = avgflag + case ('M') + masterlist(f)%avgflag(t) = avgflag + case default + write(iulog,*) trim(subname),' ERROR: unknown avgflag=',avgflag + call shr_sys_abort () + end select + end do + end if + end do + + fincl(:,1) = fincl1(:) + fincl(:,2) = fincl2(:) + fincl(:,3) = fincl3(:) + + fexcl(:,1) = fexcl1(:) + fexcl(:,2) = fexcl2(:) + fexcl(:,3) = fexcl3(:) + + ! Define field list information for all history files. + ! Update ntapes to reflect number of active history files + ! Note - branch runs can have additional auxiliary history files declared + + call htapes_fieldlist() + + ! Set number of time samples in each history file and + ! Note - the following entries will be overwritten by history restart + ! Note - with netcdf, only 1 (ncd_double) and 2 (ncd_float) are allowed + + do t=1,ntapes + tape(t)%ntimes = 0 + tape(t)%nhtfrq = nhtfrq(t) + tape(t)%mfilt = mfilt(t) + if (ndens(t) == 1) then + tape(t)%ncprec = ncd_double + else + tape(t)%ncprec = ncd_float + endif + end do + + ! Set time of beginning of current averaging interval + ! First etermine elapased time since reference date + call get_prev_time(day, sec) + do t=1,ntapes + tape(t)%begtime = day + sec/secspday + end do + + if (mainproc) then + write(iulog,*) trim(subname),' Successfully initialized MOSART history files' + write(iulog,'(72a1)') ("-",i=1,60) + endif + + end subroutine mosart_hist_HtapesBuild + + !----------------------------------------------------------------------- + + subroutine htapes_fieldlist() + + ! Define the contents of each history file based on namelist + ! input for initial or branch run, and restart data if a restart run. + ! Use arrays fincl and fexcl to modify default history tape contents. + ! Then sort the result alphanumerically. + + ! !LOCAL VARIABLES: + integer :: t, f ! tape, field indices + integer :: ff ! index into include, exclude and fprec list + character(len=max_namlen) :: name ! field name portion of fincl (i.e. no avgflag separator) + character(len=max_namlen) :: mastername ! name from masterlist field + character(len=1) :: avgflag ! averaging flag + character(len=1) :: prec_acc ! history buffer precision flag + character(len=1) :: prec_wrt ! history buffer write precision flag + type (history_entry) :: tmp ! temporary used for swapping + character(len=*),parameter :: subname = 'htapes_fieldlist' + !--------------------------------------------------------- + + ! First ensure contents of fincl and fexcl are valid names + do t = 1,max_tapes + f = 1 + do while (f < max_flds .and. fincl(f,t) /= ' ') + name = getname (fincl(f,t)) !namelist + do ff = 1,nfmaster + mastername = masterlist(ff)%field%name + if (name == mastername) exit + end do + if (name /= mastername) then + write(iulog,*) trim(subname),' ERROR: ', trim(name), ' in fincl(', f, ') ',& + 'for history tape ',t,' not found' + call shr_sys_abort() + end if + f = f + 1 + end do + + f = 1 + do while (f < max_flds .and. fexcl(f,t) /= ' ') + do ff = 1,nfmaster + mastername = masterlist(ff)%field%name + if (fexcl(f,t) == mastername) exit + end do + if (fexcl(f,t) /= mastername) then + write(iulog,*) trim(subname),' ERROR: ', fexcl(f,t), ' in fexcl(', f, ') ', & + 'for history tape ',t,' not found' + call shr_sys_abort() + end if + f = f + 1 + end do + end do + + tape(:)%nflds = 0 + do t = 1,max_tapes + + ! Loop through the masterlist set of field names and determine if any of those + ! are in the FINCL or FEXCL arrays + ! The call to list_index determines the index in the FINCL or FEXCL arrays + ! that the masterlist field corresponds to + ! Add the field to the tape if specified via namelist (FINCL[1-max_tapes]), + ! or if it is on by default and was not excluded via namelist (FEXCL[1-max_tapes]). + + do f = 1,nfmaster + mastername = masterlist(f)%field%name + call list_index (fincl(1,t), mastername, ff) + if (ff > 0) then + ! if field is in include list, ff > 0 and htape_addfld + ! will not be called for field + avgflag = getflag (fincl(ff,t)) + call htape_addfld (t, f, avgflag) + else + ! find index of field in exclude list + call list_index (fexcl(1,t), mastername, ff) + + ! if field is in exclude list, ff > 0 and htape_addfld + ! will not be called for field + ! if field is not in exclude list, ff =0 and htape_addfld + ! will be called for field (note that htape_addfld will be + ! called below only if field is not in exclude list OR in + ! include list + if (ff == 0 .and. masterlist(f)%actflag(t)) then + call htape_addfld (t, f, ' ') + end if + end if + end do + + ! Specification of tape contents now complete. + ! Sort each list of active entries + + do f = tape(t)%nflds-1,1,-1 + do ff = 1,f + if (tape(t)%hlist(ff)%field%name > tape(t)%hlist(ff+1)%field%name) then + tmp = tape(t)%hlist(ff) + tape(t)%hlist(ff ) = tape(t)%hlist(ff+1) + tape(t)%hlist(ff+1) = tmp + else if (tape(t)%hlist(ff)%field%name == tape(t)%hlist(ff+1)%field%name) then + write(iulog,*) trim(subname),' ERROR: Duplicate field ', & + tape(t)%hlist(ff)%field%name, & + 't,ff,name=',t,ff,tape(t)%hlist(ff+1)%field%name + call shr_sys_abort() + end if + end do + end do + + if (mainproc) then + if (tape(t)%nflds > 0) then + write(iulog,*) trim(subname),' : Included fields tape ',t,'=',tape(t)%nflds + end if + do f = 1,tape(t)%nflds + write(iulog,*) f,' ',tape(t)%hlist(f)%field%name,' ',tape(t)%hlist(f)%avgflag + end do + end if + end do + + ! Determine total number of active history tapes + + ntapes = 0 + do t = max_tapes,1,-1 + if (tape(t)%nflds > 0) then + ntapes = t + exit + end if + end do + + ! Ensure there are no "holes" in tape specification, i.e. empty tapes. + ! Enabling holes should not be difficult if necessary. + + do t = 1,ntapes + if (tape(t)%nflds == 0) then + write(iulog,*) trim(subname),' ERROR: Tape ',t,' is empty' + call shr_sys_abort() + end if + end do + + ! Check that the number of history files declared does not exceed + ! the maximum allowed. + + if (ntapes > max_tapes) then + write(iulog,*) trim(subname),' ERROR: Too many history files declared, max_tapes=',max_tapes + call shr_sys_abort() + end if + + if (mainproc) then + write(iulog,*) 'There will be a total of ',ntapes,'MOSART history tapes' + do t=1,ntapes + write(iulog,*) + if (nhtfrq(t) == 0) then + write(iulog,*)'MOSART History tape ',t,' write frequency is MONTHLY' + else + write(iulog,*)'MOSART History tape ',t,' write frequency = ',nhtfrq(t) + endif + write(iulog,*)'Number of time samples on MOSART history tape ',t,' is ',mfilt(t) + write(iulog,*)'Output precision on MOSART history tape ',t,'=',ndens(t) + write(iulog,*) + end do + end if + + ! Set flag indicating h-tape contents are now defined + + htapes_defined = .true. + + end subroutine htapes_fieldlist + + !----------------------------------------------------------------------- + + subroutine htape_addfld (t, f, avgflag) + + ! Add a field to the active list for a history tape. Copy the data from + ! the master field list to the active list for the tape. + + ! !ARGUMENTS: + integer, intent(in) :: t ! history tape index + integer, intent(in) :: f ! field index from master field list + character(len=1), intent(in) :: avgflag ! time averaging flag + + ! !LOCAL VARIABLES: + integer :: n ! field index on defined tape + integer :: begr ! per-proc beginning land runoff index + integer :: endr ! per-proc ending land runoff index + character(len=*),parameter :: subname = 'htape_addfld' + !------------------------------------------------------- + + ! Ensure that it is not to late to add a field to the history tape + if (htapes_defined) then + write(iulog,*) trim(subname),' ERROR: attempt to add field ', & + masterlist(f)%field%name, ' after history files are set' + call shr_sys_abort() + end if + + ! Determine bounds + begr = ctl%begr + endr = ctl%endr + + tape(t)%nflds = tape(t)%nflds + 1 + n = tape(t)%nflds + tape(t)%hlist(n)%field = masterlist(f)%field + allocate (tape(t)%hlist(n)%hbuf(begr:endr)) + allocate (tape(t)%hlist(n)%nacs(begr:endr)) + tape(t)%hlist(n)%hbuf(:) = 0._r8 + tape(t)%hlist(n)%nacs(:) = 0 + + ! Set time averaging flag based on masterlist setting or + ! override the default averaging flag with namelist setting + select case (avgflag) + case (' ') + tape(t)%hlist(n)%avgflag = masterlist(f)%avgflag(t) + case ('A','I','X','M') + tape(t)%hlist(n)%avgflag = avgflag + case default + write(iulog,*) trim(subname),' ERROR: unknown avgflag=', avgflag + call shr_sys_abort() + end select + + end subroutine htape_addfld + + !----------------------------------------------------------------------- + + subroutine mosart_hist_UpdateHbuf() + + ! Accumulate (or take min, max, etc. as appropriate) input field + ! into its history buffer for appropriate tapes. + + ! !LOCAL VARIABLES: + integer :: t ! tape index + integer :: f ! field index + integer :: k ! index + integer :: hpindex ! history pointer index + integer :: begr,endr ! beginning and ending indices + character(len=1) :: avgflag ! time averaging flag + real(r8), pointer :: hbuf(:) ! history buffer + integer , pointer :: nacs(:) ! accumulation counter + real(r8), pointer :: field(:) ! 1d pointer field + integer j + character(len=*),parameter :: subname = 'mosart_hist_UpdateHbuf' + !---------------------------------------------------------- + + begr = ctl%begr + endr = ctl%endr + + do t = 1,ntapes + do f = 1,tape(t)%nflds + avgflag = tape(t)%hlist(f)%avgflag + nacs => tape(t)%hlist(f)%nacs + hbuf => tape(t)%hlist(f)%hbuf + hpindex = tape(t)%hlist(f)%field%hpindex + field => ptr(hpindex)%ptr + + select case (avgflag) + case ('I') ! Instantaneous + do k = begr,endr + if (field(k) /= spval) then + hbuf(k) = field(k) + else + hbuf(k) = spval + end if + nacs(k) = 1 + end do + case ('A') ! Time average + do k = begr,endr + if (field(k) /= spval) then + if (nacs(k) == 0) hbuf(k) = 0._r8 + hbuf(k) = hbuf(k) + field(k) + nacs(k) = nacs(k) + 1 + else + if (nacs(k) == 0) hbuf(k) = spval + end if + end do + case ('X') ! Maximum over time + do k = begr,endr + if (field(k) /= spval) then + if (nacs(k) == 0) hbuf(k) = -1.e50_r8 + hbuf(k) = max( hbuf(k), field(k) ) + else + if (nacs(k) == 0) hbuf(k) = spval + end if + nacs(k) = 1 + end do + case ('M') ! Minimum over time + do k = begr,endr + if (field(k) /= spval) then + if (nacs(k) == 0) hbuf(k) = +1.e50_r8 + hbuf(k) = min( hbuf(k), field(k) ) + else + if (nacs(k) == 0) hbuf(k) = spval + end if + nacs(k) = 1 + end do + case default + write(iulog,*) trim(subname),' ERROR: invalid time averaging flag ', avgflag + call shr_sys_abort() + end select + end do + end do + + end subroutine mosart_hist_UpdateHbuf + + !----------------------------------------------------------------------- + + subroutine htape_create (t, histrest) + + ! Define contents of history file t. Issue the required netcdf + ! wrapper calls to define the history file contents. + + ! !ARGUMENTS: + integer, intent(in) :: t ! tape index + logical, intent(in), optional :: histrest ! if creating the history restart file + + ! !LOCAL VARIABLES: + integer :: f ! field index + integer :: p,c,l,n ! indices + integer :: ier ! error code + integer :: dimid ! dimension id temporary + integer :: dim1id(1) ! netCDF dimension id + integer :: dim2id(2) ! netCDF dimension id + integer :: ndims ! dimension counter + integer :: omode ! returned mode from netCDF call + integer :: ncprec ! output netCDF write precision + integer :: ret ! netCDF error status + integer :: dtime ! timestep size + integer :: sec_hist_nhtfrq ! nhtfrq converted to seconds + logical :: lhistrest ! local history restart flag + type(file_desc_t), pointer :: lnfid ! local file id + character(len= 8) :: curdate ! current date + character(len= 8) :: curtime ! current time + character(len=256) :: name ! name of attribute + character(len=256) :: units ! units of attribute + character(len=256) :: str ! global attribute string + character(len= 1) :: avgflag ! time averaging flag + character(len=*),parameter :: subname = 'htape_create' + !----------------------------------------------------- + + if ( present(histrest) )then + lhistrest = histrest + else + lhistrest = .false. + end if + + ! Define output write precsion for tape + ncprec = tape(t)%ncprec + if (lhistrest) then + lnfid => ncid_hist(t) + else + lnfid => nfid(t) + endif + + ! Create new netCDF file. It will be in define mode + if ( .not. lhistrest )then + if (mainproc) then + write(iulog,*) trim(subname),' : Opening netcdf htape ',trim(locfnh(t)) + end if + call ncd_pio_createfile(lnfid, trim(locfnh(t))) + call ncd_putatt(lnfid, ncd_global, 'title', 'MOSART History file information' ) + call ncd_putatt(lnfid, ncd_global, 'comment', & + "NOTE: None of the variables are weighted by land fraction!" ) + else + if (mainproc) then + write(iulog,*) trim(subname),' : Opening netcdf rhtape ',trim(locfnhr(t)) + end if + call ncd_pio_createfile(lnfid, trim(locfnhr(t))) + call ncd_putatt(lnfid, ncd_global, 'title', & + 'MOSART Restart History information, required to continue a simulation' ) + call ncd_putatt(lnfid, ncd_global, 'comment', & + "This entire file NOT needed for startup or branch simulations") + end if + + ! Create global attributes. Attributes are used to store information + ! about the data set. Global attributes are information about the + ! data set as a whole, as opposed to a single variable + + call ncd_putatt(lnfid, ncd_global, 'Conventions', trim(conventions)) + call getdatetime(curdate, curtime) + str = 'created on ' // curdate // ' ' // curtime + call ncd_putatt(lnfid, ncd_global, 'history' , trim(str)) + call ncd_putatt(lnfid, ncd_global, 'source' , trim(source)) + call ncd_putatt(lnfid, ncd_global, 'hostname' , trim(hostname)) + call ncd_putatt(lnfid, ncd_global, 'username' , trim(username)) + call ncd_putatt(lnfid, ncd_global, 'version' , trim(version)) + call ncd_putatt(lnfid, ncd_global, 'model_doi_url', trim(model_doi_url)) + + call ncd_putatt(lnfid, ncd_global, 'case_title', trim(ctitle)) + call ncd_putatt(lnfid, ncd_global, 'case_id', trim(caseid)) + + str = get_filename(frivinp) + call ncd_putatt(lnfid, ncd_global, 'input_dataset', trim(str)) + + ! + ! add global attribute time_period_freq + ! + if (nhtfrq(t) < 0) then !hour need to convert to seconds + sec_hist_nhtfrq = abs(nhtfrq(t))*3600 + else + sec_hist_nhtfrq = nhtfrq(t) + end if + + dtime = get_step_size() + if (sec_hist_nhtfrq == 0) then !month + time_period_freq = 'month_1' + else if (mod(sec_hist_nhtfrq*dtime,isecspday) == 0) then ! day + write(time_period_freq,999) 'day_',sec_hist_nhtfrq*dtime/isecspday + else if (mod(sec_hist_nhtfrq*dtime,3600) == 0) then ! hour + write(time_period_freq,999) 'hour_',(sec_hist_nhtfrq*dtime)/3600 + else if (mod(sec_hist_nhtfrq*dtime,60) == 0) then ! minute + write(time_period_freq,999) 'minute_',(sec_hist_nhtfrq*dtime)/60 + else ! second + write(time_period_freq,999) 'second_',sec_hist_nhtfrq*dtime + end if +999 format(a,i0) + + call ncd_putatt(lnfid, ncd_global, 'time_period_freq', trim(time_period_freq)) + + ! Define dimensions. + ! Time is an unlimited dimension. Character string is treated as an array of characters. + + ! Global uncompressed dimensions (including non-land points) + call ncd_defdim(lnfid, 'lon' , ctl%nlon , dimid) + call ncd_defdim(lnfid, 'lat' , ctl%nlat , dimid) + call ncd_defdim(lnfid, 'allrof', ctl%numr , dimid) + call ncd_defdim(lnfid, 'string_length', 8, strlen_dimid) + + if ( .not. lhistrest )then + call ncd_defdim(lnfid, 'hist_interval', 2, hist_interval_dimid) + call ncd_defdim(lnfid, 'time', ncd_unlimited, time_dimid) + if (mainproc)then + write(iulog,*) trim(subname),' : Successfully defined netcdf history file ',t + end if + else + if (mainproc)then + write(iulog,*) trim(subname),' : Successfully defined netcdf restart history file ',t + end if + end if + + end subroutine htape_create + + !----------------------------------------------------------------------- + + subroutine htape_timeconst(t, mode) + + ! Write time constant values to primary history tape. + + ! !ARGUMENTS: + integer, intent(in) :: t ! tape index + character(len=*), intent(in) :: mode ! 'define' or 'write' + + ! !LOCAL VARIABLES: + integer :: vid,n,i,j,m ! indices + integer :: nstep ! current step + integer :: mcsec ! seconds of current date + integer :: mdcur ! current day + integer :: mscur ! seconds of current day + integer :: mcdate ! current date + integer :: dtime ! timestep size + integer :: yr,mon,day,nbsec ! year,month,day,seconds components of a date + integer :: hours,minutes,secs ! hours,minutes,seconds of hh:mm:ss + character(len= 10) :: basedate ! base date (yyyymmdd) + character(len= 8) :: basesec ! base seconds + character(len= 8) :: cdate ! system date + character(len= 8) :: ctime ! system time + real(r8):: time ! current time + real(r8):: timedata(2) ! time interval boundaries + integer :: dim1id(1) ! netCDF dimension id + integer :: dim2id(2) ! netCDF dimension id + integer :: varid ! netCDF variable id + type(Var_desc_t) :: vardesc ! netCDF variable description + character(len=max_chars) :: long_name ! variable long name + character(len=max_namlen):: varname ! variable name + character(len=max_namlen):: units ! variable units + character(len=max_namlen):: cal ! calendar type from time-manager + character(len=max_namlen):: caldesc ! calendar description to put on file + character(len=256):: str ! global attribute string + integer :: status + character(len=*),parameter :: subname = 'htape_timeconst' + !-------------------------------------------------------- + + ! For define mode -- only do this for first time-sample + if (mode == 'define' .and. tape(t)%ntimes == 1) then + + call get_ref_date(yr, mon, day, nbsec) + nstep = get_nstep() + hours = nbsec / 3600 + minutes = (nbsec - hours*3600) / 60 + secs = (nbsec - hours*3600 - minutes*60) + write(basedate,80) yr,mon,day +80 format(i4.4,'-',i2.2,'-',i2.2) + write(basesec ,90) hours, minutes, secs +90 format(i2.2,':',i2.2,':',i2.2) + + dim1id(1) = time_dimid + str = 'days since ' // basedate // " " // basesec + call ncd_defvar(nfid(t), 'time', tape(t)%ncprec, 1, dim1id, varid, & + long_name='time',units=str) + cal = get_calendar() + if ( trim(cal) == NO_LEAP_C )then + caldesc = "noleap" + else if ( trim(cal) == GREGORIAN_C )then + caldesc = "gregorian" + end if + call ncd_putatt(nfid(t), varid, 'calendar', caldesc) + call ncd_putatt(nfid(t), varid, 'bounds', 'time_bounds') + + dim1id(1) = time_dimid + call ncd_defvar(nfid(t) , 'mcdate', ncd_int, 1, dim1id , varid, & + long_name = 'current date (YYYYMMDD)') + call ncd_defvar(nfid(t) , 'mcsec' , ncd_int, 1, dim1id , varid, & + long_name = 'current seconds of current date', units='s') + call ncd_defvar(nfid(t) , 'mdcur' , ncd_int, 1, dim1id , varid, & + long_name = 'current day (from base day)') + call ncd_defvar(nfid(t) , 'mscur' , ncd_int, 1, dim1id , varid, & + long_name = 'current seconds of current day') + call ncd_defvar(nfid(t) , 'nstep' , ncd_int, 1, dim1id , varid, & + long_name = 'time step') + + dim2id(1) = hist_interval_dimid; dim2id(2) = time_dimid + call ncd_defvar(nfid(t), 'time_bounds', ncd_double, 2, dim2id, varid, & + long_name = 'history time interval endpoints') + + dim2id(1) = strlen_dimid; dim2id(2) = time_dimid + call ncd_defvar(nfid(t), 'date_written', ncd_char, 2, dim2id, varid) + call ncd_defvar(nfid(t), 'time_written', ncd_char, 2, dim2id, varid) + + call ncd_defvar(varname='lon', xtype=tape(t)%ncprec, dim1name='lon', & + long_name='runoff coordinate longitude', units='degrees_east', ncid=nfid(t)) + call ncd_defvar(varname='lat', xtype=tape(t)%ncprec, dim1name='lat', & + long_name='runoff coordinate latitude', units='degrees_north', ncid=nfid(t)) + call ncd_defvar(varname='mask', xtype=ncd_int, dim1name='lon', dim2name='lat', & + long_name='runoff mask', units='unitless', ncid=nfid(t), ifill_value=ispval) + call ncd_defvar(varname='area', xtype=tape(t)%ncprec, dim1name='lon', dim2name='lat', & + long_name='runoff grid area', units='m2', ncid=nfid(t), fill_value=spval) + call ncd_defvar(varname='areatotal', xtype=tape(t)%ncprec, dim1name='lon', dim2name='lat', & + long_name='basin upstream areatotal', units='m2', ncid=nfid(t), fill_value=spval) + call ncd_defvar(varname='areatotal2', xtype=tape(t)%ncprec, dim1name='lon', dim2name='lat', & + long_name='computed basin upstream areatotal', units='m2', ncid=nfid(t), fill_value=spval) + + else if (mode == 'write') then + + call get_curr_time (mdcur, mscur) + call get_curr_date (yr, mon, day, mcsec) + mcdate = yr*10000 + mon*100 + day + nstep = get_nstep() + + call ncd_io('mcdate', mcdate, 'write', nfid(t), nt=tape(t)%ntimes) + call ncd_io('mcsec' , mcsec , 'write', nfid(t), nt=tape(t)%ntimes) + call ncd_io('mdcur' , mdcur , 'write', nfid(t), nt=tape(t)%ntimes) + call ncd_io('mscur' , mscur , 'write', nfid(t), nt=tape(t)%ntimes) + call ncd_io('nstep' , nstep , 'write', nfid(t), nt=tape(t)%ntimes) + + time = mdcur + mscur/secspday + call ncd_io('time' , time , 'write', nfid(t), nt=tape(t)%ntimes) + + timedata(1) = tape(t)%begtime + timedata(2) = time + call ncd_io('time_bounds', timedata, 'write', nfid(t), nt=tape(t)%ntimes) + + call getdatetime (cdate, ctime) + call ncd_io('date_written', cdate, 'write', nfid(t), nt=tape(t)%ntimes) + + call ncd_io('time_written', ctime, 'write', nfid(t), nt=tape(t)%ntimes) + + call ncd_io(varname='lon', data=ctl%rlon, ncid=nfid(t), flag='write') + call ncd_io(varname='lat', data=ctl%rlat, ncid=nfid(t), flag='write') + call ncd_io(flag='write', varname='mask', dim1name='allrof', & + data=ctl%mask, ncid=nfid(t)) + call ncd_io(flag='write', varname='area', dim1name='allrof', & + data=ctl%area, ncid=nfid(t)) + call ncd_io(flag='write', varname='areatotal', dim1name='allrof', & + data=Tunit%areatotal, ncid=nfid(t)) + call ncd_io(flag='write', varname='areatotal2', dim1name='allrof', & + data=Tunit%areatotal2, ncid=nfid(t)) + + endif + + end subroutine htape_timeconst + + !----------------------------------------------------------------------- + + subroutine mosart_hist_HtapesWrapup( rstwr, nlend ) + + ! Write history tape(s) + ! Determine if next time step is beginning of history interval and if so: + ! increment the current time sample counter, open a new history file + ! and if needed (i.e., when ntim = 1), write history data to current + ! history file, reset field accumulation counters to zero. + ! If primary history file is full or at the last time step of the simulation, + ! write restart dataset and close all history fiels. + ! If history file is full or at the last time step of the simulation: + ! close history file + ! and reset time sample counter to zero if file is full. + ! Daily-averaged data for the first day in September are written on + ! date = 00/09/02 with mscur = 0. + ! Daily-averaged data for the first day in month mm are written on + ! date = yyyy/mm/02 with mscur = 0. + ! Daily-averaged data for the 30th day (last day in September) are written + ! on date = 0000/10/01 mscur = 0. + ! Daily-averaged data for the last day in month mm are written on + ! date = yyyy/mm+1/01 with mscur = 0. + + ! !ARGUMENTS: + logical, intent(in) :: rstwr ! true => write restart file this step + logical, intent(in) :: nlend ! true => end of run on this step + + ! !LOCAL VARIABLES: + integer :: begr, endr ! beg and end rof indices + integer :: t,f,k,nt ! indices + integer :: nstep ! current step + integer :: day ! current day (1 -> 31) + integer :: mon ! current month (1 -> 12) + integer :: yr ! current year (0 -> ...) + integer :: mdcur ! current day + integer :: mscur ! seconds of current day + integer :: mcsec ! current time of day [seconds] + integer :: daym1 ! nstep-1 day (1 -> 31) + integer :: monm1 ! nstep-1 month (1 -> 12) + integer :: yrm1 ! nstep-1 year (0 -> ...) + integer :: mcsecm1 ! nstep-1 time of day [seconds] + real(r8):: time ! current time + character(len=256):: str ! global attribute string + character(len=1) :: avgflag ! averaging flag + real(r8), pointer :: histo(:) ! temporary + real(r8), pointer :: hbuf(:) ! history buffer + integer , pointer :: nacs(:) ! accumulation counter + character(len=32) :: avgstr ! time averaging type + character(len=max_chars) :: long_name ! long name + character(len=max_chars) :: units ! units + character(len=max_namlen):: varname ! variable name + character(len=*),parameter :: subname = 'hist_htapes_wrapup' + !----------------------------------------------------------- + + begr = ctl%begr + endr = ctl%endr + + ! get current step + nstep = get_nstep() + + ! Set calendar for current time step + call get_curr_date (yr, mon, day, mcsec) + call get_curr_time (mdcur, mscur) + time = mdcur + mscur/secspday + + ! Set calendar for current for previous time step + call get_prev_date (yrm1, monm1, daym1, mcsecm1) + + ! Loop over active history tapes, create new history files if necessary + ! and write data to history files if end of history interval. + do t = 1, ntapes + + ! Skip nstep=0 if monthly average + if (nstep==0 .and. tape(t)%nhtfrq==0) cycle + + ! Determine if end of history interval + tape(t)%is_endhist = .false. + if (tape(t)%nhtfrq==0) then !monthly average + if (mon /= monm1) then + tape(t)%is_endhist = .true. + end if + else + if (mod(nstep,tape(t)%nhtfrq) == 0) then + tape(t)%is_endhist = .true. + end if + end if + + ! If end of history interval + if (tape(t)%is_endhist) then + + ! Normalize by number of accumulations for time averaged case + do f = 1,tape(t)%nflds + avgflag = tape(t)%hlist(f)%avgflag + nacs => tape(t)%hlist(f)%nacs + hbuf => tape(t)%hlist(f)%hbuf + do k = begr, endr + if ((avgflag == 'A') .and. nacs(k) /= 0) then + hbuf(k) = hbuf(k) / float(nacs(k)) + end if + end do + end do + + ! Increment current time sample counter. + tape(t)%ntimes = tape(t)%ntimes + 1 + + ! Create history file if appropriate and build time comment + + ! If first time sample, generate unique history file name, open file, + ! define dims, vars, etc. + + if (tape(t)%ntimes == 1) then + locfnh(t) = set_hist_filename (hist_freq=tape(t)%nhtfrq, & + mfilt=tape(t)%mfilt, hist_file=t) + if (mainproc) then + write(iulog,*) trim(subname),' : Creating history file ', trim(locfnh(t)), & + ' at nstep = ',get_nstep() + write(iulog,*)'calling htape_create for file t = ',t + endif + call htape_create (t) + + ! Define time-constant field variables + call htape_timeconst(t, mode='define') + + ! Define model field variables + + do f = 1,tape(t)%nflds + varname = tape(t)%hlist(f)%field%name + long_name = tape(t)%hlist(f)%field%long_name + units = tape(t)%hlist(f)%field%units + avgflag = tape(t)%hlist(f)%avgflag + + select case (avgflag) + case ('A') + avgstr = 'mean' + case ('I') + avgstr = 'instantaneous' + case ('X') + avgstr = 'maximum' + case ('M') + avgstr = 'minimum' + case default + write(iulog,*) trim(subname),& + ' ERROR: unknown time averaging flag (avgflag)=',avgflag + call shr_sys_abort() + end select + call ncd_defvar(ncid=nfid(t), varname=varname, xtype=tape(t)%ncprec, & + dim1name='lon', dim2name='lat', dim3name='time', & + long_name=long_name, units=units, cell_method=avgstr, & + missing_value=spval, fill_value=spval) + end do + + ! Exit define model + call ncd_enddef(nfid(t)) + + endif + + ! Write time constant history variables + call htape_timeconst(t, mode='write') + + if (mainproc) then + write(iulog,*) + write(iulog,*) trim(subname),' : Writing current time sample to local history file ', & + trim(locfnh(t)),' at nstep = ',get_nstep(), & + ' for history time interval beginning at ', tape(t)%begtime, & + ' and ending at ',time + write(iulog,*) + endif + + ! Update beginning time of next interval + tape(t)%begtime = time + + ! Write history time slice + do f = 1,tape(t)%nflds + varname = tape(t)%hlist(f)%field%name + nt = tape(t)%ntimes + histo => tape(t)%hlist(f)%hbuf + call ncd_io(flag='write', varname=varname, dim1name='allrof', & + data=histo, ncid=nfid(t), nt=nt) + end do + + ! Zero necessary history buffers + do f = 1,tape(t)%nflds + tape(t)%hlist(f)%hbuf(:) = 0._r8 + tape(t)%hlist(f)%nacs(:) = 0 + end do + + end if + + end do ! end loop over history tapes + + ! Close open history files + ! Auxilary files may have been closed and saved off without being full, + ! must reopen the files + + do t = 1, ntapes + if (nlend) then + if_close(t) = .true. + else if (rstwr) then + if_close(t) = .true. + else + if (tape(t)%ntimes == tape(t)%mfilt) then + if_close(t) = .true. + else + if_close(t) = .false. + end if + endif + if (if_close(t)) then + if (tape(t)%ntimes /= 0) then + if (mainproc) then + write(iulog,*) + write(iulog,*) trim(subname),' : Closing local history file ',& + trim(locfnh(t)),' at nstep = ', get_nstep() + write(iulog,*) + endif + call ncd_pio_closefile(nfid(t)) + if ((.not.nlend) .and. (tape(t)%ntimes/=tape(t)%mfilt)) then + call ncd_pio_openfile (nfid(t), trim(locfnh(t)), ncd_write) + end if + else + if (mainproc) then + write(iulog,*) trim(subname),' : history tape ',t,': no open file to close' + end if + endif + if (tape(t)%ntimes==tape(t)%mfilt) then + tape(t)%ntimes = 0 + end if + endif + end do + + end subroutine mosart_hist_HtapesWrapup + + !----------------------------------------------------------------------- + + subroutine mosart_hist_Restart (ncid, flag, rdate) + + ! Read/write history file restart data. + ! If the current history file(s) are not full, file(s) are opened + ! so that subsequent time samples are added until the file is full. + ! A new history file is used on a branch run. + + ! !ARGUMENTS: + type(file_desc_t), intent(inout) :: ncid ! netcdf file + character(len=*) , intent(in) :: flag !'read' or 'write' + character(len=*) , intent(in), optional :: rdate ! restart file time stamp for name + + ! !LOCAL VARIABLES: + integer :: max_nflds ! max number of fields + integer :: begr ! per-proc beginning ocean runoff index + integer :: endr ! per-proc ending ocean runoff index + character(len=max_namlen) :: name ! variable name + character(len=max_namlen) :: name_acc ! accumulator variable name + character(len=max_namlen) :: long_name ! long name of variable + character(len=max_chars) :: long_name_acc ! long name for accumulator + character(len=max_chars) :: units ! units of variable + character(len=max_chars) :: units_acc ! accumulator units + character(len=max_chars) :: fname ! full name of history file + character(len=max_chars) :: locrest(max_tapes) ! local history restart file names + character(len=1) :: hnum ! history file index + type(var_desc_t) :: name_desc ! variable descriptor for name + type(var_desc_t) :: longname_desc ! variable descriptor for long_name + type(var_desc_t) :: units_desc ! variable descriptor for units + type(var_desc_t) :: avgflag_desc ! variable descriptor for avgflag + integer :: status ! error status + integer :: dimid ! dimension ID + integer :: start(2) ! Start array index + integer :: k ! 1d index + integer :: t ! tape index + integer :: f ! field index + integer :: varid ! variable id + integer, allocatable :: itemp2d(:,:) ! 2D temporary + real(r8), pointer :: hbuf(:) ! history buffer + integer , pointer :: nacs(:) ! accumulation counter + character(len=*),parameter :: subname = 'hist_restart_ncd' + !--------------------------------------------------------- + + ! If branch run, initialize file times and return + + if (flag == 'read') then + if (nsrest == nsrBranch) then + do t = 1,ntapes + tape(t)%ntimes = 0 + end do + RETURN + end if + ! If startup run just return + if (nsrest == nsrStartup) then + RETURN + end if + endif + + ! Read history file data only for restart run (not for branch run) + + ! First when writing out and in define mode, create files and define all variables + !================================================ + if (flag == 'define') then + !================================================ + + if (.not. present(rdate)) then + call shr_sys_abort('variable rdate must be present for writing restart files') + end if + + ! + ! On master restart file add ntapes/max_chars dimension + ! and then add the history and history restart filenames + ! + call ncd_defdim( ncid, 'ntapes' , ntapes , dimid) + call ncd_defdim( ncid, 'max_chars' , max_chars , dimid) + + call ncd_defvar(ncid=ncid, varname='locfnh', xtype=ncd_char, & + long_name="History filename", & + comment="This variable NOT needed for startup or branch simulations", & + dim1name='max_chars', dim2name="ntapes" ) + call ncd_defvar(ncid=ncid, varname='locfnhr', xtype=ncd_char, & + long_name="Restart history filename", & + comment="This variable NOT needed for startup or branch simulations", & + dim1name='max_chars', dim2name="ntapes" ) + + ! max_nflds is the maximum number of fields on any tape + ! max_flds is the maximum number possible number of fields + max_nflds = max_nFields() + + ! Loop over tapes - write out namelist information to each restart-history tape + ! only read/write accumulators and counters if needed + + do t = 1,ntapes + ! + ! Create the restart history filename and open it + ! + write(hnum,'(i1.1)') t-1 + locfnhr(t) = "./" // trim(caseid) //".mosart"// trim(inst_suffix) & + // ".rh" // hnum //"."// trim(rdate) //".nc" + call htape_create( t, histrest=.true. ) + ! + ! Add read/write accumultators and counters if needed + ! + if (.not. tape(t)%is_endhist) then + do f = 1,tape(t)%nflds + name = tape(t)%hlist(f)%field%name + long_name = tape(t)%hlist(f)%field%long_name + units = tape(t)%hlist(f)%field%units + name_acc = trim(name) // "_acc" + units_acc = "unitless positive integer" + long_name_acc = trim(long_name) // " accumulator number of samples" + nacs => tape(t)%hlist(f)%nacs + hbuf => tape(t)%hlist(f)%hbuf + + call ncd_defvar(ncid=ncid_hist(t), varname=trim(name), xtype=ncd_double, & + dim1name='lon', dim2name='lat', & + long_name=trim(long_name), units=trim(units)) + call ncd_defvar(ncid=ncid_hist(t), varname=trim(name_acc), xtype=ncd_int, & + dim1name='lon', dim2name='lat', & + long_name=trim(long_name_acc), units=trim(units_acc)) + end do + endif + + ! + ! Add namelist information to each restart history tape + ! + call ncd_defdim( ncid_hist(t), 'fname_lenp2' , max_namlen+2, dimid) + call ncd_defdim( ncid_hist(t), 'fname_len' , max_namlen , dimid) + call ncd_defdim( ncid_hist(t), 'len1' , 1 , dimid) + call ncd_defdim( ncid_hist(t), 'scalar' , 1 , dimid) + call ncd_defdim( ncid_hist(t), 'max_chars' , max_chars , dimid) + call ncd_defdim( ncid_hist(t), 'max_nflds' , max_nflds , dimid) + call ncd_defdim( ncid_hist(t), 'max_flds' , max_flds , dimid) + + call ncd_defvar(ncid=ncid_hist(t), varname='nhtfrq', xtype=ncd_int, & + long_name="Frequency of history writes", & + comment="Namelist item", & + units="absolute value of negative is in hours, 0=monthly, positive is time-steps", & + dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='mfilt', xtype=ncd_int, & + long_name="Number of history time samples on a file", units="unitless", & + comment="Namelist item", & + dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='ncprec', xtype=ncd_int, & + long_name="Flag for data precision", flag_values=(/1,2/), & + comment="Namelist item", & + nvalid_range=(/1,2/), & + flag_meanings=(/"single-precision", "double-precision"/), & + dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='fincl', xtype=ncd_char, & + comment="Namelist item", & + long_name="Fieldnames to include", & + dim1name='fname_lenp2', dim2name='max_flds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='fexcl', xtype=ncd_char, & + comment="Namelist item", & + long_name="Fieldnames to exclude", & + dim1name='fname_lenp2', dim2name='max_flds' ) + + call ncd_defvar(ncid=ncid_hist(t), varname='nflds', xtype=ncd_int, & + long_name="Number of fields on file", units="unitless", & + dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='ntimes', xtype=ncd_int, & + long_name="Number of time steps on file", units="time-step", & + dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='is_endhist', xtype=ncd_log, & + long_name="End of history file", dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='begtime', xtype=ncd_double, & + long_name="Beginning time", units="time units", & + dim1name='scalar') + + call ncd_defvar(ncid=ncid_hist(t), varname='hpindex', xtype=ncd_int, & + long_name="History pointer index", units="unitless", & + dim1name='max_nflds' ) + + call ncd_defvar(ncid=ncid_hist(t), varname='avgflag', xtype=ncd_char, & + long_name="Averaging flag", & + units="A=Average, X=Maximum, M=Minimum, I=Instantaneous", & + dim1name='len1', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='name', xtype=ncd_char, & + long_name="Fieldnames", & + dim1name='fname_len', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='long_name', xtype=ncd_char, & + long_name="Long descriptive names for fields", & + dim1name='max_chars', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='units', xtype=ncd_char, & + long_name="Units for each history field output", & + dim1name='max_chars', dim2name='max_nflds' ) + call ncd_enddef(ncid_hist(t)) + + end do ! end of ntapes loop + + RETURN + + !================================================ + else if (flag == 'write') then + !================================================ + ! Add history filenames to master restart file + do t = 1,ntapes + call ncd_io('locfnh', locfnh(t), 'write', ncid, nt=t) + call ncd_io('locfnhr', locfnhr(t), 'write', ncid, nt=t) + end do + + fincl(:,1) = fincl1(:) + fincl(:,2) = fincl2(:) + fincl(:,3) = fincl3(:) + + fexcl(:,1) = fexcl1(:) + fexcl(:,2) = fexcl2(:) + fexcl(:,3) = fexcl3(:) + + max_nflds = max_nFields() + + start(1)=1 + + + ! Add history namelist data to each history restart tape + allocate(itemp2d(max_nflds,ntapes)) + do t = 1,ntapes + call ncd_inqvid(ncid_hist(t), 'name', varid, name_desc) + call ncd_inqvid(ncid_hist(t), 'long_name', varid, longname_desc) + call ncd_inqvid(ncid_hist(t), 'units', varid, units_desc) + call ncd_inqvid(ncid_hist(t), 'avgflag', varid, avgflag_desc) + + call ncd_io(varname='fincl' , data=fincl(:,t) , ncid=ncid_hist(t), flag='write') + call ncd_io(varname='fexcl' , data=fexcl(:,t) , ncid=ncid_hist(t), flag='write') + call ncd_io(varname='is_endhist', data=tape(t)%is_endhist, ncid=ncid_hist(t), flag='write') + + itemp2d(:,:) = 0 + do f=1,tape(t)%nflds + itemp2d(f,t) = tape(t)%hlist(f)%field%hpindex + end do + call ncd_io(varname='hpindex', data=itemp2d(:,t), ncid=ncid_hist(t), flag='write') + + call ncd_io('nflds' , tape(t)%nflds, 'write', ncid_hist(t)) + call ncd_io('ntimes', tape(t)%ntimes, 'write', ncid_hist(t)) + call ncd_io('nhtfrq', tape(t)%nhtfrq, 'write', ncid_hist(t)) + call ncd_io('mfilt' , tape(t)%mfilt, 'write', ncid_hist(t)) + call ncd_io('ncprec', tape(t)%ncprec, 'write', ncid_hist(t)) + call ncd_io('begtime', tape(t)%begtime, 'write', ncid_hist(t)) + do f=1,tape(t)%nflds + start(2) = f + call ncd_io( name_desc, tape(t)%hlist(f)%field%name, & + 'write', ncid_hist(t), start ) + call ncd_io( longname_desc, tape(t)%hlist(f)%field%long_name, & + 'write', ncid_hist(t), start ) + call ncd_io( units_desc, tape(t)%hlist(f)%field%units, & + 'write', ncid_hist(t), start ) + call ncd_io( avgflag_desc, tape(t)%hlist(f)%avgflag, & + 'write', ncid_hist(t), start ) + end do + end do + deallocate(itemp2d) + + !================================================ + else if (flag == 'read') then + !================================================ + + call ncd_inqdlen(ncid,dimid,ntapes, name='ntapes') + call ncd_io('locfnh', locfnh(1:ntapes), 'read', ncid ) + call ncd_io('locfnhr', locrest(1:ntapes), 'read', ncid ) + do t = 1,ntapes + call strip_null(locrest(t)) + call strip_null(locfnh(t)) + end do + + ! Determine necessary indices - the following is needed if model decomposition + ! is different on restart + begr = ctl%begr + endr = ctl%endr + + start(1)=1 + do t = 1,ntapes + call getfil( locrest(t), locfnhr(t), 0 ) + call ncd_pio_openfile (ncid_hist(t), trim(locfnhr(t)), ncd_nowrite) + + if ( t == 1 )then + call ncd_inqdlen(ncid_hist(1),dimid,max_nflds,name='max_nflds') + allocate(itemp2d(max_nflds,ntapes)) + end if + + call ncd_inqvid(ncid_hist(t), 'name', varid, name_desc) + call ncd_inqvid(ncid_hist(t), 'long_name', varid, longname_desc) + call ncd_inqvid(ncid_hist(t), 'units', varid, units_desc) + call ncd_inqvid(ncid_hist(t), 'avgflag', varid, avgflag_desc) + + call ncd_io(varname='fincl', data=fincl(:,t), ncid=ncid_hist(t), flag='read') + call ncd_io(varname='fexcl', data=fexcl(:,t), ncid=ncid_hist(t), flag='read') + + call ncd_io('nflds', tape(t)%nflds, 'read', ncid_hist(t) ) + call ncd_io('ntimes', tape(t)%ntimes, 'read', ncid_hist(t) ) + call ncd_io('nhtfrq', tape(t)%nhtfrq, 'read', ncid_hist(t) ) + call ncd_io('mfilt', tape(t)%mfilt, 'read', ncid_hist(t) ) + call ncd_io('ncprec', tape(t)%ncprec, 'read', ncid_hist(t) ) + call ncd_io('begtime', tape(t)%begtime,'read', ncid_hist(t) ) + + call ncd_io(varname='is_endhist', data=tape(t)%is_endhist, ncid=ncid_hist(t), flag='read') + call ncd_io(varname='hpindex' , data=itemp2d(:,t) , ncid=ncid_hist(t), flag='read') + do f=1,tape(t)%nflds + tape(t)%hlist(f)%field%hpindex = itemp2d(f,t) + end do + + do f=1,tape(t)%nflds + start(2) = f + call ncd_io( name_desc, tape(t)%hlist(f)%field%name, & + 'read', ncid_hist(t), start ) + call ncd_io( longname_desc, tape(t)%hlist(f)%field%long_name, & + 'read', ncid_hist(t), start ) + call ncd_io( units_desc, tape(t)%hlist(f)%field%units, & + 'read', ncid_hist(t), start ) + call ncd_io( avgflag_desc, tape(t)%hlist(f)%avgflag, & + 'read', ncid_hist(t), start ) + call strip_null(tape(t)%hlist(f)%field%name) + call strip_null(tape(t)%hlist(f)%field%long_name) + call strip_null(tape(t)%hlist(f)%field%units) + call strip_null(tape(t)%hlist(f)%avgflag) + + allocate (tape(t)%hlist(f)%hbuf(begr:endr), & + tape(t)%hlist(f)%nacs(begr:endr), stat=status) + if (status /= 0) then + write(iulog,*) trim(subname),' ERROR: allocation error for hbuf,nacs at t,f=',t,f + call shr_sys_abort() + endif + tape(t)%hlist(f)%hbuf(:) = 0._r8 + tape(t)%hlist(f)%nacs(:) = 0 + end do ! end of flds loop + + ! If history file is not full, open it + + if (tape(t)%ntimes /= 0) then + call ncd_pio_openfile (nfid(t), trim(locfnh(t)), ncd_write) + end if + + end do ! end of tapes loop + + fincl1(:) = fincl(:,1) + fincl2(:) = fincl(:,2) + fincl3(:) = fincl(:,3) + + fexcl1(:) = fexcl(:,1) + fexcl2(:) = fexcl(:,2) + fexcl3(:) = fexcl(:,3) + + if ( allocated(itemp2d) ) deallocate(itemp2d) + + end if + + ! Read/write history file restart data. + ! If the current history file(s) are not full, file(s) are opened + ! so that subsequent time samples are added until the file is full. + ! A new history file is used on a branch run. + + if (flag == 'write') then + + do t = 1,ntapes + if (.not. tape(t)%is_endhist) then + do f = 1,tape(t)%nflds + name = tape(t)%hlist(f)%field%name + name_acc = trim(name) // "_acc" + nacs => tape(t)%hlist(f)%nacs + hbuf => tape(t)%hlist(f)%hbuf + + call ncd_io(ncid=ncid_hist(t), flag='write', varname=trim(name), & + dim1name='allrof', data=hbuf) + call ncd_io(ncid=ncid_hist(t), flag='write', varname=trim(name_acc), & + dim1name='allrof', data=nacs) + end do + end if ! end of is_endhist block + call ncd_pio_closefile(ncid_hist(t)) + end do ! end of ntapes loop + + else if (flag == 'read') then + + ! Read history restart information if history files are not full + do t = 1,ntapes + if (.not. tape(t)%is_endhist) then + do f = 1,tape(t)%nflds + name = tape(t)%hlist(f)%field%name + name_acc = trim(name) // "_acc" + nacs => tape(t)%hlist(f)%nacs + hbuf => tape(t)%hlist(f)%hbuf + + call ncd_io(ncid=ncid_hist(t), flag='read', varname=trim(name), & + dim1name='allrof', data=hbuf) + call ncd_io(ncid=ncid_hist(t), flag='read', varname=trim(name_acc), & + dim1name='allrof', data=nacs) + end do + end if + call ncd_pio_closefile(ncid_hist(t)) + end do + + end if + + end subroutine mosart_hist_Restart + + !----------------------------------------------------------------------- + + integer function max_nFields() + + ! Get the maximum number of fields on all tapes. + + ! LOCAL VARIABLES: + integer :: t ! index + character(len=*),parameter :: subname = 'max_nFields' + + max_nFields = 0 + do t = 1,ntapes + max_nFields = max(max_nFields, tape(t)%nflds) + end do + + end function max_nFields - end function max_nFields + !----------------------------------------------------------------------- -!----------------------------------------------------------------------- + character(len=max_namlen) function getname (inname) - character(len=max_namlen) function getname (inname) + ! Retrieve name portion of inname. If an averaging flag separater character + ! is present (:) in inname, lop it off. - ! DESCRIPTION: - ! Retrieve name portion of inname. If an averaging flag separater character - ! is present (:) in inname, lop it off. + ! ARGUMENTS: + character(len=*), intent(in) :: inname - ! ARGUMENTS: - implicit none - character(len=*), intent(in) :: inname + integer :: length + integer :: i + character(len=*),parameter :: subname = 'getname' - integer :: length - integer :: i - character(len=*),parameter :: subname = 'getname' + length = len (inname) + if (length < max_namlen .or. length > max_namlen+2) then + write(iulog,*) trim(subname),' ERROR: bad length=',length + call shr_sys_abort() + end if - length = len (inname) - if (length < max_namlen .or. length > max_namlen+2) then - write(iulog,*) trim(subname),' ERROR: bad length=',length - call shr_sys_abort() - end if - - getname = ' ' - do i = 1,max_namlen - if (inname(i:i) == ':') exit - getname(i:i) = inname(i:i) - end do + getname = ' ' + do i = 1,max_namlen + if (inname(i:i) == ':') exit + getname(i:i) = inname(i:i) + end do end function getname -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- character(len=1) function getflag (inname) - ! DESCRIPTION: - ! Retrieve flag portion of inname. If an averaging flag separater character - ! is present (:) in inname, return the character after it as the flag - - ! ARGUMENTS: - implicit none - character(len=*) inname ! character string - - ! LOCAL VARIABLES: - integer :: length ! length of inname - integer :: i ! loop index - character(len=*),parameter :: subname = 'getflag' - - length = len (inname) - if (length < max_namlen .or. length > max_namlen+2) then - write(iulog,*) trim(subname),' ERROR: bad length=',length - call shr_sys_abort() - end if - - getflag = ' ' - do i = 1,length - if (inname(i:i) == ':') then - getflag = inname(i+1:i+1) - exit - end if - end do + ! Retrieve flag portion of inname. If an averaging flag separater character + ! is present (:) in inname, return the character after it as the flag + + ! ARGUMENTS: + character(len=*) inname ! character string + + ! LOCAL VARIABLES: + integer :: length ! length of inname + integer :: i ! loop index + character(len=*),parameter :: subname = 'getflag' + + length = len (inname) + if (length < max_namlen .or. length > max_namlen+2) then + write(iulog,*) trim(subname),' ERROR: bad length=',length + call shr_sys_abort() + end if + + getflag = ' ' + do i = 1,length + if (inname(i:i) == ':') then + getflag = inname(i+1:i+1) + exit + end if + end do end function getflag -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- subroutine list_index (list, name, index) - ! ARGUMENTS: - implicit none - character(len=*), intent(in) :: list(max_flds) ! input list of names, possibly ":" delimited - character(len=max_namlen), intent(in) :: name ! name to be searched for - integer, intent(out) :: index ! index of "name" in "list" - - ! !LOCAL VARIABLES: - character(len=max_namlen) :: listname ! input name with ":" stripped off. - integer f ! field index - character(len=*),parameter :: subname = 'list_index' - - ! Only list items - index = 0 - do f=1,max_flds - listname = getname (list(f)) - if (listname == ' ') exit - if (listname == name) then - index = f - exit - end if - end do + ! ARGUMENTS: + character(len=*), intent(in) :: list(max_flds) ! input list of names, possibly ":" delimited + character(len=max_namlen), intent(in) :: name ! name to be searched for + integer, intent(out) :: index ! index of "name" in "list" + + ! !LOCAL VARIABLES: + character(len=max_namlen) :: listname ! input name with ":" stripped off. + integer f ! field index + character(len=*),parameter :: subname = 'list_index' + + ! Only list items + index = 0 + do f=1,max_flds + listname = getname (list(f)) + if (listname == ' ') exit + if (listname == name) then + index = f + exit + end if + end do end subroutine list_index -!----------------------------------------------------------------------- - - character(len=max_length_filename) function set_hist_filename (hist_freq, rtmhist_mfilt, hist_file) - - ! Determine history dataset filenames. - - ! !ARGUMENTS: - implicit none - integer, intent(in) :: hist_freq !history file frequency - integer, intent(in) :: rtmhist_mfilt !history file number of time-samples - integer, intent(in) :: hist_file !history file index - - ! !LOCAL VARIABLES: - character(len=256) :: cdate !date char string - character(len= 1) :: hist_index !p,1 or 2 (currently) - integer :: day !day (1 -> 31) - integer :: mon !month (1 -> 12) - integer :: yr !year (0 -> ...) - integer :: sec !seconds into current day - integer :: filename_length - character(len=*),parameter :: subname = 'set_hist_filename' - - if (hist_freq == 0 .and. rtmhist_mfilt == 1) then !monthly - call get_prev_date (yr, mon, day, sec) - write(cdate,'(i4.4,"-",i2.2)') yr,mon - else !other - call get_curr_date (yr, mon, day, sec) - write(cdate,'(i4.4,"-",i2.2,"-",i2.2,"-",i5.5)') yr,mon,day,sec - endif - write(hist_index,'(i1.1)') hist_file - 1 - set_hist_filename = "./"//trim(caseid)//".mosart"//trim(inst_suffix)//& - ".h"//hist_index//"."//trim(cdate)//".nc" - - ! check to see if the concatenated filename exceeded the - ! length. Simplest way to do this is ensure that the file - ! extension is '.nc'. - filename_length = len_trim(set_hist_filename) - if (set_hist_filename(filename_length-2:filename_length) /= '.nc') then - write(iulog, '(a,a,a,a,a)') 'ERROR: ', subname, & - ' : expected file extension ".nc", received extension "', & - set_hist_filename(filename_length-2:filename_length), '"' - write(iulog, '(a,a,a,a,a)') 'ERROR: ', subname, & - ' : filename : "', set_hist_filename, '"' - write(iulog, '(a,a,a,i3,a,i3)') 'ERROR: ', subname, & - ' Did the constructed filename exceed the maximum length? : filename length = ', & - filename_length, ', max length = ', max_length_filename - call shr_sys_abort(errMsg(__FILE__, __LINE__)) - end if - end function set_hist_filename - -!------------------------------------------------------------------------ - - subroutine RtmHistAddfld (fname, units, avgflag, long_name, ptr_rof, default) - - ! Initialize a single level history field. - - ! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: fname ! field name - character(len=*), intent(in) :: units ! units of field - character(len=1), intent(in) :: avgflag ! time averaging flag - character(len=*), intent(in) :: long_name ! long name of field - real(r8) , pointer :: ptr_rof(:) ! pointer to channel runoff - character(len=*), optional, intent(in) :: default ! if set to 'inactive, - ! field will not appear on primary tape - - ! !LOCAL VARIABLES: - integer :: n ! loop index - integer :: f ! masterlist index - integer :: hpindex ! history buffer pointer index - logical :: found ! flag indicates field found in masterlist - integer, save :: lastindex = 1 - character(len=*),parameter :: subname = 'RtmHistAddfld' - !------------------------------------------------------ - - ! History buffer pointer - - hpindex = lastindex - rtmptr(hpindex)%ptr => ptr_rof - lastindex = lastindex + 1 - if (lastindex > max_mapflds) then - write(iulog,*) trim(subname),' ERROR: ',& - ' lastindex = ',lastindex,' greater than max_mapflds= ',max_mapflds - call shr_sys_abort() - endif - - ! Add field to masterlist - - if (fname == ' ') then - write(iulog,*) trim(subname),' ERROR: blank field name not allowed' - call shr_sys_abort() - end if - do n = 1,nfmaster - if (masterlist(n)%field%name == fname) then - write(iulog,*) trim(subname),' ERROR:', fname, ' already on list' - call shr_sys_abort() - end if - end do - nfmaster = nfmaster + 1 - f = nfmaster - if (nfmaster > max_flds) then - write(iulog,*) trim(subname),' ERROR: too many fields for primary history file ', & - '-- max_flds,nfmaster=', max_flds, nfmaster - call shr_sys_abort() - end if - masterlist(f)%field%name = fname - masterlist(f)%field%long_name = long_name - masterlist(f)%field%units = units - masterlist(f)%field%hpindex = hpindex - - ! The next two fields are only in master field list, NOT in runtime active field list - ! ALL FIELDS IN THE MASTER LIST ARE INITIALIZED WITH THE ACTIVE FLAG SET TO FALSE - masterlist(f)%avgflag(:) = avgflag - masterlist(f)%actflag(:) = .false. - - if (present(default)) then - if (trim(default) == 'inactive') return - endif - - ! Look through master list for input field name. - ! When found, set active flag for that tape to true. - found = .false. - do f = 1,nfmaster - if (trim(fname) == trim(masterlist(f)%field%name)) then - masterlist(f)%actflag(1) = .true. - found = .true. - exit - end if - end do - if (.not. found) then - write(iulog,*) trim(subname),' ERROR: field=', fname, ' not found' - call shr_sys_abort() - end if - - end subroutine RtmHistAddfld - -!----------------------------------------------------------------------- - - subroutine strip_null(str) - character(len=*), intent(inout) :: str - integer :: i - do i=1,len(str) - if(ichar(str(i:i))==0) str(i:i)=' ' - end do - end subroutine strip_null - -end module RtmHistFile + !----------------------------------------------------------------------- + + character(len=max_length_filename) function set_hist_filename (hist_freq, mfilt, hist_file) + + ! Determine history dataset filenames. + + ! !ARGUMENTS: + integer, intent(in) :: hist_freq !history file frequency + integer, intent(in) :: mfilt !history file number of time-samples + integer, intent(in) :: hist_file !history file index + + ! !LOCAL VARIABLES: + character(len=256) :: cdate !date char string + character(len= 1) :: hist_index !p,1 or 2 (currently) + integer :: day !day (1 -> 31) + integer :: mon !month (1 -> 12) + integer :: yr !year (0 -> ...) + integer :: sec !seconds into current day + integer :: filename_length + character(len=*),parameter :: subname = 'set_hist_filename' + + if (hist_freq == 0 .and. mfilt == 1) then !monthly + call get_prev_date (yr, mon, day, sec) + write(cdate,'(i4.4,"-",i2.2)') yr,mon + else !other + call get_curr_date (yr, mon, day, sec) + write(cdate,'(i4.4,"-",i2.2,"-",i2.2,"-",i5.5)') yr,mon,day,sec + endif + write(hist_index,'(i1.1)') hist_file - 1 + set_hist_filename = "./"//trim(caseid)//".mosart"//trim(inst_suffix)//& + ".h"//hist_index//"."//trim(cdate)//".nc" + + ! check to see if the concatenated filename exceeded the + ! length. Simplest way to do this is ensure that the file + ! extension is '.nc'. + filename_length = len_trim(set_hist_filename) + if (set_hist_filename(filename_length-2:filename_length) /= '.nc') then + write(iulog, '(a,a,a,a,a)') 'ERROR: ', subname, & + ' : expected file extension ".nc", received extension "', & + set_hist_filename(filename_length-2:filename_length), '"' + write(iulog, '(a,a,a,a,a)') 'ERROR: ', subname, & + ' : filename : "', set_hist_filename, '"' + write(iulog, '(a,a,a,i3,a,i3)') 'ERROR: ', subname, & + ' Did the constructed filename exceed the maximum length? : filename length = ', & + filename_length, ', max length = ', max_length_filename + call shr_sys_abort(errMsg(__FILE__, __LINE__)) + end if + end function set_hist_filename + + !------------------------------------------------------------------------ + + subroutine mosart_hist_Addfld (fname, units, avgflag, long_name, ptr_rof, default) + + ! Initialize a single level history field. + + ! !ARGUMENTS: + character(len=*), intent(in) :: fname ! field name + character(len=*), intent(in) :: units ! units of field + character(len=1), intent(in) :: avgflag ! time averaging flag + character(len=*), intent(in) :: long_name ! long name of field + real(r8) , pointer :: ptr_rof(:) ! pointer to channel runoff + character(len=*), optional, intent(in) :: default ! if set to 'inactive, + ! field will not appear on primary tape + + ! !LOCAL VARIABLES: + integer :: n ! loop index + integer :: f ! masterlist index + integer :: hpindex ! history buffer pointer index + logical :: found ! flag indicates field found in masterlist + integer, save :: lastindex = 1 + character(len=*),parameter :: subname = 'mosart_hist_Addfld' + !------------------------------------------------------ + + ! History buffer pointer + + hpindex = lastindex + ptr(hpindex)%ptr => ptr_rof + lastindex = lastindex + 1 + if (lastindex > max_mapflds) then + write(iulog,*) trim(subname),' ERROR: ',& + ' lastindex = ',lastindex,' greater than max_mapflds= ',max_mapflds + call shr_sys_abort() + endif + + ! Add field to masterlist + + if (fname == ' ') then + write(iulog,*) trim(subname),' ERROR: blank field name not allowed' + call shr_sys_abort() + end if + do n = 1,nfmaster + if (masterlist(n)%field%name == fname) then + write(iulog,*) trim(subname),' ERROR:', fname, ' already on list' + call shr_sys_abort() + end if + end do + nfmaster = nfmaster + 1 + f = nfmaster + if (nfmaster > max_flds) then + write(iulog,*) trim(subname),' ERROR: too many fields for primary history file ', & + '-- max_flds,nfmaster=', max_flds, nfmaster + call shr_sys_abort() + end if + masterlist(f)%field%name = fname + masterlist(f)%field%long_name = long_name + masterlist(f)%field%units = units + masterlist(f)%field%hpindex = hpindex + + ! The next two fields are only in master field list, NOT in runtime active field list + ! ALL FIELDS IN THE MASTER LIST ARE INITIALIZED WITH THE ACTIVE FLAG SET TO FALSE + masterlist(f)%avgflag(:) = avgflag + masterlist(f)%actflag(:) = .false. + + if (present(default)) then + if (trim(default) == 'inactive') return + endif + + ! Look through master list for input field name. + ! When found, set active flag for that tape to true. + found = .false. + do f = 1,nfmaster + if (trim(fname) == trim(masterlist(f)%field%name)) then + masterlist(f)%actflag(1) = .true. + found = .true. + exit + end if + end do + if (.not. found) then + write(iulog,*) trim(subname),' ERROR: field=', fname, ' not found' + call shr_sys_abort() + end if + + end subroutine mosart_hist_Addfld + + !----------------------------------------------------------------------- + + subroutine strip_null(str) + character(len=*), intent(inout) :: str + integer :: i + do i=1,len(str) + if(ichar(str(i:i))==0) str(i:i)=' ' + end do + end subroutine strip_null + +end module mosart_histfile diff --git a/src/riverroute/mosart_histflds.F90 b/src/riverroute/mosart_histflds.F90 index 8550930..31287df 100644 --- a/src/riverroute/mosart_histflds.F90 +++ b/src/riverroute/mosart_histflds.F90 @@ -1,186 +1,175 @@ -module RtmHistFlds +module mosart_histflds -!----------------------------------------------------------------------- -! !DESCRIPTION: -! Module containing initialization of RTM history fields and files -! This is the module that the user must modify in order to add new -! history fields or modify defaults associated with existing history -! fields. -! -! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8 - use RunoffMod , only : rtmCTL - use RtmHistFile , only : RtmHistAddfld, RtmHistPrintflds - use RtmVar , only : nt_rtm, rtm_tracers - - implicit none -! -! !PUBLIC MEMBER FUNCTIONS: - public :: RtmHistFldsInit - public :: RtmHistFldsSet -! -!------------------------------------------------------------------------ - -contains - -!----------------------------------------------------------------------- - - subroutine RtmHistFldsInit() - - !------------------------------------------------------- - ! DESCRIPTION: - ! Build master field list of all possible fields in a history file. - ! Each field has associated with it a ``long\_name'' netcdf attribute that - ! describes what the field is, and a ``units'' attribute. A subroutine is - ! called to add each field to the masterlist. - ! - ! ARGUMENTS: - implicit none - !------------------------------------------------------- - - call RtmHistAddfld (fname='RIVER_DISCHARGE_OVER_LAND'//'_'//trim(rtm_tracers(1)), units='m3/s', & - avgflag='A', long_name='MOSART river basin flow: '//trim(rtm_tracers(1)), & - ptr_rof=rtmCTL%runofflnd_nt1, default='active') - - call RtmHistAddfld (fname='RIVER_DISCHARGE_OVER_LAND'//'_'//trim(rtm_tracers(2)), units='m3/s', & - avgflag='A', long_name='MOSART river basin flow: '//trim(rtm_tracers(2)), & - ptr_rof=rtmCTL%runofflnd_nt2, default='active') - - call RtmHistAddfld (fname='RIVER_DISCHARGE_TO_OCEAN'//'_'//trim(rtm_tracers(1)), units='m3/s', & - avgflag='A', long_name='MOSART river discharge into ocean: '//trim(rtm_tracers(1)), & - ptr_rof=rtmCTL%runoffocn_nt1, default='inactive') - - call RtmHistAddfld (fname='RIVER_DISCHARGE_TO_OCEAN'//'_'//trim(rtm_tracers(2)), units='m3/s', & - avgflag='A', long_name='MOSART river discharge into ocean: '//trim(rtm_tracers(2)), & - ptr_rof=rtmCTL%runoffocn_nt2, default='inactive') - - call RtmHistAddfld (fname='TOTAL_DISCHARGE_TO_OCEAN'//'_'//trim(rtm_tracers(1)), units='m3/s', & - avgflag='A', long_name='MOSART total discharge into ocean: '//trim(rtm_tracers(1)), & - ptr_rof=rtmCTL%runofftot_nt1, default='active') - - call RtmHistAddfld (fname='TOTAL_DISCHARGE_TO_OCEAN'//'_'//trim(rtm_tracers(2)), units='m3/s', & - avgflag='A', long_name='MOSART total discharge into ocean: '//trim(rtm_tracers(2)), & - ptr_rof=rtmCTL%runofftot_nt2, default='active') - - call RtmHistAddfld (fname='DIRECT_DISCHARGE_TO_OCEAN'//'_'//trim(rtm_tracers(1)), units='m3/s', & - avgflag='A', long_name='MOSART direct discharge into ocean: '//trim(rtm_tracers(1)), & - ptr_rof=rtmCTL%runoffdir_nt1, default='active') - - call RtmHistAddfld (fname='DIRECT_DISCHARGE_TO_OCEAN'//'_'//trim(rtm_tracers(2)), units='m3/s', & - avgflag='A', long_name='MOSART direct discharge into ocean: '//trim(rtm_tracers(2)), & - ptr_rof=rtmCTL%runoffdir_nt2, default='active') - - call RtmHistAddfld (fname='STORAGE'//'_'//trim(rtm_tracers(1)), units='m3', & - avgflag='A', long_name='MOSART storage: '//trim(rtm_tracers(1)), & - ptr_rof=rtmCTL%volr_nt1, default='inactive') - - call RtmHistAddfld (fname='STORAGE'//'_'//trim(rtm_tracers(2)), units='m3', & - avgflag='A', long_name='MOSART storage: '//trim(rtm_tracers(2)), & - ptr_rof=rtmCTL%volr_nt2, default='inactive') - - call RtmHistAddfld (fname='STORAGE_MCH', units='m3', & - avgflag='A', long_name='MOSART main channelstorage', & - ptr_rof=rtmCTL%volr_mch, default='inactive') - - call RtmHistAddfld (fname='DVOLRDT_LND'//'_'//trim(rtm_tracers(1)), units='m3/s', & - avgflag='A', long_name='MOSART land change in storage: '//trim(rtm_tracers(1)), & - ptr_rof=rtmCTL%dvolrdtlnd_nt1, default='inactive') - - call RtmHistAddfld (fname='DVOLRDT_LND'//'_'//trim(rtm_tracers(2)), units='m3/s', & - avgflag='A', long_name='MOSART land change in storage: '//trim(rtm_tracers(2)), & - ptr_rof=rtmCTL%dvolrdtlnd_nt2, default='inactive') - - call RtmHistAddfld (fname='DVOLRDT_OCN'//'_'//trim(rtm_tracers(1)), units='m3/s', & - avgflag='A', long_name='MOSART ocean change of storage: '//trim(rtm_tracers(1)), & - ptr_rof=rtmCTL%dvolrdtocn_nt1, default='inactive') + ! Module containing initialization of history fields and files + ! This is the module that the user must modify in order to add new + ! history fields or modify defaults associated with existing history + ! fields. - call RtmHistAddfld (fname='DVOLRDT_OCN'//'_'//trim(rtm_tracers(2)), units='m3/s', & - avgflag='A', long_name='MOSART ocean change of storage: '//trim(rtm_tracers(2)), & - ptr_rof=rtmCTL%dvolrdtocn_nt2, default='inactive') + use shr_kind_mod , only : r8 => shr_kind_r8 + use mosart_histfile , only : mosart_hist_addfld, mosart_hist_printflds + use mosart_data , only : ctl, Trunoff - call RtmHistAddfld (fname='QSUR'//'_'//trim(rtm_tracers(1)), units='m3/s', & - avgflag='A', long_name='MOSART input surface runoff: '//trim(rtm_tracers(1)), & - ptr_rof=rtmCTL%qsur_nt1, default='inactive') + implicit none + private - call RtmHistAddfld (fname='QSUR'//'_'//trim(rtm_tracers(2)), units='m3/s', & - avgflag='A', long_name='MOSART input surface runoff: '//trim(rtm_tracers(2)), & - ptr_rof=rtmCTL%qsur_nt2, default='inactive') + public :: mosart_histflds_init + public :: mosart_histflds_set - call RtmHistAddfld (fname='QSUB'//'_'//trim(rtm_tracers(1)), units='m3/s', & - avgflag='A', long_name='MOSART input subsurface runoff: '//trim(rtm_tracers(1)), & - ptr_rof=rtmCTL%qsub_nt1, default='inactive') + type, public :: hist_pointer_type + real(r8), pointer :: data(:) => null() + end type hist_pointer_type - call RtmHistAddfld (fname='QSUB'//'_'//trim(rtm_tracers(2)), units='m3/s', & - avgflag='A', long_name='MOSART input subsurface runoff: '//trim(rtm_tracers(2)), & - ptr_rof=rtmCTL%qsub_nt2, default='inactive') + type(hist_pointer_type), allocatable :: h_runofflnd(:) + type(hist_pointer_type), allocatable :: h_runoffocn(:) + type(hist_pointer_type), allocatable :: h_runofftot(:) + type(hist_pointer_type), allocatable :: h_direct(:) + type(hist_pointer_type), allocatable :: h_dvolrdtlnd(:) + type(hist_pointer_type), allocatable :: h_dvolrdtocn(:) + type(hist_pointer_type), allocatable :: h_volr(:) + type(hist_pointer_type), allocatable :: h_qsur(:) + type(hist_pointer_type), allocatable :: h_qsub(:) + type(hist_pointer_type), allocatable :: h_qgwl(:) - call RtmHistAddfld (fname='QGWL'//'_'//trim(rtm_tracers(1)), units='m3/s', & - avgflag='A', long_name='MOSART input GWL runoff: '//trim(rtm_tracers(1)), & - ptr_rof=rtmCTL%qgwl_nt1, default='inactive') - - call RtmHistAddfld (fname='QGWL'//'_'//trim(rtm_tracers(2)), units='m3/s', & - avgflag='A', long_name='MOSART input GWL runoff: '//trim(rtm_tracers(2)), & - ptr_rof=rtmCTL%qgwl_nt2, default='inactive') - - call RtmHistAddfld (fname='QIRRIG_FROM_COUPLER', units='m3/s', & - avgflag='A', long_name='Amount of water used for irrigation (total flux received from coupler)', & - ptr_rof=rtmCTL%qirrig, default='inactive') - - call RtmHistAddfld (fname='QIRRIG_ACTUAL', units='m3/s', & - avgflag='A', long_name='Actual irrigation (if limited by river storage)', & - ptr_rof=rtmCTL%qirrig_actual, default='inactive') - - ! Print masterlist of history fields - - call RtmHistPrintflds() - - end subroutine RtmHistFldsInit + real(r8), pointer :: h_volr_mch(:) +!------------------------------------------------------------------------ +contains !----------------------------------------------------------------------- - subroutine RtmHistFldsSet() - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Set mosart history fields as 1d poitner arrays - ! - implicit none - !----------------------------------------------------------------------- - - ! Currently only have two tracers - - rtmCTL%runofflnd_nt1(:) = rtmCTL%runofflnd(:,1) - rtmCTL%runofflnd_nt2(:) = rtmCTL%runofflnd(:,2) - - rtmCTL%runoffocn_nt1(:) = rtmCTL%runoffocn(:,1) - rtmCTL%runoffocn_nt2(:) = rtmCTL%runoffocn(:,2) - - rtmCTL%runofftot_nt1(:) = rtmCTL%runofftot(:,1) - rtmCTL%runofftot_nt2(:) = rtmCTL%runofftot(:,2) - - rtmCTL%runoffdir_nt1(:) = rtmCTL%direct(:,1) - rtmCTL%runoffdir_nt2(:) = rtmCTL%direct(:,2) - - rtmCTL%dvolrdtlnd_nt1(:) = rtmCTL%dvolrdtlnd(:,1) - rtmCTL%dvolrdtlnd_nt2(:) = rtmCTL%dvolrdtlnd(:,2) - - rtmCTL%dvolrdtocn_nt1(:) = rtmCTL%dvolrdtocn(:,1) - rtmCTL%dvolrdtocn_nt2(:) = rtmCTL%dvolrdtocn(:,2) - - rtmCTL%volr_nt1(:) = rtmCTL%volr(:,1) - rtmCTL%volr_nt2(:) = rtmCTL%volr(:,2) - rtmCTL%volr_mch(:) = rtmCTL%wr(:,1) - - rtmCTL%qsub_nt1(:) = rtmCTL%qsub(:,1) - rtmCTL%qsub_nt2(:) = rtmCTL%qsub(:,2) - - rtmCTL%qsur_nt1(:) = rtmCTL%qsur(:,1) - rtmCTL%qsur_nt2(:) = rtmCTL%qsur(:,2) - - rtmCTL%qgwl_nt1(:) = rtmCTL%qgwl(:,1) - rtmCTL%qgwl_nt2(:) = rtmCTL%qgwl(:,2) - - end subroutine RtmHistFldsSet + subroutine mosart_histflds_init(begr, endr, ntracers) + + ! Arguments + integer, intent(in) :: begr + integer, intent(in) :: endr + integer, intent(in) :: ntracers + + ! Local variables + integer :: nt + + !------------------------------------------------------- + ! Allocate memory for module variables + !------------------------------------------------------- + + allocate(h_runofflnd(ntracers)) + allocate(h_runoffocn(ntracers)) + allocate(h_runofftot(ntracers)) + allocate(h_direct(ntracers)) + allocate(h_dvolrdtlnd(ntracers)) + allocate(h_dvolrdtocn(ntracers)) + allocate(h_volr(ntracers)) + allocate(h_qsur(ntracers)) + allocate(h_qsub(ntracers)) + allocate(h_qgwl(ntracers)) + + do nt = 1,ntracers + allocate(h_runofflnd(nt)%data(begr:endr)) + allocate(h_runoffocn(nt)%data(begr:endr)) + allocate(h_runofftot(nt)%data(begr:endr)) + allocate(h_direct(nt)%data(begr:endr)) + allocate(h_dvolrdtlnd(nt)%data(begr:endr)) + allocate(h_dvolrdtocn(nt)%data(begr:endr)) + allocate(h_volr(nt)%data(begr:endr)) + allocate(h_qsur(nt)%data(begr:endr)) + allocate(h_qsub(nt)%data(begr:endr)) + allocate(h_qgwl(nt)%data(begr:endr)) + end do + + allocate(h_volr_mch(begr:endr)) + + !------------------------------------------------------- + ! Build master field list of all possible fields in a history file. + ! Each field has associated with it a ``long\_name'' netcdf attribute that + ! describes what the field is, and a ``units'' attribute. A subroutine is + ! called to add each field to the masterlist. + !------------------------------------------------------- + + do nt = 1,ctl%ntracers + + call mosart_hist_addfld (fname='RIVER_DISCHARGE_OVER_LAND'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & + avgflag='A', long_name='MOSART river basin flow: '//trim(ctl%tracer_names(nt)), & + ptr_rof=h_runofflnd(nt)%data, default='active') + + call mosart_hist_addfld (fname='RIVER_DISCHARGE_TO_OCEAN'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & + avgflag='A', long_name='MOSART river discharge into ocean: '//trim(ctl%tracer_names(nt)), & + ptr_rof=h_runoffocn(nt)%data, default='inactive') + + call mosart_hist_addfld (fname='TOTAL_DISCHARGE_TO_OCEAN'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & + avgflag='A', long_name='MOSART total discharge into ocean: '//trim(ctl%tracer_names(nt)), & + ptr_rof=h_runofftot(nt)%data, default='active') + + call mosart_hist_addfld (fname='DIRECT_DISCHARGE_TO_OCEAN'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & + avgflag='A', long_name='MOSART direct discharge into ocean: '//trim(ctl%tracer_names(nt)), & + ptr_rof=h_direct(nt)%data, default='active') + + call mosart_hist_addfld (fname='STORAGE'//'_'//trim(ctl%tracer_names(nt)), units='m3', & + avgflag='A', long_name='MOSART storage: '//trim(ctl%tracer_names(nt)), & + ptr_rof=h_volr(nt)%data, default='inactive') + + call mosart_hist_addfld (fname='DVOLRDT_LND'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & + avgflag='A', long_name='MOSART land change in storage: '//trim(ctl%tracer_names(nt)), & + ptr_rof=h_dvolrdtlnd(nt)%data, default='inactive') + + call mosart_hist_addfld (fname='DVOLRDT_OCN'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & + avgflag='A', long_name='MOSART ocean change of storage: '//trim(ctl%tracer_names(nt)), & + ptr_rof=h_dvolrdtocn(nt)%data, default='inactive') + + call mosart_hist_addfld (fname='QSUR'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & + avgflag='A', long_name='MOSART input surface runoff: '//trim(ctl%tracer_names(nt)), & + ptr_rof=h_qsur(nt)%data, default='inactive') + + call mosart_hist_addfld (fname='QSUB'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & + avgflag='A', long_name='MOSART input subsurface runoff: '//trim(ctl%tracer_names(nt)), & + ptr_rof=h_qsub(nt)%data, default='inactive') + + call mosart_hist_addfld (fname='QGWL'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & + avgflag='A', long_name='MOSART input GWL runoff: '//trim(ctl%tracer_names(nt)), & + ptr_rof=h_qgwl(nt)%data, default='inactive') + end do + + call mosart_hist_addfld (fname='STORAGE_MCH', units='m3', & + avgflag='A', long_name='MOSART main channelstorage', & + ptr_rof=h_volr_mch, default='inactive') + + call mosart_hist_addfld (fname='QIRRIG_FROM_COUPLER', units='m3/s', & + avgflag='A', long_name='Amount of water used for irrigation (total flux received from coupler)', & + ptr_rof=ctl%qirrig, default='inactive') + + call mosart_hist_addfld (fname='QIRRIG_ACTUAL', units='m3/s', & + avgflag='A', long_name='Actual irrigation (if limited by river storage)', & + ptr_rof=ctl%qirrig_actual, default='inactive') + + ! print masterlist of history fields + call mosart_hist_printflds() + + end subroutine mosart_histflds_init + + !----------------------------------------------------------------------- + + subroutine mosart_histflds_set(ntracers) + + !----------------------------------------------------------------------- + ! Set mosart history fields as 1d pointer arrays + !----------------------------------------------------------------------- + + ! Arguments + integer, intent(in) :: ntracers + + ! Local variables + integer :: nt + + do nt = 1,ntracers + h_runofflnd(nt)%data(:) = ctl%runofflnd(:,nt) + h_runoffocn(nt)%data(:) = ctl%runoffocn(:,nt) + h_runofftot(nt)%data(:) = ctl%runofftot(:,nt) + h_direct(nt)%data(:) = ctl%direct(:,nt) + h_dvolrdtlnd(nt)%data(:) = ctl%dvolrdtlnd(:,nt) + h_dvolrdtocn(nt)%data(:) = ctl%dvolrdtocn(:,nt) + h_qsub(nt)%data(:) = ctl%qsub(:,nt) + h_qsur(nt)%data(:) = ctl%qsur(:,nt) + h_qgwl(nt)%data(:) = ctl%qgwl(:,nt) + end do + h_volr_mch(:) = Trunoff%wr(:,1) + end subroutine mosart_histflds_set -end module RtmHistFlds +end module mosart_histflds diff --git a/src/riverroute/mosart_io.F90 b/src/riverroute/mosart_io.F90 index 2dab656..9afa99a 100644 --- a/src/riverroute/mosart_io.F90 +++ b/src/riverroute/mosart_io.F90 @@ -1,1936 +1,1935 @@ -module RtmIO +module mosart_io + + ! Generic interfaces to write fields to netcdf files + ! + 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 shr_pio_mod , only : shr_pio_getiosys, shr_pio_getiotype, shr_pio_getioformat + use mosart_vars , only : spval, ispval, iulog, mainproc, mpicom_rof, iam, npes + use perf_mod , only : t_startf, t_stopf + use pio + use mpi + + implicit none + private + + ! !PUBLIC MEMBER FUNCTIONS: + public :: check_var ! determine if variable is on netcdf file + public :: check_dim ! validity check on dimension + public :: ncd_pio_openfile ! open a file + public :: ncd_pio_createfile ! create a new file + public :: ncd_pio_closefile ! close a file + public :: ncd_pio_init ! initialize pio + public :: ncd_decomp_init ! initialize module variables for iosdesc + public :: ncd_enddef ! end define mode + public :: ncd_putatt ! put attribute + public :: ncd_defdim ! define dimension + public :: ncd_inqdid ! inquire dimension id + public :: ncd_inqdname ! inquire dimension name + public :: ncd_inqdlen ! inquire dimension length + public :: ncd_inqfdims ! inquire file dimnesions + public :: ncd_defvar ! define variables + public :: ncd_inqvid ! inquire variable id + public :: ncd_inqvname ! inquire variable name + public :: ncd_inqvdims ! inquire variable ndims + public :: ncd_inqvdids ! inquire variable dimids + public :: ncd_io ! write local data + public :: getdatetime + + integer, parameter, public :: ncd_int = pio_int + integer, parameter, public :: ncd_log =-pio_int + integer, parameter, public :: ncd_float = pio_real + integer, parameter, public :: ncd_double = pio_double + integer, parameter, public :: ncd_char = pio_char + integer, parameter, public :: ncd_global = pio_global + integer, parameter, public :: ncd_write = pio_write + integer, parameter, public :: ncd_nowrite = pio_nowrite + integer, parameter, public :: ncd_clobber = pio_clobber + integer, parameter, public :: ncd_noclobber = pio_noclobber + integer, parameter, public :: ncd_nofill = pio_nofill + integer, parameter, public :: ncd_unlimited = pio_unlimited + + ! PIO types needed for ncdio_pio interface calls + public file_desc_t + public var_desc_t + public io_desc_t + + ! !PRIVATE MEMBER FUNCTIONS: + interface ncd_putatt + module procedure ncd_putatt_int + module procedure ncd_putatt_real + module procedure ncd_putatt_char + end interface ncd_putatt + + interface ncd_defvar + module procedure ncd_defvar_bynf + module procedure ncd_defvar_bygrid + end interface ncd_defvar + + interface ncd_io + ! global scalar + module procedure ncd_io_log_var0_nf + module procedure ncd_io_int_var0_nf + module procedure ncd_io_real_var0_nf + + ! global 1d + module procedure ncd_io_log_var1_nf + module procedure ncd_io_int_var1_nf + module procedure ncd_io_real_var1_nf + module procedure ncd_io_char_var1_nf + module procedure ncd_io_char_varn_strt_nf + + ! global 2d + module procedure ncd_io_int_var2_nf + module procedure ncd_io_real_var2_nf + module procedure ncd_io_char_var2_nf + + ! local 1d + module procedure ncd_io_log_var1 + module procedure ncd_io_int_var1 + module procedure ncd_io_real_var1 + end interface ncd_io + + private :: ncd_getiodesc ! obtain iodesc + + integer , parameter, private :: debug = 0 ! local debug level + integer , parameter, public :: max_string_len = 256 ! length of strings + real(r8) , parameter, public :: fillvalue = 1.e36_r8 ! fill value for netcdf fields + + integer :: io_type, io_format + type(iosystem_desc_t), pointer, public :: pio_subsystem + + type iodesc_plus_type + character(len=64) :: name + type(IO_desc_t) :: iodesc + integer :: type + integer :: ndims + integer :: dims(4) + integer :: dimids(4) + end type iodesc_plus_type + integer,parameter ,private :: max_iodesc = 100 + integer ,private :: num_iodesc = 0 + type(iodesc_plus_type) ,private, target :: iodesc_list(max_iodesc) + + ! Decomposition data needed to generate iodesc + integer, pointer, public, protected :: compDOF(:) !----------------------------------------------------------------------- -!BOP -! -! !MODULE: RtmIO -! -! !DESCRIPTION: -! Generic interfaces to write fields to netcdf files for RTM -! -! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8, i8=>shr_kind_i8, shr_kind_cl, r4=>shr_kind_r4 - use shr_sys_mod , only : shr_sys_flush, shr_sys_abort - use shr_file_mod , only : shr_file_getunit, shr_file_freeunit - use 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 pio - -! !PUBLIC TYPES: - implicit none - private -! -! !PUBLIC MEMBER FUNCTIONS: -! - public :: check_var ! determine if variable is on netcdf file - public :: check_dim ! validity check on dimension - public :: ncd_pio_openfile ! open a file - public :: ncd_pio_createfile ! create a new file - public :: ncd_pio_closefile ! close a file - public :: ncd_pio_init ! called from rtm_comp - public :: ncd_enddef ! end define mode - public :: ncd_putatt ! put attribute - public :: ncd_defdim ! define dimension - public :: ncd_inqdid ! inquire dimension id - public :: ncd_inqdname ! inquire dimension name - public :: ncd_inqdlen ! inquire dimension length - public :: ncd_inqfdims ! inquire file dimnesions - public :: ncd_defvar ! define variables - public :: ncd_inqvid ! inquire variable id - public :: ncd_inqvname ! inquire variable name - public :: ncd_inqvdims ! inquire variable ndims - public :: ncd_inqvdids ! inquire variable dimids - public :: ncd_io ! write local data - - integer,parameter,public :: ncd_int = pio_int - integer,parameter,public :: ncd_log =-pio_int - integer,parameter,public :: ncd_float = pio_real - integer,parameter,public :: ncd_double = pio_double - integer,parameter,public :: ncd_char = pio_char - integer,parameter,public :: ncd_global = pio_global - integer,parameter,public :: ncd_write = pio_write - integer,parameter,public :: ncd_nowrite = pio_nowrite - integer,parameter,public :: ncd_clobber = pio_clobber - integer,parameter,public :: ncd_noclobber = pio_noclobber - integer,parameter,public :: ncd_nofill = pio_nofill - integer,parameter,public :: ncd_unlimited = pio_unlimited - - ! PIO types needed for ncdio_pio interface calls - public file_desc_t - public var_desc_t - public io_desc_t - - ! !PRIVATE MEMBER FUNCTIONS: - interface ncd_putatt - module procedure ncd_putatt_int - module procedure ncd_putatt_real - module procedure ncd_putatt_char - end interface - - interface ncd_defvar - module procedure ncd_defvar_bynf - module procedure ncd_defvar_bygrid - end interface - - interface ncd_io - ! global scalar - module procedure ncd_io_log_var0_nf - module procedure ncd_io_int_var0_nf - module procedure ncd_io_real_var0_nf - - ! global 1d - module procedure ncd_io_log_var1_nf - module procedure ncd_io_int_var1_nf - module procedure ncd_io_real_var1_nf - module procedure ncd_io_char_var1_nf - module procedure ncd_io_char_varn_strt_nf - - ! global 2d - module procedure ncd_io_int_var2_nf - module procedure ncd_io_real_var2_nf - module procedure ncd_io_char_var2_nf - - ! local 1d - module procedure ncd_io_log_var1 - module procedure ncd_io_int_var1 - module procedure ncd_io_real_var1 - end interface - - private :: ncd_getiodesc ! obtain iodesc - - integer,parameter,private :: debug = 0 ! local debug level - - integer , parameter , public :: max_string_len = 256 ! length of strings - real(r8), parameter , public :: fillvalue = 1.e36_r8 ! fill value for netcdf fields - - integer :: io_type, io_format - - type(iosystem_desc_t), pointer, public :: pio_subsystem - - type iodesc_plus_type - character(len=64) :: name - type(IO_desc_t) :: iodesc - integer :: type - integer :: ndims - integer :: dims(4) - integer :: dimids(4) - end type iodesc_plus_type - integer,parameter ,private :: max_iodesc = 100 - integer ,private :: num_iodesc = 0 - type(iodesc_plus_type) ,private, target :: iodesc_list(max_iodesc) - -!EOP -!----------------------------------------------------------------------- - contains - -!----------------------------------------------------------------------- - - subroutine ncd_pio_init() - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Initial PIO - ! - ! !USES: - use shr_pio_mod, only : shr_pio_getiosys, shr_pio_getiotype, shr_pio_getioformat - ! !ARGUMENTS: - implicit none - ! !LOCAL VARIABLES: - character(len=*),parameter :: subname='ncd_pio_init' ! subroutine name - !----------------------------------------------------------------------- - - PIO_subsystem => shr_pio_getiosys(ROFID) - io_type = shr_pio_getiotype(ROFID) - io_format = shr_pio_getioformat(ROFID) - - end subroutine ncd_pio_init - -!----------------------------------------------------------------------- - - subroutine ncd_pio_openfile(file, fname, mode) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Open a NetCDF PIO file - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: file ! Output PIO file handle - character(len=*) , intent(in) :: fname ! Input filename to open - integer , intent(in) :: mode ! file mode - ! !LOCAL VARIABLES: - integer :: ierr - character(len=*),parameter :: subname='ncd_pio_openfile' ! subroutine name - !----------------------------------------------------------------------- - - ierr = pio_openfile(pio_subsystem, file, io_type, fname, mode) - - if(ierr/= PIO_NOERR) then - call shr_sys_abort(subname//'ERROR: Failed to open file') - else if(pio_iotask_rank(pio_subsystem)==0 .and. mainproc) then - write(iulog,*) 'Opened existing file ', trim(fname), file%fh - end if - - end subroutine ncd_pio_openfile - -!----------------------------------------------------------------------- - - subroutine ncd_pio_closefile(file) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Close a NetCDF PIO file - ! - ! !ARGUMENTS: - type(file_desc_t), intent(inout) :: file ! PIO file handle to close - !----------------------------------------------------------------------- - - call pio_closefile(file) - - end subroutine ncd_pio_closefile - -!----------------------------------------------------------------------- - - subroutine ncd_pio_createfile(file, fname) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Create a new NetCDF file with PIO - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: file ! PIO file descriptor - character(len=*), intent(in) :: fname ! File name to create - ! !LOCAL VARIABLES: - integer :: ierr - integer :: iomode - character(len=*),parameter :: subname='ncd_pio_createfile' ! subroutine name - !----------------------------------------------------------------------- - - - iomode = PIO_CLOBBER - if(io_type == PIO_IOTYPE_NETCDF .or. io_type == PIO_IOTYPE_PNETCDF) then - iomode = ior(iomode, io_format) - endif - ierr = pio_createfile(pio_subsystem, file, io_type, fname, iomode) - - if(ierr/= PIO_NOERR) then - call shr_sys_abort( subname//' ERROR: Failed to open file to write: '//trim(fname)) - else if(pio_iotask_rank(pio_subsystem)==0 .and. mainproc) then - write(iulog,*) 'Opened file ', trim(fname), ' to write', file%fh - end if - - end subroutine ncd_pio_createfile - -!----------------------------------------------------------------------- - - subroutine check_var(ncid, varname, vardesc, readvar, print_err ) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Check if variable is on netcdf file - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! PIO file descriptor - character(len=*) , intent(in) :: varname ! Varible name to check - type(Var_desc_t) , intent(out) :: vardesc ! Output variable descriptor - logical , intent(out) :: readvar ! If variable exists or not - logical, optional, intent(in) :: print_err ! If should print about error - ! !LOCAL VARIABLES: - integer :: ret ! return value - logical :: log_err ! if should log error - character(len=*),parameter :: subname='check_var' ! subroutine name - !----------------------------------------------------------------------- - - - if ( present(print_err) )then - log_err = print_err - else - log_err = .true. - end if - readvar = .true. - call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) - ret = PIO_inq_varid (ncid, varname, vardesc) - if (ret /= PIO_noerr) then - readvar = .false. - if (mainproc .and. log_err) & - write(iulog,*) subname//': variable ',trim(varname),' is not on dataset' - end if - call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) - - end subroutine check_var - -!----------------------------------------------------------------------- - - subroutine check_dim(ncid, dimname, value) - - ! !DESCRIPTION: - ! Validity check on dimension - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t),intent(in) :: ncid ! PIO file handle - character(len=*), intent(in) :: dimname ! Dimension name - integer, intent(in) :: value ! Expected dimension size - ! !LOCAL VARIABLES: - integer :: dimid, dimlen ! temporaries - integer :: status ! error code - character(len=*),parameter :: subname='check_dim' ! subroutine name - !----------------------------------------------------------------------- - - status = pio_inq_dimid (ncid, trim(dimname), dimid) - status = pio_inq_dimlen (ncid, dimid, dimlen) - if (dimlen /= value) then - write(iulog,*) subname//' ERROR: mismatch of input dimension ',dimlen, & - ' with expected value ',value,' for variable ',trim(dimname) - call shr_sys_abort() - end if - - end subroutine check_dim - -!----------------------------------------------------------------------- - - subroutine ncd_enddef(ncid) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! enddef netcdf file - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t),intent(inout) :: ncid ! netcdf file id - ! !LOCAL VARIABLES: - integer :: status ! error status - character(len=*),parameter :: subname='ncd_enddef' ! subroutine name - !----------------------------------------------------------------------- - - status = PIO_enddef(ncid) - - end subroutine ncd_enddef - - !----------------------------------------------------------------------- - - subroutine ncd_inqdid(ncid,name,dimid,dimexist) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! inquire on a dimension id - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t),intent(inout) :: ncid ! netcdf file id - character(len=*), intent(in) :: name ! dimension name - integer , intent(out):: dimid ! dimension id - logical,optional, intent(out):: dimexist ! if this dimension exists or not - ! !LOCAL VARIABLES: - integer :: status - !----------------------------------------------------------------------- - - if ( present(dimexist) )then - call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) - end if - status = PIO_inq_dimid(ncid,name,dimid) - if ( present(dimexist) )then - if ( status == PIO_NOERR)then - dimexist = .true. - else - dimexist = .false. - end if - call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) - end if - - end subroutine ncd_inqdid - -!----------------------------------------------------------------------- - - subroutine ncd_inqdlen(ncid,dimid,len,name) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! enddef netcdf file - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - integer , intent(inout) :: dimid ! dimension id - integer , intent(out) :: len ! dimension len - character(len=*), optional, intent(in) :: name ! dimension name - ! - ! !LOCAL VARIABLES: - integer :: status - !----------------------------------------------------------------------- - - if ( present(name) )then - call ncd_inqdid(ncid,name,dimid) - end if - len = -1 - status = PIO_inq_dimlen(ncid,dimid,len) - - end subroutine ncd_inqdlen - -!----------------------------------------------------------------------- - - subroutine ncd_inqdname(ncid,dimid,dname) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! inquire dim name - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(in) :: ncid ! netcdf file id - integer , intent(in) :: dimid ! dimension id - character(len=*) , intent(out):: dname ! dimension name - ! !LOCAL VARIABLES: - integer :: status - !----------------------------------------------------------------------- - - status = PIO_inq_dimname(ncid,dimid,dname) - - end subroutine ncd_inqdname - -!----------------------------------------------------------------------- - - subroutine ncd_inqfdims(ncid, isgrid2d, ni, nj, ns) - - !----------------------------------------------------------------------- - ! !ARGUMENTS: - type(file_desc_t), intent(inout):: ncid - logical , intent(out) :: isgrid2d - integer , intent(out) :: ni - integer , intent(out) :: nj - integer , intent(out) :: ns - ! !LOCAL VARIABLES: - integer :: dimid ! netCDF id - integer :: ier ! error status - character(len=32) :: subname = 'surfrd_filedims' ! subroutine name - !----------------------------------------------------------------------- - - ni = 0 - nj = 0 - - call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) - ier = pio_inq_dimid (ncid, 'lon', dimid) - if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, ni) - ier = pio_inq_dimid (ncid, 'lat', dimid) - if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, nj) - - ier = pio_inq_dimid (ncid, 'lsmlon', dimid) - if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, ni) - ier = pio_inq_dimid (ncid, 'lsmlat', dimid) - if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, nj) - - ier = pio_inq_dimid (ncid, 'ni', dimid) - if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, ni) - ier = pio_inq_dimid (ncid, 'nj', dimid) - if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, nj) - - ier = pio_inq_dimid (ncid, 'gridcell', dimid) - if (ier == PIO_NOERR) then - ier = pio_inq_dimlen(ncid, dimid, ni) - if (ier == PIO_NOERR) nj = 1 - end if - - call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) - - if (ni == 0 .or. nj == 0) then - write(iulog,*) trim(subname),' ERROR: ni,nj = ',ni,nj,' cannot be zero ' - call shr_sys_abort() - end if - - if (nj == 1) then - isgrid2d = .false. - else - isgrid2d = .true. - end if - - ns = ni*nj - - end subroutine ncd_inqfdims - -!----------------------------------------------------------------------- - - subroutine ncd_inqvid(ncid,name,varid,vardesc,readvar) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Inquire on a variable ID - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: name ! variable name - integer , intent(out) :: varid ! variable id - type(Var_desc_t) , intent(out) :: vardesc ! variable descriptor - logical, optional, intent(out) :: readvar ! does variable exist - ! !LOCAL VARIABLES: - integer :: ret ! return code - character(len=*),parameter :: subname='ncd_inqvid' ! subroutine name - !----------------------------------------------------------------------- - - if (present(readvar)) then - readvar = .false. - call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) - ret = PIO_inq_varid(ncid,name,vardesc) - if (ret /= PIO_noerr) then - if (mainproc) write(iulog,*) subname//': variable ',trim(name),' is not on dataset' - readvar = .false. - else - readvar = .true. - end if - call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) - else - ret = PIO_inq_varid(ncid,name,vardesc) - endif - varid = vardesc%varid - - end subroutine ncd_inqvid - -!----------------------------------------------------------------------- - - subroutine ncd_inqvdims(ncid,ndims,vardesc) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! inquire variable dimensions - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(in) :: ncid ! netcdf file id - integer , intent(out) :: ndims ! variable ndims - type(Var_desc_t) , intent(inout):: vardesc ! variable descriptor - ! - ! !LOCAL VARIABLES: - integer :: status - !----------------------------------------------------------------------- - - ndims = -1 - status = PIO_inq_varndims(ncid,vardesc,ndims) - - end subroutine ncd_inqvdims - -!----------------------------------------------------------------------- - - subroutine ncd_inqvname(ncid,varid,vname,vardesc) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! inquire variable name - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(in) :: ncid ! netcdf file id - integer , intent(in) :: varid ! variable id - character(len=*) , intent(out) :: vname ! variable vname - type(Var_desc_t) , intent(inout):: vardesc ! variable descriptor - ! !LOCAL VARIABLES: - integer :: status - !----------------------------------------------------------------------- - - vname = '' - status = PIO_inq_varname(ncid,vardesc,vname) - - end subroutine ncd_inqvname - -!----------------------------------------------------------------------- - - subroutine ncd_inqvdids(ncid,dids,vardesc) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! inquire variable dimension ids - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t),intent(in) :: ncid ! netcdf file id - integer ,intent(out) :: dids(:) ! variable dids - type(Var_desc_t),intent(inout):: vardesc ! variable descriptor - ! - ! !LOCAL VARIABLES: - integer :: status - !----------------------------------------------------------------------- - - dids = -1 - status = PIO_inq_vardimid(ncid,vardesc,dids) - - end subroutine ncd_inqvdids - -!----------------------------------------------------------------------- - subroutine ncd_putatt_int(ncid,varid,attrib,value,xtype) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! put integer attributes - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t),intent(inout) :: ncid ! netcdf file id - integer ,intent(in) :: varid ! netcdf var id - character(len=*) ,intent(in) :: attrib ! netcdf attrib - integer ,intent(in) :: value ! netcdf attrib value - integer,optional ,intent(in) :: xtype ! netcdf data type - ! - ! !LOCAL VARIABLES: - integer :: status - !----------------------------------------------------------------------- - - status = PIO_put_att(ncid,varid,trim(attrib),value) - - end subroutine ncd_putatt_int - -!----------------------------------------------------------------------- - - subroutine ncd_putatt_char(ncid,varid,attrib,value,xtype) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! put character attributes - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t),intent(inout) :: ncid ! netcdf file id - integer ,intent(in) :: varid ! netcdf var id - character(len=*) ,intent(in) :: attrib ! netcdf attrib - character(len=*) ,intent(in) :: value ! netcdf attrib value - integer,optional ,intent(in) :: xtype ! netcdf data type - ! - ! !LOCAL VARIABLES: - integer :: status - !----------------------------------------------------------------------- - - status = PIO_put_att(ncid,varid,trim(attrib),value) - - end subroutine ncd_putatt_char - -!----------------------------------------------------------------------- - - subroutine ncd_putatt_real(ncid,varid,attrib,value,xtype) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! put real attributes - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t),intent(inout) :: ncid ! netcdf file id - integer ,intent(in) :: varid ! netcdf var id - character(len=*) ,intent(in) :: attrib ! netcdf attrib - real(r8) ,intent(in) :: value ! netcdf attrib value - integer ,intent(in) :: xtype ! netcdf data type - ! - ! !LOCAL VARIABLES: - integer :: status - real(r4) :: value4 - !----------------------------------------------------------------------- - - value4 = real(value, kind=r4) - - if (xtype == pio_double) then - status = PIO_put_att(ncid,varid,trim(attrib),value) - else - status = PIO_put_att(ncid,varid,trim(attrib),value4) - endif - - end subroutine ncd_putatt_real - -!----------------------------------------------------------------------- - - subroutine ncd_defdim(ncid,attrib,value,dimid) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! define dimension - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(in) :: ncid ! netcdf file id - character(len=*) , intent(in) :: attrib ! netcdf attrib - integer , intent(in) :: value ! netcdf attrib value - integer , intent(out):: dimid ! netcdf dimension id - ! - ! !LOCAL VARIABLES: - integer :: status - !----------------------------------------------------------------------- - - status = pio_def_dim(ncid,attrib,value,dimid) - - end subroutine ncd_defdim - -!----------------------------------------------------------------------- - - subroutine ncd_defvar_bynf(ncid, varname, xtype, ndims, dimid, varid, & - long_name, units, cell_method, missing_value, fill_value, & - imissing_value, ifill_value, comment, flag_meanings, & - flag_values, nvalid_range ) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Define a netcdf variable - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: varname ! variable name - integer , intent(in) :: xtype ! external type - integer , intent(in) :: ndims ! number of dims - integer , intent(inout) :: varid ! returned var id - integer , intent(in), optional :: dimid(:) ! dimids - character(len=*) , intent(in), optional :: long_name ! attribute - character(len=*) , intent(in), optional :: units ! attribute - character(len=*) , intent(in), optional :: cell_method ! attribute - character(len=*) , intent(in), optional :: comment ! attribute - character(len=*) , intent(in), optional :: flag_meanings(:) ! attribute - real(r8) , intent(in), optional :: missing_value ! attribute for real - real(r8) , intent(in), optional :: fill_value ! attribute for real - integer , intent(in), optional :: imissing_value ! attribute for int - integer , intent(in), optional :: ifill_value ! attribute for int - integer , intent(in), optional :: flag_values(:) ! attribute for int - integer , intent(in), optional :: nvalid_range(2) ! attribute for int - - ! - ! !LOCAL VARIABLES: - integer :: n ! indices - integer :: ldimid(4) ! local dimid - integer :: dimid0(1) ! local dimid - integer :: status ! error status - integer :: lxtype ! local external type (in case logical variable) - type(var_desc_t) :: vardesc ! local vardesc - character(len=255) :: dimname ! temporary - character(len=256) :: str ! temporary - character(len=*),parameter :: subname='ncd_defvar_bynf' ! subroutine name - !----------------------------------------------------------------------- - - varid = -1 - - dimid0 = 0 - ldimid = 0 - if (present(dimid)) then - ldimid(1:ndims) = dimid(1:ndims) - else ! ndims must be zero if dimid not present - if (ndims /= 0) then - write(iulog,*) subname//' ERROR: dimid not supplied and ndims ne 0 ',trim(varname),ndims - call shr_sys_abort() - endif - endif - - if ( xtype == ncd_log )then - lxtype = ncd_int - else - lxtype = xtype - end if - if (mainproc .and. debug > 1) then - write(iulog,*) 'Error in defining variable = ', trim(varname) - write(iulog,*) subname//' ',trim(varname),lxtype,ndims,ldimid(1:ndims) - endif - - if (ndims > 0) then - status = pio_inq_dimname(ncid,ldimid(ndims),dimname) - end if - - ! Define variable - if (present(dimid)) then - status = PIO_def_var(ncid,trim(varname),lxtype,dimid(1:ndims),vardesc) - else - status = PIO_def_var(ncid,trim(varname),lxtype,dimid0 ,vardesc) - endif - varid = vardesc%varid - ! - ! Add attributes - ! - if (present(long_name)) then - call ncd_putatt(ncid, varid, 'long_name', trim(long_name)) - end if - if (present(flag_values)) then - status = PIO_put_att(ncid,varid,'flag_values',flag_values) - if ( .not. present(flag_meanings)) then - write(iulog,*) 'Error in defining variable = ', trim(varname) - call shr_sys_abort( subname//" ERROR:: flag_values set -- but not flag_meanings" ) - end if - end if - if (present(flag_meanings)) then - if ( .not. present(flag_values)) then - write(iulog,*) 'Error in defining variable = ', trim(varname) - call shr_sys_abort( subname//" ERROR:: flag_meanings set -- but not flag_values" ) - end if - if ( size(flag_values) /= size(flag_meanings) ) then - write(iulog,*) 'Error in defining variable = ', trim(varname) - call shr_sys_abort( subname//" ERROR:: flag_meanings and flag_values dimension different") - end if - str = flag_meanings(1) - do n = 1, size(flag_meanings) - if ( index(flag_meanings(n), ' ') /= 0 )then - write(iulog,*) 'Error in defining variable = ', trim(varname) - call shr_sys_abort( subname//" ERROR:: flag_meanings has an invalid space in it" ) - end if - if ( n > 1 ) str = trim(str)//" "//flag_meanings(n) - end do - status = PIO_put_att(ncid,varid,'flag_meanings', trim(str) ) - end if - if (present(comment)) then - call ncd_putatt(ncid, varid, 'comment', trim(comment)) - end if - if (present(units)) then - call ncd_putatt(ncid, varid, 'units', trim(units)) - end if - if (present(cell_method)) then - str = 'time: ' // trim(cell_method) - call ncd_putatt(ncid, varid, 'cell_methods', trim(str)) - end if - if (present(fill_value)) then - call ncd_putatt(ncid, varid, '_FillValue', fill_value, lxtype) - end if - if (present(missing_value)) then - call ncd_putatt(ncid, varid, 'missing_value', missing_value, lxtype) - end if - if (present(ifill_value)) then - call ncd_putatt(ncid, varid, '_FillValue', ifill_value, lxtype) - end if - if (present(imissing_value)) then - call ncd_putatt(ncid, varid, 'missing_value', imissing_value, lxtype) - end if - if (present(nvalid_range)) then - status = PIO_put_att(ncid,varid,'valid_range', nvalid_range ) - end if - if ( xtype == ncd_log )then - status = PIO_put_att(ncid,varid,'flag_values', (/0, 1/) ) - status = PIO_put_att(ncid,varid,'flag_meanings', "FALSE TRUE" ) - status = PIO_put_att(ncid,varid,'valid_range', (/0, 1/) ) - end if - - end subroutine ncd_defvar_bynf - -!----------------------------------------------------------------------- - - subroutine ncd_defvar_bygrid(ncid, varname, xtype, & - dim1name, dim2name, dim3name, dim4name, dim5name, & - long_name, units, cell_method, missing_value, fill_value, & - imissing_value, ifill_value, comment, & - flag_meanings, flag_values, nvalid_range ) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! Define a netcdf variable - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*), intent(in) :: varname ! variable name - integer , intent(in) :: xtype ! external type - character(len=*), intent(in), optional :: dim1name ! dimension name - character(len=*), intent(in), optional :: dim2name ! dimension name - character(len=*), intent(in), optional :: dim3name ! dimension name - character(len=*), intent(in), optional :: dim4name ! dimension name - character(len=*), intent(in), optional :: dim5name ! dimension name - character(len=*), intent(in), optional :: long_name ! attribute - character(len=*), intent(in), optional :: units ! attribute - character(len=*), intent(in), optional :: cell_method ! attribute - character(len=*), intent(in), optional :: comment ! attribute - character(len=*), intent(in), optional :: flag_meanings(:) ! attribute - real(r8) , intent(in), optional :: missing_value ! attribute for real - real(r8) , intent(in), optional :: fill_value ! attribute for real - integer , intent(in), optional :: imissing_value ! attribute for int - integer , intent(in), optional :: ifill_value ! attribute for int - integer , intent(in), optional :: flag_values(:) ! attribute for int - integer , intent(in), optional :: nvalid_range(2) ! attribute for int - ! - ! !REVISION HISTORY: - ! - ! - ! !LOCAL VARIABLES: - !EOP - integer :: n ! indices - integer :: ndims ! dimension counter - integer :: dimid(5) ! dimension ids - integer :: varid ! variable id - integer :: itmp ! temporary - character(len=256) :: str ! temporary - character(len=*),parameter :: subname='ncd_defvar_bygrid' ! subroutine name - !----------------------------------------------------------------------- - - dimid(:) = 0 - - ! Determine dimension ids for variable - - if (present(dim1name)) call ncd_inqdid(ncid, dim1name, dimid(1)) - if (present(dim2name)) call ncd_inqdid(ncid, dim2name, dimid(2)) - if (present(dim3name)) call ncd_inqdid(ncid, dim3name, dimid(3)) - if (present(dim4name)) call ncd_inqdid(ncid, dim4name, dimid(4)) - if (present(dim5name)) call ncd_inqdid(ncid, dim5name, dimid(5)) - - ! Permute dim1 and dim2 if necessary - - ! Define variable - - ndims = 0 - if (present(dim1name)) then - do n = 1, size(dimid) - if (dimid(n) /= 0) ndims = ndims + 1 - end do - end if - - call ncd_defvar_bynf(ncid,varname,xtype,ndims,dimid,varid, & - long_name=long_name, units=units, cell_method=cell_method, & - missing_value=missing_value, fill_value=fill_value, & - imissing_value=imissing_value, ifill_value=ifill_value, & - comment=comment, flag_meanings=flag_meanings, & - flag_values=flag_values, nvalid_range=nvalid_range ) - - end subroutine ncd_defvar_bygrid - -!------------------------------------------------------------------------ - - subroutine ncd_io_log_var0_nf(varname, data, flag, ncid, readvar, nt) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! netcdf I/O of global integer variable - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - character(len=*) , intent(in) :: varname ! variable name - logical , intent(inout) :: data ! raw data - logical, optional, intent(out) :: readvar ! was var read? - integer, optional, intent(in) :: nt ! time sample index - ! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: start(1), count(1) ! output bounds - integer :: status ! error code - integer :: idata ! raw integer data - logical :: varpresent ! if true, variable is on tape - integer :: temp(1) ! temporary - character(len=32) :: vname ! variable error checking - type(var_desc_t) :: vardesc ! local vardesc pointer - character(len=*),parameter :: subname='ncd_io_log_var0_nf' - !----------------------------------------------------------------------- - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - status = pio_get_var(ncid, varid, idata) - if ( idata == 0 )then - data = .false. - else if ( idata == 1 )then - data = .true. - else - call shr_sys_abort( subname// & - ' ERROR: bad integer value for logical data' ) - end if - endif - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - call ncd_inqvid (ncid, varname, varid, vardesc) - if ( data )then - temp(1) = 1 - else - temp(1) = 0 - end if - if (present(nt)) then - start(1) = nt - count(1) = 1 - status = pio_put_var(ncid, varid, start, count, temp) - else - status = pio_put_var(ncid, varid, temp(1)) - end if - - - endif ! flag - - end subroutine ncd_io_log_var0_nf - -!------------------------------------------------------------------------ - - subroutine ncd_io_int_var0_nf(varname, data, flag, ncid, readvar, nt) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! netcdf I/O of global integer variable - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - character(len=*) , intent(in) :: varname ! variable name - integer , intent(inout) :: data ! raw data - logical, optional, intent(out) :: readvar ! was var read? - integer, optional, intent(in) :: nt ! time sample index - ! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: start(1), count(1) ! output bounds - integer :: status ! error code - logical :: varpresent ! if true, variable is on tape - integer :: temp(1) ! temporary - character(len=32) :: vname ! variable error checking - type(var_desc_t) :: vardesc ! local vardesc pointer - character(len=*),parameter :: subname='ncd_io_int_var0_nf' - !----------------------------------------------------------------------- - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - status = pio_get_var(ncid, varid, data) - endif - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - call ncd_inqvid (ncid, varname, varid, vardesc) - if (present(nt)) then - start(1) = nt - count(1) = 1 - temp(1) = data - status = pio_put_var(ncid, varid, start, count, temp) - else - status = pio_put_var(ncid, varid, data) - end if - - endif ! flag - - end subroutine ncd_io_int_var0_nf - -!------------------------------------------------------------------------ - - subroutine ncd_io_real_var0_nf(varname, data, flag, ncid, readvar, nt) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! netcdf I/O of global real variable - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - character(len=*) , intent(in) :: varname ! variable name - real(r8) , intent(inout) :: data ! raw data - logical, optional, intent(out) :: readvar ! was var read? - integer, optional, intent(in) :: nt ! time sample index - ! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: start(1), count(1) ! output bounds - integer :: status ! error code - logical :: varpresent ! if true, variable is on tape - real(r8):: temp(1) ! temporary - character(len=32) :: vname ! variable error checking - type(var_desc_t) :: vardesc ! local vardesc pointer - character(len=*),parameter :: subname='ncd_io_real_var0_nf' - !----------------------------------------------------------------------- - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - status = pio_get_var(ncid, vardesc, data) - endif - if (present(readvar)) readvar = varpresent - - else if (flag == 'write') then - - call ncd_inqvid (ncid, varname, varid, vardesc) - if (present(nt)) then - start(1) = nt - count(1) = 1 - temp(1) = data - status = pio_put_var(ncid, varid, start, count, temp) - else - status = pio_put_var(ncid, varid, data) - end if - - endif ! flag - - end subroutine ncd_io_real_var0_nf - -!------------------------------------------------------------------------ - - subroutine ncd_io_int_var1_nf(varname, data, flag, ncid, readvar, nt) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! netcdf I/O of global integer array - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - character(len=*) , intent(in) :: varname ! variable name - integer , intent(inout) :: data(:) ! raw data - logical, optional, intent(out) :: readvar ! was var read? - integer, optional, intent(in) :: nt ! time sample index - ! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: start(2), count(2) ! output bounds - integer :: status ! error code - logical :: varpresent ! if true, variable is on tape - character(len=32) :: vname ! variable error checking - type(var_desc_t) :: vardesc ! local vardesc pointer - character(len=*),parameter :: subname='ncd_io_int_var1_nf' - integer :: ndims - !----------------------------------------------------------------------- - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - status = pio_get_var(ncid, varid, data) - endif - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - if (present(nt)) then - start(1) = 1 - count(1) = size(data) - start(2) = nt - count(2) = 1 - ndims = 2 - else - start(1) = 1 - count(1) = size(data) - start(2) = 1 - count(2) = 1 - ndims = 1 - end if - call ncd_inqvid (ncid, varname, varid, vardesc) - status = pio_put_var(ncid, varid, start(1:ndims), count(1:ndims), data) - - endif ! flag - - end subroutine ncd_io_int_var1_nf - -!------------------------------------------------------------------------ - - subroutine ncd_io_log_var1_nf(varname, data, flag, ncid, readvar, nt) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! netcdf I/O of global integer array - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - character(len=*) , intent(in) :: varname ! variable name - logical , intent(inout) :: data(:) ! raw data - logical, optional, intent(out) :: readvar ! was var read? - integer, optional, intent(in) :: nt ! time sample index - ! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: start(2), count(2) ! output bounds - integer :: status ! error code - integer, pointer :: idata(:) ! Temporary integer data to send to file - logical :: varpresent ! if true, variable is on tape - character(len=32) :: vname ! variable error checking - type(var_desc_t) :: vardesc ! local vardesc pointer - character(len=*),parameter :: subname='ncd_io_log_var1_nf' - !----------------------------------------------------------------------- - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - allocate( idata(size(data)) ) - status = pio_get_var(ncid, varid, idata) - data = (idata == 1) - if ( any(idata /= 0 .and. idata /= 1) )then - call shr_sys_abort(subname//'ERROR: read in bad integer value(s) for logical data') - end if - deallocate( idata ) - endif - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - if (present(nt)) then - start(1) = 1 - count(1) = size(data) - start(2) = nt - count(2) = 1 - else - start(1) = 1 - count(1) = size(data) - start(2) = 1 - count(2) = 1 - end if - call ncd_inqvid (ncid, varname, varid, vardesc) - allocate( idata(size(data)) ) - where( data ) - idata = 1 - elsewhere - idata = 0 - end where - status = pio_put_var(ncid, varid, start, count, idata) - deallocate( idata ) - - endif ! flag - - end subroutine ncd_io_log_var1_nf - -!------------------------------------------------------------------------ - - subroutine ncd_io_real_var1_nf(varname, data, flag, ncid, readvar, nt) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! netcdf I/O of global real array - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - character(len=*) , intent(in) :: varname ! variable name - real(r8) , intent(inout) :: data(:) ! raw data - logical , optional, intent(out):: readvar ! was var read? - integer , optional, intent(in) :: nt ! time sample index - ! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: start(2), count(2) ! output bounds - integer :: status ! error code - logical :: varpresent ! if true, variable is on tape - character(len=32) :: vname ! variable error checking - type(var_desc_t) :: vardesc ! local vardesc pointer - character(len=*),parameter :: subname='ncd_io_real_var1_nf' - integer :: ndims - !----------------------------------------------------------------------- - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - status = pio_get_var(ncid, varid, data) - endif - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - if (present(nt)) then - start(1) = 1 - start(2) = nt - count(1) = size(data) - count(2) = 1 - ndims = 2 - else - start(1) = 1 - start(2) = 1 - count(1) = size(data) - count(2) = 1 - ndims = 1 - end if - call ncd_inqvid (ncid, varname, varid, vardesc) - status = pio_put_var(ncid, varid, start(1:ndims), count(1:ndims), data) - - endif ! flag - - end subroutine ncd_io_real_var1_nf - -!------------------------------------------------------------------------ - - subroutine ncd_io_char_var1_nf(varname, data, flag, ncid, readvar, nt ) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! netcdf I/O of global char array - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - character(len=*) , intent(in) :: varname ! variable name - character(len=*) , intent(inout) :: data ! raw data - logical , optional, intent(out):: readvar ! was var read? - integer , optional, intent(in) :: nt ! time sample index - ! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: m ! indices - integer :: status ! error code - logical :: varpresent ! if true, variable is on tape - character(len=32) :: vname ! variable error checking - character(len=1) :: tmpString(255)! temp for manipulating output string - type(var_desc_t) :: vardesc ! local vardesc pointer - character(len=*),parameter :: subname='ncd_io_char_var1_nf' - !----------------------------------------------------------------------- - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - status = pio_get_var(ncid, varid, data) - endif - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - call ncd_inqvid (ncid, varname, varid, vardesc) - - if (present(nt)) then - status = pio_put_var(ncid, varid, (/1,nt/), ival=data) - else - status = pio_put_var(ncid, varid, data ) - end if - - endif ! flag - - end subroutine ncd_io_char_var1_nf - -!------------------------------------------------------------------------ - - subroutine ncd_io_int_var2_nf(varname, data, flag, ncid, readvar, nt) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! netcdf I/O of global integer 2D array - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - character(len=*) , intent(in) :: varname ! variable name - integer , intent(inout) :: data(:,:) ! raw data - logical , optional, intent(out):: readvar ! was var read? - integer , optional, intent(in) :: nt ! time sample index - ! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: start(3), count(3) ! output bounds - integer :: status ! error code - logical :: varpresent ! if true, variable is on tape - character(len=32) :: vname ! variable error checking - type(var_desc_t) :: vardesc ! local vardesc pointer - logical :: found ! if true, found lat/lon dims on file - character(len=*),parameter :: subname='ncd_io_int_var2_nf' - integer :: ndims - !----------------------------------------------------------------------- - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - status = pio_get_var(ncid, varid, data) - endif - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - if (present(nt)) then - start(1) = 1 - start(2) = 1 - start(3) = nt - count(1) = size(data, dim=1) - count(2) = size(data, dim=2) - count(3) = 1 - ndims = 3 - else - start(1) = 1 - start(2) = 1 - start(3) = 1 - count(1) = size(data, dim=1) - count(2) = size(data, dim=2) - count(3) = 1 - ndims = 2 - end if - call ncd_inqvid(ncid, varname, varid, vardesc) - status = pio_put_var(ncid, varid, start(1:ndims), count(1:ndims), data) - - endif - - end subroutine ncd_io_int_var2_nf - -!------------------------------------------------------------------------ - - subroutine ncd_io_real_var2_nf(varname, data, flag, ncid, readvar, nt) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! netcdf I/O of global real 2D array - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t),intent(inout) :: ncid ! netcdf file id - character(len=*), intent(in) :: flag ! 'read' or 'write' - character(len=*), intent(in) :: varname ! variable name - real(r8) , intent(inout) :: data(:,:) ! raw data - logical , optional, intent(out):: readvar ! was var read? - integer , optional, intent(in) :: nt ! time sample index - ! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: start(3), count(3) ! output bounds - integer :: status ! error code - logical :: varpresent ! if true, variable is on tape - character(len=32) :: vname ! variable error checking - type(var_desc_t) :: vardesc ! local vardesc pointer - logical :: found ! if true, found lat/lon dims on file - character(len=*),parameter :: subname='ncd_io_real_var2_nf' - !----------------------------------------------------------------------- - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - status = pio_get_var(ncid, varid, data) - endif - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - if (present(nt)) then - start(1) = 1 - start(2) = 1 - start(3) = nt - count(1) = size(data, dim=1) - count(2) = size(data, dim=2) - count(3) = 1 - else - start(1) = 1 - start(2) = 1 - start(3) = 1 - count(1) = size(data, dim=1) - count(2) = size(data, dim=2) - count(3) = 1 - end if - call ncd_inqvid (ncid, varname, varid, vardesc) - status = pio_put_var(ncid, varid, start, count, data) - - endif - - end subroutine ncd_io_real_var2_nf - -!------------------------------------------------------------------------ - - subroutine ncd_io_char_var2_nf(varname, data, flag, ncid, readvar, nt) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! netcdf I/O of global character array - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t),intent(inout) :: ncid ! netcdf file id - character(len=*), intent(in) :: flag ! 'read' or 'write' - character(len=*), intent(in) :: varname ! variable name - character(len=*), intent(inout) :: data(:) ! raw data - logical , optional, intent(out):: readvar ! was var read? - integer , optional, intent(in) :: nt ! time sample index - ! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: start(3), count(3) ! output bounds - integer :: status ! error code - logical :: varpresent ! if true, variable is on tape - character(len=32) :: vname ! variable error checking - type(var_desc_t) :: vardesc ! local vardesc pointer - logical :: found ! if true, found lat/lon dims on file - character(len=*),parameter :: subname='ncd_io_char_var2_nf' - !----------------------------------------------------------------------- - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - data = ' ' - status = pio_get_var(ncid, varid, data) - endif - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - call ncd_inqvid (ncid, varname, varid, vardesc) - if (present(nt)) then - start(1) = 1 - start(2) = 1 - start(3) = nt - count(1) = size(data) - count(2) = len(data) - count(3) = 1 - status = pio_put_var(ncid, varid, start, count, data) - else - status = pio_put_var(ncid, varid, data) - end if - - endif - - end subroutine ncd_io_char_var2_nf - - !------------------------------------------------------------------------ - !BOP - ! - ! !IROUTINE: ncd_io_char_varn_strt_nf - ! - ! !INTERFACE: - subroutine ncd_io_char_varn_strt_nf(vardesc, data, flag, ncid, & - start ) - ! - ! !DESCRIPTION: - ! netcdf I/O of global character array with start indices input - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t),intent(inout) :: ncid ! netcdf file id - character(len=*), intent(in) :: flag ! 'read' or 'write' - type(var_desc_t), intent(in) :: vardesc ! local vardesc pointer - character(len=*), intent(inout) :: data ! raw data for this index - integer , intent(in) :: start(:) ! output bounds - ! - ! !REVISION HISTORY: - ! - ! - ! !LOCAL VARIABLES: - !EOP - integer :: status ! error code - character(len=*),parameter :: subname='ncd_io_char_varn_strt_nf' - !----------------------------------------------------------------------- - - if (flag == 'read') then - status = pio_get_var(ncid, vardesc, start, data ) - elseif (flag == 'write') then - status = pio_put_var(ncid, vardesc, start, data ) - endif - - end subroutine ncd_io_char_varn_strt_nf - -!----------------------------------------------------------------------- - - subroutine ncd_io_int_var1(varname, data, dim1name, flag, ncid, nt, readvar) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! I/O for 1d integer field - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - character(len=*) , intent(in) :: varname ! variable name - integer , pointer :: data(:) ! local decomposition data - character(len=*) , intent(in) :: dim1name ! dimension name - integer , optional, intent(in) :: nt ! time sample index - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) - ! !LOCAL VARIABLES: - character(len=32) :: dimname ! temporary - integer :: n ! index - integer :: iodnum ! iodesc num in list - integer :: varid ! varid - integer :: ndims ! ndims for var - integer :: ndims_iod ! ndims iodesc for var - integer :: dims(4) ! dim sizes - integer :: dids(4) ! dim ids - integer :: start(3) ! netcdf start index - integer :: count(3) ! netcdf count index - integer :: status ! error code - logical :: varpresent ! if true, variable is on tape - integer :: xtype ! netcdf data type - integer , pointer :: compDOF(:) - type(iodesc_plus_type) , pointer :: iodesc_plus - type(var_desc_t) :: vardesc - character(len=*),parameter :: subname='ncd_io_int_var1' ! subroutine name - !----------------------------------------------------------------------- - - if (mainproc .and. debug > 1) then - write(iulog,*) subname//' ',trim(flag),' ',trim(varname),' ',trim(dim1name) - end if - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - status = pio_inq_varndims(ncid, vardesc, ndims) - status = pio_inq_vardimid(ncid, vardesc, dids) - status = pio_inq_vartype (ncid, vardesc, xtype) - status = pio_inq_dimname(ncid,dids(ndims),dimname) - if ('time' == trim(dimname)) then - ndims_iod = ndims - 1 - else - ndims_iod = ndims - end if - do n = 1,ndims_iod - status = pio_inq_dimlen(ncid,dids(n),dims(n)) - enddo - call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & - xtype, iodnum) - iodesc_plus => iodesc_list(iodnum) - if (present(nt)) then - call pio_setframe(ncid,vardesc, int(nt,kind=PIO_Offset_kind)) - end if - call pio_read_darray(ncid, vardesc, iodesc_plus%iodesc, data, status) - end if - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - call ncd_inqvid(ncid, varname ,varid, vardesc) - status = pio_inq_varndims(ncid, vardesc, ndims) - status = pio_inq_vardimid(ncid, vardesc, dids) - status = pio_inq_vartype (ncid, vardesc, xtype) - status = pio_inq_dimname(ncid,dids(ndims),dimname) - if ('time' == trim(dimname)) then - ndims_iod = ndims - 1 - else - ndims_iod = ndims - end if - do n = 1,ndims_iod - status = pio_inq_dimlen(ncid,dids(n),dims(n)) - enddo - call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & - xtype, iodnum) - iodesc_plus => iodesc_list(iodnum) - if (present(nt)) then - call pio_setframe(ncid, vardesc, int(nt,kind=PIO_Offset_kind)) - end if - call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, data, status, fillval=ispval) - - else - - if (mainproc) then - write(iulog,*) subname//' ERROR: unsupported flag ',trim(flag) - call shr_sys_abort() - endif - - endif - - end subroutine ncd_io_int_var1 - -!----------------------------------------------------------------------- - - subroutine ncd_io_log_var1(varname, data, dim1name, & - flag, ncid, nt, readvar) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! I/O for 1d integer field - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - character(len=*) , intent(in) :: varname ! variable name - logical , pointer :: data(:) ! local decomposition data - character(len=*) , intent(in) :: dim1name ! dimension name - integer , optional, intent(in) :: nt ! time sample index - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) - ! !LOCAL VARIABLES: - character(len=32) :: dimname ! temporary - integer :: n ! index - integer :: iodnum ! iodesc num in list - integer :: varid ! varid - integer :: ndims ! ndims for var - integer :: ndims_iod ! ndims iodesc for var - integer :: dims(4) ! dim sizes - integer :: dids(4) ! dim ids - integer :: start(3) ! netcdf start index - integer :: count(3) ! netcdf count index - integer :: status ! error code - integer, pointer :: idata(:) ! Temporary integer data to send to file - logical :: varpresent ! if true, variable is on tape - integer :: xtype ! netcdf data type - integer , pointer :: compDOF(:) - type(iodesc_plus_type) , pointer :: iodesc_plus - type(var_desc_t) :: vardesc - character(len=*),parameter :: subname='ncd_io_log_var1' ! subroutine name - !----------------------------------------------------------------------- - - if (mainproc .and. debug > 1) then - write(iulog,*) subname//' ',trim(flag),' ',trim(varname) - end if - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - allocate( idata(size(data)) ) - status = pio_inq_varndims(ncid, vardesc, ndims) - status = pio_inq_vardimid(ncid, vardesc, dids) - status = pio_inq_vartype (ncid, vardesc, xtype) - status = pio_inq_dimname(ncid,dids(ndims),dimname) - if ('time' == trim(dimname)) then - ndims_iod = ndims - 1 - else - ndims_iod = ndims - end if - do n = 1,ndims_iod - status = pio_inq_dimlen(ncid,dids(n),dims(n)) - enddo - call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & - xtype, iodnum) - iodesc_plus => iodesc_list(iodnum) - if (present(nt)) then - call pio_setframe(ncid,vardesc, int(nt,kind=PIO_Offset_kind)) - end if - call pio_read_darray(ncid, vardesc, iodesc_plus%iodesc, idata, status) - data = (idata == 1) - if ( any(idata /= 0 .and. idata /= 1) )then - call shr_sys_abort( subname//' ERROR: read in bad integer value(s) for logical data' ) - end if - deallocate( idata ) - end if - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - call ncd_inqvid(ncid, varname ,varid, vardesc) - status = pio_inq_varndims(ncid, vardesc, ndims) - status = pio_inq_vardimid(ncid, vardesc, dids) - status = pio_inq_vartype (ncid, vardesc, xtype) - status = pio_inq_dimname(ncid,dids(ndims),dimname) - if ('time' == trim(dimname)) then - ndims_iod = ndims - 1 - else - ndims_iod = ndims - end if - do n = 1,ndims_iod - status = pio_inq_dimlen(ncid,dids(n),dims(n)) - enddo - call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & - xtype, iodnum) - iodesc_plus => iodesc_list(iodnum) - if (present(nt)) then - call pio_setframe(ncid, vardesc, int(nt,kind=PIO_Offset_kind)) - end if - allocate( idata(size(data)) ) - where( data ) - idata = 1 - elsewhere - idata = 0 - end where - call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, idata, status, fillval=0) - deallocate( idata ) - - else - - if (mainproc) then - write(iulog,*) subname//' ERROR: unsupported flag ',trim(flag) - call shr_sys_abort() - endif - - endif - - end subroutine ncd_io_log_var1 - !----------------------------------------------------------------------- - subroutine ncd_io_real_var1(varname, data, dim1name, & - flag, ncid, nt, readvar) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! I/O for 1d real field - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t),intent(inout) :: ncid ! netcdf file id - character(len=*), intent(in) :: flag ! 'read' or 'write' - character(len=*), intent(in) :: varname ! variable name - real(r8) , pointer :: data(:) ! local decomposition data - character(len=*), intent(in) :: dim1name ! dimension name - integer , optional, intent(in) :: nt ! time sample index - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) - ! !LOCAL VARIABLES: - character(len=32) :: dimname ! temporary - integer :: iodnum ! iodesc num in list - integer :: varid ! varid - integer :: ndims ! ndims for var - integer :: ndims_iod ! ndims iodesc for var - integer :: n ! index - integer :: dims(4) ! dim sizes - integer :: dids(4) ! dim ids - integer :: start(3) ! netcdf start index - integer :: count(3) ! netcdf count index - integer :: status ! error code - logical :: varpresent ! if true, variable is on tape - integer :: xtype ! netcdf data type - integer , pointer :: compDOF(:) - type(iodesc_plus_type) , pointer :: iodesc_plus - type(var_desc_t) :: vardesc - character(len=*),parameter :: subname='ncd_io_real_var1' ! subroutine name - !----------------------------------------------------------------------- - - if (mainproc .and. debug > 1) then - write(iulog,*) trim(subname),' ',trim(flag),' ',trim(varname) - endif - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - status = pio_inq_varndims(ncid, vardesc, ndims) - status = pio_inq_vardimid(ncid,vardesc, dids) - status = pio_inq_vartype(ncid, vardesc, xtype) - status = pio_inq_dimname(ncid,dids(ndims),dimname) - if ('time' == trim(dimname)) then - ndims_iod = ndims - 1 - else - ndims_iod = ndims - end if - do n = 1,ndims_iod - status = pio_inq_dimlen(ncid,dids(n),dims(n)) - enddo - call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & - xtype, iodnum) - iodesc_plus => iodesc_list(iodnum) - if (present(nt)) then - call pio_setframe(ncid, vardesc, int(nt,kind=PIO_Offset_kind)) - end if - call pio_read_darray(ncid, vardesc, iodesc_plus%iodesc, data, status) - end if - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - call ncd_inqvid(ncid, varname ,varid, vardesc) - status = pio_inq_varndims(ncid, vardesc, ndims) - status = pio_inq_vardimid(ncid, vardesc, dids) - status = pio_inq_vartype (ncid, vardesc, xtype) - status = pio_inq_dimname(ncid,dids(ndims),dimname) - if ('time' == trim(dimname)) then - ndims_iod = ndims - 1 - else - ndims_iod = ndims - end if - do n = 1,ndims_iod - status = pio_inq_dimlen(ncid,dids(n),dims(n)) - enddo - call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & - xtype, iodnum) - iodesc_plus => iodesc_list(iodnum) - if (present(nt)) then - call pio_setframe(ncid,vardesc, int(nt,kind=PIO_Offset_kind)) - end if - if(xtype == ncd_float) then - call shr_sys_abort( subname//' error: Attempt to write out single-precision data which is current NOT implemented (see issue #18)' ) - else - call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, data, status, fillval=spval) - endif - else - - if (mainproc) then - write(iulog,*) subname,' error: unsupported flag ',trim(flag) - call shr_sys_abort() - endif - - endif - - end subroutine ncd_io_real_var1 - -!------------------------------------------------------------------------ - - subroutine ncd_getiodesc(ncid, ndims, dims, dimids, xtype, iodnum) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! Returns an index to an io descriptor - ! - ! !ARGUMENTS: - type(file_desc_t), intent(inout) :: ncid ! PIO file descriptor - integer , intent(in) :: ndims ! ndims for var - integer , intent(in) :: dims(:) ! dim sizes - integer , intent(in) :: dimids(:) ! dim ids - integer , intent(in) :: xtype ! file external type - integer , intent(out) :: iodnum ! iodesc num in list - ! !LOCAL VARIABLES: - integer :: k,m,n,cnt ! indices - integer :: lsize ! local size - integer :: gsize ! global size - integer :: status ! error status - logical :: found ! true => found created iodescriptor - integer :: ndims_file ! temporary - character(len=64) dimname_file ! dimension name on file - character(len=64) dimname_iodesc ! dimension name from io descriptor - integer, pointer :: compDOF(:) - character(len=32) :: subname = 'ncd_getiodesc' - !------------------------------------------------------------------------ - - ! Determining if need to create a new io descriptor - - n = 1 - found = .false. - do while (n <= num_iodesc .and. .not.found) - if (ndims == iodesc_list(n)%ndims .and. xtype == iodesc_list(n)%type) then - found = .true. - ! First found implies that dimension sizes are the same - do m = 1,ndims - if (dims(m) /= iodesc_list(n)%dims(m)) then - found = .false. - endif - enddo - ! If found - then also check that dimension names are equal - - ! dimension ids in iodescriptor are only used to query dimension - ! names associated with that iodescriptor - if (found) then - do m = 1,ndims - status = PIO_inq_dimname(ncid,dimids(m),dimname_file) - status = PIO_inquire(ncid, ndimensions=ndims_file) - if (iodesc_list(n)%dimids(m) > ndims_file) then - found = .false. - exit - else - status = PIO_inq_dimname(ncid,iodesc_list(n)%dimids(m),dimname_iodesc) - if (trim(dimname_file) .ne. trim(dimname_iodesc)) then - found = .false. - exit - end if - end if - end do - end if - if (found) then - iodnum = n - if (iodnum > num_iodesc) then - write(iulog,*) trim(subname),' ERROR: iodnum out of range ',iodnum,num_iodesc - call shr_sys_abort() - endif - RETURN - endif - endif - n = n + 1 - enddo - - ! Creating a new io descriptor - - if (ndims > 0) then - num_iodesc = num_iodesc + 1 - if (num_iodesc > max_iodesc) then - write(iulog,*) trim(subname),' ERROR num_iodesc gt max_iodesc ',max_iodesc - call shr_sys_abort() - endif - iodnum = num_iodesc - if (mainproc .and. debug > 1) then - write(iulog,*) trim(subname),' creating iodesc at iodnum,ndims,dims(1:ndims),xtype',& - iodnum,ndims,dims(1:ndims),xtype - endif - end if - - ! Initialize the decomposition for PIO - - gsize = rtmCTL%numr - lsize = rtmCTL%lnumr - allocate(compDOF(lsize)) - cnt = 0 - do m = rtmCTL%begr, rtmCTL%endr - cnt = cnt + 1 - compDOF(cnt) = rtmCTL%gindex(m) - enddo - if (debug > 1) then - do m = 0,npes-1 - if (iam == m) then - write(iulog,*) trim(subname),' sizes1 = ',iam,gsize,lsize,npes - write(iulog,*) trim(subname),' compDOF = ',iam,size(compDOF),minval(compDOF),maxval(compDOF) - call shr_sys_flush(iulog) - endif - call mpi_barrier(mpicom_rof,status) - enddo - endif - call pio_initdecomp(pio_subsystem, xTYPE, dims(1:ndims), compDOF, iodesc_list(iodnum)%iodesc) - deallocate(compDOF) - - iodesc_list(iodnum)%type = xtype - iodesc_list(iodnum)%ndims = ndims - iodesc_list(iodnum)%dims = 0 - iodesc_list(iodnum)%dims(1:ndims) = dims(1:ndims) - iodesc_list(iodnum)%dimids(1:ndims) = dimids(1:ndims) - - - end subroutine ncd_getiodesc - -end module RtmIO + subroutine ncd_pio_init(rofid) + + !----------------------------------------------------------------------- + ! Initialize mosart pio + ! + ! !ARGUMENTS: + integer, intent(in) :: rofid + + ! !LOCAL VARIABLES: + character(len=*),parameter :: subname='ncd_pio_init' ! subroutine name + !----------------------------------------------------------------------- + + PIO_subsystem => shr_pio_getiosys(rofid) + io_type = shr_pio_getiotype(rofid) + io_format = shr_pio_getioformat(rofid) + + end subroutine ncd_pio_init + + !----------------------------------------------------------------------- + + subroutine ncd_decomp_init(begr, endr, gsize, gindex) + + ! Initialize module variable compDOF used to set iodesc + + ! Arguments + integer, intent(in) :: begr + integer, intent(in) :: endr + integer, intent(in) :: gsize + integer, intent(in) :: gindex(begr:endr) + + ! Local variables + integer :: m + integer :: cnt + integer :: lsize + integer :: status ! error code + character(len=*),parameter :: subname='ncd_decomp_init' + !------------------------------------------------------ + + lsize = endr - begr + 1 + allocate(compDOF(lsize)) + cnt = 0 + do m = begr, endr + cnt = cnt + 1 + compDOF(cnt) = gindex(m) + enddo + if (debug > 1) then + do m = 0,npes-1 + if (iam == m) then + write(iulog,*) trim(subname),' sizes1 = ',& + iam,gsize,lsize,npes + write(iulog,*) trim(subname),' compDOF = ',& + iam,size(compDOF),minval(compDOF),maxval(compDOF) + endif + call mpi_barrier(mpicom_rof, status) + enddo + endif + + end subroutine ncd_decomp_init + + !----------------------------------------------------------------------- + + subroutine ncd_pio_openfile(file, fname, mode) + + !----------------------------------------------------------------------- + ! Open a NetCDF PIO file + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t), intent(inout) :: file ! Output PIO file handle + character(len=*) , intent(in) :: fname ! Input filename to open + integer , intent(in) :: mode ! file mode + ! !LOCAL VARIABLES: + integer :: ierr + character(len=*),parameter :: subname='ncd_pio_openfile' ! subroutine name + !----------------------------------------------------------------------- + + ierr = pio_openfile(pio_subsystem, file, io_type, fname, mode) + + if(ierr/= PIO_NOERR) then + call shr_sys_abort(subname//'ERROR: Failed to open file') + else if(pio_iotask_rank(pio_subsystem)==0 .and. mainproc) then + write(iulog,*) 'Opened existing file ', trim(fname), file%fh + end if + + end subroutine ncd_pio_openfile + + !----------------------------------------------------------------------- + + subroutine ncd_pio_closefile(file) + + !----------------------------------------------------------------------- + ! Close a NetCDF PIO file + ! + ! !ARGUMENTS: + type(file_desc_t), intent(inout) :: file ! PIO file handle to close + !----------------------------------------------------------------------- + + call pio_closefile(file) + + end subroutine ncd_pio_closefile + + !----------------------------------------------------------------------- + + subroutine ncd_pio_createfile(file, fname) + + !----------------------------------------------------------------------- + ! Create a new NetCDF file with PIO + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t), intent(inout) :: file ! PIO file descriptor + character(len=*), intent(in) :: fname ! File name to create + ! !LOCAL VARIABLES: + integer :: ierr + integer :: iomode + character(len=*),parameter :: subname='ncd_pio_createfile' ! subroutine name + !----------------------------------------------------------------------- + + + iomode = PIO_CLOBBER + if(io_type == PIO_IOTYPE_NETCDF .or. io_type == PIO_IOTYPE_PNETCDF) then + iomode = ior(iomode, io_format) + endif + ierr = pio_createfile(pio_subsystem, file, io_type, fname, iomode) + + if(ierr/= PIO_NOERR) then + call shr_sys_abort( subname//' ERROR: Failed to open file to write: '//trim(fname)) + else if(pio_iotask_rank(pio_subsystem)==0 .and. mainproc) then + write(iulog,*) 'Opened file ', trim(fname), ' to write', file%fh + end if + + end subroutine ncd_pio_createfile + + !----------------------------------------------------------------------- + + subroutine check_var(ncid, varname, vardesc, readvar, print_err ) + + !----------------------------------------------------------------------- + ! Check if variable is on netcdf file + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t), intent(inout) :: ncid ! PIO file descriptor + character(len=*) , intent(in) :: varname ! Varible name to check + type(Var_desc_t) , intent(out) :: vardesc ! Output variable descriptor + logical , intent(out) :: readvar ! If variable exists or not + logical, optional, intent(in) :: print_err ! If should print about error + ! !LOCAL VARIABLES: + integer :: ret ! return value + logical :: log_err ! if should log error + character(len=*),parameter :: subname='check_var' ! subroutine name + !----------------------------------------------------------------------- + + + if ( present(print_err) )then + log_err = print_err + else + log_err = .true. + end if + readvar = .true. + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + ret = PIO_inq_varid (ncid, varname, vardesc) + if (ret /= PIO_noerr) then + readvar = .false. + if (mainproc .and. log_err) & + write(iulog,*) subname//': variable ',trim(varname),' is not on dataset' + end if + call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + + end subroutine check_var + + !----------------------------------------------------------------------- + + subroutine check_dim(ncid, dimname, value) + + ! Validity check on dimension + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t),intent(in) :: ncid ! PIO file handle + character(len=*), intent(in) :: dimname ! Dimension name + integer, intent(in) :: value ! Expected dimension size + ! !LOCAL VARIABLES: + integer :: dimid, dimlen ! temporaries + integer :: status ! error code + character(len=*),parameter :: subname='check_dim' ! subroutine name + !----------------------------------------------------------------------- + + status = pio_inq_dimid (ncid, trim(dimname), dimid) + status = pio_inq_dimlen (ncid, dimid, dimlen) + if (dimlen /= value) then + write(iulog,*) subname//' ERROR: mismatch of input dimension ',dimlen, & + ' with expected value ',value,' for variable ',trim(dimname) + call shr_sys_abort() + end if + + end subroutine check_dim + + !----------------------------------------------------------------------- + + subroutine ncd_enddef(ncid) + + !----------------------------------------------------------------------- + ! enddef netcdf file + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t),intent(inout) :: ncid ! netcdf file id + ! !LOCAL VARIABLES: + integer :: status ! error status + character(len=*),parameter :: subname='ncd_enddef' ! subroutine name + !----------------------------------------------------------------------- + + status = PIO_enddef(ncid) + + end subroutine ncd_enddef + + !----------------------------------------------------------------------- + + subroutine ncd_inqdid(ncid,name,dimid,dimexist) + + !----------------------------------------------------------------------- + ! inquire on a dimension id + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t),intent(inout) :: ncid ! netcdf file id + character(len=*), intent(in) :: name ! dimension name + integer , intent(out):: dimid ! dimension id + logical,optional, intent(out):: dimexist ! if this dimension exists or not + ! !LOCAL VARIABLES: + integer :: status + !----------------------------------------------------------------------- + + if ( present(dimexist) )then + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + end if + status = PIO_inq_dimid(ncid,name,dimid) + if ( present(dimexist) )then + if ( status == PIO_NOERR)then + dimexist = .true. + else + dimexist = .false. + end if + call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + end if + + end subroutine ncd_inqdid + + !----------------------------------------------------------------------- + + subroutine ncd_inqdlen(ncid,dimid,len,name) + + !----------------------------------------------------------------------- + ! enddef netcdf file + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + integer , intent(inout) :: dimid ! dimension id + integer , intent(out) :: len ! dimension len + character(len=*), optional, intent(in) :: name ! dimension name + ! + ! !LOCAL VARIABLES: + integer :: status + !----------------------------------------------------------------------- + + if ( present(name) )then + call ncd_inqdid(ncid,name,dimid) + end if + len = -1 + status = PIO_inq_dimlen(ncid,dimid,len) + + end subroutine ncd_inqdlen + + !----------------------------------------------------------------------- + + subroutine ncd_inqdname(ncid,dimid,dname) + + !----------------------------------------------------------------------- + ! inquire dim name + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t), intent(in) :: ncid ! netcdf file id + integer , intent(in) :: dimid ! dimension id + character(len=*) , intent(out):: dname ! dimension name + ! !LOCAL VARIABLES: + integer :: status + !----------------------------------------------------------------------- + + status = PIO_inq_dimname(ncid,dimid,dname) + + end subroutine ncd_inqdname + + !----------------------------------------------------------------------- + + subroutine ncd_inqfdims(ncid, isgrid2d, ni, nj, ns) + + !----------------------------------------------------------------------- + ! !ARGUMENTS: + type(file_desc_t), intent(inout):: ncid + logical , intent(out) :: isgrid2d + integer , intent(out) :: ni + integer , intent(out) :: nj + integer , intent(out) :: ns + ! !LOCAL VARIABLES: + integer :: dimid ! netCDF id + integer :: ier ! error status + character(len=32) :: subname = 'surfrd_filedims' ! subroutine name + !----------------------------------------------------------------------- + + ni = 0 + nj = 0 + + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + ier = pio_inq_dimid (ncid, 'lon', dimid) + if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, ni) + ier = pio_inq_dimid (ncid, 'lat', dimid) + if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, nj) + + ier = pio_inq_dimid (ncid, 'lsmlon', dimid) + if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, ni) + ier = pio_inq_dimid (ncid, 'lsmlat', dimid) + if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, nj) + + ier = pio_inq_dimid (ncid, 'ni', dimid) + if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, ni) + ier = pio_inq_dimid (ncid, 'nj', dimid) + if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, nj) + + ier = pio_inq_dimid (ncid, 'gridcell', dimid) + if (ier == PIO_NOERR) then + ier = pio_inq_dimlen(ncid, dimid, ni) + if (ier == PIO_NOERR) nj = 1 + end if + + call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + + if (ni == 0 .or. nj == 0) then + write(iulog,*) trim(subname),' ERROR: ni,nj = ',ni,nj,' cannot be zero ' + call shr_sys_abort() + end if + + if (nj == 1) then + isgrid2d = .false. + else + isgrid2d = .true. + end if + + ns = ni*nj + + end subroutine ncd_inqfdims + + !----------------------------------------------------------------------- + + subroutine ncd_inqvid(ncid,name,varid,vardesc,readvar) + + !----------------------------------------------------------------------- + ! Inquire on a variable ID + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: name ! variable name + integer , intent(out) :: varid ! variable id + type(Var_desc_t) , intent(out) :: vardesc ! variable descriptor + logical, optional, intent(out) :: readvar ! does variable exist + ! !LOCAL VARIABLES: + integer :: ret ! return code + character(len=*),parameter :: subname='ncd_inqvid' ! subroutine name + !----------------------------------------------------------------------- + + if (present(readvar)) then + readvar = .false. + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + ret = PIO_inq_varid(ncid,name,vardesc) + if (ret /= PIO_noerr) then + if (mainproc) write(iulog,*) subname//': variable ',trim(name),' is not on dataset' + readvar = .false. + else + readvar = .true. + end if + call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + else + ret = PIO_inq_varid(ncid,name,vardesc) + endif + varid = vardesc%varid + + end subroutine ncd_inqvid + + !----------------------------------------------------------------------- + + subroutine ncd_inqvdims(ncid,ndims,vardesc) + + !----------------------------------------------------------------------- + ! inquire variable dimensions + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t), intent(in) :: ncid ! netcdf file id + integer , intent(out) :: ndims ! variable ndims + type(Var_desc_t) , intent(inout):: vardesc ! variable descriptor + ! + ! !LOCAL VARIABLES: + integer :: status + !----------------------------------------------------------------------- + + ndims = -1 + status = PIO_inq_varndims(ncid,vardesc,ndims) + + end subroutine ncd_inqvdims + + !----------------------------------------------------------------------- + + subroutine ncd_inqvname(ncid,varid,vname,vardesc) + + !----------------------------------------------------------------------- + ! inquire variable name + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t), intent(in) :: ncid ! netcdf file id + integer , intent(in) :: varid ! variable id + character(len=*) , intent(out) :: vname ! variable vname + type(Var_desc_t) , intent(inout):: vardesc ! variable descriptor + ! !LOCAL VARIABLES: + integer :: status + !----------------------------------------------------------------------- + + vname = '' + status = PIO_inq_varname(ncid,vardesc,vname) + + end subroutine ncd_inqvname + + !----------------------------------------------------------------------- + + subroutine ncd_inqvdids(ncid,dids,vardesc) + + !----------------------------------------------------------------------- + ! inquire variable dimension ids + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t),intent(in) :: ncid ! netcdf file id + integer ,intent(out) :: dids(:) ! variable dids + type(Var_desc_t),intent(inout):: vardesc ! variable descriptor + ! + ! !LOCAL VARIABLES: + integer :: status + !----------------------------------------------------------------------- + + dids = -1 + status = PIO_inq_vardimid(ncid,vardesc,dids) + + end subroutine ncd_inqvdids + + !----------------------------------------------------------------------- + subroutine ncd_putatt_int(ncid,varid,attrib,value,xtype) + + !----------------------------------------------------------------------- + ! put integer attributes + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t),intent(inout) :: ncid ! netcdf file id + integer ,intent(in) :: varid ! netcdf var id + character(len=*) ,intent(in) :: attrib ! netcdf attrib + integer ,intent(in) :: value ! netcdf attrib value + integer,optional ,intent(in) :: xtype ! netcdf data type + ! + ! !LOCAL VARIABLES: + integer :: status + !----------------------------------------------------------------------- + + status = PIO_put_att(ncid,varid,trim(attrib),value) + + end subroutine ncd_putatt_int + + !----------------------------------------------------------------------- + + subroutine ncd_putatt_char(ncid,varid,attrib,value,xtype) + + !----------------------------------------------------------------------- + ! put character attributes + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t),intent(inout) :: ncid ! netcdf file id + integer ,intent(in) :: varid ! netcdf var id + character(len=*) ,intent(in) :: attrib ! netcdf attrib + character(len=*) ,intent(in) :: value ! netcdf attrib value + integer,optional ,intent(in) :: xtype ! netcdf data type + ! + ! !LOCAL VARIABLES: + integer :: status + !----------------------------------------------------------------------- + + status = PIO_put_att(ncid,varid,trim(attrib),value) + + end subroutine ncd_putatt_char + + !----------------------------------------------------------------------- + + subroutine ncd_putatt_real(ncid,varid,attrib,value,xtype) + + !----------------------------------------------------------------------- + ! put real attributes + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t),intent(inout) :: ncid ! netcdf file id + integer ,intent(in) :: varid ! netcdf var id + character(len=*) ,intent(in) :: attrib ! netcdf attrib + real(r8) ,intent(in) :: value ! netcdf attrib value + integer ,intent(in) :: xtype ! netcdf data type + ! + ! !LOCAL VARIABLES: + integer :: status + real(r4) :: value4 + !----------------------------------------------------------------------- + + value4 = real(value, kind=r4) + + if (xtype == pio_double) then + status = PIO_put_att(ncid,varid,trim(attrib),value) + else + status = PIO_put_att(ncid,varid,trim(attrib),value4) + endif + + end subroutine ncd_putatt_real + + !----------------------------------------------------------------------- + + subroutine ncd_defdim(ncid,attrib,value,dimid) + + !----------------------------------------------------------------------- + ! define dimension + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t), intent(in) :: ncid ! netcdf file id + character(len=*) , intent(in) :: attrib ! netcdf attrib + integer , intent(in) :: value ! netcdf attrib value + integer , intent(out):: dimid ! netcdf dimension id + ! + ! !LOCAL VARIABLES: + integer :: status + !----------------------------------------------------------------------- + + status = pio_def_dim(ncid,attrib,value,dimid) + + end subroutine ncd_defdim + + !----------------------------------------------------------------------- + + subroutine ncd_defvar_bynf(ncid, varname, xtype, ndims, dimid, varid, & + long_name, units, cell_method, missing_value, fill_value, & + imissing_value, ifill_value, comment, flag_meanings, & + flag_values, nvalid_range ) + + !----------------------------------------------------------------------- + ! Define a netcdf variable + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: varname ! variable name + integer , intent(in) :: xtype ! external type + integer , intent(in) :: ndims ! number of dims + integer , intent(inout) :: varid ! returned var id + integer , intent(in), optional :: dimid(:) ! dimids + character(len=*) , intent(in), optional :: long_name ! attribute + character(len=*) , intent(in), optional :: units ! attribute + character(len=*) , intent(in), optional :: cell_method ! attribute + character(len=*) , intent(in), optional :: comment ! attribute + character(len=*) , intent(in), optional :: flag_meanings(:) ! attribute + real(r8) , intent(in), optional :: missing_value ! attribute for real + real(r8) , intent(in), optional :: fill_value ! attribute for real + integer , intent(in), optional :: imissing_value ! attribute for int + integer , intent(in), optional :: ifill_value ! attribute for int + integer , intent(in), optional :: flag_values(:) ! attribute for int + integer , intent(in), optional :: nvalid_range(2) ! attribute for int + + ! + ! !LOCAL VARIABLES: + integer :: n ! indices + integer :: ldimid(4) ! local dimid + integer :: dimid0(1) ! local dimid + integer :: status ! error status + integer :: lxtype ! local external type (in case logical variable) + type(var_desc_t) :: vardesc ! local vardesc + character(len=255) :: dimname ! temporary + character(len=256) :: str ! temporary + character(len=*),parameter :: subname='ncd_defvar_bynf' ! subroutine name + !----------------------------------------------------------------------- + + varid = -1 + + dimid0 = 0 + ldimid = 0 + if (present(dimid)) then + ldimid(1:ndims) = dimid(1:ndims) + else ! ndims must be zero if dimid not present + if (ndims /= 0) then + write(iulog,*) subname//' ERROR: dimid not supplied and ndims ne 0 ',trim(varname),ndims + call shr_sys_abort() + endif + endif + + if ( xtype == ncd_log )then + lxtype = ncd_int + else + lxtype = xtype + end if + if (mainproc .and. debug > 1) then + write(iulog,*) 'Error in defining variable = ', trim(varname) + write(iulog,*) subname//' ',trim(varname),lxtype,ndims,ldimid(1:ndims) + endif + + if (ndims > 0) then + status = pio_inq_dimname(ncid,ldimid(ndims),dimname) + end if + + ! Define variable + if (present(dimid)) then + status = PIO_def_var(ncid,trim(varname),lxtype,dimid(1:ndims),vardesc) + else + status = PIO_def_var(ncid,trim(varname),lxtype,dimid0 ,vardesc) + endif + varid = vardesc%varid + ! + ! Add attributes + ! + if (present(long_name)) then + call ncd_putatt(ncid, varid, 'long_name', trim(long_name)) + end if + if (present(flag_values)) then + status = PIO_put_att(ncid,varid,'flag_values',flag_values) + if ( .not. present(flag_meanings)) then + write(iulog,*) 'Error in defining variable = ', trim(varname) + call shr_sys_abort( subname//" ERROR:: flag_values set -- but not flag_meanings" ) + end if + end if + if (present(flag_meanings)) then + if ( .not. present(flag_values)) then + write(iulog,*) 'Error in defining variable = ', trim(varname) + call shr_sys_abort( subname//" ERROR:: flag_meanings set -- but not flag_values" ) + end if + if ( size(flag_values) /= size(flag_meanings) ) then + write(iulog,*) 'Error in defining variable = ', trim(varname) + call shr_sys_abort( subname//" ERROR:: flag_meanings and flag_values dimension different") + end if + str = flag_meanings(1) + do n = 1, size(flag_meanings) + if ( index(flag_meanings(n), ' ') /= 0 )then + write(iulog,*) 'Error in defining variable = ', trim(varname) + call shr_sys_abort( subname//" ERROR:: flag_meanings has an invalid space in it" ) + end if + if ( n > 1 ) str = trim(str)//" "//flag_meanings(n) + end do + status = PIO_put_att(ncid,varid,'flag_meanings', trim(str) ) + end if + if (present(comment)) then + call ncd_putatt(ncid, varid, 'comment', trim(comment)) + end if + if (present(units)) then + call ncd_putatt(ncid, varid, 'units', trim(units)) + end if + if (present(cell_method)) then + str = 'time: ' // trim(cell_method) + call ncd_putatt(ncid, varid, 'cell_methods', trim(str)) + end if + if (present(fill_value)) then + call ncd_putatt(ncid, varid, '_FillValue', fill_value, lxtype) + end if + if (present(missing_value)) then + call ncd_putatt(ncid, varid, 'missing_value', missing_value, lxtype) + end if + if (present(ifill_value)) then + call ncd_putatt(ncid, varid, '_FillValue', ifill_value, lxtype) + end if + if (present(imissing_value)) then + call ncd_putatt(ncid, varid, 'missing_value', imissing_value, lxtype) + end if + if (present(nvalid_range)) then + status = PIO_put_att(ncid,varid,'valid_range', nvalid_range ) + end if + if ( xtype == ncd_log )then + status = PIO_put_att(ncid,varid,'flag_values', (/0, 1/) ) + status = PIO_put_att(ncid,varid,'flag_meanings', "FALSE TRUE" ) + status = PIO_put_att(ncid,varid,'valid_range', (/0, 1/) ) + end if + + end subroutine ncd_defvar_bynf + + !----------------------------------------------------------------------- + + subroutine ncd_defvar_bygrid(ncid, varname, xtype, & + dim1name, dim2name, dim3name, dim4name, dim5name, & + long_name, units, cell_method, missing_value, fill_value, & + imissing_value, ifill_value, comment, & + flag_meanings, flag_values, nvalid_range ) + + !------------------------------------------------------------------------ + ! Define a netcdf variable + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*), intent(in) :: varname ! variable name + integer , intent(in) :: xtype ! external type + character(len=*), intent(in), optional :: dim1name ! dimension name + character(len=*), intent(in), optional :: dim2name ! dimension name + character(len=*), intent(in), optional :: dim3name ! dimension name + character(len=*), intent(in), optional :: dim4name ! dimension name + character(len=*), intent(in), optional :: dim5name ! dimension name + character(len=*), intent(in), optional :: long_name ! attribute + character(len=*), intent(in), optional :: units ! attribute + character(len=*), intent(in), optional :: cell_method ! attribute + character(len=*), intent(in), optional :: comment ! attribute + character(len=*), intent(in), optional :: flag_meanings(:) ! attribute + real(r8) , intent(in), optional :: missing_value ! attribute for real + real(r8) , intent(in), optional :: fill_value ! attribute for real + integer , intent(in), optional :: imissing_value ! attribute for int + integer , intent(in), optional :: ifill_value ! attribute for int + integer , intent(in), optional :: flag_values(:) ! attribute for int + integer , intent(in), optional :: nvalid_range(2) ! attribute for int + ! + ! !REVISION HISTORY: + ! + ! + ! !LOCAL VARIABLES: + !EOP + integer :: n ! indices + integer :: ndims ! dimension counter + integer :: dimid(5) ! dimension ids + integer :: varid ! variable id + integer :: itmp ! temporary + character(len=256) :: str ! temporary + character(len=*),parameter :: subname='ncd_defvar_bygrid' ! subroutine name + !----------------------------------------------------------------------- + + dimid(:) = 0 + + ! Determine dimension ids for variable + + if (present(dim1name)) call ncd_inqdid(ncid, dim1name, dimid(1)) + if (present(dim2name)) call ncd_inqdid(ncid, dim2name, dimid(2)) + if (present(dim3name)) call ncd_inqdid(ncid, dim3name, dimid(3)) + if (present(dim4name)) call ncd_inqdid(ncid, dim4name, dimid(4)) + if (present(dim5name)) call ncd_inqdid(ncid, dim5name, dimid(5)) + + ! Permute dim1 and dim2 if necessary + + ! Define variable + + ndims = 0 + if (present(dim1name)) then + do n = 1, size(dimid) + if (dimid(n) /= 0) ndims = ndims + 1 + end do + end if + + call ncd_defvar_bynf(ncid,varname,xtype,ndims,dimid,varid, & + long_name=long_name, units=units, cell_method=cell_method, & + missing_value=missing_value, fill_value=fill_value, & + imissing_value=imissing_value, ifill_value=ifill_value, & + comment=comment, flag_meanings=flag_meanings, & + flag_values=flag_values, nvalid_range=nvalid_range ) + + end subroutine ncd_defvar_bygrid + + !------------------------------------------------------------------------ + + subroutine ncd_io_log_var0_nf(varname, data, flag, ncid, readvar, nt) + + !------------------------------------------------------------------------ + ! netcdf I/O of global integer variable + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + logical , intent(inout) :: data ! raw data + logical, optional, intent(out) :: readvar ! was var read? + integer, optional, intent(in) :: nt ! time sample index + ! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: start(1), count(1) ! output bounds + integer :: status ! error code + integer :: idata ! raw integer data + logical :: varpresent ! if true, variable is on tape + integer :: temp(1) ! temporary + character(len=32) :: vname ! variable error checking + type(var_desc_t) :: vardesc ! local vardesc pointer + character(len=*),parameter :: subname='ncd_io_log_var0_nf' + !----------------------------------------------------------------------- + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + status = pio_get_var(ncid, varid, idata) + if ( idata == 0 )then + data = .false. + else if ( idata == 1 )then + data = .true. + else + call shr_sys_abort( subname// & + ' ERROR: bad integer value for logical data' ) + end if + endif + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + call ncd_inqvid (ncid, varname, varid, vardesc) + if ( data )then + temp(1) = 1 + else + temp(1) = 0 + end if + if (present(nt)) then + start(1) = nt + count(1) = 1 + status = pio_put_var(ncid, varid, start, count, temp) + else + status = pio_put_var(ncid, varid, temp(1)) + end if + + + endif ! flag + + end subroutine ncd_io_log_var0_nf + + !------------------------------------------------------------------------ + + subroutine ncd_io_int_var0_nf(varname, data, flag, ncid, readvar, nt) + + !------------------------------------------------------------------------ + ! netcdf I/O of global integer variable + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + integer , intent(inout) :: data ! raw data + logical, optional, intent(out) :: readvar ! was var read? + integer, optional, intent(in) :: nt ! time sample index + ! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: start(1), count(1) ! output bounds + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + integer :: temp(1) ! temporary + character(len=32) :: vname ! variable error checking + type(var_desc_t) :: vardesc ! local vardesc pointer + character(len=*),parameter :: subname='ncd_io_int_var0_nf' + !----------------------------------------------------------------------- + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + status = pio_get_var(ncid, varid, data) + endif + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + call ncd_inqvid (ncid, varname, varid, vardesc) + if (present(nt)) then + start(1) = nt + count(1) = 1 + temp(1) = data + status = pio_put_var(ncid, varid, start, count, temp) + else + status = pio_put_var(ncid, varid, data) + end if + + endif ! flag + + end subroutine ncd_io_int_var0_nf + + !------------------------------------------------------------------------ + + subroutine ncd_io_real_var0_nf(varname, data, flag, ncid, readvar, nt) + + !------------------------------------------------------------------------ + ! netcdf I/O of global real variable + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + real(r8) , intent(inout) :: data ! raw data + logical, optional, intent(out) :: readvar ! was var read? + integer, optional, intent(in) :: nt ! time sample index + ! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: start(1), count(1) ! output bounds + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + real(r8):: temp(1) ! temporary + character(len=32) :: vname ! variable error checking + type(var_desc_t) :: vardesc ! local vardesc pointer + character(len=*),parameter :: subname='ncd_io_real_var0_nf' + !----------------------------------------------------------------------- + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + status = pio_get_var(ncid, vardesc, data) + endif + if (present(readvar)) readvar = varpresent + + else if (flag == 'write') then + + call ncd_inqvid (ncid, varname, varid, vardesc) + if (present(nt)) then + start(1) = nt + count(1) = 1 + temp(1) = data + status = pio_put_var(ncid, varid, start, count, temp) + else + status = pio_put_var(ncid, varid, data) + end if + + endif ! flag + + end subroutine ncd_io_real_var0_nf + + !------------------------------------------------------------------------ + + subroutine ncd_io_int_var1_nf(varname, data, flag, ncid, readvar, nt) + + !------------------------------------------------------------------------ + ! netcdf I/O of global integer array + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + integer , intent(inout) :: data(:) ! raw data + logical, optional, intent(out) :: readvar ! was var read? + integer, optional, intent(in) :: nt ! time sample index + ! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: start(2), count(2) ! output bounds + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + character(len=32) :: vname ! variable error checking + type(var_desc_t) :: vardesc ! local vardesc pointer + character(len=*),parameter :: subname='ncd_io_int_var1_nf' + integer :: ndims + !----------------------------------------------------------------------- + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + status = pio_get_var(ncid, varid, data) + endif + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + if (present(nt)) then + start(1) = 1 + count(1) = size(data) + start(2) = nt + count(2) = 1 + ndims = 2 + else + start(1) = 1 + count(1) = size(data) + start(2) = 1 + count(2) = 1 + ndims = 1 + end if + call ncd_inqvid (ncid, varname, varid, vardesc) + status = pio_put_var(ncid, varid, start(1:ndims), count(1:ndims), data) + + endif ! flag + + end subroutine ncd_io_int_var1_nf + + !------------------------------------------------------------------------ + + subroutine ncd_io_log_var1_nf(varname, data, flag, ncid, readvar, nt) + + !------------------------------------------------------------------------ + ! netcdf I/O of global integer array + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + logical , intent(inout) :: data(:) ! raw data + logical, optional, intent(out) :: readvar ! was var read? + integer, optional, intent(in) :: nt ! time sample index + ! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: start(2), count(2) ! output bounds + integer :: status ! error code + integer, pointer :: idata(:) ! Temporary integer data to send to file + logical :: varpresent ! if true, variable is on tape + character(len=32) :: vname ! variable error checking + type(var_desc_t) :: vardesc ! local vardesc pointer + character(len=*),parameter :: subname='ncd_io_log_var1_nf' + !----------------------------------------------------------------------- + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + allocate( idata(size(data)) ) + status = pio_get_var(ncid, varid, idata) + data = (idata == 1) + if ( any(idata /= 0 .and. idata /= 1) )then + call shr_sys_abort(subname//'ERROR: read in bad integer value(s) for logical data') + end if + deallocate( idata ) + endif + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + if (present(nt)) then + start(1) = 1 + count(1) = size(data) + start(2) = nt + count(2) = 1 + else + start(1) = 1 + count(1) = size(data) + start(2) = 1 + count(2) = 1 + end if + call ncd_inqvid (ncid, varname, varid, vardesc) + allocate( idata(size(data)) ) + where( data ) + idata = 1 + elsewhere + idata = 0 + end where + status = pio_put_var(ncid, varid, start, count, idata) + deallocate( idata ) + + endif ! flag + + end subroutine ncd_io_log_var1_nf + + !------------------------------------------------------------------------ + + subroutine ncd_io_real_var1_nf(varname, data, flag, ncid, readvar, nt) + + !------------------------------------------------------------------------ + ! netcdf I/O of global real array + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + real(r8) , intent(inout) :: data(:) ! raw data + logical , optional, intent(out):: readvar ! was var read? + integer , optional, intent(in) :: nt ! time sample index + ! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: start(2), count(2) ! output bounds + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + character(len=32) :: vname ! variable error checking + type(var_desc_t) :: vardesc ! local vardesc pointer + character(len=*),parameter :: subname='ncd_io_real_var1_nf' + integer :: ndims + !----------------------------------------------------------------------- + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + status = pio_get_var(ncid, varid, data) + endif + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + if (present(nt)) then + start(1) = 1 + start(2) = nt + count(1) = size(data) + count(2) = 1 + ndims = 2 + else + start(1) = 1 + start(2) = 1 + count(1) = size(data) + count(2) = 1 + ndims = 1 + end if + call ncd_inqvid (ncid, varname, varid, vardesc) + status = pio_put_var(ncid, varid, start(1:ndims), count(1:ndims), data) + + endif ! flag + + end subroutine ncd_io_real_var1_nf + + !------------------------------------------------------------------------ + + subroutine ncd_io_char_var1_nf(varname, data, flag, ncid, readvar, nt ) + + !------------------------------------------------------------------------ + ! netcdf I/O of global char array + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + character(len=*) , intent(inout) :: data ! raw data + logical , optional, intent(out):: readvar ! was var read? + integer , optional, intent(in) :: nt ! time sample index + ! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: m ! indices + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + character(len=32) :: vname ! variable error checking + character(len=1) :: tmpString(255)! temp for manipulating output string + type(var_desc_t) :: vardesc ! local vardesc pointer + character(len=*),parameter :: subname='ncd_io_char_var1_nf' + !----------------------------------------------------------------------- + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + status = pio_get_var(ncid, varid, data) + endif + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + call ncd_inqvid (ncid, varname, varid, vardesc) + + if (present(nt)) then + status = pio_put_var(ncid, varid, (/1,nt/), ival=data) + else + status = pio_put_var(ncid, varid, data ) + end if + + endif ! flag + + end subroutine ncd_io_char_var1_nf + + !------------------------------------------------------------------------ + + subroutine ncd_io_int_var2_nf(varname, data, flag, ncid, readvar, nt) + + !------------------------------------------------------------------------ + ! netcdf I/O of global integer 2D array + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + integer , intent(inout) :: data(:,:) ! raw data + logical , optional, intent(out):: readvar ! was var read? + integer , optional, intent(in) :: nt ! time sample index + ! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: start(3), count(3) ! output bounds + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + character(len=32) :: vname ! variable error checking + type(var_desc_t) :: vardesc ! local vardesc pointer + logical :: found ! if true, found lat/lon dims on file + character(len=*),parameter :: subname='ncd_io_int_var2_nf' + integer :: ndims + !----------------------------------------------------------------------- + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + status = pio_get_var(ncid, varid, data) + endif + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + if (present(nt)) then + start(1) = 1 + start(2) = 1 + start(3) = nt + count(1) = size(data, dim=1) + count(2) = size(data, dim=2) + count(3) = 1 + ndims = 3 + else + start(1) = 1 + start(2) = 1 + start(3) = 1 + count(1) = size(data, dim=1) + count(2) = size(data, dim=2) + count(3) = 1 + ndims = 2 + end if + call ncd_inqvid(ncid, varname, varid, vardesc) + status = pio_put_var(ncid, varid, start(1:ndims), count(1:ndims), data) + + endif + + end subroutine ncd_io_int_var2_nf + + !------------------------------------------------------------------------ + + subroutine ncd_io_real_var2_nf(varname, data, flag, ncid, readvar, nt) + + !------------------------------------------------------------------------ + ! netcdf I/O of global real 2D array + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t),intent(inout) :: ncid ! netcdf file id + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + real(r8) , intent(inout) :: data(:,:) ! raw data + logical , optional, intent(out):: readvar ! was var read? + integer , optional, intent(in) :: nt ! time sample index + ! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: start(3), count(3) ! output bounds + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + character(len=32) :: vname ! variable error checking + type(var_desc_t) :: vardesc ! local vardesc pointer + logical :: found ! if true, found lat/lon dims on file + character(len=*),parameter :: subname='ncd_io_real_var2_nf' + !----------------------------------------------------------------------- + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + status = pio_get_var(ncid, varid, data) + endif + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + if (present(nt)) then + start(1) = 1 + start(2) = 1 + start(3) = nt + count(1) = size(data, dim=1) + count(2) = size(data, dim=2) + count(3) = 1 + else + start(1) = 1 + start(2) = 1 + start(3) = 1 + count(1) = size(data, dim=1) + count(2) = size(data, dim=2) + count(3) = 1 + end if + call ncd_inqvid (ncid, varname, varid, vardesc) + status = pio_put_var(ncid, varid, start, count, data) + + endif + + end subroutine ncd_io_real_var2_nf + + !------------------------------------------------------------------------ + + subroutine ncd_io_char_var2_nf(varname, data, flag, ncid, readvar, nt) + + !------------------------------------------------------------------------ + ! netcdf I/O of global character array + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t),intent(inout) :: ncid ! netcdf file id + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + character(len=*), intent(inout) :: data(:) ! raw data + logical , optional, intent(out):: readvar ! was var read? + integer , optional, intent(in) :: nt ! time sample index + ! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: start(3), count(3) ! output bounds + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + character(len=32) :: vname ! variable error checking + type(var_desc_t) :: vardesc ! local vardesc pointer + logical :: found ! if true, found lat/lon dims on file + character(len=*),parameter :: subname='ncd_io_char_var2_nf' + !----------------------------------------------------------------------- + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + data = ' ' + status = pio_get_var(ncid, varid, data) + endif + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + call ncd_inqvid (ncid, varname, varid, vardesc) + if (present(nt)) then + start(1) = 1 + start(2) = 1 + start(3) = nt + count(1) = size(data) + count(2) = len(data) + count(3) = 1 + status = pio_put_var(ncid, varid, start, count, data) + else + status = pio_put_var(ncid, varid, data) + end if + + endif + + end subroutine ncd_io_char_var2_nf + + !------------------------------------------------------------------------ + subroutine ncd_io_char_varn_strt_nf(vardesc, data, flag, ncid, start ) + + ! netcdf I/O of global character array with start indices input + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t),intent(inout) :: ncid ! netcdf file id + character(len=*), intent(in) :: flag ! 'read' or 'write' + type(var_desc_t), intent(in) :: vardesc ! local vardesc pointer + character(len=*), intent(inout) :: data ! raw data for this index + integer , intent(in) :: start(:) ! output bounds + + ! !LOCAL VARIABLES: + integer :: status ! error code + character(len=*),parameter :: subname='ncd_io_char_varn_strt_nf' + !----------------------------------------------------------------------- + + if (flag == 'read') then + status = pio_get_var(ncid, vardesc, start, data ) + elseif (flag == 'write') then + status = pio_put_var(ncid, vardesc, start, data ) + endif + + end subroutine ncd_io_char_varn_strt_nf + + !----------------------------------------------------------------------- + + subroutine ncd_io_int_var1(varname, data, dim1name, flag, ncid, nt, readvar) + + !----------------------------------------------------------------------- + ! I/O for 1d integer field + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + integer , pointer :: data(:) ! local decomposition data + character(len=*) , intent(in) :: dim1name ! dimension name + integer , optional, intent(in) :: nt ! time sample index + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + ! !LOCAL VARIABLES: + character(len=32) :: dimname ! temporary + integer :: n ! index + integer :: iodnum ! iodesc num in list + integer :: varid ! varid + integer :: ndims ! ndims for var + integer :: ndims_iod ! ndims iodesc for var + integer :: dims(4) ! dim sizes + integer :: dids(4) ! dim ids + integer :: start(3) ! netcdf start index + integer :: count(3) ! netcdf count index + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + integer :: xtype ! netcdf data type + type(iodesc_plus_type) , pointer :: iodesc_plus + type(var_desc_t) :: vardesc + character(len=*),parameter :: subname='ncd_io_int_var1' ! subroutine name + !----------------------------------------------------------------------- + + if (mainproc .and. debug > 1) then + write(iulog,*) subname//' ',trim(flag),' ',trim(varname),' ',trim(dim1name) + end if + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + status = pio_inq_varndims(ncid, vardesc, ndims) + status = pio_inq_vardimid(ncid, vardesc, dids) + status = pio_inq_vartype (ncid, vardesc, xtype) + status = pio_inq_dimname(ncid,dids(ndims),dimname) + if ('time' == trim(dimname)) then + ndims_iod = ndims - 1 + else + ndims_iod = ndims + end if + do n = 1,ndims_iod + status = pio_inq_dimlen(ncid,dids(n),dims(n)) + enddo + call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & + xtype, iodnum) + iodesc_plus => iodesc_list(iodnum) + if (present(nt)) then + call pio_setframe(ncid,vardesc, int(nt,kind=PIO_Offset_kind)) + end if + call pio_read_darray(ncid, vardesc, iodesc_plus%iodesc, data, status) + end if + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + call ncd_inqvid(ncid, varname ,varid, vardesc) + status = pio_inq_varndims(ncid, vardesc, ndims) + status = pio_inq_vardimid(ncid, vardesc, dids) + status = pio_inq_vartype (ncid, vardesc, xtype) + status = pio_inq_dimname(ncid,dids(ndims),dimname) + if ('time' == trim(dimname)) then + ndims_iod = ndims - 1 + else + ndims_iod = ndims + end if + do n = 1,ndims_iod + status = pio_inq_dimlen(ncid,dids(n),dims(n)) + enddo + call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & + xtype, iodnum) + iodesc_plus => iodesc_list(iodnum) + if (present(nt)) then + call pio_setframe(ncid, vardesc, int(nt,kind=PIO_Offset_kind)) + end if + call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, data, status, fillval=ispval) + + else + + if (mainproc) then + write(iulog,*) subname//' ERROR: unsupported flag ',trim(flag) + call shr_sys_abort() + endif + + endif + + end subroutine ncd_io_int_var1 + + !----------------------------------------------------------------------- + + subroutine ncd_io_log_var1(varname, data, dim1name, & + flag, ncid, nt, readvar) + + !----------------------------------------------------------------------- + ! I/O for 1d integer field + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + logical , pointer :: data(:) ! local decomposition data + character(len=*) , intent(in) :: dim1name ! dimension name + integer , optional, intent(in) :: nt ! time sample index + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + ! !LOCAL VARIABLES: + character(len=32) :: dimname ! temporary + integer :: n ! index + integer :: iodnum ! iodesc num in list + integer :: varid ! varid + integer :: ndims ! ndims for var + integer :: ndims_iod ! ndims iodesc for var + integer :: dims(4) ! dim sizes + integer :: dids(4) ! dim ids + integer :: start(3) ! netcdf start index + integer :: count(3) ! netcdf count index + integer :: status ! error code + integer, pointer :: idata(:) ! Temporary integer data to send to file + logical :: varpresent ! if true, variable is on tape + integer :: xtype ! netcdf data type + type(iodesc_plus_type) , pointer :: iodesc_plus + type(var_desc_t) :: vardesc + character(len=*),parameter :: subname='ncd_io_log_var1' ! subroutine name + !----------------------------------------------------------------------- + + if (mainproc .and. debug > 1) then + write(iulog,*) subname//' ',trim(flag),' ',trim(varname) + end if + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + allocate( idata(size(data)) ) + status = pio_inq_varndims(ncid, vardesc, ndims) + status = pio_inq_vardimid(ncid, vardesc, dids) + status = pio_inq_vartype (ncid, vardesc, xtype) + status = pio_inq_dimname(ncid,dids(ndims),dimname) + if ('time' == trim(dimname)) then + ndims_iod = ndims - 1 + else + ndims_iod = ndims + end if + do n = 1,ndims_iod + status = pio_inq_dimlen(ncid,dids(n),dims(n)) + enddo + call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & + xtype, iodnum) + iodesc_plus => iodesc_list(iodnum) + if (present(nt)) then + call pio_setframe(ncid,vardesc, int(nt,kind=PIO_Offset_kind)) + end if + call pio_read_darray(ncid, vardesc, iodesc_plus%iodesc, idata, status) + data = (idata == 1) + if ( any(idata /= 0 .and. idata /= 1) )then + call shr_sys_abort( subname//' ERROR: read in bad integer value(s) for logical data' ) + end if + deallocate( idata ) + end if + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + call ncd_inqvid(ncid, varname ,varid, vardesc) + status = pio_inq_varndims(ncid, vardesc, ndims) + status = pio_inq_vardimid(ncid, vardesc, dids) + status = pio_inq_vartype (ncid, vardesc, xtype) + status = pio_inq_dimname(ncid,dids(ndims),dimname) + if ('time' == trim(dimname)) then + ndims_iod = ndims - 1 + else + ndims_iod = ndims + end if + do n = 1,ndims_iod + status = pio_inq_dimlen(ncid,dids(n),dims(n)) + enddo + call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & + xtype, iodnum) + iodesc_plus => iodesc_list(iodnum) + if (present(nt)) then + call pio_setframe(ncid, vardesc, int(nt,kind=PIO_Offset_kind)) + end if + allocate( idata(size(data)) ) + where( data ) + idata = 1 + elsewhere + idata = 0 + end where + call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, idata, status, fillval=0) + deallocate( idata ) + + else + + if (mainproc) then + write(iulog,*) subname//' ERROR: unsupported flag ',trim(flag) + call shr_sys_abort() + endif + + endif + + end subroutine ncd_io_log_var1 + + !----------------------------------------------------------------------- + + subroutine ncd_io_real_var1(varname, data, dim1name, & + flag, ncid, nt, readvar) + + !----------------------------------------------------------------------- + ! I/O for 1d real field + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t),intent(inout) :: ncid ! netcdf file id + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + real(r8) , pointer :: data(:) ! local decomposition data + character(len=*), intent(in) :: dim1name ! dimension name + integer , optional, intent(in) :: nt ! time sample index + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + ! !LOCAL VARIABLES: + character(len=32) :: dimname ! temporary + integer :: iodnum ! iodesc num in list + integer :: varid ! varid + integer :: ndims ! ndims for var + integer :: ndims_iod ! ndims iodesc for var + integer :: n ! index + integer :: dims(4) ! dim sizes + integer :: dids(4) ! dim ids + integer :: start(3) ! netcdf start index + integer :: count(3) ! netcdf count index + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + integer :: xtype ! netcdf data type + type(iodesc_plus_type) , pointer :: iodesc_plus + type(var_desc_t) :: vardesc + character(len=*),parameter :: subname='ncd_io_real_var1' ! subroutine name + !----------------------------------------------------------------------- + + if (mainproc .and. debug > 1) then + write(iulog,*) trim(subname),' ',trim(flag),' ',trim(varname) + endif + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + status = pio_inq_varndims(ncid, vardesc, ndims) + status = pio_inq_vardimid(ncid,vardesc, dids) + status = pio_inq_vartype(ncid, vardesc, xtype) + status = pio_inq_dimname(ncid,dids(ndims),dimname) + if ('time' == trim(dimname)) then + ndims_iod = ndims - 1 + else + ndims_iod = ndims + end if + do n = 1,ndims_iod + status = pio_inq_dimlen(ncid,dids(n),dims(n)) + enddo + call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & + xtype, iodnum) + iodesc_plus => iodesc_list(iodnum) + if (present(nt)) then + call pio_setframe(ncid, vardesc, int(nt,kind=PIO_Offset_kind)) + end if + call pio_read_darray(ncid, vardesc, iodesc_plus%iodesc, data, status) + end if + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + call ncd_inqvid(ncid, varname ,varid, vardesc) + status = pio_inq_varndims(ncid, vardesc, ndims) + status = pio_inq_vardimid(ncid, vardesc, dids) + status = pio_inq_vartype (ncid, vardesc, xtype) + status = pio_inq_dimname(ncid,dids(ndims),dimname) + if ('time' == trim(dimname)) then + ndims_iod = ndims - 1 + else + ndims_iod = ndims + end if + do n = 1,ndims_iod + status = pio_inq_dimlen(ncid,dids(n),dims(n)) + enddo + call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & + xtype, iodnum) + iodesc_plus => iodesc_list(iodnum) + if (present(nt)) then + call pio_setframe(ncid,vardesc, int(nt,kind=PIO_Offset_kind)) + end if + if(xtype == ncd_float) then + call shr_sys_abort( subname//' error: Attempt to write out single-precision data which is current NOT implemented (see issue #18)' ) + else + call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, data, status, fillval=spval) + endif + else + + if (mainproc) then + write(iulog,*) subname,' error: unsupported flag ',trim(flag) + call shr_sys_abort() + endif + + endif + + end subroutine ncd_io_real_var1 + + !------------------------------------------------------------------------ + + subroutine ncd_getiodesc(ncid, ndims, dims, dimids, xtype, iodnum) + + !------------------------------------------------------------------------ + ! Returns an index to an io descriptor + ! + ! !ARGUMENTS: + type(file_desc_t), intent(inout) :: ncid ! PIO file descriptor + integer , intent(in) :: ndims ! ndims for var + integer , intent(in) :: dims(:) ! dim sizes + integer , intent(in) :: dimids(:) ! dim ids + integer , intent(in) :: xtype ! file external type + integer , intent(out) :: iodnum ! iodesc num in list + + ! !LOCAL VARIABLES: + integer :: k,m,n ! indices + integer :: status ! error status + logical :: found ! true => found created iodescriptor + integer :: ndims_file ! temporary + character(len=64) dimname_file ! dimension name on file + character(len=64) dimname_iodesc ! dimension name from io descriptor + character(len=32) :: subname = 'ncd_getiodesc' + !------------------------------------------------------------------------ + + ! Determining if need to create a new io descriptor + + n = 1 + found = .false. + do while (n <= num_iodesc .and. .not.found) + if (ndims == iodesc_list(n)%ndims .and. xtype == iodesc_list(n)%type) then + found = .true. + ! First found implies that dimension sizes are the same + do m = 1,ndims + if (dims(m) /= iodesc_list(n)%dims(m)) then + found = .false. + endif + enddo + ! If found - then also check that dimension names are equal - + ! dimension ids in iodescriptor are only used to query dimension + ! names associated with that iodescriptor + if (found) then + do m = 1,ndims + status = PIO_inq_dimname(ncid,dimids(m),dimname_file) + status = PIO_inquire(ncid, ndimensions=ndims_file) + if (iodesc_list(n)%dimids(m) > ndims_file) then + found = .false. + exit + else + status = PIO_inq_dimname(ncid,iodesc_list(n)%dimids(m),dimname_iodesc) + if (trim(dimname_file) .ne. trim(dimname_iodesc)) then + found = .false. + exit + end if + end if + end do + end if + if (found) then + iodnum = n + if (iodnum > num_iodesc) then + write(iulog,*) trim(subname),' ERROR: iodnum out of range ',iodnum,num_iodesc + call shr_sys_abort() + endif + RETURN + endif + endif + n = n + 1 + enddo + + ! Creating a new io descriptor + + if (ndims > 0) then + num_iodesc = num_iodesc + 1 + if (num_iodesc > max_iodesc) then + write(iulog,*) trim(subname),' ERROR num_iodesc gt max_iodesc ',max_iodesc + call shr_sys_abort() + endif + iodnum = num_iodesc + if (mainproc .and. debug > 1) then + write(iulog,*) trim(subname),' creating iodesc at iodnum,ndims,dims(1:ndims),xtype',& + iodnum,ndims,dims(1:ndims),xtype + endif + end if + + ! Initialize the decomposition for PIO + call pio_initdecomp(pio_subsystem, xTYPE, dims(1:ndims), compDOF, iodesc_list(iodnum)%iodesc) + + iodesc_list(iodnum)%type = xtype + iodesc_list(iodnum)%ndims = ndims + iodesc_list(iodnum)%dims = 0 + iodesc_list(iodnum)%dims(1:ndims) = dims(1:ndims) + iodesc_list(iodnum)%dimids(1:ndims) = dimids(1:ndims) + + end subroutine ncd_getiodesc + + !----------------------------------------------------------------------- + + subroutine getdatetime (cdate, ctime) + ! + ! Get date and time + ! + ! 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 :: values(8) !temporary + integer :: ier !MPI error code + !----------------------------------------------------------------------- + + if (mainproc) then + call date_and_time (date, time, zone, values) + + cdate(1:2) = date(5:6) + cdate(3:3) = '/' + cdate(4:5) = date(7:8) + cdate(6:6) = '/' + cdate(7:8) = date(3:4) + + ctime(1:2) = time(1:2) + ctime(3:3) = ':' + ctime(4:5) = time(3:4) + ctime(6:6) = ':' + ctime(7:8) = time(5:6) + endif + + call mpi_bcast (cdate,len(cdate),MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (ctime,len(ctime),MPI_CHARACTER, 0, mpicom_rof, ier) + + end subroutine getdatetime + +end module mosart_io diff --git a/src/riverroute/mosart_mod.F90 b/src/riverroute/mosart_mod.F90 index 9b4f897..9d3c104 100644 --- a/src/riverroute/mosart_mod.F90 +++ b/src/riverroute/mosart_mod.F90 @@ -1,4 +1,4 @@ -module RtmMod +module mosart_mod !----------------------------------------------------------------------- ! Mosart Routing Model @@ -8,84 +8,58 @@ module RtmMod 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, & + use mosart_vars , only : re, spval, iulog, ice_runoff, & + frivinp, nsrContinue, nsrBranch, nsrStartup, nsrest, & inst_index, inst_suffix, inst_name, decomp_option, & bypass_routing_option, qgwl_runoff_option, barrier_timers, & - 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 + mainproc, npes, iam, mpicom_rof + use mosart_data , only : ctl, Tctl, Tunit, TRunoff, Tpara + use mosart_fileutils , only : getfil + use mosart_timemanager , only : timemgr_init, get_nstep, get_curr_date + use mosart_histflds , only : mosart_histflds_init, mosart_histflds_set + use mosart_histfile , only : mosart_hist_updatehbuf, mosart_hist_htapeswrapup, mosart_hist_htapesbuild, & + ndens, mfilt, nhtfrq, avgflag_pertape, avgflag_pertape, & + fincl1, fincl2, fincl3, fexcl1, fexcl2, fexcl3, max_tapes, max_namlen + use mosart_restfile , only : mosart_rest_timemanager, mosart_rest_getfile, mosart_rest_fileread, & + mosart_rest_filewrite, mosart_rest_filename, finidat, nrevsn + use mosart_physics_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 + ESMF_TERMORDER_SRCSEQ, ESMF_Mesh + use mosart_IO ! TODO: put in only here use pio use mpi - + ! + ! !PUBLIC TYPES: implicit none private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: mosart_read_namelist ! Read in mosart namelist + public :: mosart_init1 ! Initialize mosart grid + public :: mosart_init2 ! Initialize mosart maps + public :: mosart_run ! River routing model + ! + ! mosart namelists + integer :: coupling_period ! mosart coupling period + integer :: delt_mosart ! mosart internal timestep (->nsub) + logical :: use_halo_option ! enable halo capability using ESMF - ! 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_FloodInit - private :: MOSART_SubTimestep - - ! MOSART tracers - character(len=256) :: rtm_trstr ! tracer string + ! subcycling + integer :: nsub_save ! previous nsub + real(r8) :: delt_save ! previous delt - ! MOSART namelists - integer :: coupling_period ! mosart coupling period - integer :: delt_mosart ! mosart internal timestep (->nsub) + ! global (glo) + integer , allocatable :: IDkey(:) ! translation key from ID to gindex - ! 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] + ! budget accumulation + real(r8), allocatable :: budget_accum(:) ! BUDGET accumulator over run + integer :: budget_accum_cnt ! counter for budget_accum - ! 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 character(len=256) :: nlfilename_rof = 'mosart_in' - character(len=256) :: fnamer ! name of netcdf restart file + character(len=256) :: fnamer ! name of netcdf restart file + character(*), parameter :: u_FILE_u = & __FILE__ !----------------------------------------------------------------------- @@ -93,45 +67,43 @@ module RtmMod contains !----------------------------------------------------------------------- - subroutine MOSART_read_namelist(flood_active) + subroutine mosart_read_namelist() ! ! Read and distribute mosart namelist ! - ! arguments - logical, intent(out) :: flood_active - ! ! 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) ' + 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 + namelist /mosart_inparm / frivinp, finidat, nrevsn, coupling_period, ice_runoff, & + ndens, mfilt, nhtfrq, fincl1, fincl2, fincl3, fexcl1, fexcl2, fexcl3, & + avgflag_pertape, decomp_option, bypass_routing_option, qgwl_runoff_option, & + use_halo_option, delt_mosart + + ! TODO: add the following as namelists + ctl%ntracers = 2 ! number of tracers + allocate(ctl%tracer_names(ctl%ntracers)) + ctl%tracer_names(:) = (/'LIQ','ICE'/) ! tracer names ! Preset values - do_rtmflood = .false. ice_runoff = .true. - finidat_rtm = ' ' - nrevsn_rtm = ' ' + finidat = ' ' + nrevsn = ' ' coupling_period = -1 delt_mosart = 3600 decomp_option = 'basin' bypass_routing_option = 'direct_in_place' qgwl_runoff_option = 'threshold' + use_halo_option = .false. nlfilename_rof = "mosart_in" // trim(inst_suffix) inquire (file = trim(nlfilename_rof), exist = lexist) @@ -152,31 +124,26 @@ subroutine MOSART_read_namelist(flood_active) 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) + call mpi_bcast (finidat, len(finidat), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (frivinp, len(frivinp), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (nrevsn, len(nrevsn), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (decomp_option, len(decomp_option), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (use_halo_option, 1, MPI_LOGICAL, 0, mpicom_rof, ier) + call mpi_bcast (coupling_period, 1, MPI_INTEGER, 0, mpicom_rof, ier) + call mpi_bcast (delt_mosart, 1, MPI_INTEGER, 0, mpicom_rof, ier) + call mpi_bcast (bypass_routing_option, len(bypass_routing_option), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (qgwl_runoff_option, len(qgwl_runoff_option), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (ice_runoff, 1, MPI_LOGICAL, 0, mpicom_rof, ier) + call mpi_bcast (nhtfrq, size(nhtfrq), MPI_INTEGER, 0, mpicom_rof, ier) + call mpi_bcast (mfilt, size(mfilt), MPI_INTEGER, 0, mpicom_rof, ier) + call mpi_bcast (ndens, size(ndens), MPI_INTEGER, 0, mpicom_rof, ier) + call mpi_bcast (fexcl1, (max_namlen+2)*size(fexcl1), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (fexcl2, (max_namlen+2)*size(fexcl2), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (fexcl3, (max_namlen+2)*size(fexcl3), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (fincl1, (max_namlen+2)*size(fincl1), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (fincl2, (max_namlen+2)*size(fincl2), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (fincl3, (max_namlen+2)*size(fincl3), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (avgflag_pertape, size(avgflag_pertape), MPI_CHARACTER, 0, mpicom_rof, ier) runtyp(:) = 'missing' runtyp(nsrStartup + 1) = 'initial' @@ -189,20 +156,19 @@ subroutine MOSART_read_namelist(flood_active) write(iulog,*) ' coupling_period = ',coupling_period write(iulog,*) ' delt_mosart = ',delt_mosart write(iulog,*) ' decomp option = ',trim(decomp_option) + write(iulog,*) ' use_halo_optoin = ',use_halo_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) + if (nsrest == nsrStartup .and. finidat /= ' ') then + write(iulog,*) ' mosart initial data = ',trim(finidat) end if endif - flood_active = do_rtmflood - - if (frivinp_rtm == ' ') then - call shr_sys_abort( subname//' ERROR: frivinp_rtm NOT set' ) + if (frivinp == ' ') then + call shr_sys_abort( subname//' ERROR: frivinp NOT set' ) else if (mainproc) then - write(iulog,*) ' MOSART river data = ',trim(frivinp_rtm) + write(iulog,*) ' mosart river data = ',trim(frivinp) endif end if @@ -219,1348 +185,159 @@ subroutine MOSART_read_namelist(flood_active) end if if (coupling_period <= 0) then - write(iulog,*) subname,' ERROR MOSART coupling_period invalid',coupling_period + 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 + 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)) + if (nhtfrq(i) == 0) then + mfilt(i) = 1 + else if (nhtfrq(i) < 0) then + nhtfrq(i) = nint(-nhtfrq(i)*SHR_CONST_CDAY/(24._r8*coupling_period)) endif end do - end subroutine MOSART_read_namelist + end subroutine mosart_read_namelist !----------------------------------------------------------------------- - subroutine MOSART_init1() + subroutine mosart_init1(rc) !------------------------------------------------- - ! Initialize MOSART grid, mask, decomp + ! Initialize mosart grid, mask, decomp + ! + ! Arguments + integer, intent(out) :: rc ! ! 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 -#else - integer,parameter :: dbug = 3 ! 0 = none, 1=normal, 2=much, 3=max -#endif - character(len=*),parameter :: subname = '(MOSART_init1) ' + integer :: n, nr, nt ! indices + type(file_desc_t) :: ncid ! netcdf file id + character(len=256) :: trstr ! tracer string + character(len=256) :: locfn ! local file + integer :: dimid ! netcdf dimension identifier + character(len=*), parameter :: subname = '(mosart_init1) ' !------------------------------------------------- - !------------------------------------------------------- - ! Intiialize MOSART pio - !------------------------------------------------------- - - call ncd_pio_init() + rc = ESMF_SUCCESS !------------------------------------------------------- - ! 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 ) + !------------------------------------------------------- + if ((nsrest == nsrStartup .and. finidat /= ' ') .or. & + (nsrest == nsrContinue) .or. (nsrest == nsrBranch )) then + call mosart_rest_getfile( file=fnamer ) endif + !------------------------------------------------------- ! Initialize time manager + !------------------------------------------------------- if (nsrest == nsrStartup) then call timemgr_init(dtime_in=coupling_period) else - call RtmRestTimeManager(file=fnamer) + call mosart_rest_timemanager(file=fnamer) end if !------------------------------------------------------- - ! Initialize rtm_trstr + ! Write out tracers to stdout !------------------------------------------------------- - - 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) + trstr = trim(ctl%tracer_names(1)) + do n = 2,ctl%ntracers + trstr = trim(trstr)//':'//trim(ctl%tracer_names(n)) + enddo + write(iulog,*)'mosart tracers = ',ctl%ntracers,trim(trstr) end if !------------------------------------------------------- - ! Read input data (river direction file) + ! Obtain global sizes of grid from 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 getfil(frivinp, locfn, 0 ) + call ncd_pio_openfile(ncid, trim(locfn), 0) call ncd_inqdid(ncid,'lon',dimid) - call ncd_inqdlen(ncid,dimid,rtmlon) + call ncd_inqdlen(ncid,dimid,ctl%nlon) 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_inqdlen(ncid,dimid,ctl%nlat) 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 + write(iulog,'(a)') 'MOSART river data file name: ',trim(frivinp) + write(iulog,'(a)') 'Successfully read mosart dimensions' + write(iulog,'(a,i8,2x,i8)') 'Values for global nlon/nlat: ',ctl%nlon,ctl%nlat endif !------------------------------------------------------- - ! 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 (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 - - 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 + ! Initialize ctl derived type allocatable variables !------------------------------------------------------- - - if (do_rtmflood) then - write(iulog,*) subname,' Flood not validated in this version, abort' - call shr_sys_abort(subname//' Flood feature unavailable') - call MOSART_FloodInit (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 + allocate(IDkey(ctl%nlon*ctl%nlat)) + call ctl%Init(locfn, decomp_option, use_halo_option, IDkey, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return !------------------------------------------------------- - ! Initialize runoff data type + ! Initialize pio compDOF (module variable in mosart_io) !------------------------------------------------------- + call ncd_decomp_init(ctl%begr, ctl%endr, ctl%numr, ctl%gindex) - 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 + end subroutine mosart_init1 !----------------------------------------------------------------------- - subroutine MOSART_init2(rc) + subroutine mosart_init2(Emesh, rc) - ! Second phyas of MOSART initialization, including ESMF Mapping - ! Author: Hongyi Li + ! Second phyas of mosart initialization ! ! Arguments - integer, intent(out) :: rc + type(ESMF_Mesh), intent(in) :: Emesh + 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)' + integer :: nr, nt + integer :: begr, endr + integer :: ntracers + 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 + ! Set up local variables to be used below + begr = ctl%begr + endr = ctl%endr + ntracers = ctl%ntracers - 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 + !------------------------------------------------------- + ! Initialize MOSART types TCtl, Tpara, TUnit and Trunoff + !------------------------------------------------------- - if(TUnit%hslp(iunit) <= 0._r8) then - TUnit%hslp(iunit) = 0.005_r8 - end if + call Tctl%Init() - TUnit%rslpsqrt(iunit) = sqrt(Tunit%rslp(iunit)) - TUnit%tslpsqrt(iunit) = sqrt(Tunit%tslp(iunit)) - TUnit%hslpsqrt(iunit) = sqrt(Tunit%hslp(iunit)) + call Tpara%Init(begr, endr) - end do + call TRunoff%Init(begr, endr, ntracers) - 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) + call Tunit%Init(begr, endr, ntracers, ctl%nlon, ctl%nlat, Emesh, & + trim(frivinp), IDKey, Tpara%c_twid, Tctl%DLevelR, ctl%area, ctl%gindex, ctl%outletg, pio_subsystem, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - 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. & + if ((nsrest == nsrStartup .and. finidat /= ' ') .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 + call mosart_rest_fileread( file=fnamer ) endif - do nt = 1,nt_rtm - do nr = rtmCTL%begr,rtmCTL%endr + do nt = 1,ntracers + do nr = begr,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)) + ctl%volr(nr,nt) = (TRunoff%wt(nr,nt) + TRunoff%wr(nr,nt) + TRunoff%wh(nr,nt)*ctl%area(nr)) enddo enddo call t_stopf('mosarti_restart') @@ -1570,38 +347,41 @@ subroutine MOSART_init2(rc) !------------------------------------------------------- call t_startf('mosarti_histinit') - call RtmHistFldsInit() + call mosart_histflds_init(begr, endr, ntracers) if (nsrest==nsrStartup .or. nsrest==nsrBranch) then - call RtmHistHtapesBuild() + call mosart_hist_HtapesBuild() end if - call RtmHistFldsSet() + call mosart_histflds_set(ntracers) if (mainproc) write(iulog,*) subname,' done' call t_stopf('mosarti_histinit') - end subroutine MOSART_init2 + end subroutine mosart_init2 !----------------------------------------------------------------------- - subroutine MOSART_run(rstwr, nlend, rdate, rc) + subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) - ! Run MOSART river routing model + ! Run mosart river routing model ! ! Arguments + integer , intent(in) :: begr, endr, ntracers logical , intent(in) :: rstwr ! true => write restart file this step) logical , intent(in) :: nlend ! true => end of run on this step character(len=*) , intent(in) :: rdate ! restart file time stamp for name integer , intent(out) :: rc ! ! Local variables + ! BUDGET terms 1-10 are for volumes (m3) + ! BUDGET terms 11-30 are for flows (m3/s) 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 + real(r8) :: budget_terms(30,ntracers) ! BUDGET terms + real(r8) :: budget_input + real(r8) :: budget_output + real(r8) :: budget_volume + real(r8) :: budget_total + real(r8) :: budget_euler + real(r8) :: budget_eroutlag + real(r8) :: budget_global(30,ntracers) ! 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 @@ -1609,9 +389,6 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) 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 @@ -1619,10 +396,12 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) 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) ' + real(r8) :: river_depth_minimum = 1.e-4 ! gridcell average minimum river depth [m] + real(r8) :: river_volume_minimum ! gridcell area multiplied by average river_depth_minimum [m3] + real(r8) :: qgwl_volume ! volume of runoff during time step [m3] + real(r8) :: irrig_volume ! volume of irrigation demand during time step [m3] + logical, save :: first_call = .true. ! first time flag (for backwards compatibility) + character(len=*),parameter :: subname = ' (mosart_run) ' !----------------------------------------------------------------------- call t_startf('mosartr_tot') @@ -1635,17 +414,23 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) 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 + if (tod == 0) then + if (mainproc) then + write(iulog,*) ' ' + write(iulog,'(2a,i10,i6)') trim(subname),' model date is',ymd,tod + end if endif delt_coupling = coupling_period*1.0_r8 + if (first_call) then 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 + allocate(budget_accum(ntracers)) + if (mainproc) then + write(iulog,'(2a,g20.12)') trim(subname),' mosart coupling period ',delt_coupling + end if end if budget_check = .false. @@ -1653,48 +438,34 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) 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) + do nt = 1,ntracers + do nr = begr,endr + budget_terms( 1,nt) = budget_terms( 1,nt) + ctl%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) + budget_terms( 7,nt) = budget_terms( 7,nt) + TRunoff%wh(nr,nt)*ctl%area(nr) + budget_terms(13,nt) = budget_terms(13,nt) + ctl%qsur(nr,nt) + budget_terms(14,nt) = budget_terms(14,nt) + ctl%qsub(nr,nt) + budget_terms(15,nt) = budget_terms(15,nt) + ctl%qgwl(nr,nt) + budget_terms(17,nt) = budget_terms(17,nt) + ctl%qsur(nr,nt) + ctl%qsub(nr,nt)+ ctl%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) + budget_terms(16,nt) = budget_terms(16,nt) + ctl%qirrig(nr) + budget_terms(17,nt) = budget_terms(17,nt) + ctl%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) + do nr = begr,endr + do nt = 1,ntracers + TRunoff%qsur(nr,nt) = ctl%qsur(nr,nt) + TRunoff%qsub(nr,nt) = ctl%qsub(nr,nt) + TRunoff%qgwl(nr,nt) = ctl%qgwl(nr,nt) enddo enddo @@ -1706,25 +477,24 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) call t_startf('mosartr_irrig') nt = 1 - rtmCTL%qirrig_actual = 0._r8 - do nr = rtmCTL%begr,rtmCTL%endr + ctl%qirrig_actual = 0._r8 + do nr = begr,endr ! calculate volume of irrigation flux during timestep - irrig_volume = -rtmCTL%qirrig(nr) * coupling_period + irrig_volume = -ctl%qirrig(nr) * coupling_period ! compare irrig_volume to main channel storage; ! add overage to subsurface runoff if(irrig_volume > TRunoff%wr(nr,nt)) 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) + ctl%qsub(nr,nt) = ctl%qsub(nr,nt) + (TRunoff%wr(nr,nt) - irrig_volume) / coupling_period + TRunoff%qsub(nr,nt) = ctl%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 + ctl%qirrig_actual(nr) = - irrig_volume / coupling_period ! remove irrigation from wr (main channel) TRunoff%wr(nr,nt) = TRunoff%wr(nr,nt) - irrig_volume @@ -1736,20 +506,20 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) ! 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 + ! ctl%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 + ctl%flood = 0._r8 + do nr = begr,endr + ! initialize ctl%flood to zero + if (ctl%mask(nr) == 1) then + if (ctl%volr(nr,nt) > ctl%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) + ctl%flood(nr) = (ctl%volr(nr,nt)-ctl%fthresh(nr)) / (delt_coupling) - ! rtmCTL%flood will be sent back to land - so must subtract this + ! ctl%flood will be sent back to land - so must subtract this ! from the input runoff from land ! tcraig, comment - this seems like an odd approach, you ! might create negative forcing. why not take it out of @@ -1758,7 +528,7 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) ! 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) + TRunoff%qsur(nr,nt) = TRunoff%qsur(nr,nt) - ctl%flood(nr) endif endif enddo @@ -1781,9 +551,9 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) ! Set up pointer arrays into srcfield and dstfield !----------------------------------------------------- - call ESMF_FieldGet(srcfield, farrayPtr=src_direct, rc=rc) + call ESMF_FieldGet(Tunit%srcfield, farrayPtr=src_direct, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(dstfield, farrayPtr=dst_direct, rc=rc) + call ESMF_FieldGet(Tunit%dstfield, farrayPtr=dst_direct, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return !----------------------------------------------------- @@ -1795,10 +565,10 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) dst_direct(:,:) = 0._r8 ! set euler_calc = false for frozen runoff - TUnit%euler_calc(nt) = .false. + Tunit%euler_calc(nt) = .false. cnt = 0 - do nr = rtmCTL%begr,rtmCTL%endr + do nr = begr,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 @@ -1806,14 +576,15 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) TRunoff%qgwl(nr,nt) = 0._r8 enddo - call ESMF_FieldSMM(srcfield, dstfield, rh_direct, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) + call ESMF_FieldSMM(Tunit%srcfield, Tunit%dstfield, Tunit%rh_direct, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return ! copy direct transfer water to output field + ctl%direct = 0._r8 cnt = 0 - do nr = rtmCTL%begr,rtmCTL%endr + do nr = begr,endr cnt = cnt + 1 - rtmCTL%direct(nr,nt) = rtmCTL%direct(nr,nt) + dst_direct(nt,cnt) + ctl%direct(nr,nt) = ctl%direct(nr,nt) + dst_direct(nt,cnt) enddo !----------------------------------------------------- @@ -1829,7 +600,7 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) !--- copy direct transfer fields, convert kg/m2s to m3/s cnt = 0 - do nr = rtmCTL%begr,rtmCTL%endr + do nr = begr,endr cnt = cnt + 1 if (trim(qgwl_runoff_option) == 'all') then src_direct(nt,cnt) = TRunoff%qgwl(nr,nt) @@ -1842,14 +613,14 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) endif enddo - call ESMF_FieldSMM(srcfield, dstfield, rh_direct, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) + call ESMF_FieldSMM(Tunit%srcfield, Tunit%dstfield, Tunit%rh_direct, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return !--- copy direct transfer water to output field --- cnt = 0 - do nr = rtmCTL%begr,rtmCTL%endr + do nr = begr,endr cnt = cnt + 1 - rtmCTL%direct(nr,nt) = rtmCTL%direct(nr,nt) + dst_direct(nt,cnt) + ctl%direct(nr,nt) = ctl%direct(nr,nt) + dst_direct(nt,cnt) enddo endif @@ -1860,27 +631,26 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) if (trim(bypass_routing_option) == 'direct_in_place') then nt = 1 - do nr = rtmCTL%begr,rtmCTL%endr + do nr = begr,endr if (trim(qgwl_runoff_option) == 'all') then - rtmCTL%direct(nr,nt) = TRunoff%qgwl(nr,nt) + ctl%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) + ctl%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) + qgwl_volume = TRunoff%qgwl(nr,nt) * ctl%area(nr) * coupling_period + river_volume_minimum = river_depth_minimum * ctl%area(nr) ! if qgwl is negative, and adding it to the main channel ! would bring main channel storage below a threshold, ! send qgwl directly to ocean - if (((qgwl_volume + TRunoff%wr(nr,nt)) < river_volume_minimum) & - .and. (TRunoff%qgwl(nr,nt) < 0._r8)) then - rtmCTL%direct(nr,nt) = TRunoff%qgwl(nr,nt) + if (((qgwl_volume + TRunoff%wr(nr,nt)) < river_volume_minimum) .and. (TRunoff%qgwl(nr,nt) < 0._r8)) then + ctl%direct(nr,nt) = TRunoff%qgwl(nr,nt) TRunoff%qgwl(nr,nt) = 0._r8 endif endif @@ -1894,24 +664,23 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) !------------------------------------------------------- if (trim(bypass_routing_option) == 'direct_in_place') then - do nt = 1,nt_rtm - do nr = rtmCTL%begr,rtmCTL%endr + do nt = 1,ntracers + do nr = begr,endr if (TRunoff%qsub(nr,nt) < 0._r8) then - rtmCTL%direct(nr,nt) = rtmCTL%direct(nr,nt) + TRunoff%qsub(nr,nt) + ctl%direct(nr,nt) = ctl%direct(nr,nt) + TRunoff%qsub(nr,nt) TRunoff%qsub(nr,nt) = 0._r8 endif if (TRunoff%qsur(nr,nt) < 0._r8) then - rtmCTL%direct(nr,nt) = rtmCTL%direct(nr,nt) + TRunoff%qsur(nr,nt) + ctl%direct(nr,nt) = ctl%direct(nr,nt) + TRunoff%qsur(nr,nt) TRunoff%qsur(nr,nt) = 0._r8 endif - if (TUnit%mask(nr) > 0) then + 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) + ctl%direct(nr,nt) = ctl%direct(nr,nt) + TRunoff%qsub(nr,nt) + TRunoff%qsur(nr,nt) + TRunoff%qgwl(nr,nt) TRunoff%qsub(nr,nt) = 0._r8 TRunoff%qsur(nr,nt) = 0._r8 TRunoff%qgwl(nr,nt) = 0._r8 @@ -1926,9 +695,9 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) dst_direct(:,:) = 0._r8 cnt = 0 - do nr = rtmCTL%begr,rtmCTL%endr + do nr = begr,endr cnt = cnt + 1 - do nt = 1,nt_rtm + do nt = 1,ntracers !---- negative qsub water, remove from TRunoff --- if (TRunoff%qsub(nr,nt) < 0._r8) then src_direct(nt,cnt) = src_direct(nt,cnt) + TRunoff%qsub(nr,nt) @@ -1943,7 +712,7 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) !---- water outside the basin --- !---- *** DO NOT TURN THIS ONE OFF, conservation will fail *** --- - if (TUnit%mask(nr) > 0) then + 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) & @@ -1955,29 +724,29 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) enddo enddo - call ESMF_FieldSMM(srcfield, dstfield, rh_direct, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) + call ESMF_FieldSMM(Tunit%srcfield, Tunit%dstfield, Tunit%rh_direct, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return !--- copy direct transfer water to output field --- cnt = 0 - do nr = rtmCTL%begr,rtmCTL%endr + do nr = begr,endr cnt = cnt + 1 - do nt = 1,nt_rtm - rtmCTL%direct(nr,nt) = rtmCTL%direct(nr,nt) + dst_direct(nt,cnt) + do nt = 1,ntracers + ctl%direct(nr,nt) = ctl%direct(nr,nt) + dst_direct(nt,cnt) enddo enddo endif call t_stopf('mosartr_SMdirect') !----------------------------------- - ! MOSART Subcycling + ! 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) + do nt = 1,ntracers + write(iulog,'(2a,i6,l4)') trim(subname),' euler_calc for nt = ',nt,Tunit%euler_calc(nt) enddo endif @@ -1988,7 +757,7 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) 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',& + write(iulog,'(2a,2g20.12,2i12)') trim(subname),' mosart delt update from/to',& delt_save,delt,nsub_save,nsub end if endif @@ -1998,134 +767,124 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) Tctl%DeltaT = delt !----------------------------------- - ! MOSART euler solver + ! 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) + do nt = 1,ntracers + do nr = begr,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) + do nt = 1,ntracers + do nr = begr,endr + TRunoff%qsur(nr,nt) = TRunoff%qsur(nr,nt) / ctl%area(nr) + TRunoff%qsub(nr,nt) = TRunoff%qsub(nr,nt) / ctl%area(nr) + TRunoff%qgwl(nr,nt) = TRunoff%qgwl(nr,nt) / ctl%area(nr) enddo enddo + ! Subcycle the call to Euler + call t_startf('mosartr_euler') + ctl%flow = 0._r8 + ctl%erout_prev = 0._r8 + ctl%eroutup_avg = 0._r8 + ctl%erlat_avg = 0._r8 do ns = 1,nsub - - call t_startf('mosartr_euler') + ! solve the ODEs with Euler algorithm 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) + do nt = 1,ntracers + do nr = begr,endr + ctl%flow(nr,nt) = ctl%flow(nr,nt) + TRunoff%flow(nr,nt) + ctl%erout_prev(nr,nt) = ctl%erout_prev(nr,nt) + TRunoff%erout_prev(nr,nt) + ctl%eroutup_avg(nr,nt) = ctl%eroutup_avg(nr,nt) + TRunoff%eroutup_avg(nr,nt) + ctl%erlat_avg(nr,nt) = ctl%erlat_avg(nr,nt) + TRunoff%erlat_avg(nr,nt) enddo enddo - enddo ! nsub + call t_stopf('mosartr_euler') - !----------------------------------- ! average flow over subcycling - !----------------------------------- - - flow = flow / float(nsub) - erout_prev = erout_prev / float(nsub) - eroutup_avg = eroutup_avg / float(nsub) - erlat_avg = erlat_avg / float(nsub) + ctl%flow = ctl%flow / float(nsub) + ctl%erout_prev = ctl%erout_prev / float(nsub) + ctl%eroutup_avg = ctl%eroutup_avg / float(nsub) + ctl%erlat_avg = ctl%erlat_avg / float(nsub) - !----------------------------------- ! update states when subsycling completed - !----------------------------------- - - 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) + ! TODO: move of this to hist_set_flds + ctl%runoff = 0._r8 + ctl%runofflnd = spval + ctl%runoffocn = spval + ctl%dvolrdt = 0._r8 + ctl%dvolrdtlnd = spval + ctl%dvolrdtocn = spval + do nt = 1,ntracers + do nr = begr,endr + volr_init = ctl%volr(nr,nt) + ctl%volr(nr,nt) = (TRunoff%wt(nr,nt) + TRunoff%wr(nr,nt) + TRunoff%wh(nr,nt)*ctl%area(nr)) + ctl%dvolrdt(nr,nt) = (ctl%volr(nr,nt) - volr_init) / delt_coupling + ctl%runoff(nr,nt) = ctl%flow(nr,nt) + ctl%runofftot(nr,nt) = ctl%direct(nr,nt) + if (ctl%mask(nr) == 1) then + ctl%runofflnd(nr,nt) = ctl%runoff(nr,nt) + ctl%dvolrdtlnd(nr,nt)= ctl%dvolrdt(nr,nt) + elseif (ctl%mask(nr) >= 2) then + ctl%runoffocn(nr,nt) = ctl%runoff(nr,nt) + ctl%runofftot(nr,nt) = ctl%runofftot(nr,nt) + ctl%runoff(nr,nt) + ctl%dvolrdtocn(nr,nt)= ctl%dvolrdt(nr,nt) endif enddo enddo - 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) + do nt = 1,ntracers + do nr = begr,endr + budget_terms( 2,nt) = budget_terms( 2,nt) + ctl%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) + budget_terms( 8,nt) = budget_terms( 8,nt) + TRunoff%wh(nr,nt)*ctl%area(nr) + budget_terms(21,nt) = budget_terms(21,nt) + ctl%direct(nr,nt) + if (ctl%mask(nr) >= 2) then + budget_terms(18,nt) = budget_terms(18,nt) + ctl%runoff(nr,nt) + budget_terms(26,nt) = budget_terms(26,nt) - ctl%erout_prev(nr,nt) + budget_terms(27,nt) = budget_terms(27,nt) + ctl%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) + budget_terms(23,nt) = budget_terms(23,nt) - ctl%erout_prev(nr,nt) + budget_terms(24,nt) = budget_terms(24,nt) + ctl%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) + budget_terms(25,nt) = budget_terms(25,nt) - ctl%eroutup_avg(nr,nt) + budget_terms(28,nt) = budget_terms(28,nt) - ctl%erlat_avg(nr,nt) + budget_terms(22,nt) = budget_terms(22,nt) + ctl%runoff(nr,nt) + ctl%direct(nr,nt) + ctl%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) + do nr = begr,endr + budget_terms(19,nt) = budget_terms(19,nt) + ctl%flood(nr) + budget_terms(22,nt) = budget_terms(22,nt) + ctl%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 + do nt = 1,ntracers 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_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 @@ -2147,13 +906,11 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) ! 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 + write(iulog,'(2a,i10,i6)') trim(subname),' mosart BUDGET diagnostics (million m3) for ',ymd,tod + do nt = 1,ntracers 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_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) @@ -2190,26 +947,26 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) endif ! budget_check !----------------------------------- - ! Write out MOSART history file + ! Write out mosart history file !----------------------------------- call t_startf('mosartr_hbuf') - call RtmHistFldsSet() - call RtmHistUpdateHbuf() + call mosart_histflds_set(ntracers) + call mosart_hist_updatehbuf() call t_stopf('mosartr_hbuf') call t_startf('mosartr_htapes') - call RtmHistHtapesWrapup( rstwr, nlend ) + call mosart_hist_htapeswrapup( rstwr, nlend ) call t_stopf('mosartr_htapes') !----------------------------------- - ! Write out MOSART restart file + ! Write out mosart restart file !----------------------------------- if (rstwr) then call t_startf('mosartr_rest') - filer = RtmRestFileName(rdate=rdate) - call RtmRestFileWrite( filer, rdate=rdate ) + filer = mosart_rest_filename(rdate=rdate) + call mosart_rest_filewrite( filer, rdate=rdate ) call t_stopf('mosartr_rest') end if @@ -2221,127 +978,6 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) call t_stopf('mosartr_tot') - end subroutine MOSART_run - - !----------------------------------------------------------------------- - - subroutine MOSART_FloodInit(frivinp, begr, endr, fthresh, evel ) - - ! Arguments - 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 = '(MOSART_FloodInit) ' - !----------------------------------------------------------------------- - - 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 (mainproc) 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 MOSART_FloodInit - - !---------------------------------------------------------------------------- - - subroutine MOSART_SubTimestep() - - ! predescribe the sub-time-steps for channel routing - - ! Local variables - integer :: iunit !local index - character(len=*),parameter :: subname = '(MOSART_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 MOSART_SubTimestep + end subroutine mosart_run -end module RtmMod +end module mosart_mod diff --git a/src/riverroute/mosart_physics_mod.F90 b/src/riverroute/mosart_physics_mod.F90 index e7349d4..3699f71 100644 --- a/src/riverroute/mosart_physics_mod.F90 +++ b/src/riverroute/mosart_physics_mod.F90 @@ -1,24 +1,15 @@ -module MOSART_physics_mod +MODULE MOSART_physics_mod !----------------------------------------------------------------------- - ! Description: core code of MOSART. Can be incoporated within any - ! land model via a interface module - ! + ! Description: core code of MOSART. ! 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 - use RunoffMod , only : Tctl, TUnit, TRunoff, TPara, rtmCTL + use mosart_vars , only : iulog, barrier_timers, mpicom_rof + use mosart_data , only : Tctl, TUnit, TRunoff, TPara, ctl use perf_mod , only : t_startf, t_stopf use nuopc_shr_methods , only : chkerr use ESMF , only : ESMF_FieldGet, ESMF_FieldSMM, ESMF_Finalize, & @@ -27,13 +18,6 @@ module MOSART_physics_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)) - character(*), parameter :: u_FILE_u = & - __FILE__ - public :: Euler public :: updatestate_hillslope public :: updatestate_subnetwork @@ -41,18 +25,26 @@ module MOSART_physics_mod public :: hillsloperouting public :: subnetworkrouting public :: mainchannelrouting - !----------------------------------------------------------------------- + real(r8), parameter :: TINYVALUE = 1.0e-14_r8 ! double precision variable has a significance of about 16 decimal digits + real(r8), parameter :: SLOPE1def = 0.1_r8 ! here give it a small value in order to avoid the abrupt change of hydraulic radidus etc. + + character(*), parameter :: u_FILE_u = & + __FILE__ + +!----------------------------------------------------------------------- contains +!----------------------------------------------------------------------- - !----------------------------------------------------------------------- subroutine Euler(rc) ! solve the ODEs with Euler algorithm + + ! Arguments integer, intent(out) :: rc ! Local variables - integer :: iunit, m, k, unitUp, cnt, ier !local index + integer :: nt, nr, m, k, unitUp, cnt, ier !local index real(r8) :: temp_erout, localDeltaT real(r8) :: negchan real(r8), pointer :: src_eroutUp(:,:) @@ -65,24 +57,24 @@ subroutine Euler(rc) rc = ESMF_SUCCESS call t_startf('mosartr_hillslope') - do nt=1,nt_rtm + do nt=1,ctl%ntracers 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) + do nr=ctl%begr,ctl%endr + if(TUnit%mask(nr) > 0) then + call hillslopeRouting(nr,nt,Tctl%DeltaT) + TRunoff%wh(nr,nt) = TRunoff%wh(nr,nt) + TRunoff%dwh(nr,nt) * Tctl%DeltaT + + call UpdateState_hillslope(nr,nt) + TRunoff%etin(nr,nt) = (-TRunoff%ehout(nr,nt) + TRunoff%qsub(nr,nt)) * TUnit%area(nr) * TUnit%frac(nr) endif end do endif end do call t_stopf('mosartr_hillslope') - call ESMF_FieldGet(srcfield, farrayPtr=src_eroutUp, rc=rc) + call ESMF_FieldGet(Tunit%srcfield, farrayPtr=src_eroutUp, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(dstfield, farrayPtr=dst_eroutUp, rc=rc) + call ESMF_FieldGet(Tunit%dstfield, farrayPtr=dst_eroutUp, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return src_eroutUp(:,:) = 0._r8 dst_eroutUp(:,:) = 0._r8 @@ -96,10 +88,10 @@ subroutine Euler(rc) do m=1,Tctl%DLevelH2R !--- accumulate/average erout at prior timestep (used in eroutUp calc) for budget analysis - do nt=1,nt_rtm + do nt=1,ctl%ntracers 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) + do nr=ctl%begr,ctl%endr + TRunoff%erout_prev(nr,nt) = TRunoff%erout_prev(nr,nt) + TRunoff%erout(nr,nt) end do end if end do @@ -110,20 +102,20 @@ subroutine Euler(rc) call t_startf('mosartr_subnetwork') TRunoff%erlateral(:,:) = 0._r8 - do nt=1,nt_rtm + do nt=1,ctl%ntracers 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) + do nr=ctl%begr,ctl%endr + if(TUnit%mask(nr) > 0) then + localDeltaT = Tctl%DeltaT/Tctl%DLevelH2R/TUnit%numDT_t(nr) + do k=1,TUnit%numDT_t(nr) + call subnetworkRouting(nr,nt,localDeltaT) + TRunoff%wt(nr,nt) = TRunoff%wt(nr,nt) + TRunoff%dwt(nr,nt) * localDeltaT + call UpdateState_subnetwork(nr,nt) + TRunoff%erlateral(nr,nt) = TRunoff%erlateral(nr,nt)-TRunoff%etout(nr,nt) end do ! numDT_t - TRunoff%erlateral(iunit,nt) = TRunoff%erlateral(iunit,nt) / TUnit%numDT_t(iunit) + TRunoff%erlateral(nr,nt) = TRunoff%erlateral(nr,nt) / TUnit%numDT_t(nr) endif - end do ! iunit + end do ! nr endif ! euler_calc end do ! nt call t_stopf('mosartr_subnetwork') @@ -144,23 +136,23 @@ subroutine Euler(rc) TRunoff%eroutUp = 0._r8 src_eroutUp(:,:) = 0._r8 cnt = 0 - do iunit = rtmCTL%begr,rtmCTL%endr + do nr = ctl%begr,ctl%endr cnt = cnt + 1 - do nt = 1,nt_rtm - src_eroutUp(nt,cnt) = TRunoff%erout(iunit,nt) + do nt = 1,ctl%ntracers + src_eroutUp(nt,cnt) = TRunoff%erout(nr,nt) enddo enddo ! --- map src_eroutUp to dst_eroutUp - call ESMF_FieldSMM(srcfield, dstField, rh_eroutUp, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) + call ESMF_FieldSMM(TUnit%srcfield, TUnit%dstField, TUnit%rh_eroutUp, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return !--- copy mapped eroutUp to TRunoff --- cnt = 0 - do iunit = rtmCTL%begr,rtmCTL%endr + do nr = ctl%begr,ctl%endr cnt = cnt + 1 - do nt = 1,nt_rtm - TRunoff%eroutUp(iunit,nt) = dst_eroutUp(nt,cnt) + do nt = 1,ctl%ntracers + TRunoff%eroutUp(nr,nt) = dst_eroutUp(nt,cnt) enddo enddo @@ -174,25 +166,29 @@ subroutine Euler(rc) !------------------ call t_startf('mosartr_chanroute') - do nt=1,nt_rtm + do nt=1,ctl%ntracers 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) + do nr=ctl%begr,ctl%endr + if(TUnit%mask(nr) > 0) then + localDeltaT = Tctl%DeltaT/Tctl%DLevelH2R/TUnit%numDT_r(nr) temp_erout = 0._r8 - do k=1,TUnit%numDT_r(iunit) - call mainchannelRouting(iunit,nt,localDeltaT) - TRunoff%wr(iunit,nt) = TRunoff%wr(iunit,nt) + TRunoff%dwr(iunit,nt) * localDeltaT + do k=1,TUnit%numDT_r(nr) + call mainchannelRouting(nr,nt,localDeltaT) + TRunoff%wr(nr,nt) = TRunoff%wr(nr,nt) + TRunoff%dwr(nr,nt) * localDeltaT ! check for negative channel storage - call UpdateState_mainchannel(iunit,nt) + ! if(TRunoff%wr(nr,1) < -1.e-10) then + ! write(iulog,*) 'Negative channel storage! ', nr, TRunoff%wr(nr,1) + ! call shr_sys_abort('mosart: negative channel storage') + ! end if + call UpdateState_mainchannel(nr,nt) ! erout here might be inflow to some downstream subbasin, so treat it differently than erlateral - temp_erout = temp_erout + TRunoff%erout(iunit,nt) + temp_erout = temp_erout + TRunoff%erout(nr,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) + temp_erout = temp_erout / TUnit%numDT_r(nr) + TRunoff%erout(nr,nt) = temp_erout + TRunoff%flow(nr,nt) = TRunoff%flow(nr,nt) - TRunoff%erout(nr,nt) endif - end do ! iunit + end do ! nr endif ! euler_calc end do ! nt negchan = min(negchan, minval(TRunoff%wr(:,:))) @@ -203,7 +199,7 @@ subroutine Euler(rc) ! 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') + ! call shr_sys_abort('mosart: negative channel storage') endif TRunoff%flow = TRunoff%flow / Tctl%DLevelH2R TRunoff%erout_prev = TRunoff%erout_prev / Tctl%DLevelH2R @@ -214,64 +210,69 @@ end subroutine Euler !----------------------------------------------------------------------- - subroutine hillslopeRouting(iunit, nt, theDeltaT) + subroutine hillslopeRouting(nr, nt, theDeltaT) ! Hillslope routing considering uniform runoff generation across hillslope ! Arguments - integer, intent(in) :: iunit, nt + integer, intent(in) :: nr, 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) + TRunoff%ehout(nr,nt) = -CREHT_nosqrt(TUnit%hslpsqrt(nr), TUnit%nh(nr), TUnit%Gxr(nr), TRunoff%yh(nr,nt)) + if(TRunoff%ehout(nr,nt) < 0._r8 .and. & + TRunoff%wh(nr,nt) + (TRunoff%qsur(nr,nt) + TRunoff%ehout(nr,nt)) * theDeltaT < TINYVALUE) then + TRunoff%ehout(nr,nt) = -(TRunoff%qsur(nr,nt) + TRunoff%wh(nr,nt) / theDeltaT) end if - TRunoff%dwh(iunit,nt) = (TRunoff%qsur(iunit,nt) + TRunoff%ehout(iunit,nt)) + TRunoff%dwh(nr,nt) = (TRunoff%qsur(nr,nt) + TRunoff%ehout(nr,nt)) end subroutine hillslopeRouting !----------------------------------------------------------------------- - subroutine subnetworkRouting(iunit,nt,theDeltaT) + subroutine subnetworkRouting(nr,nt,theDeltaT) ! subnetwork channel routing ! Arguments - integer, intent(in) :: iunit,nt + integer, intent(in) :: nr,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) + if(TUnit%tlen(nr) <= TUnit%hlen(nr)) then ! if no tributaries, not subnetwork channel routing + TRunoff%etout(nr,nt) = -TRunoff%etin(nr,nt) else - TRunoff%vt(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) + TRunoff%vt(nr,nt) = CRVRMAN_nosqrt(TUnit%tslpsqrt(nr), TUnit%nt(nr), TRunoff%rt(nr,nt)) + TRunoff%etout(nr,nt) = -TRunoff%vt(nr,nt) * TRunoff%mt(nr,nt) + if(TRunoff%wt(nr,nt) + (TRunoff%etin(nr,nt) + TRunoff%etout(nr,nt)) * theDeltaT < TINYVALUE) then + TRunoff%etout(nr,nt) = -(TRunoff%etin(nr,nt) + TRunoff%wt(nr,nt)/theDeltaT) + if(TRunoff%mt(nr,nt) > 0._r8) then + TRunoff%vt(nr,nt) = -TRunoff%etout(nr,nt)/TRunoff%mt(nr,nt) end if end if end if - TRunoff%dwt(iunit,nt) = TRunoff%etin(iunit,nt) + TRunoff%etout(iunit,nt) + TRunoff%dwt(nr,nt) = TRunoff%etin(nr,nt) + TRunoff%etout(nr,nt) + + ! check stability + ! if(TRunoff%vt(nr,nt) < -TINYVALUE .or. TRunoff%vt(nr,nt) > 30) then + ! write(iulog,*) "Numerical error in subnetworkRouting, ", nr,nt,TRunoff%vt(nr,nt) + ! end if end subroutine subnetworkRouting !----------------------------------------------------------------------- - subroutine mainchannelRouting(iunit, nt, theDeltaT) + subroutine mainchannelRouting(nr, nt, theDeltaT) ! main channel routing ! Arguments - integer, intent(in) :: iunit, nt + integer, intent(in) :: nr, nt real(r8), intent(in) :: theDeltaT if(Tctl%RoutingMethod == 1) then - call Routing_KW(iunit, nt, theDeltaT) + call Routing_KW(nr, nt, theDeltaT) else if(Tctl%RoutingMethod == 2) then - call Routing_MC(iunit, nt, theDeltaT) + call Routing_MC(nr, nt, theDeltaT) else if(Tctl%RoutingMethod == 3) then - call Routing_THREW(iunit, nt, theDeltaT) + call Routing_THREW(nr, nt, theDeltaT) else if(Tctl%RoutingMethod == 4) then - call Routing_DW(iunit, nt, theDeltaT) + call Routing_DW(nr, nt, theDeltaT) else call shr_sys_abort( "mosart: Please check the routing method! There are only 4 methods available." ) end if @@ -280,160 +281,157 @@ end subroutine mainchannelRouting !----------------------------------------------------------------------- - subroutine Routing_KW(iunit, nt, theDeltaT) + subroutine Routing_KW(nr, nt, theDeltaT) ! classic kinematic wave routing method ! Arguments - integer, intent(in) :: iunit, nt + integer, intent(in) :: nr, nt real(r8), intent(in) :: theDeltaT + + ! Local variables integer :: k real(r8) :: temp_gwl, temp_dwr, temp_gwl0 ! estimate the inflow from upstream units - TRunoff%erin(iunit,nt) = 0._r8 - TRunoff%erin(iunit,nt) = TRunoff%erin(iunit,nt) - TRunoff%eroutUp(iunit,nt) + TRunoff%erin(nr,nt) = 0._r8 + TRunoff%erin(nr,nt) = TRunoff%erin(nr,nt) - TRunoff%eroutUp(nr,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) + if(TUnit%rlen(nr) <= 0._r8) then ! no river network, no channel routing + TRunoff%vr(nr,nt) = 0._r8 + TRunoff%erout(nr,nt) = -TRunoff%erin(nr,nt)-TRunoff%erlateral(nr,nt) else - if(TUnit%areaTotal2(iunit)/TUnit%rwidth(iunit)/TUnit%rlen(iunit) > 1e6_r8) then - TRunoff%erout(iunit,nt) = -TRunoff%erin(iunit,nt)-TRunoff%erlateral(iunit,nt) + if(TUnit%areaTotal2(nr)/TUnit%rwidth(nr)/TUnit%rlen(nr) > 1e6_r8) then + TRunoff%erout(nr,nt) = -TRunoff%erin(nr,nt)-TRunoff%erlateral(nr,nt) else - TRunoff%vr(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) + TRunoff%vr(nr,nt) = CRVRMAN_nosqrt(TUnit%rslpsqrt(nr), TUnit%nr(nr), TRunoff%rr(nr,nt)) + TRunoff%erout(nr,nt) = -TRunoff%vr(nr,nt) * TRunoff%mr(nr,nt) + if(-TRunoff%erout(nr,nt) > TINYVALUE .and. TRunoff%wr(nr,nt) + & + (TRunoff%erlateral(nr,nt) + TRunoff%erin(nr,nt) + TRunoff%erout(nr,nt)) * theDeltaT < TINYVALUE) then + TRunoff%erout(nr,nt) = & + -(TRunoff%erlateral(nr,nt) + TRunoff%erin(nr,nt) + TRunoff%wr(nr,nt) / theDeltaT) + if(TRunoff%mr(nr,nt) > 0._r8) then + TRunoff%vr(nr,nt) = -TRunoff%erout(nr,nt) / TRunoff%mr(nr,nt) end if end if end if end if - temp_gwl = TRunoff%qgwl(iunit,nt) * TUnit%area(iunit) * TUnit%frac(iunit) + temp_gwl = TRunoff%qgwl(nr,nt) * TUnit%area(nr) * TUnit%frac(nr) - TRunoff%dwr(iunit,nt) = TRunoff%erlateral(iunit,nt) + TRunoff%erin(iunit,nt) + TRunoff%erout(iunit,nt) + temp_gwl + TRunoff%dwr(nr,nt) = TRunoff%erlateral(nr,nt) + TRunoff%erin(nr,nt) + TRunoff%erout(nr,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 + if((TRunoff%wr(nr,nt)/theDeltaT & + + TRunoff%dwr(nr,nt)) < -TINYVALUE) then + write(iulog,*) 'mosart: ERROR main channel going negative: ', nr, nt + write(iulog,*) theDeltaT, TRunoff%wr(nr,nt), & + TRunoff%wr(nr,nt)/theDeltaT, TRunoff%dwr(nr,nt), temp_gwl write(iulog,*) ' ' endif + ! check for stability + ! if(TRunoff%vr(nr,nt) < -TINYVALUE .or. TRunoff%vr(nr,nt) > 30) then + ! write(iulog,*) "Numerical error inRouting_KW, ", nr,nt,TRunoff%vr(nr,nt) + ! end if + + ! check for negative wr + ! if(TRunoff%wr(nr,nt) > 1._r8 .and. & + ! (TRunoff%wr(nr,nt)/theDeltaT + TRunoff%dwr(nr,nt))/TRunoff%wr(nr,nt) < -TINYVALUE) then + ! write(iulog,*) 'negative wr!', TRunoff%wr(nr,nt), TRunoff%dwr(nr,nt), temp_dwr, temp_gwl, temp_gwl0, theDeltaT + ! stop + ! end if + end subroutine Routing_KW !----------------------------------------------------------------------- - subroutine Routing_MC(iunit, nt, theDeltaT) + subroutine Routing_MC(nr, nt, theDeltaT) ! Muskingum-Cunge routing method ! Arguments - integer, intent(in) :: iunit, nt + integer, intent(in) :: nr, nt real(r8), intent(in) :: theDeltaT end subroutine Routing_MC !----------------------------------------------------------------------- - subroutine Routing_THREW(iunit, nt, theDeltaT) + subroutine Routing_THREW(nr, nt, theDeltaT) ! kinematic wave routing method from THREW model ! Arguments - integer, intent(in) :: iunit, nt + integer, intent(in) :: nr, nt real(r8), intent(in) :: theDeltaT end subroutine Routing_THREW !----------------------------------------------------------------------- - subroutine Routing_DW(iunit, nt, theDeltaT) + subroutine Routing_DW(nr, nt, theDeltaT) ! classic diffusion wave routing method ! Arguments - integer, intent(in) :: iunit, nt + integer, intent(in) :: nr, nt real(r8), intent(in) :: theDeltaT end subroutine Routing_DW !----------------------------------------------------------------------- - subroutine updateState_hillslope(iunit,nt) + subroutine updateState_hillslope(nr,nt) ! update the state variables at hillslope ! Arguments - integer, intent(in) :: iunit, nt + integer, intent(in) :: nr, nt - TRunoff%yh(iunit,nt) = TRunoff%wh(iunit,nt) !/ TUnit%area(iunit) / TUnit%frac(iunit) + TRunoff%yh(nr,nt) = TRunoff%wh(nr,nt) !/ TUnit%area(nr) / TUnit%frac(nr) end subroutine updateState_hillslope !----------------------------------------------------------------------- - subroutine updateState_subnetwork(iunit,nt) + subroutine updateState_subnetwork(nr,nt) ! update the state variables in subnetwork channel ! Arguments - integer, intent(in) :: iunit,nt + integer, intent(in) :: nr,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)) + if(TUnit%tlen(nr) > 0._r8 .and. TRunoff%wt(nr,nt) > 0._r8) then + TRunoff%mt(nr,nt) = GRMR(TRunoff%wt(nr,nt), TUnit%tlen(nr)) + TRunoff%yt(nr,nt) = GRHT(TRunoff%mt(nr,nt), TUnit%twidth(nr)) + TRunoff%pt(nr,nt) = GRPT(TRunoff%yt(nr,nt), TUnit%twidth(nr)) + TRunoff%rt(nr,nt) = GRRR(TRunoff%mt(nr,nt), TRunoff%pt(nr,nt)) else - TRunoff%mt(iunit,nt) = 0._r8 - TRunoff%yt(iunit,nt) = 0._r8 - TRunoff%pt(iunit,nt) = 0._r8 - TRunoff%rt(iunit,nt) = 0._r8 + TRunoff%mt(nr,nt) = 0._r8 + TRunoff%yt(nr,nt) = 0._r8 + TRunoff%pt(nr,nt) = 0._r8 + TRunoff%rt(nr,nt) = 0._r8 end if end subroutine updateState_subnetwork !----------------------------------------------------------------------- - subroutine updateState_mainchannel(iunit, nt) + subroutine updateState_mainchannel(nr, nt) ! update the state variables in main channel ! Arguments - integer, intent(in) :: iunit, nt + integer, intent(in) :: nr, 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)) + if(TUnit%rlen(nr) > 0._r8 .and. TRunoff%wr(nr,nt) > 0._r8) then + TRunoff%mr(nr,nt) = GRMR(TRunoff%wr(nr,nt), TUnit%rlen(nr)) + TRunoff%yr(nr,nt) = GRHR(TRunoff%mr(nr,nt), TUnit%rwidth(nr), TUnit%rwidth0(nr), TUnit%rdepth(nr)) + TRunoff%pr(nr,nt) = GRPR(TRunoff%yr(nr,nt), TUnit%rwidth(nr), TUnit%rwidth0(nr), TUnit%rdepth(nr)) + TRunoff%rr(nr,nt) = GRRR(TRunoff%mr(nr,nt), TRunoff%pr(nr,nt)) else - TRunoff%mr(iunit,nt) = 0._r8 - TRunoff%yr(iunit,nt) = 0._r8 - TRunoff%pr(iunit,nt) = 0._r8 - TRunoff%rr(iunit,nt) = 0._r8 + TRunoff%mr(nr,nt) = 0._r8 + TRunoff%yr(nr,nt) = 0._r8 + TRunoff%pr(nr,nt) = 0._r8 + TRunoff%rr(nr,nt) = 0._r8 end if end subroutine updateState_mainchannel !----------------------------------------------------------------------- - function CRVRMAN(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. @@ -441,6 +439,7 @@ function CRVRMAN_nosqrt(sqrtslp_, n_, rr_) result(v_) real(r8), intent(in) :: sqrtslp_, n_, rr_ ! sqrt(slope), manning's roughness coeff., hydraulic radius real(r8) :: v_ ! v_ is discharge + ! Local varaibles real(r8) :: ftemp, vtemp if(rr_ <= 0._r8) then @@ -448,22 +447,8 @@ function CRVRMAN_nosqrt(sqrtslp_, n_, rr_) result(v_) 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 + end function CRVRMAN_nosqrt !----------------------------------------------------------------------- @@ -477,7 +462,7 @@ function CREHT_nosqrt(sqrthslp_, nh_, Gxr_, yh_) result(eht_) real(r8) :: vh_ vh_ = CRVRMAN_nosqrt(sqrthslp_,nh_,yh_) eht_ = Gxr_*yh_*vh_ - return + end function CREHT_nosqrt !----------------------------------------------------------------------- @@ -490,7 +475,6 @@ function GRMR(wr_, rlen_) result(mr_) real(r8) :: mr_ ! wetted channel area mr_ = wr_ / rlen_ - return end function GRMR !----------------------------------------------------------------------- @@ -507,7 +491,6 @@ function GRHT(mt_, twid_) result(ht_) else ht_ = mt_ / twid_ end if - return end function GRHT !----------------------------------------------------------------------- @@ -524,7 +507,6 @@ function GRPT(ht_, twid_) result(pt_) else pt_ = twid_ + 2._r8 * ht_ end if - return end function GRPT !----------------------------------------------------------------------- @@ -541,7 +523,6 @@ function GRRR(mr_, pr_) result(rr_) else rr_ = mr_ / pr_ end if - return end function GRRR !----------------------------------------------------------------------- @@ -557,6 +538,7 @@ function GRHR(mr_, rwidth_, rwidth0_, rdepth_) result(hr_) real(r8), intent(in) :: mr_, rwidth_, rwidth0_, rdepth_ ! wetted channel area, channel width, flood plain wid, water depth real(r8) :: hr_ ! water depth + ! Local variables real(r8) :: SLOPE1 ! slope of flood plain, TO DO real(r8) :: deltamr_ @@ -591,8 +573,10 @@ function GRPR(hr_, rwidth_, rwidth0_,rdepth_) result(pr_) real(r8), intent(in) :: hr_, rwidth_, rwidth0_, rdepth_ ! wwater depth, channel width, flood plain wid, water depth real(r8) :: pr_ ! water depth + ! Local variables real(r8) :: SLOPE1 ! slope of flood plain, TO DO real(r8) :: deltahr_ + real(r8) :: sinatanSLOPE1defr ! 1.0/sin(atan(slope1)) logical, save :: first_call = .true. SLOPE1 = SLOPE1def @@ -611,60 +595,10 @@ function GRPR(hr_, rwidth_, rwidth0_,rdepth_) result(pr_) 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 - 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 +end MODULE MOSART_physics_mod diff --git a/src/riverroute/mosart_restfile.F90 b/src/riverroute/mosart_restfile.F90 index 8139272..4f8111f 100644 --- a/src/riverroute/mosart_restfile.F90 +++ b/src/riverroute/mosart_restfile.F90 @@ -1,47 +1,52 @@ -module RtmRestFile +module mosart_restfile - !----------------------------------------------------------------------- ! 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: + + use shr_kind_mod, only : r8 => shr_kind_r8, CL => shr_kind_cl + use shr_sys_mod, only : shr_sys_abort + use mosart_vars, only : iulog, inst_suffix, caseid, nsrest, & + spval, mainproc, nsrContinue, nsrBranch, nsrStartup, & + ctitle, version, username, hostname, conventions, source + use mosart_data, only : ctl, Trunoff + use mosart_histfile, only : mosart_hist_restart + use mosart_fileutils, only : getfil + use mosart_timemanager, only : timemgr_restart, get_nstep, get_curr_date + use mosart_io + implicit none private + + ! public member functions: + public :: mosart_rest_FileName + public :: mosart_rest_FileRead + public :: mosart_rest_FileWrite + public :: mosart_rest_Getfile + public :: mosart_rest_TimeManager + public :: mosart_rest_restart ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: RtmRestFileName - public :: RtmRestFileRead - public :: RtmRestFileWrite - public :: RtmRestGetfile - public :: RtmRestTimeManager - public :: RtmRestart - ! - ! !PRIVATE MEMBER FUNCTIONS: + ! private member functions: private :: restFile_read_pfile private :: restFile_write_pfile ! Writes restart pointer file private :: restFile_dimset - !----------------------------------------------------------------------- + ! true => allow case name to remain the same for branch run + ! by default this is not allowed + logical, public :: brnch_retain_casename = .false. + + ! file name for local restart pointer file + character(len=CL) :: rpntfil = 'rpointer.rof' + + ! initial conditions file name + character(len=CL), public :: finidat + + ! restart data file name for branch run + character(len=CL), public :: nrevsn + +!----------------------------------------------------------------------- contains +!----------------------------------------------------------------------- - !----------------------------------------------------------------------- - subroutine RtmRestFileWrite( file, rdate ) + subroutine mosart_rest_FileWrite( file, rdate ) !------------------------------------- ! Read/write MOSART restart file. @@ -65,14 +70,14 @@ subroutine RtmRestFileWrite( file, rdate ) 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 mosart_rest_restart ( ncid, flag='define' ) + call mosart_hist_restart ( ncid, flag='define', rdate=rdate ) call timemgr_restart( ncid, flag='define' ) call ncd_enddef(ncid) ! Write restart file variables - call RtmRestart( ncid, flag='write' ) - call RtmHistRestart ( ncid, flag='write' ) + call mosart_rest_restart( ncid, flag='write' ) + call mosart_hist_restart ( ncid, flag='write' ) call timemgr_restart( ncid, flag='write' ) call ncd_pio_closefile(ncid) @@ -92,11 +97,11 @@ subroutine RtmRestFileWrite( file, rdate ) write(iulog,'(72a1)') ("-",i=1,60) end if - end subroutine RtmRestFileWrite + end subroutine mosart_rest_FileWrite !----------------------------------------------------------------------- - subroutine RtmRestFileRead( file ) + subroutine mosart_rest_FileRead( file ) !------------------------------------- ! Read a MOSART restart file. @@ -112,8 +117,8 @@ subroutine RtmRestFileRead( file ) ! 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 mosart_rest_restart(ncid, flag='read') + call mosart_hist_restart(ncid, flag='read') call ncd_pio_closefile(ncid) ! Write out diagnostic info @@ -123,11 +128,11 @@ subroutine RtmRestFileRead( file ) write(iulog,*) end if - end subroutine RtmRestFileRead + end subroutine mosart_rest_FileRead !----------------------------------------------------------------------- - subroutine RtmRestTimeManager( file ) + subroutine mosart_rest_TimeManager( file ) !------------------------------------- ! Read a MOSART restart file. @@ -153,23 +158,23 @@ subroutine RtmRestTimeManager( file ) write(iulog,*) end if - end subroutine RtmRestTimeManager + end subroutine mosart_rest_TimeManager !----------------------------------------------------------------------- - subroutine RtmRestGetfile( file, path ) + subroutine mosart_rest_Getfile( file ) !------------------------------------- ! 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 + ! Local variables: + integer :: status ! return status + integer :: length ! temporary + character(len=256) :: ftest,ctest ! temporaries + character(len=256) :: path ! full pathname of netcdf restart file !------------------------------------- ! Continue run: @@ -180,13 +185,13 @@ subroutine RtmRestGetfile( file, path ) end if ! Branch run: - ! Restart file pathname is obtained from namelist "nrevsn_rtm" + ! Restart file pathname is obtained from namelist "nrevsn" if (nsrest==nsrBranch) then - length = len_trim(nrevsn_rtm) - if (nrevsn_rtm(length-2:length) == '.nc') then - path = trim(nrevsn_rtm) + length = len_trim(nrevsn) + if (nrevsn(length-2:length) == '.nc') then + path = trim(nrevsn) else - path = trim(nrevsn_rtm) // '.nc' + path = trim(nrevsn) // '.nc' end if call getfil( path, file, 0 ) @@ -207,10 +212,10 @@ subroutine RtmRestGetfile( file, path ) ! Initial run if (nsrest==nsrStartup) then - call getfil( finidat_rtm, file, 0 ) + call getfil( finidat, file, 0 ) end if - end subroutine RtmRestGetfile + end subroutine mosart_rest_Getfile !----------------------------------------------------------------------- @@ -232,7 +237,7 @@ subroutine restFile_read_pfile( pnamer ) ! 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. + ! [nrevsn] contains the full pathname of the restart file. ! New history files are always created for branch runs. if (mainproc) then @@ -285,17 +290,17 @@ end subroutine restFile_write_pfile !----------------------------------------------------------------------- - character(len=256) function RtmRestFileName( rdate ) + character(len=256) function mosart_rest_FileName( rdate ) ! Arguments character(len=*), intent(in) :: rdate ! input date for restart file name - RtmRestFileName = "./"//trim(caseid)//".mosart"//trim(inst_suffix)//".r."//trim(rdate)//".nc" + mosart_rest_FileName = "./"//trim(caseid)//".mosart"//trim(inst_suffix)//".r."//trim(rdate)//".nc" if (mainproc) then - write(iulog,*)'writing restart file ',trim(RtmRestFileName),' for model date = ',rdate + write(iulog,*)'writing restart file ',trim(mosart_rest_FileName),' for model date = ',rdate end if - end function RtmRestFileName + end function mosart_rest_FileName !------------------------------------------------------------------------ @@ -318,9 +323,9 @@ subroutine restFile_dimset( ncid ) ! Define dimensions - call ncd_defdim(ncid, 'rtmlon' , rtmlon , dimid) - call ncd_defdim(ncid, 'rtmlat' , rtmlat , dimid) - call ncd_defdim(ncid, 'string_length', 64 , dimid) + call ncd_defdim(ncid, 'nlon' , ctl%nlon , dimid) + call ncd_defdim(ncid, 'nlat' , ctl%nlat , dimid) + call ncd_defdim(ncid, 'string_length', 64 , dimid) ! Define global attributes @@ -341,7 +346,7 @@ end subroutine restFile_dimset !----------------------------------------------------------------------- - subroutine RtmRestart(ncid, flag) + subroutine mosart_rest_restart(ncid, flag) !------------------------------------- ! Read/write MOSART restart data. @@ -359,51 +364,51 @@ subroutine RtmRestart(ncid, flag) !------------------------------------- do nv = 1,7 - do nt = 1,nt_rtm + do nt = 1,ctl%ntracers if (nv == 1) then - vname = 'RTM_VOLR_'//trim(rtm_tracers(nt)) + vname = 'VOLR_'//trim(ctl%tracer_names(nt)) lname = 'water volume in cell (volr)' uname = 'm3' - dfld => rtmCTL%volr(:,nt) + dfld => ctl%volr(:,nt) elseif (nv == 2) then - vname = 'RTM_RUNOFF_'//trim(rtm_tracers(nt)) + vname = 'RUNOFF_'//trim(ctl%tracer_names(nt)) lname = 'runoff (runoff)' uname = 'm3/s' - dfld => rtmCTL%runoff(:,nt) + dfld => ctl%runoff(:,nt) elseif (nv == 3) then - vname = 'RTM_DVOLRDT_'//trim(rtm_tracers(nt)) + vname = 'DVOLRDT_'//trim(ctl%tracer_names(nt)) lname = 'water volume change in cell (dvolrdt)' uname = 'mm/s' - dfld => rtmCTL%dvolrdt(:,nt) + dfld => ctl%dvolrdt(:,nt) elseif (nv == 4) then - vname = 'RTM_WH_'//trim(rtm_tracers(nt)) + vname = 'WH_'//trim(ctl%tracer_names(nt)) lname = 'surface water storage at hillslopes in cell' uname = 'm' - dfld => rtmCTL%wh(:,nt) + dfld => Trunoff%wh(:,nt) elseif (nv == 5) then - vname = 'RTM_WT_'//trim(rtm_tracers(nt)) + vname = 'WT_'//trim(ctl%tracer_names(nt)) lname = 'water storage in tributary channels in cell' uname = 'm3' - dfld => rtmCTL%wt(:,nt) + dfld => Trunoff%wt(:,nt) elseif (nv == 6) then - vname = 'RTM_WR_'//trim(rtm_tracers(nt)) + vname = 'WR_'//trim(ctl%tracer_names(nt)) lname = 'water storage in main channel in cell' uname = 'm3' - dfld => rtmCTL%wr(:,nt) + dfld => Trunoff%wr(:,nt) elseif (nv == 7) then - vname = 'RTM_EROUT_'//trim(rtm_tracers(nt)) + vname = 'EROUT_'//trim(ctl%tracer_names(nt)) lname = 'instataneous flow out of main channel in cell' uname = 'm3/s' - dfld => rtmCTL%erout(:,nt) + dfld => Trunoff%erout(:,nt) else - write(iulog,*) 'Rtm ERROR: illegal nv value a ',nv + write(iulog,*) 'ERROR: illegal nv value a ',nv call shr_sys_abort() endif if (flag == 'define') then call ncd_defvar(ncid=ncid, varname=trim(vname), & - xtype=ncd_double, dim1name='rtmlon', dim2name='rtmlat', & + xtype=ncd_double, dim1name='nlon', dim2name='nlat', & long_name=trim(lname), units=trim(uname), fill_value=spval) else if (flag == 'read' .or. flag == 'write') then call ncd_io(varname=trim(vname), data=dfld, dim1name='allrof', & @@ -421,30 +426,30 @@ subroutine RtmRestart(ncid, flag) 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. + do n = ctl%begr,ctl%endr + do nt = 1,ctl%ntracers + if (abs(ctl%volr(n,nt)) > 1.e30) ctl%volr(n,nt) = 0. + if (abs(ctl%runoff(n,nt)) > 1.e30) ctl%runoff(n,nt) = 0. + if (abs(ctl%dvolrdt(n,nt)) > 1.e30) ctl%dvolrdt(n,nt) = 0. + if (abs(Trunoff%wh(n,nt)) > 1.e30) Trunoff%wh(n,nt) = 0. + if (abs(Trunoff%wt(n,nt)) > 1.e30) Trunoff%wt(n,nt) = 0. + if (abs(Trunoff%wr(n,nt)) > 1.e30) Trunoff%wr(n,nt) = 0. + if (abs(Trunoff%erout(n,nt)) > 1.e30) Trunoff%erout(n,nt) = 0. end do - if (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) + if (ctl%mask(n) == 1) then + do nt = 1,ctl%ntracers + ctl%runofflnd(n,nt) = ctl%runoff(n,nt) + ctl%dvolrdtlnd(n,nt)= ctl%dvolrdt(n,nt) end do - elseif (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) + elseif (ctl%mask(n) >= 2) then + do nt = 1,ctl%ntracers + ctl%runoffocn(n,nt) = ctl%runoff(n,nt) + ctl%dvolrdtocn(n,nt)= ctl%dvolrdt(n,nt) enddo endif enddo endif - end subroutine RtmRestart + end subroutine mosart_rest_restart -end module RtmRestFile +end module mosart_restfile diff --git a/src/riverroute/mosart_tctl_type.F90 b/src/riverroute/mosart_tctl_type.F90 new file mode 100644 index 0000000..ce35168 --- /dev/null +++ b/src/riverroute/mosart_tctl_type.F90 @@ -0,0 +1,30 @@ +module mosart_tctl_type + + use shr_kind_mod, only : r8 => shr_kind_r8, CL => SHR_KIND_CL + + implicit none + private + + type Tctl_type + real(r8) :: DeltaT ! Time step in seconds + integer :: DLevelH2R ! The base number of channel routing sub-time-steps within one hillslope routing step. + ! Usually channel routing requires small time steps than hillslope routing. + integer :: DLevelR ! The number of channel routing sub-time-steps at a higher level within one channel routing step at a lower level. + integer :: RoutingMethod ! Flag for routing methods. 1 --> variable storage method from SWAT model; 2 --> Muskingum method? + contains + procedure :: Init + end type Tctl_type + public :: Tctl_type + +contains + + subroutine Init(this) + class(Tctl_type) :: this + + this%RoutingMethod = 1 + this%DLevelH2R = 5 + this%DLevelR = 3 + + end subroutine Init + +end module mosart_tctl_type diff --git a/src/riverroute/mosart_timemanager.F90 b/src/riverroute/mosart_timemanager.F90 index a19c52f..3ba642b 100644 --- a/src/riverroute/mosart_timemanager.F90 +++ b/src/riverroute/mosart_timemanager.F90 @@ -1,10 +1,9 @@ -module RtmTimeManager +module mosart_timemanager use shr_kind_mod, only: r8 => shr_kind_r8 use shr_sys_mod , only: shr_sys_abort - use RtmSpmd , only: mpicom_rof, mainproc - use RtmVar , only: isecspday, iulog, nsrest, nsrContinue - use RtmIO + use mosart_vars , only: isecspday, iulog, nsrest, nsrContinue, mpicom_rof, mainproc + use mosart_io use ESMF use mpi @@ -13,1078 +12,906 @@ module RtmTimeManager ! Public methods - public ::& - timemgr_setup, &! setup startup values - timemgr_init, &! time manager initialization - timemgr_restart, &! read/write time manager restart info and restart time manager - advance_timestep, &! increment timestep number - get_clock, &! get the clock from the time-manager - get_step_size, &! return step size in seconds - get_nstep, &! return timestep number - get_curr_date, &! return date components at end of current timestep - get_prev_date, &! return date components at beginning of current timestep - get_start_date, &! return components of the start date - get_ref_date, &! return components of the reference date - get_curr_time, &! return components of elapsed time since reference date at end of current timestep - get_prev_time, &! return components of elapsed time since reference date at beg of current timestep - get_calendar, &! return calendar - is_first_step, &! return true on first step of initial run - is_first_restart_step, &! return true on first step of restart or branch run - is_end_curr_day, &! return true on last timestep in current day - is_end_curr_month, &! return true on last timestep in current month - is_last_step, &! return true on last timestep - is_restart ! return true if this is a restart run - -! Public parameter data + public :: timemgr_setup ! setup startup values + public :: timemgr_init ! time manager initialization + public :: timemgr_restart ! read/write time manager restart info and restart time manager + public :: advance_timestep ! increment timestep number + public :: get_step_size ! return step size in seconds + public :: get_nstep ! return timestep number + public :: get_curr_date ! return date components at end of current timestep + public :: get_prev_date ! return date components at beginning of current timestep + public :: get_start_date ! return components of the start date + public :: get_ref_date ! return components of the reference date + public :: get_curr_time ! return components of elapsed time since reference date at end of current timestep + public :: get_prev_time ! return components of elapsed time since reference date at beg of current timestep + public :: get_calendar ! return calendar + public :: is_restart ! return true if this is a restart run + + ! Calendar types character(len=*), public, parameter :: NO_LEAP_C = 'NO_LEAP' character(len=*), public, parameter :: GREGORIAN_C = 'GREGORIAN' -! Private module data + type(ESMF_Calendar), target :: tm_cal ! calendar + type(ESMF_Clock) :: tm_clock ! model clock -! Private data for input - - character(len=ESMF_MAXSTR), save :: calendar = NO_LEAP_C ! Calendar to use in date calculations + character(len=ESMF_MAXSTR) :: calendar = NO_LEAP_C ! Calendar to use in date calculations integer, parameter :: uninit_int = -999999999 real(r8), parameter :: uninit_r8 = -999999999.0 -! Input - integer, save ::& - dtime = uninit_int ! timestep in seconds - -! Input from CESM driver - integer, save ::& - nelapse = uninit_int, &! number of timesteps (or days if negative) to extend a run - start_ymd = uninit_int, &! starting date for run in yearmmdd format - start_tod = 0, &! starting time of day for run in seconds - stop_ymd = uninit_int, &! stopping date for run in yearmmdd format - stop_tod = 0, &! stopping time of day for run in seconds - ref_ymd = uninit_int, &! reference date for time coordinate in yearmmdd format - ref_tod = 0 ! reference time of day for time coordinate in seconds - type(ESMF_Calendar), target, save :: & - tm_cal ! calendar - type(ESMF_Clock), save :: & - tm_clock ! model clock - integer, save ::& ! Data required to restart time manager: - rst_nstep = uninit_int, &! current step number - rst_step_days = uninit_int, &! days component of timestep size - rst_step_sec = uninit_int, &! timestep size seconds - rst_start_ymd = uninit_int, &! start date - rst_start_tod = uninit_int, &! start time of day - rst_ref_ymd = uninit_int, &! reference date - rst_ref_tod = uninit_int, &! reference time of day - rst_curr_ymd = uninit_int, &! current date - rst_curr_tod = uninit_int ! current time of day - character(len=ESMF_MAXSTR), save :: & - rst_calendar ! Calendar - - logical, save :: tm_first_restart_step = .false. ! true for first step of a restart or branch run - integer, save :: cal_type = uninit_int ! calendar type - logical, save :: timemgr_set = .false. ! true when timemgr initialized - -! Private module methods - private :: timemgr_spmdbcast + ! Input + integer :: dtime = uninit_int ! timestep in seconds + + ! Initialization data + integer :: start_ymd = uninit_int ! starting date for run in yearmmdd format + integer :: start_tod = 0 ! starting time of day for run in seconds + integer :: stop_ymd = uninit_int ! stopping date for run in yearmmdd format + integer :: stop_tod = 0 ! stopping time of day for run in seconds + integer :: ref_ymd = uninit_int ! reference date for time coordinate in yearmmdd format + integer :: ref_tod = 0 ! reference time of day for time coordinate in seconds + + ! Data required to restart time manager: + integer :: rst_nstep = uninit_int ! current step number + integer :: rst_step_days = uninit_int ! days component of timestep size + integer :: rst_step_sec = uninit_int ! timestep size seconds + integer :: rst_start_ymd = uninit_int ! start date + integer :: rst_start_tod = uninit_int ! start time of day + integer :: rst_ref_ymd = uninit_int ! reference date + integer :: rst_ref_tod = uninit_int ! reference time of day + integer :: rst_curr_ymd = uninit_int ! current date + integer :: rst_curr_tod = uninit_int ! current time of day + character(len=ESMF_MAXSTR) :: rst_calendar ! Calendar + + integer :: cal_type = uninit_int ! calendar type + logical :: timemgr_set = .false. ! true when timemgr initialized + + ! Private module methods private :: init_calendar private :: init_clock private :: timemgr_print private :: TimeGetymd -contains - -!========================================================================================= - -subroutine timemgr_setup( calendar_in, start_ymd_in, start_tod_in, ref_ymd_in, & - ref_tod_in, stop_ymd_in, stop_tod_in, nelapse_in) - - ! set time manager startup values - character(len=*), optional, intent(IN) :: calendar_in ! Calendar type - integer , optional, intent(IN) :: nelapse_in ! Number of step (or days) to advance - integer , optional, intent(IN) :: start_ymd_in ! Start date (YYYYMMDD) - integer , optional, intent(IN) :: start_tod_in ! Start time of day (sec) - integer , optional, intent(IN) :: ref_ymd_in ! Reference date (YYYYMMDD) - integer , optional, intent(IN) :: ref_tod_in ! Reference time of day (sec) - integer , optional, intent(IN) :: stop_ymd_in ! Stop date (YYYYMMDD) - integer , optional, intent(IN) :: stop_tod_in ! Stop time of day (sec) - character(len=*), parameter :: sub = 'rtm::set_timemgr_init' - - ! timemgr_set is called in timemgr_init and timemgr_restart - if ( timemgr_set ) then - call shr_sys_abort( sub//":: timemgr_init or timemgr_restart already called" ) - end if - if (present(calendar_in) ) calendar = trim(calendar_in) - if (present(start_ymd_in)) start_ymd = start_ymd_in - if (present(start_tod_in)) start_tod = start_tod_in - if (present(ref_ymd_in) ) ref_ymd = ref_ymd_in - if (present(ref_tod_in) ) ref_tod = ref_tod_in - if (present(stop_ymd_in) ) stop_ymd = stop_ymd_in - if (present(stop_tod_in) ) stop_tod = stop_tod_in - if (present(nelapse_in) ) nelapse = nelapse_in - -end subroutine timemgr_setup - -!========================================================================================= - -subroutine timemgr_init( dtime_in ) - - ! Initialize the ESMF time manager from the sync clock - ! - integer, intent(in) :: dtime_in ! Time-step (sec) - ! - integer :: rc ! return code - integer :: yr, mon, day, tod ! Year, month, day, and second as integers - type(ESMF_Time) :: start_date ! start date for run - type(ESMF_Time) :: stop_date ! stop date for run - type(ESMF_Time) :: curr_date ! temporary date used in logic - type(ESMF_Time) :: ref_date ! reference date for time coordinate - type(ESMF_Time) :: current ! current date (from clock) - type(ESMF_TimeInterval) :: day_step_size ! day step size - type(ESMF_TimeInterval) :: step_size ! timestep size - logical :: run_length_specified = .false. - character(len=*), parameter :: sub = 'rtm::timemgr_init' - - ! - dtime = real(dtime_in) - call timemgr_spmdbcast( ) - - ! Initalize calendar - call init_calendar() - - ! Initalize start date. - if ( start_ymd == uninit_int ) then - write(iulog,*)sub,': start_ymd must be specified ' - call shr_sys_abort - end if - if ( start_tod == uninit_int ) then - write(iulog,*)sub,': start_tod must be specified ' - call shr_sys_abort - end if - start_date = TimeSetymd( start_ymd, start_tod, "start_date" ) - - ! Initialize current date - curr_date = start_date - - ! Initalize stop date. - stop_date = TimeSetymd( 99991231, stop_tod, "stop_date" ) - - call ESMF_TimeIntervalSet( step_size, s=dtime, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting step_size') - - call ESMF_TimeIntervalSet( day_step_size, d=1, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting day_step_size') - - if ( stop_ymd /= uninit_int ) then - current = TimeSetymd( stop_ymd, stop_tod, "stop_date" ) - if ( current < stop_date ) stop_date = current - run_length_specified = .true. - end if - if ( nelapse /= uninit_int ) then - if ( nelapse >= 0 ) then - current = curr_date + step_size*nelapse - else - current = curr_date - day_step_size*nelapse - end if - if ( current < stop_date ) stop_date = current - run_length_specified = .true. - end if - if ( .not. run_length_specified ) then - call shr_sys_abort (sub//': Must specify stop_ymd or nelapse') - end if - - ! Error check - if ( stop_date <= start_date ) then - write(iulog,*)sub, ': stop date must be specified later than start date: ' - call ESMF_TimeGet( start_date, yy=yr, mm=mon, dd=day, s=tod ) - write(iulog,*) ' Start date (yr, mon, day, tod): ', yr, mon, day, tod - call ESMF_TimeGet( stop_date, yy=yr, mm=mon, dd=day, s=tod ) - write(iulog,*) ' Stop date (yr, mon, day, tod): ', yr, mon, day, tod - call shr_sys_abort - end if - if ( curr_date >= stop_date ) then - write(iulog,*)sub, ': stop date must be specified later than current date: ' - call ESMF_TimeGet( curr_date, yy=yr, mm=mon, dd=day, s=tod ) - write(iulog,*) ' Current date (yr, mon, day, tod): ', yr, mon, day, tod - call ESMF_TimeGet( stop_date, yy=yr, mm=mon, dd=day, s=tod ) - write(iulog,*) ' Stop date (yr, mon, day, tod): ', yr, mon, day, tod - call shr_sys_abort - end if - - ! Initalize reference date for time coordinate. - if ( ref_ymd /= uninit_int ) then - ref_date = TimeSetymd( ref_ymd, ref_tod, "ref_date" ) - else - ref_date = start_date - end if - - ! Initialize clock - call init_clock( start_date, ref_date, curr_date, stop_date ) - - ! Print configuration summary to log file (stdout). - if (mainproc) call timemgr_print() - - timemgr_set = .true. - -end subroutine timemgr_init - -!========================================================================================= - -subroutine init_clock( start_date, ref_date, curr_date, stop_date ) - - ! Initialize the clock based on the start_date, ref_date, and curr_date - ! as well as the settings from the namelist specifying the time to stop - ! - type(ESMF_Time), intent(in) :: start_date ! start date for run - type(ESMF_Time), intent(in) :: ref_date ! reference date for time coordinate - type(ESMF_Time), intent(in) :: curr_date ! current date (equal to start_date) - type(ESMF_Time), intent(in) :: stop_date ! stop date for run - ! - character(len=*), parameter :: sub = 'rtm::init_clock' - type(ESMF_TimeInterval) :: step_size ! timestep size - type(ESMF_Time) :: current ! current date (from clock) - integer :: yr, mon, day, tod ! Year, month, day, and second as integers - integer :: rc ! return code - ! - call ESMF_TimeIntervalSet( step_size, s=dtime, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting step_size') - - ! Initialize the clock - - tm_clock = ESMF_ClockCreate(name="RTM Time-manager clock", timeStep=step_size, startTime=start_date, & - stopTime=stop_date, refTime=ref_date, rc=rc) - call chkrc(rc, sub//': error return from ESMF_ClockSetup') - - ! Advance clock to the current time (in case of a restart) - - call ESMF_ClockGet(tm_clock, currTime=current, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - do while( curr_date > current ) - call ESMF_ClockAdvance( tm_clock, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockAdvance') - call ESMF_ClockGet(tm_clock, currTime=current ) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - end do -end subroutine init_clock - -!========================================================================================= - -function TimeSetymd( ymd, tod, desc ) - - - ! Set the time by an integer as YYYYMMDD and integer seconds in the day - ! - integer, intent(in) :: ymd ! Year, month, day YYYYMMDD - integer, intent(in) :: tod ! Time of day in seconds - character(len=*), intent(in) :: desc ! Description of time to set - ! - type(ESMF_Time) :: TimeSetymd ! Return value - ! - character(len=*), parameter :: sub = 'rtm::TimeSetymd' - integer :: yr, mon, day ! Year, month, day as integers - integer :: rc ! return code - ! - if ( (ymd < 0) .or. (tod < 0) .or. (tod > isecspday) )then - write(iulog,*) sub//': error yymmdd is a negative number or time-of-day out of bounds', & - ymd, tod - call shr_sys_abort - end if - yr = ymd / 10000 - mon = (ymd - yr*10000) / 100 - day = ymd - yr*10000 - mon*100 - call ESMF_TimeSet( TimeSetymd, yy=yr, mm=mon, dd=day, s=tod, & - calendar=tm_cal, rc=rc) - call chkrc(rc, sub//': error return from ESMF_TimeSet: setting '//trim(desc)) -end function TimeSetymd - -!========================================================================================= - -integer function TimeGetymd( date, tod ) - - ! Get the date and time of day in ymd from ESMF Time. - ! - type(ESMF_Time), intent(inout) :: date ! Input date to convert to ymd - integer, intent(out), optional :: tod ! Time of day in seconds - ! - character(len=*), parameter :: sub = 'rtm::TimeGetymd' - integer :: yr, mon, day - integer :: rc ! return code - ! - call ESMF_TimeGet( date, yy=yr, mm=mon, dd=day, rc=rc) - call chkrc(rc, sub//': error return from ESMF_TimeGet') - TimeGetymd = yr*10000 + mon*100 + day - if ( present( tod ) )then - call ESMF_TimeGet( date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) - call chkrc(rc, sub//': error return from ESMF_TimeGet') - end if - if ( yr < 0 )then - write(iulog,*) sub//': error year is less than zero', yr - call shr_sys_abort - end if -end function TimeGetymd - -!========================================================================================= - -subroutine timemgr_restart(ncid, flag) - - ! Read/Write information needed on restart to a netcdf file. - ! - type(file_desc_t), intent(inout) :: ncid ! netcdf id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - ! - logical :: run_length_specified = .false. - integer :: rc ! return code - integer :: yr, mon, day, tod ! Year, month, day, and second as integers - logical :: readvar ! determine if variable is on initial file - integer :: rst_caltype ! calendar type - type(ESMF_Time) :: start_date ! start date for run - type(ESMF_Time) :: stop_date ! stop date for run - type(ESMF_Time) :: ref_date ! reference date for run - type(ESMF_Time) :: curr_date ! date of data in restart file - type(ESMF_Time) :: current ! current date (from clock) - type(ESMF_TimeInterval) :: day_step_size ! day step size - type(ESMF_TimeInterval) :: step_size ! timestep size - integer, parameter :: noleap = 1 - integer, parameter :: gregorian = 2 - character(len=135) :: varname - character(len=len(calendar)) :: cal - character(len=*), parameter :: sub = 'timemgr_restart' - ! - if (flag == 'write') then - rst_calendar = calendar - else if (flag == 'read') then - calendar = rst_calendar - end if - varname = 'timemgr_rst_type' - if (flag == 'define') then - call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & - long_name='calendar type', units='unitless', flag_meanings=(/ "NO_LEAP_C", "GREGORIAN" /), & - flag_values=(/ noleap, gregorian /), ifill_value=uninit_int ) - else if (flag == 'read' .or. flag == 'write') then - if (flag== 'write') then - cal = to_upper(calendar) - if ( trim(cal) == NO_LEAP_C ) then - rst_caltype = noleap - else if ( trim(cal) == GREGORIAN_C ) then - rst_caltype = gregorian - else - call shr_sys_abort(sub//'ERROR: unrecognized calendar specified= '//trim(calendar)) - end if - end if - call ncd_io(varname=varname, data=rst_caltype, & - ncid=ncid, flag=flag, readvar=readvar) - if (flag=='read' .and. .not. readvar) then - if (is_restart()) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') - end if - end if - if (flag == 'read') then - if ( rst_caltype == noleap ) then - calendar = NO_LEAP_C - else if ( rst_caltype == gregorian ) then - calendar = GREGORIAN_C - else - write(iulog,*)sub,': unrecognized calendar type in restart file: ',rst_caltype - call shr_sys_abort( sub//'ERROR: bad calendar type in restart file') - end if - end if - end if - - if (flag == 'write') then - call ESMF_ClockGet( tm_clock, startTime=start_date, currTime=curr_date, refTime=ref_date, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - rst_step_sec = dtime - rst_start_ymd = TimeGetymd( start_date, tod=rst_start_tod ) - rst_ref_ymd = TimeGetymd( ref_date, tod=rst_ref_tod ) - rst_curr_ymd = TimeGetymd( curr_date, tod=rst_curr_tod ) - end if - - varname = 'timemgr_rst_step_sec' - if (flag == 'define') then - call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & - long_name='seconds component of timestep size', units='sec', nvalid_range=(/0,isecspday/), ifill_value=uninit_int) - else if (flag == 'read' .or. flag == 'write') then - call ncd_io(varname=varname, data=rst_step_sec, & - ncid=ncid, flag=flag, readvar=readvar) - if (flag=='read' .and. .not. readvar) then - if (is_restart()) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') - end if - end if - if ( rst_step_sec < 0 .or. rst_step_sec > isecspday ) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' out of range') - end if - end if - - varname = 'timemgr_rst_start_ymd' - if (flag == 'define') then - call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & - long_name='start date', units='YYYYMMDD', ifill_value=uninit_int) - else if (flag == 'read' .or. flag == 'write') then - call ncd_io(varname=varname, data=rst_start_ymd, & - ncid=ncid, flag=flag, readvar=readvar) - if (flag=='read' .and. .not. readvar) then - if (is_restart()) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') - end if - end if - end if - - varname = 'timemgr_rst_start_tod' - if (flag == 'define') then - call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & - long_name='start time of day', units='sec', nvalid_range=(/0,isecspday/), ifill_value=uninit_int) - else if (flag == 'read' .or. flag == 'write') then - call ncd_io(varname=varname, data=rst_start_tod, & - ncid=ncid, flag=flag, readvar=readvar) - if (flag=='read' .and. .not. readvar) then - if (is_restart()) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') - end if - end if - if ( rst_start_tod < 0 .or. rst_start_tod > isecspday ) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' out of range') - end if - end if - - varname = 'timemgr_rst_ref_ymd' - if (flag == 'define') then - call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & - long_name='reference date', units='YYYYMMDD', ifill_value=uninit_int) - else if (flag == 'read' .or. flag == 'write') then - call ncd_io(varname=varname, data=rst_ref_ymd, & - ncid=ncid, flag=flag, readvar=readvar) - if (flag=='read' .and. .not. readvar) then - if (is_restart()) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') - end if - end if - end if - - varname = 'timemgr_rst_ref_tod' - if (flag == 'define') then - call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & - long_name='reference time of day', units='sec', nvalid_range=(/0,isecspday/), ifill_value=uninit_int) - else if (flag == 'read' .or. flag == 'write') then - call ncd_io(varname=varname, data=rst_ref_tod, & - ncid=ncid, flag=flag, readvar=readvar) - if (flag=='read' .and. .not. readvar) then - if (is_restart()) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') - end if - end if - if ( rst_start_tod < 0 .or. rst_start_tod > isecspday ) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' out of range') - end if - end if - - varname = 'timemgr_rst_curr_ymd' - if (flag == 'define') then - call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & - long_name='current date', units='YYYYMMDD', ifill_value=uninit_int) - else if (flag == 'read' .or. flag == 'write') then - call ncd_io(varname=varname, data=rst_curr_ymd, & - ncid=ncid, flag=flag, readvar=readvar) - if (flag=='read' .and. .not. readvar) then - if (is_restart()) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') - end if - end if - end if - - varname = 'timemgr_rst_curr_tod' - if (flag == 'define') then - call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & - long_name='current time of day', units='sec', nvalid_range=(/0,isecspday/), ifill_value=uninit_int ) - else if (flag == 'read' .or. flag == 'write') then - call ncd_io(varname=varname, data=rst_curr_tod, & - ncid=ncid, flag=flag, readvar=readvar) - if (flag=='read' .and. .not. readvar) then - if (is_restart()) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') - end if - end if - if ( rst_curr_tod < 0 .or. rst_curr_tod > isecspday ) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' out of range') - end if - end if - - - if (flag == 'read') then - - ! Restart the ESMF time manager using the synclock for ending date. - call timemgr_spmdbcast( ) - - ! Initialize calendar from restart info - call init_calendar() - - ! Initialize the timestep from restart info - dtime = rst_step_sec - - ! Initialize start date from restart info - start_date = TimeSetymd( rst_start_ymd, rst_start_tod, "start_date" ) - - ! Initialize current date from restart info - curr_date = TimeSetymd( rst_curr_ymd, rst_curr_tod, "curr_date" ) - - ! Initialize stop date from sync clock or namelist input - stop_date = TimeSetymd( 99991231, stop_tod, "stop_date" ) - - call ESMF_TimeIntervalSet( step_size, s=dtime, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting step_size') - - call ESMF_TimeIntervalSet( day_step_size, d=1, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting day_step_size') - - if ( stop_ymd /= uninit_int ) then - current = TimeSetymd( stop_ymd, stop_tod, "stop_date" ) - if ( current < stop_date ) stop_date = current - run_length_specified = .true. - else if ( nelapse /= uninit_int ) then - if ( nelapse >= 0 ) then - current = curr_date + step_size*nelapse - else - current = curr_date - day_step_size*nelapse - end if - if ( current < stop_date ) stop_date = current - run_length_specified = .true. - end if - if ( .not. run_length_specified ) then - call shr_sys_abort (sub//': Must specify stop_ymd or nelapse') - end if - - ! Error check - if ( stop_date <= start_date ) then - write(iulog,*)sub, ': stop date must be specified later than start date: ' - call ESMF_TimeGet( start_date, yy=yr, mm=mon, dd=day, s=tod ) - write(iulog,*) ' Start date (yr, mon, day, tod): ', yr, mon, day, tod - call ESMF_TimeGet( stop_date, yy=yr, mm=mon, dd=day, s=tod ) - write(iulog,*) ' Stop date (yr, mon, day, tod): ', yr, mon, day, tod - call shr_sys_abort - end if - if ( curr_date >= stop_date ) then - write(iulog,*)sub, ': stop date must be specified later than current date: ' - call ESMF_TimeGet( curr_date, yy=yr, mm=mon, dd=day, s=tod ) - write(iulog,*) ' Current date (yr, mon, day, tod): ', yr, mon, day, tod - call ESMF_TimeGet( stop_date, yy=yr, mm=mon, dd=day, s=tod ) - write(iulog,*) ' Stop date (yr, mon, day, tod): ', yr, mon, day, tod - call shr_sys_abort - end if - - ! Initialize ref date from restart info - ref_date = TimeSetymd( rst_ref_ymd, rst_ref_tod, "ref_date" ) - - ! Initialize clock - call init_clock( start_date, ref_date, curr_date, stop_date ) - - ! Set flag that this is the first timestep of the restart run. - tm_first_restart_step = .true. - - ! Print configuration summary to log file (stdout). - if (mainproc) call timemgr_print() - - timemgr_set = .true. - - end if - -end subroutine timemgr_restart - -!========================================================================================= - -subroutine init_calendar( ) - - !--------------------------------------------------------------------------------- - ! Initialize calendar - ! - ! Local variables - ! - character(len=*), parameter :: sub = 'rtm::init_calendar' - type(ESMF_CalKind_Flag) :: cal_type ! calendar type - character(len=len(calendar)) :: caltmp - integer :: rc ! return code - !--------------------------------------------------------------------------------- - - caltmp = to_upper(calendar) - if ( trim(caltmp) == NO_LEAP_C ) then - cal_type = ESMF_CALKIND_NOLEAP - else if ( trim(caltmp) == GREGORIAN_C ) then - cal_type = ESMF_CALKIND_GREGORIAN - else - write(iulog,*)sub,': unrecognized calendar specified: ',calendar - call shr_sys_abort - end if - tm_cal = ESMF_CalendarCreate( name=caltmp, calkindflag=cal_type, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_CalendarSet') - -end subroutine init_calendar - !========================================================================================= - -subroutine timemgr_print() - - !--------------------------------------------------------------------------------- - character(len=*), parameter :: sub = 'rtm::timemgr_print' - integer :: rc - integer :: yr, mon, day - integer :: & ! Data required to restart time manager: - nstep = uninit_int, &! current step number - step_sec = uninit_int, &! timestep size seconds - start_yr = uninit_int, &! start year - start_mon = uninit_int, &! start month - start_day = uninit_int, &! start day of month - start_tod = uninit_int, &! start time of day - stop_yr = uninit_int, &! stop year - stop_mon = uninit_int, &! stop month - stop_day = uninit_int, &! stop day of month - stop_tod = uninit_int, &! stop time of day - ref_yr = uninit_int, &! reference year - ref_mon = uninit_int, &! reference month - ref_day = uninit_int, &! reference day of month - ref_tod = uninit_int, &! reference time of day - curr_yr = uninit_int, &! current year - curr_mon = uninit_int, &! current month - curr_day = uninit_int, &! current day of month - curr_tod = uninit_int ! current time of day - integer(ESMF_KIND_I8) :: step_no - type(ESMF_Time) :: start_date! start date for run - type(ESMF_Time) :: stop_date ! stop date for run - type(ESMF_Time) :: curr_date ! date of data in restart file - type(ESMF_Time) :: ref_date ! reference date - type(ESMF_TimeInterval) :: step ! Time-step - !--------------------------------------------------------------------------------- - - call ESMF_ClockGet( tm_clock, startTime=start_date, currTime=curr_date, & - refTime=ref_date, stopTime=stop_date, timeStep=step, & - advanceCount=step_no, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - nstep = step_no - - write(iulog,*)' ******** RTM Time Manager Configuration ********' - - call ESMF_TimeIntervalGet( step, s=step_sec, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeIntervalGet') - - call ESMF_TimeGet( start_date, yy=start_yr, mm=start_mon, dd=start_day, & - s=start_tod, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeGet') - call ESMF_TimeGet( stop_date, yy=stop_yr, mm=stop_mon, dd=stop_day, & - s=stop_tod, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeGet') - call ESMF_TimeGet( ref_date, yy=ref_yr, mm=ref_mon, dd=ref_day, s=ref_tod, & - rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeGet') - call ESMF_TimeGet( curr_date, yy=curr_yr, mm=curr_mon, dd=curr_day, & - s=curr_tod, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeGet') - - write(iulog,*)' Calendar type: ',trim(calendar) - write(iulog,*)' Timestep size (seconds): ', step_sec - write(iulog,*)' Start date (yr mon day tod): ', start_yr, start_mon, & - start_day, start_tod - write(iulog,*)' Stop date (yr mon day tod): ', stop_yr, stop_mon, & - stop_day, stop_tod - write(iulog,*)' Reference date (yr mon day tod): ', ref_yr, ref_mon, & - ref_day, ref_tod - write(iulog,*)' Current step number: ', nstep - write(iulog,*)' Current date (yr mon day tod): ', curr_yr, curr_mon, & - curr_day, curr_tod - - write(iulog,*)' ************************************************' - -end subroutine timemgr_print - -!========================================================================================= - -subroutine advance_timestep() - - ! Increment the timestep number. - - character(len=*), parameter :: sub = 'rtm::advance_timestep' - integer :: rc - - call ESMF_ClockAdvance( tm_clock, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockAdvance') - - tm_first_restart_step = .false. - -end subroutine advance_timestep - -!========================================================================================= - -subroutine get_clock( clock ) - - ! Return the ESMF clock - - type(ESMF_Clock), intent(inout) :: clock - - character(len=*), parameter :: sub = 'rtm::get_clock' - type(ESMF_TimeInterval) :: step_size - type(ESMF_Time) :: start_date, stop_date, ref_date - integer :: rc - - call ESMF_ClockGet( tm_clock, timeStep=step_size, startTime=start_date, & - stoptime=stop_date, reftime=ref_date, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - call ESMF_ClockSet(clock, timeStep=step_size, startTime=start_date, & - stoptime=stop_date, reftime=ref_date, rc=rc) - call chkrc(rc, sub//': error return from ESMF_ClockSet') - -end subroutine get_clock - -!========================================================================================= - -integer function get_step_size() - - ! Return the step size in seconds. - - character(len=*), parameter :: sub = 'rtm::get_step_size' - type(ESMF_TimeInterval) :: step_size ! timestep size - integer :: rc - - call ESMF_ClockGet(tm_clock, timeStep=step_size, rc=rc) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - - call ESMF_TimeIntervalGet(step_size, s=get_step_size, rc=rc) - call chkrc(rc, sub//': error return from ESMF_ClockTimeIntervalGet') - -end function get_step_size - +contains !========================================================================================= -integer function get_nstep() - - ! Return the timestep number. - - character(len=*), parameter :: sub = 'rtm::get_nstep' - integer :: rc - integer(ESMF_KIND_I8) :: step_no - - call ESMF_ClockGet(tm_clock, advanceCount=step_no, rc=rc) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - - get_nstep = step_no - -end function get_nstep - -!========================================================================================= + subroutine timemgr_setup( calendar_in, start_ymd_in, start_tod_in, ref_ymd_in, & + ref_tod_in, stop_ymd_in, stop_tod_in) + + ! set time manager startup values + character(len=*), optional, intent(in) :: calendar_in ! Calendar type + integer , optional, intent(in) :: start_ymd_in ! Start date (YYYYMMDD) + integer , optional, intent(in) :: start_tod_in ! Start time of day (sec) + integer , optional, intent(in) :: ref_ymd_in ! Reference date (YYYYMMDD) + integer , optional, intent(in) :: ref_tod_in ! Reference time of day (sec) + integer , optional, intent(in) :: stop_ymd_in ! Stop date (YYYYMMDD) + integer , optional, intent(in) :: stop_tod_in ! Stop time of day (sec) + character(len=*), parameter :: sub = 'timemgr_setup' + + ! timemgr_set is called in timemgr_init and timemgr_restart + if ( timemgr_set ) then + call shr_sys_abort( sub//":: timemgr_init or timemgr_restart already called" ) + end if + if (present(calendar_in) ) calendar = trim(calendar_in) + if (present(start_ymd_in)) start_ymd = start_ymd_in + if (present(start_tod_in)) start_tod = start_tod_in + if (present(ref_ymd_in) ) ref_ymd = ref_ymd_in + if (present(ref_tod_in) ) ref_tod = ref_tod_in + if (present(stop_ymd_in) ) stop_ymd = stop_ymd_in + if (present(stop_tod_in) ) stop_tod = stop_tod_in + + end subroutine timemgr_setup + + !========================================================================================= + + subroutine timemgr_init( dtime_in ) + + ! Initialize the ESMF time manager from the sync clock + + ! Arguments + integer, intent(in) :: dtime_in ! Time-step (sec) + + ! Local variables + integer :: rc ! return code + integer :: yr, mon, day, tod ! Year, month, day, and second as integers + type(ESMF_Time) :: start_date ! start date for run + type(ESMF_Time) :: stop_date ! stop date for run + type(ESMF_Time) :: curr_date ! temporary date used in logic + type(ESMF_Time) :: ref_date ! reference date for time coordinate + type(ESMF_Time) :: current ! current date (from clock) + type(ESMF_TimeInterval) :: day_step_size ! day step size + type(ESMF_TimeInterval) :: step_size ! timestep size + character(len=*), parameter :: sub = 'timemgr_init' + + dtime = real(dtime_in) + + ! Initalize calendar + call init_calendar() + + ! Initalize start date. + if ( start_ymd == uninit_int ) then + write(iulog,*)sub,': start_ymd must be specified ' + call shr_sys_abort + end if + if ( start_tod == uninit_int ) then + write(iulog,*)sub,': start_tod must be specified ' + call shr_sys_abort + end if + start_date = TimeSetymd( start_ymd, start_tod, "start_date" ) + + ! Initialize current date + curr_date = start_date + + ! Initalize stop date. + stop_date = TimeSetymd( 99991231, stop_tod, "stop_date" ) + call ESMF_TimeIntervalSet( step_size, s=dtime, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting step_size') + call ESMF_TimeIntervalSet( day_step_size, d=1, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting day_step_size') + + if ( stop_ymd /= uninit_int ) then + current = TimeSetymd( stop_ymd, stop_tod, "stop_date" ) + if ( current < stop_date ) stop_date = current + else + call shr_sys_abort (sub//': Must specify stop_ymd') + end if -subroutine get_curr_date(yr, mon, day, tod, offset) - - !----------------------------------------------------------------------------------------- - ! Return date components valid at end of current timestep with an optional - ! offset (positive or negative) in seconds. - - integer, intent(out) ::& - yr, &! year - mon, &! month - day, &! day of month - tod ! time of day (seconds past 0Z) - - integer, optional, intent(in) :: offset ! Offset from current time in seconds. - ! Positive for future times, negative - ! for previous times. - - character(len=*), parameter :: sub = 'rtm::get_curr_date' - integer :: rc - type(ESMF_Time) :: date - type(ESMF_TimeInterval) :: off - !----------------------------------------------------------------------------------------- - - call ESMF_ClockGet( tm_clock, currTime=date, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - - if (present(offset)) then - if (offset > 0) then - call ESMF_TimeIntervalSet( off, s=offset, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet') - date = date + off - else if (offset < 0) then - call ESMF_TimeIntervalSet( off, s=-offset, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet') - date = date - off + ! Error check + if ( stop_date <= start_date ) then + write(iulog,*)sub, ': stop date must be specified later than start date: ' + call ESMF_TimeGet( start_date, yy=yr, mm=mon, dd=day, s=tod ) + write(iulog,*) ' Start date (yr, mon, day, tod): ', yr, mon, day, tod + call ESMF_TimeGet( stop_date, yy=yr, mm=mon, dd=day, s=tod ) + write(iulog,*) ' Stop date (yr, mon, day, tod): ', yr, mon, day, tod + call shr_sys_abort + end if + if ( curr_date >= stop_date ) then + write(iulog,*)sub, ': stop date must be specified later than current date: ' + call ESMF_TimeGet( curr_date, yy=yr, mm=mon, dd=day, s=tod ) + write(iulog,*) ' Current date (yr, mon, day, tod): ', yr, mon, day, tod + call ESMF_TimeGet( stop_date, yy=yr, mm=mon, dd=day, s=tod ) + write(iulog,*) ' Stop date (yr, mon, day, tod): ', yr, mon, day, tod + call shr_sys_abort end if - end if - call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) - call chkrc(rc, sub//': error return from ESMF_TimeGet') + ! Initalize reference date for time coordinate. + if ( ref_ymd /= uninit_int ) then + ref_date = TimeSetymd( ref_ymd, ref_tod, "ref_date" ) + else + ref_date = start_date + end if -end subroutine get_curr_date + ! Initialize clock + call init_clock( start_date, ref_date, curr_date, stop_date ) + + ! Print configuration summary to log file (stdout). + if (mainproc) call timemgr_print() + + timemgr_set = .true. + + end subroutine timemgr_init + + !========================================================================================= + + subroutine init_clock( start_date, ref_date, curr_date, stop_date ) + + ! Initialize the clock based on the start_date, ref_date, and curr_date + ! as well as the settings from the namelist specifying the time to stop + ! + type(ESMF_Time), intent(in) :: start_date ! start date for run + type(ESMF_Time), intent(in) :: ref_date ! reference date for time coordinate + type(ESMF_Time), intent(in) :: curr_date ! current date (equal to start_date) + type(ESMF_Time), intent(in) :: stop_date ! stop date for run + ! + character(len=*), parameter :: sub = 'init_clock' + type(ESMF_TimeInterval) :: step_size ! timestep size + type(ESMF_Time) :: current ! current date (from clock) + integer :: yr, mon, day, tod ! Year, month, day, and second as integers + integer :: rc ! return code + ! + call ESMF_TimeIntervalSet( step_size, s=dtime, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting step_size') + + ! Initialize the clock + + tm_clock = ESMF_ClockCreate(name="MOSART Time-manager clock", timeStep=step_size, startTime=start_date, & + stopTime=stop_date, refTime=ref_date, rc=rc) + call chkrc(rc, sub//': error return from ESMF_ClockSetup') + + ! Advance clock to the current time (in case of a restart) + + call ESMF_ClockGet(tm_clock, currTime=current, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + do while( curr_date > current ) + call ESMF_ClockAdvance( tm_clock, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockAdvance') + call ESMF_ClockGet(tm_clock, currTime=current ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + end do + end subroutine init_clock + + !========================================================================================= + + function TimeSetymd( ymd, tod, desc ) + + + ! Set the time by an integer as YYYYMMDD and integer seconds in the day + ! + integer, intent(in) :: ymd ! Year, month, day YYYYMMDD + integer, intent(in) :: tod ! Time of day in seconds + character(len=*), intent(in) :: desc ! Description of time to set + ! + type(ESMF_Time) :: TimeSetymd ! Return value + ! + character(len=*), parameter :: sub = 'TimeSetymd' + integer :: yr, mon, day ! Year, month, day as integers + integer :: rc ! return code + ! + if ( (ymd < 0) .or. (tod < 0) .or. (tod > isecspday) )then + write(iulog,*) sub//': error yymmdd is a negative number or time-of-day out of bounds', & + ymd, tod + call shr_sys_abort + end if + yr = ymd / 10000 + mon = (ymd - yr*10000) / 100 + day = ymd - yr*10000 - mon*100 + call ESMF_TimeSet( TimeSetymd, yy=yr, mm=mon, dd=day, s=tod, & + calendar=tm_cal, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeSet: setting '//trim(desc)) + end function TimeSetymd + + !========================================================================================= + + integer function TimeGetymd( date, tod ) + + ! Get the date and time of day in ymd from ESMF Time. + ! + type(ESMF_Time), intent(inout) :: date ! Input date to convert to ymd + integer, intent(out), optional :: tod ! Time of day in seconds + ! + character(len=*), parameter :: sub = 'TimeGetymd' + integer :: yr, mon, day + integer :: rc ! return code + ! + call ESMF_TimeGet( date, yy=yr, mm=mon, dd=day, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + TimeGetymd = yr*10000 + mon*100 + day + if ( present( tod ) )then + call ESMF_TimeGet( date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + end if + if ( yr < 0 )then + write(iulog,*) sub//': error year is less than zero', yr + call shr_sys_abort + end if + end function TimeGetymd + + !========================================================================================= + + subroutine timemgr_restart(ncid, flag) + + ! Read/Write information needed on restart to a netcdf file. + ! + type(file_desc_t), intent(inout) :: ncid ! netcdf id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + ! + integer :: yr, mon, day, tod ! Year, month, day, and second as integers + logical :: readvar ! determine if variable is on initial file + integer :: rst_caltype ! calendar type + type(ESMF_Time) :: start_date ! start date for run + type(ESMF_Time) :: stop_date ! stop date for run + type(ESMF_Time) :: ref_date ! reference date for run + type(ESMF_Time) :: curr_date ! date of data in restart file + type(ESMF_Time) :: current ! current date (from clock) + type(ESMF_TimeInterval) :: day_step_size ! day step size + type(ESMF_TimeInterval) :: step_size ! timestep size + integer, parameter :: noleap = 1 + integer, parameter :: gregorian = 2 + character(len=135) :: varname + character(len=len(calendar)) :: cal + integer :: rc ! return code + character(len=*), parameter :: sub = 'timemgr_restart' + ! + if (flag == 'write') then + rst_calendar = calendar + else if (flag == 'read') then + calendar = rst_calendar + end if + varname = 'timemgr_rst_type' + if (flag == 'define') then + call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & + long_name='calendar type', units='unitless', flag_meanings=(/ "NO_LEAP_C", "GREGORIAN" /), & + flag_values=(/ noleap, gregorian /), ifill_value=uninit_int ) + else if (flag == 'read' .or. flag == 'write') then + if (flag== 'write') then + cal = to_upper(calendar) + if ( trim(cal) == NO_LEAP_C ) then + rst_caltype = noleap + else if ( trim(cal) == GREGORIAN_C ) then + rst_caltype = gregorian + else + call shr_sys_abort(sub//'ERROR: unrecognized calendar specified= '//trim(calendar)) + end if + end if + call ncd_io(varname=varname, data=rst_caltype, & + ncid=ncid, flag=flag, readvar=readvar) + if (flag=='read' .and. .not. readvar) then + if (is_restart()) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') + end if + end if + if (flag == 'read') then + if ( rst_caltype == noleap ) then + calendar = NO_LEAP_C + else if ( rst_caltype == gregorian ) then + calendar = GREGORIAN_C + else + write(iulog,*)sub,': unrecognized calendar type in restart file: ',rst_caltype + call shr_sys_abort( sub//'ERROR: bad calendar type in restart file') + end if + end if + end if -!========================================================================================= + if (flag == 'write') then + call ESMF_ClockGet( tm_clock, startTime=start_date, currTime=curr_date, refTime=ref_date, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + rst_step_sec = dtime + rst_start_ymd = TimeGetymd( start_date, tod=rst_start_tod ) + rst_ref_ymd = TimeGetymd( ref_date, tod=rst_ref_tod ) + rst_curr_ymd = TimeGetymd( curr_date, tod=rst_curr_tod ) + end if -subroutine get_prev_date(yr, mon, day, tod) + varname = 'timemgr_rst_step_sec' + if (flag == 'define') then + call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & + long_name='seconds component of timestep size', units='sec', nvalid_range=(/0,isecspday/), ifill_value=uninit_int) + else if (flag == 'read' .or. flag == 'write') then + call ncd_io(varname=varname, data=rst_step_sec, & + ncid=ncid, flag=flag, readvar=readvar) + if (flag=='read' .and. .not. readvar) then + if (is_restart()) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') + end if + end if + if ( rst_step_sec < 0 .or. rst_step_sec > isecspday ) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' out of range') + end if + end if -! Return date components valid at beginning of current timestep. + varname = 'timemgr_rst_start_ymd' + if (flag == 'define') then + call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & + long_name='start date', units='YYYYMMDD', ifill_value=uninit_int) + else if (flag == 'read' .or. flag == 'write') then + call ncd_io(varname=varname, data=rst_start_ymd, & + ncid=ncid, flag=flag, readvar=readvar) + if (flag=='read' .and. .not. readvar) then + if (is_restart()) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') + end if + end if + end if -! Arguments - integer, intent(out) ::& - yr, &! year - mon, &! month - day, &! day of month - tod ! time of day (seconds past 0Z) + varname = 'timemgr_rst_start_tod' + if (flag == 'define') then + call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & + long_name='start time of day', units='sec', nvalid_range=(/0,isecspday/), ifill_value=uninit_int) + else if (flag == 'read' .or. flag == 'write') then + call ncd_io(varname=varname, data=rst_start_tod, & + ncid=ncid, flag=flag, readvar=readvar) + if (flag=='read' .and. .not. readvar) then + if (is_restart()) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') + end if + end if + if ( rst_start_tod < 0 .or. rst_start_tod > isecspday ) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' out of range') + end if + end if -! Local variables - character(len=*), parameter :: sub = 'rtm::get_prev_date' - integer :: rc - type(ESMF_Time) :: date -!----------------------------------------------------------------------------------------- + varname = 'timemgr_rst_ref_ymd' + if (flag == 'define') then + call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & + long_name='reference date', units='YYYYMMDD', ifill_value=uninit_int) + else if (flag == 'read' .or. flag == 'write') then + call ncd_io(varname=varname, data=rst_ref_ymd, & + ncid=ncid, flag=flag, readvar=readvar) + if (flag=='read' .and. .not. readvar) then + if (is_restart()) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') + end if + end if + end if - call ESMF_ClockGet(tm_clock, prevTime=date, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet') + varname = 'timemgr_rst_ref_tod' + if (flag == 'define') then + call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & + long_name='reference time of day', units='sec', nvalid_range=(/0,isecspday/), ifill_value=uninit_int) + else if (flag == 'read' .or. flag == 'write') then + call ncd_io(varname=varname, data=rst_ref_tod, & + ncid=ncid, flag=flag, readvar=readvar) + if (flag=='read' .and. .not. readvar) then + if (is_restart()) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') + end if + end if + if ( rst_start_tod < 0 .or. rst_start_tod > isecspday ) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' out of range') + end if + end if - call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) - call chkrc(rc, sub//': error return from ESMF_TimeGet') + varname = 'timemgr_rst_curr_ymd' + if (flag == 'define') then + call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & + long_name='current date', units='YYYYMMDD', ifill_value=uninit_int) + else if (flag == 'read' .or. flag == 'write') then + call ncd_io(varname=varname, data=rst_curr_ymd, & + ncid=ncid, flag=flag, readvar=readvar) + if (flag=='read' .and. .not. readvar) then + if (is_restart()) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') + end if + end if + end if -end subroutine get_prev_date + varname = 'timemgr_rst_curr_tod' + if (flag == 'define') then + call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & + long_name='current time of day', units='sec', nvalid_range=(/0,isecspday/), ifill_value=uninit_int ) + else if (flag == 'read' .or. flag == 'write') then + call ncd_io(varname=varname, data=rst_curr_tod, & + ncid=ncid, flag=flag, readvar=readvar) + if (flag=='read' .and. .not. readvar) then + if (is_restart()) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') + end if + end if + if ( rst_curr_tod < 0 .or. rst_curr_tod > isecspday ) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' out of range') + end if + end if -!========================================================================================= -subroutine get_start_date(yr, mon, day, tod) + if (flag == 'read') then - ! Return date components valid at beginning of initial run. - integer, intent(out) ::& - yr, &! year - mon, &! month - day, &! day of month - tod ! time of day (seconds past 0Z) + ! Initialize calendar from restart info + call init_calendar() - character(len=*), parameter :: sub = 'rtm::get_start_date' - integer :: rc - type(ESMF_Time) :: date + ! Initialize the timestep from restart info + dtime = rst_step_sec - call ESMF_ClockGet(tm_clock, startTime=date, rc=rc) - call chkrc(rc, sub//': error return from ESMF_ClockGet') + ! Initialize start date from restart info + start_date = TimeSetymd( rst_start_ymd, rst_start_tod, "start_date" ) - call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) - call chkrc(rc, sub//': error return from ESMF_TimeGet') + ! Initialize current date from restart info + curr_date = TimeSetymd( rst_curr_ymd, rst_curr_tod, "curr_date" ) -end subroutine get_start_date + ! Initialize stop date from sync clock or namelist input + stop_date = TimeSetymd( 99991231, stop_tod, "stop_date" ) -!========================================================================================= + call ESMF_TimeIntervalSet( step_size, s=dtime, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting step_size') + call ESMF_TimeIntervalSet( day_step_size, d=1, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting day_step_size') + if ( stop_ymd /= uninit_int ) then + current = TimeSetymd( stop_ymd, stop_tod, "stop_date" ) + if ( current < stop_date ) stop_date = current + else + call shr_sys_abort (sub//': Must specify stop_ymd') + end if -subroutine get_ref_date(yr, mon, day, tod) + ! Error check + if ( stop_date <= start_date ) then + write(iulog,*)sub, ': stop date must be specified later than start date: ' + call ESMF_TimeGet( start_date, yy=yr, mm=mon, dd=day, s=tod ) + write(iulog,*) ' Start date (yr, mon, day, tod): ', yr, mon, day, tod + call ESMF_TimeGet( stop_date, yy=yr, mm=mon, dd=day, s=tod ) + write(iulog,*) ' Stop date (yr, mon, day, tod): ', yr, mon, day, tod + call shr_sys_abort + end if + if ( curr_date >= stop_date ) then + write(iulog,*)sub, ': stop date must be specified later than current date: ' + call ESMF_TimeGet( curr_date, yy=yr, mm=mon, dd=day, s=tod ) + write(iulog,*) ' Current date (yr, mon, day, tod): ', yr, mon, day, tod + call ESMF_TimeGet( stop_date, yy=yr, mm=mon, dd=day, s=tod ) + write(iulog,*) ' Stop date (yr, mon, day, tod): ', yr, mon, day, tod + call shr_sys_abort + end if -! Return date components of the reference date. + ! Initialize ref date from restart info + ref_date = TimeSetymd( rst_ref_ymd, rst_ref_tod, "ref_date" ) -! Arguments - integer, intent(out) ::& - yr, &! year - mon, &! month - day, &! day of month - tod ! time of day (seconds past 0Z) + ! Initialize clock + call init_clock( start_date, ref_date, curr_date, stop_date ) -! Local variables - character(len=*), parameter :: sub = 'rtm::get_ref_date' - integer :: rc - type(ESMF_Time) :: date -!----------------------------------------------------------------------------------------- + ! Print configuration summary to log file (stdout). + if (mainproc) call timemgr_print() - call ESMF_ClockGet(tm_clock, refTime=date, rc=rc) - call chkrc(rc, sub//': error return from ESMF_ClockGet') + timemgr_set = .true. - call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) - call chkrc(rc, sub//': error return from ESMF_TimeGet') + end if -end subroutine get_ref_date + end subroutine timemgr_restart + + !========================================================================================= + + subroutine init_calendar( ) + + !--------------------------------------------------------------------------------- + ! Initialize calendar + ! + ! Local variables + type(ESMF_CalKind_Flag) :: cal_type ! calendar type + character(len=len(calendar)) :: caltmp + integer :: rc ! return code + character(len=*), parameter :: sub = 'init_calendar' + !--------------------------------------------------------------------------------- + + caltmp = to_upper(calendar) + if ( trim(caltmp) == NO_LEAP_C ) then + cal_type = ESMF_CALKIND_NOLEAP + else if ( trim(caltmp) == GREGORIAN_C ) then + cal_type = ESMF_CALKIND_GREGORIAN + else + write(iulog,*)sub,': unrecognized calendar specified: ',calendar + call shr_sys_abort + end if + tm_cal = ESMF_CalendarCreate( name=caltmp, calkindflag=cal_type, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_CalendarSet') + + end subroutine init_calendar + + !========================================================================================= + + subroutine timemgr_print() + + !--------------------------------------------------------------------------------- + character(len=*), parameter :: sub = 'timemgr_print' + integer :: rc + integer :: yr, mon, day + integer :: & ! Data required to restart time manager: + nstep = uninit_int, &! current step number + step_sec = uninit_int, &! timestep size seconds + start_yr = uninit_int, &! start year + start_mon = uninit_int, &! start month + start_day = uninit_int, &! start day of month + start_tod = uninit_int, &! start time of day + stop_yr = uninit_int, &! stop year + stop_mon = uninit_int, &! stop month + stop_day = uninit_int, &! stop day of month + stop_tod = uninit_int, &! stop time of day + ref_yr = uninit_int, &! reference year + ref_mon = uninit_int, &! reference month + ref_day = uninit_int, &! reference day of month + ref_tod = uninit_int, &! reference time of day + curr_yr = uninit_int, &! current year + curr_mon = uninit_int, &! current month + curr_day = uninit_int, &! current day of month + curr_tod = uninit_int ! current time of day + integer(ESMF_KIND_I8) :: step_no + type(ESMF_Time) :: start_date! start date for run + type(ESMF_Time) :: stop_date ! stop date for run + type(ESMF_Time) :: curr_date ! date of data in restart file + type(ESMF_Time) :: ref_date ! reference date + type(ESMF_TimeInterval) :: step ! Time-step + !--------------------------------------------------------------------------------- + + call ESMF_ClockGet( tm_clock, startTime=start_date, currTime=curr_date, & + refTime=ref_date, stopTime=stop_date, timeStep=step, & + advanceCount=step_no, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + nstep = step_no -!========================================================================================= + write(iulog,*)' ******** Time Manager Configuration ********' + + call ESMF_TimeIntervalGet( step, s=step_sec, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalGet') + + call ESMF_TimeGet( start_date, yy=start_yr, mm=start_mon, dd=start_day, & + s=start_tod, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + call ESMF_TimeGet( stop_date, yy=stop_yr, mm=stop_mon, dd=stop_day, & + s=stop_tod, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + call ESMF_TimeGet( ref_date, yy=ref_yr, mm=ref_mon, dd=ref_day, s=ref_tod, & + rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + call ESMF_TimeGet( curr_date, yy=curr_yr, mm=curr_mon, dd=curr_day, & + s=curr_tod, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + + write(iulog,*)' Calendar type: ',trim(calendar) + write(iulog,*)' Timestep size (seconds): ', step_sec + write(iulog,*)' Start date (yr mon day tod): ', start_yr, start_mon, & + start_day, start_tod + write(iulog,*)' Stop date (yr mon day tod): ', stop_yr, stop_mon, & + stop_day, stop_tod + write(iulog,*)' Reference date (yr mon day tod): ', ref_yr, ref_mon, & + ref_day, ref_tod + write(iulog,*)' Current step number: ', nstep + write(iulog,*)' Current date (yr mon day tod): ', curr_yr, curr_mon, & + curr_day, curr_tod + + write(iulog,*)' ************************************************' + + end subroutine timemgr_print + + !========================================================================================= + + subroutine advance_timestep() + + ! Increment the timestep number. + + integer :: rc + character(len=*), parameter :: sub = 'advance_timestep' + + call ESMF_ClockAdvance( tm_clock, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockAdvance') + + end subroutine advance_timestep + + !========================================================================================= + + integer function get_step_size() + + ! Return the step size in seconds. + + type(ESMF_TimeInterval) :: step_size ! timestep size + integer :: rc + character(len=*), parameter :: sub = 'get_step_size' + + call ESMF_ClockGet(tm_clock, timeStep=step_size, rc=rc) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + call ESMF_TimeIntervalGet(step_size, s=get_step_size, rc=rc) + call chkrc(rc, sub//': error return from ESMF_ClockTimeIntervalGet') + + end function get_step_size + + !========================================================================================= + + integer function get_nstep() + + ! Return the timestep number. + + character(len=*), parameter :: sub = 'get_nstep' + integer :: rc + integer(ESMF_KIND_I8) :: step_no + + call ESMF_ClockGet(tm_clock, advanceCount=step_no, rc=rc) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + + get_nstep = step_no + + end function get_nstep -subroutine get_curr_time(days, seconds) + !========================================================================================= -! Return time components valid at end of current timestep. -! Current time is the time interval between the current date and the reference date. + subroutine get_curr_date(yr, mon, day, tod, offset) -! Arguments - integer, intent(out) ::& - days, &! number of whole days in time interval - seconds ! remaining seconds in time interval + !----------------------------------------------------------------------------------------- + ! Return date components valid at end of current timestep with an optional + ! offset (positive or negative) in seconds. -! Local variables - character(len=*), parameter :: sub = 'rtm::get_curr_time' - integer :: rc - type(ESMF_Time) :: cdate, rdate - type(ESMF_TimeInterval) :: diff -!----------------------------------------------------------------------------------------- + integer, intent(out) ::& + yr, &! year + mon, &! month + day, &! day of month + tod ! time of day (seconds past 0Z) - call ESMF_ClockGet( tm_clock, currTime=cdate, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet') + integer, optional, intent(in) :: offset ! Offset from current time in seconds. + ! Positive for future times, negative + ! for previous times. - call ESMF_ClockGet( tm_clock, refTime=rdate, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet') + character(len=*), parameter :: sub = 'get_curr_date' + integer :: rc + type(ESMF_Time) :: date + type(ESMF_TimeInterval) :: off + !----------------------------------------------------------------------------------------- - diff = cdate - rdate + call ESMF_ClockGet( tm_clock, currTime=date, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') - call ESMF_TimeIntervalGet(diff, d=days, s=seconds, rc=rc) - call chkrc(rc, sub//': error return from ESMF_TimeIntervalGet') + if (present(offset)) then + if (offset > 0) then + call ESMF_TimeIntervalSet( off, s=offset, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet') + date = date + off + else if (offset < 0) then + call ESMF_TimeIntervalSet( off, s=-offset, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet') + date = date - off + end if + end if -end subroutine get_curr_time + call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeGet') -!========================================================================================= + end subroutine get_curr_date -subroutine get_prev_time(days, seconds) + !========================================================================================= -! Return time components valid at beg of current timestep. -! prev time is the time interval between the prev date and the reference date. + subroutine get_prev_date(yr, mon, day, tod) -! Arguments - integer, intent(out) ::& - days, &! number of whole days in time interval - seconds ! remaining seconds in time interval + ! Return date components valid at beginning of current timestep. -! Local variables - character(len=*), parameter :: sub = 'rtm::get_prev_time' - integer :: rc - type(ESMF_Time) :: date, ref_date - type(ESMF_TimeInterval) :: diff -!----------------------------------------------------------------------------------------- + ! Arguments + integer, intent(out) ::& + yr, &! year + mon, &! month + day, &! day of month + tod ! time of day (seconds past 0Z) - call ESMF_ClockGet(tm_clock, prevTime=date, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet for prevTime') - call ESMF_ClockGet(tm_clock, refTime=ref_date, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet for refTime') - diff = date - ref_date - call ESMF_TimeIntervalGet( diff, d=days, s=seconds, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeintervalGet') + ! Local variables + character(len=*), parameter :: sub = 'get_prev_date' + integer :: rc + type(ESMF_Time) :: date + !----------------------------------------------------------------------------------------- -end subroutine get_prev_time + call ESMF_ClockGet(tm_clock, prevTime=date, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeGet') -!========================================================================================= + end subroutine get_prev_date -function get_calendar() + !========================================================================================= - ! Return calendar + subroutine get_start_date(yr, mon, day, tod) - character(len=ESMF_MAXSTR) :: get_calendar + ! Return date components valid at beginning of initial run. + integer, intent(out) ::& + yr, &! year + mon, &! month + day, &! day of month + tod ! time of day (seconds past 0Z) - get_calendar = calendar + character(len=*), parameter :: sub = 'get_start_date' + integer :: rc + type(ESMF_Time) :: date -end function get_calendar + call ESMF_ClockGet(tm_clock, startTime=date, rc=rc) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeGet') -!========================================================================================= + end subroutine get_start_date -function is_end_curr_day() + !========================================================================================= - ! Return true if current timestep is last timestep in current day. - logical :: is_end_curr_day + subroutine get_ref_date(yr, mon, day, tod) - integer ::& - yr, &! year - mon, &! month - day, &! day of month - tod ! time of day (seconds past 0Z) + ! Return date components of the reference date. - call get_curr_date(yr, mon, day, tod) - is_end_curr_day = (tod == 0) + ! Arguments + integer, intent(out) :: yr ! year + integer, intent(out) :: mon ! month + integer, intent(out) :: day ! day of month + integer, intent(out) :: tod ! time of day (seconds past 0Z) -end function is_end_curr_day + ! Local variables + integer :: rc + type(ESMF_Time) :: date + character(len=*), parameter :: sub = 'get_ref_date' + !----------------------------------------------------------------------------------------- -!========================================================================================= + call ESMF_ClockGet(tm_clock, refTime=date, rc=rc) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeGet') -logical function is_end_curr_month() + end subroutine get_ref_date - ! Return true if current timestep is last timestep in current month. - integer :: yr, mon, day, tod ! time of day (seconds past 0Z) + !========================================================================================= - call get_curr_date(yr, mon, day, tod) - is_end_curr_month = (day == 1 .and. tod == 0) + subroutine get_curr_time(days, seconds) -end function is_end_curr_month + ! Return time components valid at end of current timestep. + ! Current time is the time interval between the current date and the reference date. -!========================================================================================= + ! Arguments + integer, intent(out) :: days ! number of whole days in time interval + integer, intent(out) :: seconds ! remaining seconds in time interval -logical function is_first_step() + ! Local variables + integer :: rc + type(ESMF_Time) :: cdate, rdate + type(ESMF_TimeInterval) :: diff + character(len=*), parameter :: sub = 'get_curr_time' + !----------------------------------------------------------------------------------------- - ! Return true on first step of initial run only. - character(len=*), parameter :: sub = 'rtm::is_first_step' - integer :: rc - integer :: nstep - integer(ESMF_KIND_I8) :: step_no + call ESMF_ClockGet( tm_clock, currTime=cdate, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') - call ESMF_ClockGet( tm_clock, advanceCount=step_no, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - nstep = step_no - is_first_step = (nstep == 0) + call ESMF_ClockGet( tm_clock, refTime=rdate, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') -end function is_first_step + diff = cdate - rdate -!========================================================================================= + call ESMF_TimeIntervalGet(diff, d=days, s=seconds, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalGet') -logical function is_first_restart_step() + end subroutine get_curr_time - ! Return true on first step of restart run only. - is_first_restart_step = tm_first_restart_step + !========================================================================================= -end function is_first_restart_step + subroutine get_prev_time(days, seconds) -!========================================================================================= + ! Return time components valid at beg of current timestep. + ! prev time is the time interval between the prev date and the reference date. -logical function is_last_step() + ! Arguments + integer, intent(out) ::& + days, &! number of whole days in time interval + seconds ! remaining seconds in time interval - ! Return true on last timestep. - character(len=*), parameter :: sub = 'rtm::is_last_step' - type(ESMF_Time) :: stop_date - type(ESMF_Time) :: curr_date - type(ESMF_TimeInterval) :: time_step - integer :: rc + ! Local variables + character(len=*), parameter :: sub = 'get_prev_time' + integer :: rc + type(ESMF_Time) :: date, ref_date + type(ESMF_TimeInterval) :: diff + !----------------------------------------------------------------------------------------- - call ESMF_ClockGet( tm_clock, stopTime=stop_date, & - currTime=curr_date, TimeStep=time_step, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - if ( curr_date+time_step > stop_date ) then - is_last_step = .true. - else - is_last_step = .false. - end if + call ESMF_ClockGet(tm_clock, prevTime=date, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet for prevTime') + call ESMF_ClockGet(tm_clock, refTime=ref_date, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet for refTime') + diff = date - ref_date + call ESMF_TimeIntervalGet( diff, d=days, s=seconds, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeintervalGet') -end function is_last_step + end subroutine get_prev_time -!========================================================================================= + !========================================================================================= -subroutine chkrc(rc, mes) - integer, intent(in) :: rc ! return code from time management library - character(len=*), intent(in) :: mes ! error message - if ( rc == ESMF_SUCCESS ) return - write(iulog,*) mes - call shr_sys_abort ('CHKRC') -end subroutine chkrc + function get_calendar() -!========================================================================================= + ! Return calendar + character(len=ESMF_MAXSTR) :: get_calendar -function to_upper(str) + get_calendar = calendar - ! Convert character string to upper case. Use achar and iachar intrinsics - ! to ensure use of ascii collating sequence. - character(len=*), intent(in) :: str ! String to convert to upper case - character(len=len(str)) :: to_upper + end function get_calendar - 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 + subroutine chkrc(rc, mes) + integer, intent(in) :: rc ! return code from time management library + character(len=*), intent(in) :: mes ! error message + if ( rc == ESMF_SUCCESS ) return + write(iulog,*) mes + call shr_sys_abort ('CHKRC') + end subroutine chkrc -end function to_upper + !========================================================================================= -!========================================================================================= + function to_upper(str) -logical function is_restart( ) - ! Determine if restart run - if (nsrest == nsrContinue) then - is_restart = .true. - else - is_restart = .false. - end if -end function is_restart + ! Convert character string to upper case. Use achar and iachar intrinsics + ! to ensure use of ascii collating sequence. + character(len=*), intent(in) :: str ! String to convert to upper case + character(len=len(str)) :: to_upper -!========================================================================================= + integer :: i ! Index + integer :: aseq ! ascii collating sequence + character(len=1) :: ctmp ! Character temporary -subroutine timemgr_spmdbcast( ) + 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 - integer :: ier + end function to_upper - call mpi_bcast (dtime, 1, MPI_INTEGER, 0, mpicom_rof, ier) + !========================================================================================= -end subroutine timemgr_spmdbcast + logical function is_restart( ) + ! Determine if restart run + if (nsrest == nsrContinue) then + is_restart = .true. + else + is_restart = .false. + end if + end function is_restart -end module RtmTimeManager +end module mosart_timemanager diff --git a/src/riverroute/mosart_tparameter_type.F90 b/src/riverroute/mosart_tparameter_type.F90 new file mode 100644 index 0000000..8133e89 --- /dev/null +++ b/src/riverroute/mosart_tparameter_type.F90 @@ -0,0 +1,33 @@ +module mosart_tparameter_type + + ! parameters to be calibrated. Ideally, these parameters are supposed to be uniform for one region + + use shr_kind_mod, only : r8 => shr_kind_r8, CL => SHR_KIND_CL + + implicit none + private + + public :: Tparameter_type + type Tparameter_type + real(r8), pointer :: c_nr(:) ! coefficient to adjust the manning's roughness of channels + 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 + contains + procedure, public :: Init + end type Tparameter_type + +contains + + subroutine Init(this, begr, endr) + + ! Arguments + class(tparameter_type) :: this + integer, intent(in) :: begr, endr + + ! Initialize TPara + allocate (this%c_twid(begr:endr)) + this%c_twid = 1.0_r8 + + end subroutine Init + +end module mosart_tparameter_type diff --git a/src/riverroute/mosart_tspatialunit_type.F90 b/src/riverroute/mosart_tspatialunit_type.F90 new file mode 100644 index 0000000..7aadc5d --- /dev/null +++ b/src/riverroute/mosart_tspatialunit_type.F90 @@ -0,0 +1,658 @@ +module mosart_tspatialunit_type + + ! Topographic and geometric properties, applicable for both grid- and subbasin-based representations + + use shr_kind_mod, only : r8 => shr_kind_r8, CL => SHR_KIND_CL + use shr_sys_mod, only : shr_sys_abort + use shr_mpi_mod, only : shr_mpi_sum, shr_mpi_max + use mosart_io, only : ncd_pio_openfile, compDOF + use mosart_vars, only : mainproc, mpicom_rof, iulog + use nuopc_shr_methods, only : chkerr + use pio + use ESMF + + implicit none + private + + type Tspatialunit_type + + ! grid properties + integer , pointer :: mask(:) ! mosart mask of mosart cell, 0=null, 1=land with dnID, 2=outlet + integer , pointer :: ID0(:) + real(r8), pointer :: lat(:) ! latitude of the centroid of the cell + real(r8), pointer :: lon(:) ! longitude of the centroid of the cell + real(r8), pointer :: area(:) ! area of local cell, [m2] + real(r8), pointer :: areaTotal(:) ! total upstream drainage area, [m2] + real(r8), pointer :: areaTotal2(:)! computed total upstream drainage area, [m2] + real(r8), pointer :: rlenTotal(:) ! length of all reaches, [m] + real(r8), pointer :: Gxr(:) ! drainage density within the cell, [1/m] + real(r8), pointer :: frac(:) ! fraction of cell included in the study area, [-] + logical , pointer :: euler_calc(:) ! flag for calculating tracers in euler + + ! hillslope properties + real(r8), pointer :: nh(:) ! manning's roughness of the hillslope (channel network excluded) + real(r8), pointer :: hslp(:) ! slope of hillslope, [-] + real(r8), pointer :: hslpsqrt(:) ! sqrt of slope of hillslope, [-] + real(r8), pointer :: hlen(:) ! length of hillslope within the cell, [m] + + ! subnetwork channel properties + real(r8), pointer :: nt(:) ! manning's roughness of the subnetwork at hillslope + real(r8), pointer :: tslp(:) ! average slope of tributaries, [-] + real(r8), pointer :: tslpsqrt(:) ! sqrt of average slope of tributaries, [-] + real(r8), pointer :: tlen(:) ! length of all sub-network reach within the cell, [m] + real(r8), pointer :: twidth(:) ! bankfull width of the sub-reach, [m] + real(r8), pointer :: twidth0(:) ! unadjusted twidth + + ! main channel properties + real(r8), pointer :: nr(:) ! manning's roughness of the main reach + real(r8), pointer :: rlen(:) ! length of main river reach, [m] + real(r8), pointer :: rslp(:) ! slope of main river reach, [-] + real(r8), pointer :: rslpsqrt(:) ! sqrt of slope of main river reach, [-] + real(r8), pointer :: rwidth(:) ! bankfull width of main reach, [m] + real(r8), pointer :: rwidth0(:) ! total width of the flood plain, [m] + real(r8), pointer :: rdepth(:) ! bankfull depth of river cross section, [m] + ! + integer , pointer :: dnID(:) ! IDs of the downstream units, corresponding to the subbasin ID in the input table + integer , pointer :: iUp(:,:) ! IDs of upstream units, corresponding to the subbasin ID in the input table + integer , pointer :: nUp(:) ! number of upstream units, maximum 8 + integer , pointer :: indexDown(:) ! indices of the downstream units in the ID array. sometimes subbasins IDs may not be continuous + integer , pointer :: numDT_r(:) ! for a main reach, the number of sub-time-steps needed for numerical stability + integer , pointer :: numDT_t(:) ! for a subnetwork reach, the number of sub-time-steps needed for numerical stability + real(r8), pointer :: phi_r(:) ! the indicator used to define numDT_r + real(r8), pointer :: phi_t(:) ! the indicator used to define numDT_t + + ! mapping + type(ESMF_Field) :: srcField + type(ESMF_Field) :: dstField + type(ESMF_RouteHandle) :: rh_direct + type(ESMF_RouteHandle) :: rh_eroutUp + + contains + + procedure, public :: Init + procedure, private :: set_routehandles + procedure, private :: set_subtimesteps + procedure, private :: set_areatotal2 + + end type Tspatialunit_type + public :: Tspatialunit_type + + character(*), parameter :: u_FILE_u = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine Init(this, begr, endr, ntracers, nlon, nlat, EMesh, & + frivinp, IDkey, c_twid, DLevelR, area, gindex, outletg, pio_subsystem, rc) + + ! Arguments + class(Tspatialunit_type) :: this + integer , intent(in) :: begr, endr + integer , intent(in) :: ntracers + real(r8) , intent(in) :: area(begr:endr) + integer , intent(in) :: nlon, nlat + character(len=*) , intent(in) :: frivinp + integer , intent(in) :: IDkey(:) + real(r8) , intent(in) :: c_twid(begr:endr) + integer , intent(in) :: DLevelR + type(iosystem_desc_t) , pointer :: pio_subsystem + type(ESMF_Mesh) , intent(in) :: Emesh + integer , intent(in) :: gindex(begr:endr) + integer , intent(in) :: outletg(begr:endr) + integer , intent(out) :: rc + + ! Local variables + integer :: n + integer :: ier + type(file_desc_t) :: ncid ! pio file desc + type(var_desc_t) :: vardesc ! pio variable desc + type(io_desc_t) :: iodesc_dbl ! pio io desc + type(io_desc_t) :: iodesc_int ! pio io desc + integer :: dids(2) ! variable dimension ids + integer :: dsizes(2) ! variable dimension lengths + real(r8) :: hlen_max, rlen_min + character(len=*),parameter :: FORMI = '(2A,2i10)' + character(len=*),parameter :: FORMR = '(2A,2g15.7)' + character(len=*),parameter :: subname = '(mosart_tspatialunit_type_init) ' + !-------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! Read in routing parameters + call ncd_pio_openfile (ncid, trim(frivinp), 0) + call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + + ! Setup iodesc based on frac dids + ier = pio_inq_varid(ncid, name='frac', vardesc=vardesc) + ier = pio_inq_vardimid(ncid, vardesc, dids) + ier = pio_inq_dimlen(ncid, dids(1),dsizes(1)) + ier = pio_inq_dimlen(ncid, dids(2),dsizes(2)) + call pio_initdecomp(pio_subsystem, pio_double, dsizes, compDOF, iodesc_dbl) + call pio_initdecomp(pio_subsystem, pio_int , dsizes, compDOF, iodesc_int) + + allocate(this%euler_calc(ntracers)) + this%euler_calc = .true. + + allocate(this%frac(begr:endr)) + ier = pio_inq_varid(ncid, name='frac', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%frac, ier) + if (mainproc) then + write(iulog,FORMR) trim(subname),' read frac ',minval(this%frac),maxval(this%frac) + end if + + ! read fdir, convert to mask + ! fdir <0 ocean, 0=outlet, >0 land + ! tunit mask is 0=ocean, 1=land, 2=outlet for mosart calcs + + allocate(this%mask(begr:endr)) + ier = pio_inq_varid(ncid, name='fdir', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_int, this%mask, ier) + if (mainproc) then + write(iulog,'(2A,2i10)') trim(subname),' read fdir mask ',minval(this%mask),maxval(this%mask) + end if + + do n = begr, endr + if (this%mask(n) < 0) then + this%mask(n) = 0 + elseif (this%mask(n) == 0) then + this%mask(n) = 2 + if (abs(this%frac(n)-1.0_r8)>1.0e-9) then + write(iulog,*) subname,' ERROR frac ne 1.0',n,this%frac(n) + call shr_sys_abort(subname//' ERROR frac ne 1.0') + endif + elseif (this%mask(n) > 0) then + this%mask(n) = 1 + if (abs(this%frac(n)-1.0_r8)>1.0e-9) then + write(iulog,*) subname,' ERROR frac ne 1.0',n,this%frac(n) + call shr_sys_abort(subname//' ERROR frac ne 1.0') + endif + else + call shr_sys_abort(subname//' this mask error') + endif + enddo + + allocate(this%ID0(begr:endr)) + ier = pio_inq_varid(ncid, name='ID', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_int, this%ID0, ier) + if (mainproc) write(iulog,'(2A,2i10)') trim(subname),' read ID0 ',minval(this%ID0),maxval(this%ID0) + + allocate(this%dnID(begr:endr)) + ier = pio_inq_varid(ncid, name='dnID', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_int, this%dnID, ier) + if (mainproc) write(iulog,'(2A,2i10)') trim(subname),' read dnID ',minval(this%dnID),maxval(this%dnID) + + ! RESET ID0 and dnID indices using the IDkey to be consistent with standard gindex order + do n=begr, endr + this%ID0(n) = IDkey(this%ID0(n)) + if (this%dnID(n) > 0 .and. this%dnID(n) <= nlon*nlat) then + if (IDkey(this%dnID(n)) > 0 .and. IDkey(this%dnID(n)) <= nlon*nlat) then + this%dnID(n) = IDkey(this%dnID(n)) + else + write(iulog,*) subname,' ERROR bad IDkey for this%dnID',n,this%dnID(n),IDkey(this%dnID(n)) + call shr_sys_abort(subname//' ERROR bad IDkey for this%dnID') + endif + endif + enddo + + allocate(this%area(begr:endr)) + ier = pio_inq_varid(ncid, name='area', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%area, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read area ',minval(this%area),maxval(this%area) + + do n=begr, endr + if (this%area(n) < 0._r8) this%area(n) = area(n) + if (this%area(n) /= area(n)) then + write(iulog,*) subname,' ERROR area mismatch',this%area(n),area(n) + call shr_sys_abort(subname//' ERROR area mismatch') + endif + enddo + + allocate(this%areaTotal(begr:endr)) + ier = pio_inq_varid(ncid, name='areaTotal', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%areaTotal, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read areaTotal ',minval(this%areaTotal),maxval(this%areaTotal) + + allocate(this%rlenTotal(begr:endr)) + this%rlenTotal = 0._r8 + + allocate(this%nh(begr:endr)) + ier = pio_inq_varid(ncid, name='nh', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%nh, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read nh ',minval(this%nh),maxval(this%nh) + + allocate(this%hslp(begr:endr)) + ier = pio_inq_varid(ncid, name='hslp', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%hslp, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read hslp ',minval(this%hslp),maxval(this%hslp) + + allocate(this%hslpsqrt(begr:endr)) + this%hslpsqrt = 0._r8 + + allocate(this%gxr(begr:endr)) + ier = pio_inq_varid(ncid, name='gxr', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%gxr, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read gxr ',minval(this%gxr),maxval(this%gxr) + + allocate(this%hlen(begr:endr)) + this%hlen = 0._r8 + + allocate(this%tslp(begr:endr)) + ier = pio_inq_varid(ncid, name='tslp', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%tslp, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read tslp ',minval(this%tslp),maxval(this%tslp) + + allocate(this%tslpsqrt(begr:endr)) + this%tslpsqrt = 0._r8 + + allocate(this%tlen(begr:endr)) + this%tlen = 0._r8 + + allocate(this%twidth(begr:endr)) + ier = pio_inq_varid(ncid, name='twid', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%twidth, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read twidth ',minval(this%twidth),maxval(this%twidth) + + ! save twidth before adjusted below + allocate(this%twidth0(begr:endr)) + this%twidth0(begr:endr)=this%twidth(begr:endr) + + allocate(this%nt(begr:endr)) + ier = pio_inq_varid(ncid, name='nt', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%nt, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read nt ',minval(this%nt),maxval(this%nt) + + allocate(this%rlen(begr:endr)) + ier = pio_inq_varid(ncid, name='rlen', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%rlen, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read rlen ',minval(this%rlen),maxval(this%rlen) + + allocate(this%rslp(begr:endr)) + ier = pio_inq_varid(ncid, name='rslp', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%rslp, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read rslp ',minval(this%rslp),maxval(this%rslp) + + allocate(this%rslpsqrt(begr:endr)) + this%rslpsqrt = 0._r8 + + allocate(this%rwidth(begr:endr)) + ier = pio_inq_varid(ncid, name='rwid', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%rwidth, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read rwidth ',minval(this%rwidth),maxval(this%rwidth) + + allocate(this%rwidth0(begr:endr)) + ier = pio_inq_varid(ncid, name='rwid0', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%rwidth0, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read rwidth0 ',minval(this%rwidth0),maxval(this%rwidth0) + + allocate(this%rdepth(begr:endr)) + ier = pio_inq_varid(ncid, name='rdep', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%rdepth, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read rdepth ',minval(this%rdepth),maxval(this%rdepth) + + allocate(this%nr(begr:endr)) + ier = pio_inq_varid(ncid, name='nr', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%nr, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read nr ',minval(this%nr),maxval(this%nr) + + allocate(this%nUp(begr:endr)) + this%nUp = 0 + allocate(this%iUp(begr:endr,8)) + this%iUp = 0 + allocate(this%indexDown(begr:endr)) + this%indexDown = 0 + + ! control parameters and some other derived parameters + ! estimate derived input variables + + ! add minimum value to rlen (length of main channel); rlen values can + ! be too small, leading to tlen values that are too large + + do n=begr,endr + rlen_min = sqrt(this%area(n)) + if(this%rlen(n) < rlen_min) then + this%rlen(n) = rlen_min + end if + end do + + do n=begr,endr + if(this%Gxr(n) > 0._r8) then + this%rlenTotal(n) = this%area(n)*this%Gxr(n) + end if + end do + + do n=begr,endr + if(this%rlen(n) > this%rlenTotal(n)) then + this%rlenTotal(n) = this%rlen(n) + end if + end do + + do n=begr,endr + + if(this%rlen(n) > 0._r8) then + this%hlen(n) = this%area(n) / this%rlenTotal(n) / 2._r8 + + ! constrain hlen (hillslope length) values based on cell area + hlen_max = max(1000.0_r8, sqrt(this%area(n))) + if(this%hlen(n) > hlen_max) then + this%hlen(n) = hlen_max ! allievate the outlier in drainag\e density estimation. TO DO + end if + + this%tlen(n) = this%area(n) / this%rlen(n) / 2._r8 - this%hlen(n) + + if (this%twidth(n) < 0._r8) then + this%twidth(n) = 0._r8 + end if + if ( this%tlen(n) > 0._r8 .and. & + (this%rlenTotal(n)-this%rlen(n))/this%tlen(n) > 1._r8 ) then + this%twidth(n) = c_twid(n)*this%twidth(n) * & + ((this%rlenTotal(n)-this%rlen(n))/this%tlen(n)) + end if + if (this%tlen(n) > 0._r8 .and. this%twidth(n) <= 0._r8) then + this%twidth(n) = 0._r8 + end if + else + this%hlen(n) = 0._r8 + this%tlen(n) = 0._r8 + this%twidth(n) = 0._r8 + end if + if(this%rslp(n) <= 0._r8) then + this%rslp(n) = 0.0001_r8 + end if + if(this%tslp(n) <= 0._r8) then + this%tslp(n) = 0.0001_r8 + end if + if(this%hslp(n) <= 0._r8) then + this%hslp(n) = 0.005_r8 + end if + + this%rslpsqrt(n) = sqrt(this%rslp(n)) + this%tslpsqrt(n) = sqrt(this%tslp(n)) + this%hslpsqrt(n) = sqrt(this%hslp(n)) + end do + + call pio_freedecomp(ncid, iodesc_dbl) + call pio_freedecomp(ncid, iodesc_int) + call pio_closefile(ncid) + + ! Create srcfield and dstfield - needed for mapping + this%srcfield = ESMF_FieldCreate(EMesh, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, & + ungriddedLBound=(/1/), ungriddedUBound=(/ntracers/), gridToFieldMap=(/2/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + this%dstfield = ESMF_FieldCreate(EMesh, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, & + ungriddedLBound=(/1/), ungriddedUBound=(/ntracers/), gridToFieldMap=(/2/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Create route handles + call this%set_routehandles(begr, endr, gindex, outletg, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Compute areatotal2 + ! this basically advects upstream areas downstream and + ! adds them up as it goes until all upstream areas are accounted for + allocate(this%areatotal2(begr:endr)) + call this%set_areatotal2(begr, endr, nlon, nlat, area, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Determine subcycling time steps + allocate(this%numDT_r(begr:endr)) + allocate(this%numDT_t(begr:endr)) + allocate(this%phi_r(begr:endr)) + allocate(this%phi_t(begr:endr)) + call this%set_subtimesteps(begr, endr, DLevelR) + + end subroutine Init + + !----------------------------------------------------------------------- + + subroutine set_routehandles(this, begr, endr, gindex, outletg, rc) + + ! Arguments + class(Tspatialunit_type) :: this + integer , intent(in) :: begr, endr + integer , intent(in) :: gindex(begr:endr) + integer , intent(in) :: outletg(begr:endr) + integer , intent(out) :: rc + + ! Local variables + integer :: nn, n, cnt, nr, nt + real(r8), pointer :: src_direct(:,:) + real(r8), pointer :: dst_direct(:,:) + real(r8), pointer :: src_eroutUp(:,:) + real(r8), pointer :: dst_eroutUp(:,:) + real(r8), allocatable :: factorList(:) + integer , allocatable :: factorIndexList(:,:) + integer :: srcTermProcessing_Value = 0 + !-------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! --------------------------------------- + ! Calculate map for direct to outlet mapping + ! --------------------------------------- + + ! Set up pointer arrays into srcfield and dstfield + call ESMF_FieldGet(this%srcfield, farrayPtr=src_direct, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(this%dstfield, farrayPtr=dst_direct, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + src_direct(:,:) = 0._r8 + dst_direct(:,:) = 0._r8 + + ! The route handle rh_direct will then be used in mosart_run + cnt = endr - begr + 1 + allocate(factorList(cnt)) + allocate(factorIndexList(2,cnt)) + cnt = 0 + do nr = begr,endr + cnt = cnt + 1 + if (outletg(nr) > 0) then + factorList(cnt) = 1.0_r8 + factorIndexList(1,cnt) = gindex(nr) + factorIndexList(2,cnt) = outletg(nr) + else + factorList(cnt) = 1.0_r8 + factorIndexList(1,cnt) = gindex(nr) + factorIndexList(2,cnt) = gindex(nr) + endif + enddo + + call ESMF_FieldSMMStore(this%srcField, this%dstField, this%rh_direct, factorList, factorIndexList, & + ignoreUnmatchedIndices=.true., srcTermProcessing=srcTermProcessing_Value, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + deallocate(factorList) + deallocate(factorIndexList) + + if (mainproc) write(iulog,*) " Done initializing rh_direct " + + ! --------------------------------------- + ! Compute map rh_eroutUp + ! --------------------------------------- + + ! Set up pointer arrays into srcfield and dstfield + call ESMF_FieldGet(this%srcfield, farrayPtr=src_eroutUp, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(this%dstfield, farrayPtr=dst_eroutUp, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + src_eroutUp(:,:) = 0._r8 + dst_eroutUp(:,:) = 0._r8 + + cnt = 0 + do nr = begr,endr + if (this%dnID(nr) > 0) then + cnt = cnt + 1 + end if + end do + allocate(factorList(cnt)) + allocate(factorIndexList(2,cnt)) + cnt = 0 + do nr = begr,endr + if (this%dnID(nr) > 0) then + cnt = cnt + 1 + factorList(cnt) = 1.0_r8 + factorIndexList(1,cnt) = this%ID0(nr) + factorIndexList(2,cnt) = this%dnID(nr) + endif + enddo + if (mainproc) write(iulog,*) " Done initializing rh_eroutUp" + + call ESMF_FieldSMMStore(this%srcfield, this%dstfield, this%rh_eroutUp, factorList, factorIndexList, & + ignoreUnmatchedIndices=.true., srcTermProcessing=srcTermProcessing_Value, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + deallocate(factorList) + deallocate(factorIndexList) + + end subroutine set_routehandles + + !----------------------------------------------------------------------- + + subroutine set_areatotal2(this, begr, endr, nlon, nlat, area, rc) + + ! Arguments + class(Tspatialunit_type) :: this + integer , intent(in) :: begr, endr + integer , intent(in) :: nlon,nlat + real(r8) , intent(in) :: area(begr:endr) + integer , intent(out) :: rc + + ! Local variables + integer :: nr, cnt, tcnt ! indices + real(r8) :: areatot_prev, areatot_tmp, areatot_new + real(r8), pointer :: src_direct(:,:) + real(r8), pointer :: dst_direct(:,:) + real(r8), pointer :: src_eroutUp(:,:) + real(r8), pointer :: dst_eroutUp(:,:) + character(len=*),parameter :: subname = '(mosart_tspatialunit_type_set_areatotal2) ' + ! -------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! --------------------------------------- + ! compute areatot from area using dnID + ! --------------------------------------- + + ! Set up pointer arrays into srcfield and dstfield + call ESMF_FieldGet(this%srcfield, farrayPtr=src_eroutUp, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(this%dstfield, farrayPtr=dst_eroutUp, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + src_eroutUp(:,:) = 0._r8 + dst_eroutUp(:,:) = 0._r8 + + ! this basically advects upstream areas downstream and + ! adds them up as it goes until all upstream areas are accounted for + + this%areatotal2(:) = 0._r8 + + ! initialize dst_eroutUp to local area and add that to areatotal2 + cnt = 0 + dst_eroutUp(:,:) = 0._r8 + do nr = begr,endr + cnt = cnt + 1 + dst_eroutUp(1,cnt) = area(nr) + this%areatotal2(nr) = area(nr) + enddo + + tcnt = 0 + areatot_prev = -99._r8 + areatot_new = -50._r8 + do while (areatot_new /= areatot_prev .and. tcnt < nlon*nlat) + + tcnt = tcnt + 1 + + ! copy dst_eroutUp to src_eroutUp for next downstream step + src_eroutUp(:,:) = 0._r8 + cnt = 0 + do nr = begr,endr + cnt = cnt + 1 + src_eroutUp(1,cnt) = dst_eroutUp(1,cnt) + enddo + + dst_eroutUp(:,:) = 0._r8 + call ESMF_FieldSMM(this%srcfield, this%dstField, this%rh_eroutUp, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! add dst_eroutUp to areatot and compute new global sum + cnt = 0 + areatot_prev = areatot_new + areatot_tmp = 0._r8 + do nr = begr,endr + cnt = cnt + 1 + this%areatotal2(nr) = this%areatotal2(nr) + dst_eroutUp(1,cnt) + areatot_tmp = areatot_tmp + this%areatotal2(nr) + enddo + call shr_mpi_sum(areatot_tmp, areatot_new, mpicom_rof, 'areatot_new', all=.true.) + + if (mainproc) then + write(iulog,*) trim(subname),' areatot calc ',tcnt,areatot_new + endif + enddo + + if (areatot_new /= areatot_prev) then + write(iulog,*) trim(subname),' MOSART ERROR: areatot incorrect ',areatot_new, areatot_prev + call shr_sys_abort(trim(subname)//' MOSART ERROR areatot incorrect') + endif + + end subroutine set_areatotal2 + + !----------------------------------------------------------------------- + + subroutine set_subtimesteps(this, begr, endr, DLevelR) + + ! Set the sub-time-steps for channel routing + + ! Arguments + class(Tspatialunit_type) :: this + integer, intent(in) :: begr, endr + integer, intent(in) :: DLevelR + + ! Local variables + integer :: nr !local index + integer :: numDT_r, numDT_t + character(len=*),parameter :: subname = '(mosart_tspatialunit_type_subtimestep) ' + ! -------------------------------------------------------------- + + this%numDT_r(:) = 1 + this%numDT_t(:) = 1 + this%phi_r(:) = 0._r8 + this%phi_t(:) = 0._r8 + + do nr = begr,endr + if (this%mask(nr) > 0 .and. this%rlen(nr) > 0._r8) then + this%phi_r(nr) = this%areaTotal2(nr)*sqrt(this%rslp(nr))/(this%rlen(nr)*this%rwidth(nr)) + if (this%phi_r(nr) >= 10._r8) then + this%numDT_r(nr) = (this%numDT_r(nr)*log10(this%phi_r(nr))*DLevelR) + 1 + else + this%numDT_r(nr) = this%numDT_r(nr)*1.0_r8*DLevelR + 1 + end if + end if + if (this%numDT_r(nr) < 1) this%numDT_r(nr) = 1 + + if (this%tlen(nr) > 0._r8) then + this%phi_t(nr) = this%area(nr)*sqrt(this%tslp(nr))/(this%tlen(nr)*this%twidth(nr)) + if (this%phi_t(nr) >= 10._r8) then + this%numDT_t(nr) = (this%numDT_t(nr)*log10(this%phi_t(nr))*DLevelR) + 1 + else + this%numDT_t(nr) = (this%numDT_t(nr)*1.0*DLevelR) + 1 + end if + end if + if (this%numDT_t(nr) < 1) this%numDT_t(nr) = 1 + end do + + call shr_mpi_max(maxval(this%numDT_r),numDT_r,mpicom_rof,'numDT_r',all=.false.) + call shr_mpi_max(maxval(this%numDT_t),numDT_t,mpicom_rof,'numDT_t',all=.false.) + if (mainproc) then + write(iulog,*) subname,' DLevelR = ',DlevelR + write(iulog,*) subname,' numDT_r = ',minval(this%numDT_r),maxval(this%numDT_r) + write(iulog,*) subname,' numDT_r max = ',numDT_r + write(iulog,*) subname,' numDT_t = ',minval(this%numDT_t),maxval(this%numDT_t) + write(iulog,*) subname,' numDT_t max = ',numDT_t + endif + + end subroutine set_subtimesteps + +end module mosart_tspatialunit_type diff --git a/src/riverroute/mosart_tstatusflux_type.F90 b/src/riverroute/mosart_tstatusflux_type.F90 new file mode 100644 index 0000000..583819b --- /dev/null +++ b/src/riverroute/mosart_tstatusflux_type.F90 @@ -0,0 +1,166 @@ +module mosart_tstatusflux_type + + ! status and flux variables + + use shr_kind_mod, only : r8 => shr_kind_r8, CL => SHR_KIND_CL + + implicit none + private + + public :: TstatusFlux_type + type TstatusFlux_type + ! hillsloope + !! states + real(r8), pointer :: wh(:,:) ! storage of surface water, [m] + real(r8), pointer :: dwh(:,:) ! change of water storage, [m/s] + real(r8), pointer :: yh(:,:) ! depth of surface water, [m] + real(r8), pointer :: wsat(:,:) ! storage of surface water within saturated area at hillslope [m] + real(r8), pointer :: wunsat(:,:) ! storage of surface water within unsaturated area at hillslope [m] + real(r8), pointer :: qhorton(:,:) ! Infiltration excess runoff generated from hillslope, [m/s] + real(r8), pointer :: qdunne(:,:) ! Saturation excess runoff generated from hillslope, [m/s] + real(r8), pointer :: qsur(:,:) ! Surface runoff generated from hillslope, [m/s] + real(r8), pointer :: qsub(:,:) ! Subsurface runoff generated from hillslope, [m/s] + real(r8), pointer :: qgwl(:,:) ! gwl runoff term from glacier, wetlands and lakes, [m/s] + !! fluxes + real(r8), pointer :: ehout(:,:) ! overland flow from hillslope into the sub-channel, [m/s] + real(r8), pointer :: asat(:,:) ! saturated area fraction from hillslope, [-] + real(r8), pointer :: esat(:,:) ! evaporation from saturated area fraction at hillslope, [m/s] + + ! subnetwork channel + !! states + real(r8), pointer :: tarea(:,:) ! area of channel water surface, [m2] + real(r8), pointer :: wt(:,:) ! storage of surface water, [m3] + real(r8), pointer :: dwt(:,:) ! change of water storage, [m3] + real(r8), pointer :: yt(:,:) ! water depth, [m] + real(r8), pointer :: mt(:,:) ! cross section area, [m2] + real(r8), pointer :: rt(:,:) ! hydraulic radii, [m] + real(r8), pointer :: pt(:,:) ! wetness perimeter, [m] + real(r8), pointer :: vt(:,:) ! flow velocity, [m/s] + real(r8), pointer :: tt(:,:) ! mean travel time of the water within the channel, [s] + !! fluxes + real(r8), pointer :: tevap(:,:) ! evaporation, [m/s] + real(r8), pointer :: etin(:,:) ! lateral inflow from hillslope, including surface and subsurface runoff generation components, [m3/s] + real(r8), pointer :: etout(:,:) ! discharge from sub-network into the main reach, [m3/s] + + ! main channel + !! states + real(r8), pointer :: rarea(:,:) ! area of channel water surface, [m2] + real(r8), pointer :: wr(:,:) ! storage of surface water, [m3] + real(r8), pointer :: dwr(:,:) ! change of water storage, [m3] + real(r8), pointer :: yr(:,:) ! water depth. [m] + real(r8), pointer :: mr(:,:) ! cross section area, [m2] + real(r8), pointer :: rr(:,:) ! hydraulic radius, [m] + real(r8), pointer :: pr(:,:) ! wetness perimeter, [m] + real(r8), pointer :: vr(:,:) ! flow velocity, [m/s] + real(r8), pointer :: tr(:,:) ! mean travel time of the water within the channel, [s] + !! exchange fluxes + real(r8), pointer :: erlg(:,:) ! evaporation, [m/s] + real(r8), pointer :: erlateral(:,:) ! lateral flow from hillslope, including surface and subsurface runoff generation components, [m3/s] + real(r8), pointer :: erin(:,:) ! inflow from upstream links, [m3/s] + real(r8), pointer :: erout(:,:) ! outflow into downstream links, [m3/s] + real(r8), pointer :: erout_prev(:,:) ! outflow into downstream links from previous timestep, [m3/s] + real(r8), pointer :: eroutUp(:,:) ! outflow sum of upstream gridcells, instantaneous (m3/s) + real(r8), pointer :: eroutUp_avg(:,:) ! outflow sum of upstream gridcells, average [m3/s] + real(r8), pointer :: erlat_avg(:,:) ! erlateral average [m3/s] + real(r8), pointer :: flow(:,:) ! streamflow from the outlet of the reach, [m3/s] + real(r8), pointer :: erin1(:,:) ! inflow from upstream links during previous step, used for Muskingum method, [m3/s] + real(r8), pointer :: erin2(:,:) ! inflow from upstream links during current step, used for Muskingum method, [m3/s] + real(r8), pointer :: ergwl(:,:) ! flux item for the adjustment of water balance residual in glacie, wetlands and lakes dynamics [m3/s] + + !! for Runge-Kutta algorithm + real(r8), pointer :: wrtemp(:,:) ! temporary storage item, for 4th order Runge-Kutta algorithm; + real(r8), pointer :: erintemp(:,:) + real(r8), pointer :: erouttemp(:,:) + real(r8), pointer :: k1(:,:) + real(r8), pointer :: k2(:,:) + real(r8), pointer :: k3(:,:) + real(r8), pointer :: k4(:,:) + contains + procedure, public :: Init + end type TstatusFlux_type + +contains + + subroutine Init(this, begr, endr, ntracers) + class(TstatusFlux_type) :: this + integer, intent(in) :: begr, endr, ntracers + + ! Initialize water states and fluxes + allocate (this%wh(begr:endr,ntracers)) + this%wh = 0._r8 + allocate (this%dwh(begr:endr,ntracers)) + this%dwh = 0._r8 + allocate (this%yh(begr:endr,ntracers)) + this%yh = 0._r8 + allocate (this%qsur(begr:endr,ntracers)) + this%qsur = 0._r8 + allocate (this%qsub(begr:endr,ntracers)) + this%qsub = 0._r8 + allocate (this%qgwl(begr:endr,ntracers)) + this%qgwl = 0._r8 + allocate (this%ehout(begr:endr,ntracers)) + this%ehout = 0._r8 + allocate (this%tarea(begr:endr,ntracers)) + this%tarea = 0._r8 + allocate (this%wt(begr:endr,ntracers)) + this%wt= 0._r8 + allocate (this%dwt(begr:endr,ntracers)) + this%dwt = 0._r8 + allocate (this%yt(begr:endr,ntracers)) + this%yt = 0._r8 + allocate (this%mt(begr:endr,ntracers)) + this%mt = 0._r8 + allocate (this%rt(begr:endr,ntracers)) + this%rt = 0._r8 + allocate (this%pt(begr:endr,ntracers)) + this%pt = 0._r8 + allocate (this%vt(begr:endr,ntracers)) + this%vt = 0._r8 + allocate (this%tt(begr:endr,ntracers)) + this%tt = 0._r8 + allocate (this%etin(begr:endr,ntracers)) + this%etin = 0._r8 + allocate (this%etout(begr:endr,ntracers)) + this%etout = 0._r8 + allocate (this%rarea(begr:endr,ntracers)) + this%rarea = 0._r8 + allocate (this%wr(begr:endr,ntracers)) + this%wr = 0._r8 + allocate (this%dwr(begr:endr,ntracers)) + this%dwr = 0._r8 + allocate (this%yr(begr:endr,ntracers)) + this%yr = 0._r8 + allocate (this%mr(begr:endr,ntracers)) + this%mr = 0._r8 + allocate (this%rr(begr:endr,ntracers)) + this%rr = 0._r8 + allocate (this%pr(begr:endr,ntracers)) + this%pr = 0._r8 + allocate (this%vr(begr:endr,ntracers)) + this%vr = 0._r8 + allocate (this%tr(begr:endr,ntracers)) + this%tr = 0._r8 + allocate (this%erlg(begr:endr,ntracers)) + this%erlg = 0._r8 + allocate (this%erlateral(begr:endr,ntracers)) + this%erlateral = 0._r8 + allocate (this%erin(begr:endr,ntracers)) + this%erin = 0._r8 + allocate (this%erout(begr:endr,ntracers)) + this%erout = 0._r8 + allocate (this%erout_prev(begr:endr,ntracers)) + this%erout_prev = 0._r8 + allocate (this%eroutUp(begr:endr,ntracers)) + this%eroutUp = 0._r8 + allocate (this%eroutUp_avg(begr:endr,ntracers)) + this%eroutUp_avg = 0._r8 + allocate (this%erlat_avg(begr:endr,ntracers)) + this%erlat_avg = 0._r8 + allocate (this%ergwl(begr:endr,ntracers)) + this%ergwl = 0._r8 + allocate (this%flow(begr:endr,ntracers)) + this%flow = 0._r8 + + end subroutine Init + +end module mosart_tstatusflux_type diff --git a/src/riverroute/mosart_vars.F90 b/src/riverroute/mosart_vars.F90 index 75dc480..5dd647d 100644 --- a/src/riverroute/mosart_vars.F90 +++ b/src/riverroute/mosart_vars.F90 @@ -1,134 +1,59 @@ -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 : mainproc - use ESMF - - implicit none - - !TODO - nt_rtm and rtm_tracers need to be removed and set by access to the index array - integer, parameter, public :: nt_rtm = 2 ! number of tracers - character(len=3), parameter, public :: rtm_tracers(nt_rtm) = (/'LIQ','ICE'/) - - ! Constants - integer, parameter, private :: iundef = -9999999 - integer, parameter, private :: rundef = -9999999._r8 - - real(r8), public, parameter :: secspday = SHR_CONST_CDAY ! Seconds per day - integer, public, parameter :: isecspday= secspday ! Integer seconds per day - real(r8), public, parameter :: spval = 1.e36_r8 ! special value for real data - integer , public, parameter :: ispval = -9999 ! special value for int data - real(r8) :: re = SHR_CONST_REARTH*0.001_r8 ! radius of earth (km) - logical , public :: barrier_timers = .false. ! barrier timers - - ! Run control variables - character(len=CL), public :: caseid = ' ' ! case id - character(len=CL), public :: ctitle = ' ' ! case title - integer, public, parameter :: nsrStartup = 0 ! Startup from initial conditions - integer, public, parameter :: nsrContinue = 1 ! Continue from restart files - integer, public, parameter :: nsrBranch = 2 ! Branch from restart files - integer, public :: nsrest = iundef ! Type of run - logical, public :: brnch_retain_casename = .false. ! true => allow case name to remain the same for branch run - ! by default this is not allowed - logical, public :: noland = .false. ! true => no valid land points -- do NOT run - character(len=32), public :: decomp_option ! decomp option - character(len=32), public :: bypass_routing_option ! bypass routing model method - character(len=32), public :: qgwl_runoff_option ! method for handling qgwl runoff - character(len=CL), public :: hostname = ' ' ! Hostname of machine running on - character(len=CL), public :: username = ' ' ! username of user running program - character(len=CL), public :: version = " " ! version of program - character(len=CL), public :: conventions = "CF-1.0" ! dataset conventions - character(len=CL), public :: source = "Model for Scale Adaptive River Transport MOSART1.0" ! description of this source - character(len=CL), public :: model_doi_url ! Web address of the Digital Object Identifier (DOI) for this model version - - ! Unit Numbers - integer, public :: iulog = 6 ! "stdout" log file unit number, default is 6 - - ! Instance control - integer, public :: inst_index - character(len=16), public :: inst_name - character(len=16), public :: inst_suffix - - ! Rtm control variables - character(len=CL), public :: nrevsn_rtm = ' ' ! restart data file name for branch run - character(len=CL), public :: finidat_rtm = ' ' ! initial conditions file name - character(len=CL), public :: frivinp_rtm = ' ' ! MOSART input data file name - logical, public :: ice_runoff = .true. ! true => runoff is split into liquid and ice, otherwise just liquid - - ! Rtm grid size - integer :: rtmlon = 1 ! number of mosart longitudes (initialize) - integer :: rtmlat = 1 ! number of mosart latitudes (initialize) - - character(len=CL), public :: rpntfil = 'rpointer.rof' ! file name for local restart pointer file - - logical, private :: RtmVar_isset = .false. - - 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 -!================================================================================ - - subroutine RtmVarSet( caseid_in, ctitle_in, brnch_retain_casename_in, & - nsrest_in, version_in, hostname_in, username_in, & - model_doi_url_in ) - - !----------------------------------------------------------------------- - ! Set input control variables. - ! - ! !ARGUMENTS: - character(len=CL), optional, intent(IN) :: caseid_in ! case id - character(len=CL), optional, intent(IN) :: ctitle_in ! case title - integer , optional, intent(IN) :: nsrest_in ! 0: initial run. 1: restart: 3: branch - character(len=CL), optional, intent(IN) :: version_in ! model version - character(len=CL), optional, intent(IN) :: hostname_in ! hostname running on - character(len=CL), optional, intent(IN) :: username_in ! username running job - character(len=CL), optional, intent(IN) :: model_doi_url_in ! web address of Digital Object Identifier (DOI) for model version - logical , optional, intent(IN) :: brnch_retain_casename_in ! true => allow case name to - !----------------------------------------------------------------------- - - if ( RtmVar_isset )then - call shr_sys_abort( 'RtmVarSet ERROR:: control variables already set -- EXIT' ) - end if - - if (present(caseid_in)) caseid = caseid_in - if (present(ctitle_in)) ctitle = ctitle_in - if (present(nsrest_in)) nsrest = nsrest_in - if (present(version_in)) version = version_in - if (present(username_in)) username = username_in - if (present(hostname_in)) hostname = hostname_in - if (present(model_doi_url_in)) model_doi_url = model_doi_url_in - if (present(brnch_retain_casename_in)) brnch_retain_casename = brnch_retain_casename_in - - end subroutine RtmVarSet - -!================================================================================ - - subroutine RtmVarInit( ) - if (mainproc) then - if (nsrest == iundef) then - call shr_sys_abort( 'RtmVarInit ERROR:: must set nsrest' ) - end if - if (nsrest == nsrBranch .and. nrevsn_rtm == ' ') then - call shr_sys_abort( 'RtmVarInit ERROR: need to set restart data file name' ) - end if - if (nsrest == nsrStartup ) then - nrevsn_rtm = ' ' - end if - if (nsrest == nsrContinue) then - nrevsn_rtm = 'set by restart pointer file file' - end if - if (nsrest /= nsrStartup .and. nsrest /= nsrContinue .and. nsrest /= nsrBranch ) then - call shr_sys_abort( 'RtmVarInit ERROR: nsrest NOT set to a valid value' ) - end if - endif - RtmVar_isset = .true. - end subroutine RtmVarInit - -end module RtmVar +module mosart_vars + + 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 ESMF + + implicit none + public + + ! MPI + logical :: mainproc ! proc 0 logical for printing msgs + integer :: iam ! processor number + integer :: npes ! number of processors for mosart + integer :: mpicom_rof ! communicator group for mosart + logical :: barrier_timers = .false. ! barrier timers + + ! Constants + integer , parameter :: iundef = -9999999 + integer , parameter :: rundef = -9999999._r8 + real(r8) , parameter :: secspday = SHR_CONST_CDAY ! Seconds per day + integer , parameter :: isecspday = secspday ! Integer seconds per day + real(r8) , parameter :: spval = 1.e36_r8 ! special value for real data + integer , parameter :: ispval = -9999 ! special value for int data + + real(r8) :: re = SHR_CONST_REARTH*0.001_r8 ! radius of earth (km) + + ! Run startup + integer , parameter :: nsrStartup = 0 ! Startup from initial conditions + integer , parameter :: nsrContinue = 1 ! Continue from restart files + integer , parameter :: nsrBranch = 2 ! Branch from restart files + integer :: nsrest = iundef ! Type of run + + ! Namelist variables + character(len=CL) :: frivinp ! MOSART input data file name + logical :: ice_runoff ! true => runoff is split into liquid and ice, otherwise just liquid + character(len=32) :: decomp_option ! decomp option + character(len=32) :: bypass_routing_option ! bypass routing model method + character(len=32) :: qgwl_runoff_option ! method for handling qgwl runoff + + ! Metadata variables used in history and restart generation + character(len=CL) :: caseid = ' ' ! case id + character(len=CL) :: ctitle = ' ' ! case title + character(len=CL) :: hostname = ' ' ! Hostname of machine running on + character(len=CL) :: username = ' ' ! username of user running program + character(len=CL) :: version = " " ! version of program + character(len=CL) :: conventions = "CF-1.0" ! dataset conventions + character(len=CL) :: model_doi_url ! Web address of the Digital Object Identifier (DOI) for this model version + character(len=CL) :: source = "Model for Scale Adaptive River Transport MOSART1.0" ! description of this source + + ! Stdout + integer :: iulog = 6 ! "stdout" log file unit number, default is 6 + + ! Instance control + integer :: inst_index + character(len=16) :: inst_name + character(len=16) :: inst_suffix + +end module mosart_vars From 291d2c56ed2aed4340dc1b8a74c4cbc88d1a21fe Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 1 Jan 2024 20:46:43 +0100 Subject: [PATCH 18/86] addressed most changes requested in PR --- cime_config/namelist_definition_mosart.xml | 2 +- src/cpl/nuopc/rof_comp_nuopc.F90 | 65 +++-- src/riverroute/mosart_control_type.F90 | 3 +- src/riverroute/mosart_mod.F90 | 29 +- src/riverroute/mosart_restfile.F90 | 50 ++-- src/riverroute/mosart_timemanager.F90 | 294 ++++++++------------ src/riverroute/mosart_tspatialunit_type.F90 | 8 +- src/riverroute/mosart_vars.F90 | 13 +- 8 files changed, 212 insertions(+), 252 deletions(-) diff --git a/cime_config/namelist_definition_mosart.xml b/cime_config/namelist_definition_mosart.xml index eca45b8..dea084e 100644 --- a/cime_config/namelist_definition_mosart.xml +++ b/cime_config/namelist_definition_mosart.xml @@ -69,7 +69,7 @@ If true, add capability to have halo option for mosart fields. - In particarul these can be used to create derivatives using halo values + In particular these can be used to create derivatives using halo values from neighboring cells. diff --git a/src/cpl/nuopc/rof_comp_nuopc.F90 b/src/cpl/nuopc/rof_comp_nuopc.F90 index 1be1b4c..9cf190e 100644 --- a/src/cpl/nuopc/rof_comp_nuopc.F90 +++ b/src/cpl/nuopc/rof_comp_nuopc.F90 @@ -4,33 +4,44 @@ module rof_comp_nuopc ! This is the NUOPC cap for MOSART !---------------------------------------------------------------------------- - use ESMF + use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_GridCompSetEntryPoint, ESMF_State, & + ESMF_Clock, ESMF_ClockGet, ESMF_ClockSet, ESMF_ClockAdvance, & + ESMF_ClockGetAlarm, ESMF_ClockGetNextTime, ESMF_ClockGet, ESMF_ClockGetAlarm, & + ESMF_ClockGetAlarmList, ESMF_Alarm, ESMF_AlarmSet, ESMF_AlarmIsRinging, & + ESMF_AlarmRingerOff, ESMF_Time, ESMF_TimeGet, ESMF_TimeInterval, & + ESMF_CalKind_Flag, ESMF_CALKIND_NOLEAP, ESMF_CALKIND_GREGORIAN, & + ESMF_Mesh, ESMF_MeshCreate, ESMF_FILEFORMAT_ESMFMESH, & + ESMF_DistGrid, ESMF_DistGridCreate, & + ESMF_MethodRemove,ESMF_VM, ESMF_VMGet, ESMF_LogFoundError, & + ESMF_SUCCESS, ESMF_LogWrite, ESMF_FAILURE, ESMF_LogFoundError, & + ESMF_LOGERR_PASSTHRU, ESMF_LOGMSG_ERROR, ESMF_LOGMSG_INFO, & + ESMF_METHOD_INITIALIZE, ESMF_ALARMLIST_ALL, & + operator(==), operator(/=), operator(<), operator(<=), & + operator(>), operator(>=), operator(-), operator(+) use NUOPC , only : NUOPC_CompDerive, NUOPC_CompSetEntryPoint, NUOPC_CompSpecialize use NUOPC , only : NUOPC_CompFilterPhaseMap, NUOPC_CompAttributeGet, NUOPC_CompAttributeSet - use NUOPC_Model , only : model_routine_SS => SetServices - use NUOPC_Model , only : SetVM - use NUOPC_Model , only : model_label_Advance => label_Advance - use NUOPC_Model , only : model_label_DataInitialize => label_DataInitialize - use NUOPC_Model , only : model_label_SetRunClock => label_SetRunClock - use NUOPC_Model , only : model_label_Finalize => label_Finalize - use NUOPC_Model , only : NUOPC_ModelGet - use shr_kind_mod , only : R8=>SHR_KIND_R8, CL=>SHR_KIND_CL + use NUOPC_Model , only : model_routine_SS => SetServices, & + model_label_Advance => label_Advance, & + model_label_DataInitialize => label_DataInitialize, & + model_label_SetRunClock => label_SetRunClock, & + model_label_Finalize => label_Finalize, & + SetVM, NUOPC_ModelGet + use shr_kind_mod , only : R8=>SHR_KIND_R8, CL=>SHR_KIND_CL, CS=>SHR_KIND_CS use shr_sys_mod , only : shr_sys_abort - use shr_file_mod , only : shr_file_getlogunit, shr_file_setlogunit + use shr_log_mod , only : shr_log_getlogunit, shr_log_setlogunit use shr_cal_mod , only : shr_cal_noleap, shr_cal_gregorian, shr_cal_ymd2date - use mosart_vars , only : nsrStartup, nsrContinue, nsrBranch - use mosart_vars , only : inst_index, inst_suffix, inst_name - use mosart_vars , only : mainproc, mpicom_rof, iam, npes, iulog - use mosart_vars , only : nsrest, caseid, ctitle, version, hostname, username + use mosart_vars , only : nsrStartup, nsrContinue, nsrBranch, & + inst_index, inst_suffix, inst_name, & + mainproc, mpicom_rof, iam, npes, iulog, & + nsrest, caseid, ctitle, version, hostname, username use mosart_data , only : ctl use mosart_mod , only : mosart_read_namelist, mosart_init1, mosart_init2, mosart_run use mosart_timemanager , only : timemgr_setup, get_curr_date, get_step_size, advance_timestep use mosart_io , only : ncd_pio_init use mosart_restfile , only : brnch_retain_casename - use rof_import_export , only : 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 rof_import_export , only : import_fields, export_fields, advertise_fields, realize_fields + use nuopc_shr_methods , only : chkerr, state_setscalar, state_getscalar, state_diagnose, alarmInit, & + set_component_logging, get_component_instance, log_clock_advance use perf_mod , only : t_startf, t_stopf, t_barrierf implicit none @@ -200,6 +211,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call set_component_logging(gcomp, mainproc, iulog, shrlogunit, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + call shr_log_setLogUnit (iulog) !---------------------------------------------------------------------------- ! advertise fields @@ -379,7 +391,6 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! Reset shr logging to original values !---------------------------------------------------------------------------- - call shr_file_setLogUnit (shrlogunit) call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO) end subroutine InitializeAdvertise @@ -414,13 +425,12 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) + call shr_log_setLogUnit (iulog) + !---------------------------------------------------------------------------- ! Reset shr logging to my log file !---------------------------------------------------------------------------- - call shr_file_getLogUnit (shrlogunit) - call shr_file_setLogUnit (iulog) - call ESMF_GridCompGet(gcomp, vm=vm, localPet=localPet, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call ESMF_VMGet(vm, pet=localPet, peCount=localPeCount, rc=rc) @@ -542,7 +552,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ! Reset shr logging !---------------------------------------------------------------------------- - call shr_file_setLogUnit (shrlogunit) + call shr_log_setLogUnit (shrlogunit) call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO) !-------------------------------- @@ -596,16 +606,15 @@ subroutine ModelAdvance(gcomp, rc) logical :: nlend ! .true. ==> signaling last time-step integer :: lbnum ! input to memory diagnostic integer :: g,i ! indices - character(len=32) :: rdate ! date char string for restart file names + character(len=CS) :: rdate ! date char string for restart file names character(len=*),parameter :: subname=trim(modName)//':(ModelAdvance) ' !------------------------------------------------------- rc = ESMF_SUCCESS call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) - call shr_file_getLogUnit (shrlogunit) - call shr_file_setLogUnit (iulog) -!$ call omp_set_num_threads(nthrds) + call shr_log_getLogUnit (shrlogunit) + call shr_log_setLogUnit (iulog) #if (defined _MEMTRACE) if(mainproc) then @@ -729,7 +738,7 @@ subroutine ModelAdvance(gcomp, rc) ! Reset shr logging to my original values !-------------------------------- - call shr_file_setLogUnit (shrlogunit) + call shr_log_setLogUnit (shrlogunit) #if (defined _MEMTRACE) if(mainproc) then diff --git a/src/riverroute/mosart_control_type.F90 b/src/riverroute/mosart_control_type.F90 index 4b037be..2d81391 100644 --- a/src/riverroute/mosart_control_type.F90 +++ b/src/riverroute/mosart_control_type.F90 @@ -7,8 +7,9 @@ module mosart_control_type use mosart_io, only : ncd_io, ncd_pio_openfile, ncd_pio_closefile use mosart_vars, only : mainproc, iam, npes, mpicom_rof, iulog, spval, re use pio, only : file_desc_t, PIO_BCAST_ERROR, pio_seterrorhandling + use ESMF, only : ESMF_DistGrid, ESMF_Array, ESMF_RouteHandle, ESMF_SUCCESS, & + ESMF_DistGridCreate, ESMF_ArrayCreate, ESMF_ArrayHaloStore, ESMF_ArrayHalo use perf_mod, only : t_startf, t_stopf - use ESMF use nuopc_shr_methods , only : chkerr implicit none diff --git a/src/riverroute/mosart_mod.F90 b/src/riverroute/mosart_mod.F90 index 9d3c104..0a45cb4 100644 --- a/src/riverroute/mosart_mod.F90 +++ b/src/riverroute/mosart_mod.F90 @@ -4,7 +4,7 @@ module mosart_mod ! Mosart Routing Model ! ! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_kind_mod , only : r8 => shr_kind_r8, CS => shr_kind_cs, CL => shr_kind_CL use shr_sys_mod , only : shr_sys_abort use shr_mpi_mod , only : shr_mpi_sum, shr_mpi_max use shr_const_mod , only : SHR_CONST_PI, SHR_CONST_CDAY @@ -27,9 +27,10 @@ module mosart_mod use nuopc_shr_methods , only : chkerr use ESMF , only : ESMF_SUCCESS, ESMF_FieldGet, ESMF_FieldSMMStore, ESMF_FieldSMM, & ESMF_TERMORDER_SRCSEQ, ESMF_Mesh - use mosart_IO ! TODO: put in only here - use pio - use mpi + use mosart_io , only : ncd_pio_openfile, ncd_inqdid, ncd_inqdlen, ncd_pio_closefile, ncd_decomp_init, & + pio_subsystem + use pio , only : file_desc_t + use mpi , only : mpi_bcast, mpi_barrier, MPI_CHARACTER, MPI_LOGICAL, MPI_INTEGER ! ! !PUBLIC TYPES: implicit none @@ -57,8 +58,8 @@ module mosart_mod real(r8), allocatable :: budget_accum(:) ! BUDGET accumulator over run integer :: budget_accum_cnt ! counter for budget_accum - character(len=256) :: nlfilename_rof = 'mosart_in' - character(len=256) :: fnamer ! name of netcdf restart file + character(len=CL) :: nlfilename_rof = 'mosart_in' + character(len=CL) :: fnamer ! name of netcdf restart file character(*), parameter :: u_FILE_u = & __FILE__ @@ -76,7 +77,7 @@ subroutine mosart_read_namelist() integer :: ier ! error code integer :: unitn ! unit for namelist file logical :: lexist ! File exists - character(len= 7) :: runtyp(4) ! run type + character(len=CS) :: runtyp(4) ! run type character(len=*),parameter :: subname = '(mosart_read_namelist) ' !----------------------------------------------------------------------- @@ -134,9 +135,9 @@ subroutine mosart_read_namelist() call mpi_bcast (bypass_routing_option, len(bypass_routing_option), MPI_CHARACTER, 0, mpicom_rof, ier) call mpi_bcast (qgwl_runoff_option, len(qgwl_runoff_option), MPI_CHARACTER, 0, mpicom_rof, ier) call mpi_bcast (ice_runoff, 1, MPI_LOGICAL, 0, mpicom_rof, ier) - call mpi_bcast (nhtfrq, size(nhtfrq), MPI_INTEGER, 0, mpicom_rof, ier) - call mpi_bcast (mfilt, size(mfilt), MPI_INTEGER, 0, mpicom_rof, ier) - call mpi_bcast (ndens, size(ndens), MPI_INTEGER, 0, mpicom_rof, ier) + call mpi_bcast (nhtfrq, size(nhtfrq), MPI_INTEGER, 0, mpicom_rof, ier) + call mpi_bcast (mfilt, size(mfilt), MPI_INTEGER, 0, mpicom_rof, ier) + call mpi_bcast (ndens, size(ndens), MPI_INTEGER, 0, mpicom_rof, ier) call mpi_bcast (fexcl1, (max_namlen+2)*size(fexcl1), MPI_CHARACTER, 0, mpicom_rof, ier) call mpi_bcast (fexcl2, (max_namlen+2)*size(fexcl2), MPI_CHARACTER, 0, mpicom_rof, ier) call mpi_bcast (fexcl3, (max_namlen+2)*size(fexcl3), MPI_CHARACTER, 0, mpicom_rof, ier) @@ -152,7 +153,7 @@ subroutine mosart_read_namelist() if (mainproc) then write(iulog,*) 'define run:' - write(iulog,*) ' run type = ',runtyp(nsrest+1) + write(iulog,*) ' run type = ',trim(runtyp(nsrest+1)) write(iulog,*) ' coupling_period = ',coupling_period write(iulog,*) ' delt_mosart = ',delt_mosart write(iulog,*) ' decomp option = ',trim(decomp_option) @@ -217,8 +218,8 @@ subroutine mosart_init1(rc) ! Local variables integer :: n, nr, nt ! indices type(file_desc_t) :: ncid ! netcdf file id - character(len=256) :: trstr ! tracer string - character(len=256) :: locfn ! local file + character(len=CL) :: trstr ! tracer string + character(len=CL) :: locfn ! local file integer :: dimid ! netcdf dimension identifier character(len=*), parameter :: subname = '(mosart_init1) ' !------------------------------------------------- @@ -389,7 +390,7 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) integer :: nsub ! subcyling for cfl real(r8) :: delt ! delt associated with subcycling real(r8) :: delt_coupling ! real value of coupling_period - character(len=256) :: filer ! restart file name + character(len=CL) :: filer ! restart file name integer :: cnt ! counter for gridcells integer :: ier ! error code real(r8), pointer :: src_direct(:,:) diff --git a/src/riverroute/mosart_restfile.F90 b/src/riverroute/mosart_restfile.F90 index 4f8111f..b208f5d 100644 --- a/src/riverroute/mosart_restfile.F90 +++ b/src/riverroute/mosart_restfile.F90 @@ -2,7 +2,7 @@ module mosart_restfile ! Read from and write to the MOSART restart file. - use shr_kind_mod, only : r8 => shr_kind_r8, CL => shr_kind_cl + use shr_kind_mod, only : r8 => shr_kind_r8, CL => shr_kind_cl, CS => shr_kind_cs use shr_sys_mod, only : shr_sys_abort use mosart_vars, only : iulog, inst_suffix, caseid, nsrest, & spval, mainproc, nsrContinue, nsrBranch, nsrStartup, & @@ -11,7 +11,9 @@ module mosart_restfile use mosart_histfile, only : mosart_hist_restart use mosart_fileutils, only : getfil use mosart_timemanager, only : timemgr_restart, get_nstep, get_curr_date - use mosart_io + use mosart_io, only : ncd_pio_createfile, ncd_enddef, ncd_pio_openfile, ncd_pio_closefile, & + ncd_defdim, ncd_putatt, ncd_defvar, ncd_io, ncd_global, ncd_double + use pio, only : file_desc_t implicit none private @@ -173,8 +175,8 @@ subroutine mosart_rest_Getfile( file ) ! Local variables: integer :: status ! return status integer :: length ! temporary - character(len=256) :: ftest,ctest ! temporaries - character(len=256) :: path ! full pathname of netcdf restart file + character(len=CL) :: ftest,ctest ! temporaries + character(len=CL) :: path ! full pathname of netcdf restart file !------------------------------------- ! Continue run: @@ -228,10 +230,10 @@ subroutine restFile_read_pfile( pnamer ) 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 + integer :: nio ! restart unit + integer :: ier ! error return from fortran open + integer :: i ! index + character(len=CL) :: locfn ! Restart pointer file name !------------------------------------- ! Obtain the restart file from the restart pointer file. @@ -271,7 +273,7 @@ subroutine restFile_write_pfile( fnamer ) ! Local variables integer :: nio ! restart pointer file unit number integer :: ier ! error return from fortran open - character(len=256) :: filename ! local file name + character(len=CL) :: filename ! local file name !------------------------------------- if (mainproc) then @@ -290,7 +292,7 @@ end subroutine restFile_write_pfile !----------------------------------------------------------------------- - character(len=256) function mosart_rest_FileName( rdate ) + character(len=CL) function mosart_rest_FileName( rdate ) ! Arguments character(len=*), intent(in) :: rdate ! input date for restart file name @@ -313,11 +315,11 @@ subroutine restFile_dimset( ncid ) 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 + integer :: dimid ! netCDF dimension id + integer :: ier ! error status + character(len=CS) :: curdate ! current date + character(len=CS) :: curtime ! current time + character(len=CL) :: str character(len=*),parameter :: subname='restFile_dimset' !------------------------------------- @@ -325,7 +327,7 @@ subroutine restFile_dimset( ncid ) call ncd_defdim(ncid, 'nlon' , ctl%nlon , dimid) call ncd_defdim(ncid, 'nlat' , ctl%nlat , dimid) - call ncd_defdim(ncid, 'string_length', 64 , dimid) + call ncd_defdim(ncid, 'string_length', CS , dimid) ! Define global attributes @@ -352,18 +354,20 @@ subroutine mosart_rest_restart(ncid, flag) ! Read/write MOSART restart data. ! ! Arguments: - type(file_desc_t), intent(inout) :: ncid ! netcdf id - character(len=*) , intent(in) :: flag ! 'read' or 'write' + 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 + logical :: readvar ! determine if variable is on initial file + integer :: n,nt,nv ! indices + integer :: nvariables real(r8) , pointer :: dfld(:) ! temporary array - character(len=32) :: vname,uname - character(len=255) :: lname + character(len=CS) :: vname,uname + character(len=CL) :: lname !------------------------------------- - do nv = 1,7 + nvariables = 7 + do nv = 1,nvariables do nt = 1,ctl%ntracers if (nv == 1) then diff --git a/src/riverroute/mosart_timemanager.F90 b/src/riverroute/mosart_timemanager.F90 index 3ba642b..1d35ae7 100644 --- a/src/riverroute/mosart_timemanager.F90 +++ b/src/riverroute/mosart_timemanager.F90 @@ -1,11 +1,18 @@ module mosart_timemanager - use shr_kind_mod, only: r8 => shr_kind_r8 - use shr_sys_mod , only: shr_sys_abort - use mosart_vars , only: isecspday, iulog, nsrest, nsrContinue, mpicom_rof, mainproc - use mosart_io - use ESMF - use mpi + use shr_kind_mod , only: r8 => shr_kind_r8, CS => shr_kind_CS + use shr_sys_mod , only: shr_sys_abort + use shr_string_mod , only: shr_string_toUpper + use mosart_vars , only: isecspday, iulog, nsrest, nsrContinue, mpicom_rof, mainproc + use ESMF , only: ESMF_MAXSTR, ESMF_Calendar, ESMF_Clock, ESMF_Time, ESMF_TimeInterval, & + ESMF_TimeIntervalSet, ESMF_TimeIntervalGet, ESMF_TimeSet, ESMF_TimeGet, & + ESMF_ClockCreate, ESMF_ClockGet, ESMF_ClockAdvance, & + ESMF_CalKind_Flag, ESMF_CalendarCreate, & + ESMF_CALKIND_NOLEAP, ESMF_CALKIND_GREGORIAN, ESMF_SUCCESS, ESMF_KIND_I8, & + operator(==), operator(/=), operator(<), operator(<=), & + operator(>), operator(>=), operator(-) + use mosart_io , only: ncd_defvar, ncd_io, ncd_int + use pio , only: file_desc_t implicit none private @@ -50,8 +57,6 @@ module mosart_timemanager integer :: ref_tod = 0 ! reference time of day for time coordinate in seconds ! Data required to restart time manager: - integer :: rst_nstep = uninit_int ! current step number - integer :: rst_step_days = uninit_int ! days component of timestep size integer :: rst_step_sec = uninit_int ! timestep size seconds integer :: rst_start_ymd = uninit_int ! start date integer :: rst_start_tod = uninit_int ! start time of day @@ -147,7 +152,6 @@ subroutine timemgr_init( dtime_in ) 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 @@ -196,29 +200,28 @@ subroutine init_clock( start_date, ref_date, curr_date, stop_date ) ! Initialize the clock based on the start_date, ref_date, and curr_date ! as well as the settings from the namelist specifying the time to stop - ! + + ! Arguments type(ESMF_Time), intent(in) :: start_date ! start date for run type(ESMF_Time), intent(in) :: ref_date ! reference date for time coordinate type(ESMF_Time), intent(in) :: curr_date ! current date (equal to start_date) type(ESMF_Time), intent(in) :: stop_date ! stop date for run - ! - character(len=*), parameter :: sub = 'init_clock' + + ! Local variables type(ESMF_TimeInterval) :: step_size ! timestep size type(ESMF_Time) :: current ! current date (from clock) integer :: yr, mon, day, tod ! Year, month, day, and second as integers integer :: rc ! return code - ! - call ESMF_TimeIntervalSet( step_size, s=dtime, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting step_size') + character(len=*), parameter :: sub = 'init_clock' ! Initialize the clock - + call ESMF_TimeIntervalSet( step_size, s=dtime, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting step_size') tm_clock = ESMF_ClockCreate(name="MOSART Time-manager clock", timeStep=step_size, startTime=start_date, & stopTime=stop_date, refTime=ref_date, rc=rc) call chkrc(rc, sub//': error return from ESMF_ClockSetup') ! Advance clock to the current time (in case of a restart) - call ESMF_ClockGet(tm_clock, currTime=current, rc=rc ) call chkrc(rc, sub//': error return from ESMF_ClockGet') do while( curr_date > current ) @@ -233,19 +236,21 @@ end subroutine init_clock function TimeSetymd( ymd, tod, desc ) - ! Set the time by an integer as YYYYMMDD and integer seconds in the day - ! - integer, intent(in) :: ymd ! Year, month, day YYYYMMDD - integer, intent(in) :: tod ! Time of day in seconds - character(len=*), intent(in) :: desc ! Description of time to set - ! - type(ESMF_Time) :: TimeSetymd ! Return value - ! - character(len=*), parameter :: sub = 'TimeSetymd' + + ! Arguments + integer , intent(in) :: ymd ! Year, month, day YYYYMMDD + integer , intent(in) :: tod ! Time of day in seconds + character(len=*) , intent(in) :: desc ! Description of time to set + + ! Return value + type(ESMF_Time) :: TimeSetymd ! Return value + + ! Local variables integer :: yr, mon, day ! Year, month, day as integers integer :: rc ! return code - ! + character(len=*), parameter :: sub = 'TimeSetymd' + if ( (ymd < 0) .or. (tod < 0) .or. (tod > isecspday) )then write(iulog,*) sub//': error yymmdd is a negative number or time-of-day out of bounds', & ymd, tod @@ -254,8 +259,7 @@ function TimeSetymd( ymd, tod, desc ) yr = ymd / 10000 mon = (ymd - yr*10000) / 100 day = ymd - yr*10000 - mon*100 - call ESMF_TimeSet( TimeSetymd, yy=yr, mm=mon, dd=day, s=tod, & - calendar=tm_cal, rc=rc) + call ESMF_TimeSet( TimeSetymd, yy=yr, mm=mon, dd=day, s=tod, calendar=tm_cal, rc=rc) call chkrc(rc, sub//': error return from ESMF_TimeSet: setting '//trim(desc)) end function TimeSetymd @@ -268,9 +272,9 @@ integer function TimeGetymd( date, tod ) type(ESMF_Time), intent(inout) :: date ! Input date to convert to ymd integer, intent(out), optional :: tod ! Time of day in seconds ! - character(len=*), parameter :: sub = 'TimeGetymd' integer :: yr, mon, day integer :: rc ! return code + character(len=*), parameter :: sub = 'TimeGetymd' ! call ESMF_TimeGet( date, yy=yr, mm=mon, dd=day, rc=rc) call chkrc(rc, sub//': error return from ESMF_TimeGet') @@ -292,7 +296,7 @@ subroutine timemgr_restart(ncid, flag) ! Read/Write information needed on restart to a netcdf file. ! type(file_desc_t), intent(inout) :: ncid ! netcdf id - character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: flag ! 'read' or 'write' ! integer :: yr, mon, day, tod ! Year, month, day, and second as integers logical :: readvar ! determine if variable is on initial file @@ -306,7 +310,7 @@ subroutine timemgr_restart(ncid, flag) type(ESMF_TimeInterval) :: step_size ! timestep size integer, parameter :: noleap = 1 integer, parameter :: gregorian = 2 - character(len=135) :: varname + character(len=CS) :: varname character(len=len(calendar)) :: cal integer :: rc ! return code character(len=*), parameter :: sub = 'timemgr_restart' @@ -323,7 +327,7 @@ subroutine timemgr_restart(ncid, flag) flag_values=(/ noleap, gregorian /), ifill_value=uninit_int ) else if (flag == 'read' .or. flag == 'write') then if (flag== 'write') then - cal = to_upper(calendar) + cal = shr_string_toUpper(calendar) if ( trim(cal) == NO_LEAP_C ) then rst_caltype = noleap else if ( trim(cal) == GREGORIAN_C ) then @@ -540,13 +544,13 @@ subroutine init_calendar( ) ! Initialize calendar ! ! Local variables - type(ESMF_CalKind_Flag) :: cal_type ! calendar type + type(ESMF_CalKind_Flag) :: cal_type ! calendar type character(len=len(calendar)) :: caltmp - integer :: rc ! return code - character(len=*), parameter :: sub = 'init_calendar' + integer :: rc ! return code + character(len=*), parameter :: sub = 'init_calendar' !--------------------------------------------------------------------------------- - caltmp = to_upper(calendar) + caltmp = shr_string_toUpper(calendar) if ( trim(caltmp) == NO_LEAP_C ) then cal_type = ESMF_CALKIND_NOLEAP else if ( trim(caltmp) == GREGORIAN_C ) then @@ -565,72 +569,58 @@ end subroutine init_calendar subroutine timemgr_print() !--------------------------------------------------------------------------------- + integer :: rc + integer :: yr, mon, day + integer :: nstep = uninit_int ! current step number + integer :: step_sec = uninit_int ! timestep size seconds + integer :: start_yr = uninit_int ! start year + integer :: start_mon = uninit_int ! start month + integer :: start_day = uninit_int ! start day of month + integer :: start_tod = uninit_int ! start time of day + integer :: stop_yr = uninit_int ! stop year + integer :: stop_mon = uninit_int ! stop month + integer :: stop_day = uninit_int ! stop day of month + integer :: stop_tod = uninit_int ! stop time of day + integer :: ref_yr = uninit_int ! reference year + integer :: ref_mon = uninit_int ! reference month + integer :: ref_day = uninit_int ! reference day of month + integer :: ref_tod = uninit_int ! reference time of day + integer :: curr_yr = uninit_int ! current year + integer :: curr_mon = uninit_int ! current month + integer :: curr_day = uninit_int ! current day of month + integer :: curr_tod = uninit_int ! current time of day + type(ESMF_Time) :: start_date ! start date for run + type(ESMF_Time) :: stop_date ! stop date for run + type(ESMF_Time) :: curr_date ! date of data in restart file + type(ESMF_Time) :: ref_date ! reference date + type(ESMF_TimeInterval) :: step ! Time-step + integer(ESMF_KIND_I8) :: step_no character(len=*), parameter :: sub = 'timemgr_print' - integer :: rc - integer :: yr, mon, day - integer :: & ! Data required to restart time manager: - nstep = uninit_int, &! current step number - step_sec = uninit_int, &! timestep size seconds - start_yr = uninit_int, &! start year - start_mon = uninit_int, &! start month - start_day = uninit_int, &! start day of month - start_tod = uninit_int, &! start time of day - stop_yr = uninit_int, &! stop year - stop_mon = uninit_int, &! stop month - stop_day = uninit_int, &! stop day of month - stop_tod = uninit_int, &! stop time of day - ref_yr = uninit_int, &! reference year - ref_mon = uninit_int, &! reference month - ref_day = uninit_int, &! reference day of month - ref_tod = uninit_int, &! reference time of day - curr_yr = uninit_int, &! current year - curr_mon = uninit_int, &! current month - curr_day = uninit_int, &! current day of month - curr_tod = uninit_int ! current time of day - integer(ESMF_KIND_I8) :: step_no - type(ESMF_Time) :: start_date! start date for run - type(ESMF_Time) :: stop_date ! stop date for run - type(ESMF_Time) :: curr_date ! date of data in restart file - type(ESMF_Time) :: ref_date ! reference date - type(ESMF_TimeInterval) :: step ! Time-step !--------------------------------------------------------------------------------- call ESMF_ClockGet( tm_clock, startTime=start_date, currTime=curr_date, & - refTime=ref_date, stopTime=stop_date, timeStep=step, & - advanceCount=step_no, rc=rc ) + refTime=ref_date, stopTime=stop_date, timeStep=step, advanceCount=step_no, rc=rc ) call chkrc(rc, sub//': error return from ESMF_ClockGet') nstep = step_no - - write(iulog,*)' ******** Time Manager Configuration ********' - call ESMF_TimeIntervalGet( step, s=step_sec, rc=rc ) call chkrc(rc, sub//': error return from ESMF_TimeIntervalGet') - - call ESMF_TimeGet( start_date, yy=start_yr, mm=start_mon, dd=start_day, & - s=start_tod, rc=rc ) + call ESMF_TimeGet( start_date, yy=start_yr, mm=start_mon, dd=start_day, s=start_tod, rc=rc ) call chkrc(rc, sub//': error return from ESMF_TimeGet') - call ESMF_TimeGet( stop_date, yy=stop_yr, mm=stop_mon, dd=stop_day, & - s=stop_tod, rc=rc ) + call ESMF_TimeGet( stop_date, yy=stop_yr, mm=stop_mon, dd=stop_day, s=stop_tod, rc=rc ) call chkrc(rc, sub//': error return from ESMF_TimeGet') - call ESMF_TimeGet( ref_date, yy=ref_yr, mm=ref_mon, dd=ref_day, s=ref_tod, & - rc=rc ) + call ESMF_TimeGet( ref_date, yy=ref_yr, mm=ref_mon, dd=ref_day, s=ref_tod, rc=rc ) call chkrc(rc, sub//': error return from ESMF_TimeGet') - call ESMF_TimeGet( curr_date, yy=curr_yr, mm=curr_mon, dd=curr_day, & - s=curr_tod, rc=rc ) + call ESMF_TimeGet( curr_date, yy=curr_yr, mm=curr_mon, dd=curr_day, s=curr_tod, rc=rc ) call chkrc(rc, sub//': error return from ESMF_TimeGet') - write(iulog,*)' Calendar type: ',trim(calendar) - write(iulog,*)' Timestep size (seconds): ', step_sec - write(iulog,*)' Start date (yr mon day tod): ', start_yr, start_mon, & - start_day, start_tod - write(iulog,*)' Stop date (yr mon day tod): ', stop_yr, stop_mon, & - stop_day, stop_tod - write(iulog,*)' Reference date (yr mon day tod): ', ref_yr, ref_mon, & - ref_day, ref_tod - write(iulog,*)' Current step number: ', nstep - write(iulog,*)' Current date (yr mon day tod): ', curr_yr, curr_mon, & - curr_day, curr_tod - + write(iulog,*)' ******** Time Manager Configuration ********' + write(iulog,*)' Calendar type: ', trim(calendar) + write(iulog,*)' Timestep size (seconds): ', step_sec + write(iulog,*)' Start date (yr mon day tod): ', start_yr, start_mon, start_day, start_tod + write(iulog,*)' Stop date (yr mon day tod): ', stop_yr, stop_mon, stop_day, stop_tod + write(iulog,*)' Reference date (yr mon day tod): ', ref_yr, ref_mon, ref_day, ref_tod + write(iulog,*)' Current step number: ', nstep + write(iulog,*)' Current date (yr mon day tod): ', curr_yr, curr_mon, curr_day, curr_tod write(iulog,*)' ************************************************' end subroutine timemgr_print @@ -672,9 +662,9 @@ integer function get_nstep() ! Return the timestep number. - character(len=*), parameter :: sub = 'get_nstep' integer :: rc integer(ESMF_KIND_I8) :: step_no + character(len=*), parameter :: sub = 'get_nstep' call ESMF_ClockGet(tm_clock, advanceCount=step_no, rc=rc) call chkrc(rc, sub//': error return from ESMF_ClockGet') @@ -685,43 +675,23 @@ end function get_nstep !========================================================================================= - subroutine get_curr_date(yr, mon, day, tod, offset) - - !----------------------------------------------------------------------------------------- - ! Return date components valid at end of current timestep with an optional - ! offset (positive or negative) in seconds. + subroutine get_curr_date(yr, mon, day, tod) - integer, intent(out) ::& - yr, &! year - mon, &! month - day, &! day of month - tod ! time of day (seconds past 0Z) + ! Return date components valid at end of current timestep - integer, optional, intent(in) :: offset ! Offset from current time in seconds. - ! Positive for future times, negative - ! for previous times. + integer , intent(out) :: yr ! year + integer , intent(out) :: mon ! month + integer , intent(out) :: day ! day of month + integer , intent(out) :: tod ! time of day (seconds past 0Z) - character(len=*), parameter :: sub = 'get_curr_date' - integer :: rc - type(ESMF_Time) :: date + ! Local variables + integer :: rc + type(ESMF_Time) :: date type(ESMF_TimeInterval) :: off - !----------------------------------------------------------------------------------------- + character(len=*), parameter :: sub = 'get_curr_date' call ESMF_ClockGet( tm_clock, currTime=date, rc=rc ) call chkrc(rc, sub//': error return from ESMF_ClockGet') - - if (present(offset)) then - if (offset > 0) then - call ESMF_TimeIntervalSet( off, s=offset, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet') - date = date + off - else if (offset < 0) then - call ESMF_TimeIntervalSet( off, s=-offset, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet') - date = date - off - end if - end if - call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) call chkrc(rc, sub//': error return from ESMF_TimeGet') @@ -734,17 +704,15 @@ subroutine get_prev_date(yr, mon, day, tod) ! Return date components valid at beginning of current timestep. ! Arguments - integer, intent(out) ::& - yr, &! year - mon, &! month - day, &! day of month - tod ! time of day (seconds past 0Z) + integer, intent(out) :: yr ! year + integer, intent(out) :: mon ! month + integer, intent(out) :: day ! day of month + integer, intent(out) :: tod ! time of day (seconds past 0Z) ! Local variables - character(len=*), parameter :: sub = 'get_prev_date' integer :: rc type(ESMF_Time) :: date - !----------------------------------------------------------------------------------------- + character(len=*), parameter :: sub = 'get_prev_date' call ESMF_ClockGet(tm_clock, prevTime=date, rc=rc ) call chkrc(rc, sub//': error return from ESMF_ClockGet') @@ -758,15 +726,17 @@ end subroutine get_prev_date subroutine get_start_date(yr, mon, day, tod) ! Return date components valid at beginning of initial run. - integer, intent(out) ::& - yr, &! year - mon, &! month - day, &! day of month - tod ! time of day (seconds past 0Z) - character(len=*), parameter :: sub = 'get_start_date' + ! Arguments + integer, intent(out) :: yr ! year + integer, intent(out) :: mon ! month + integer, intent(out) :: day ! day of month + integer, intent(out) :: tod ! time of day (seconds past 0Z) + + ! Local variables integer :: rc type(ESMF_Time) :: date + character(len=*), parameter :: sub = 'get_start_date' call ESMF_ClockGet(tm_clock, startTime=date, rc=rc) call chkrc(rc, sub//': error return from ESMF_ClockGet') @@ -791,7 +761,6 @@ subroutine get_ref_date(yr, mon, day, tod) integer :: rc type(ESMF_Time) :: date character(len=*), parameter :: sub = 'get_ref_date' - !----------------------------------------------------------------------------------------- call ESMF_ClockGet(tm_clock, refTime=date, rc=rc) call chkrc(rc, sub//': error return from ESMF_ClockGet') @@ -816,16 +785,12 @@ subroutine get_curr_time(days, seconds) type(ESMF_Time) :: cdate, rdate type(ESMF_TimeInterval) :: diff character(len=*), parameter :: sub = 'get_curr_time' - !----------------------------------------------------------------------------------------- call ESMF_ClockGet( tm_clock, currTime=cdate, rc=rc ) call chkrc(rc, sub//': error return from ESMF_ClockGet') - call ESMF_ClockGet( tm_clock, refTime=rdate, rc=rc ) call chkrc(rc, sub//': error return from ESMF_ClockGet') - diff = cdate - rdate - call ESMF_TimeIntervalGet(diff, d=days, s=seconds, rc=rc) call chkrc(rc, sub//': error return from ESMF_TimeIntervalGet') @@ -839,16 +804,14 @@ subroutine get_prev_time(days, seconds) ! prev time is the time interval between the prev date and the reference date. ! Arguments - integer, intent(out) ::& - days, &! number of whole days in time interval - seconds ! remaining seconds in time interval + integer, intent(out) :: days ! number of whole days in time interval + integer, intent(out) :: seconds ! remaining seconds in time interval ! Local variables - character(len=*), parameter :: sub = 'get_prev_time' integer :: rc type(ESMF_Time) :: date, ref_date type(ESMF_TimeInterval) :: diff - !----------------------------------------------------------------------------------------- + character(len=*), parameter :: sub = 'get_prev_time' call ESMF_ClockGet(tm_clock, prevTime=date, rc=rc ) call chkrc(rc, sub//': error return from ESMF_ClockGet for prevTime') @@ -873,38 +836,6 @@ end function get_calendar !========================================================================================= - subroutine chkrc(rc, mes) - integer, intent(in) :: rc ! return code from time management library - character(len=*), intent(in) :: mes ! error message - if ( rc == ESMF_SUCCESS ) return - write(iulog,*) mes - call shr_sys_abort ('CHKRC') - end subroutine chkrc - - !========================================================================================= - - function to_upper(str) - - ! Convert character string to upper case. Use achar and iachar intrinsics - ! to ensure use of ascii collating sequence. - character(len=*), intent(in) :: str ! String to convert to upper case - character(len=len(str)) :: to_upper - - integer :: i ! Index - integer :: aseq ! ascii collating sequence - character(len=1) :: ctmp ! Character temporary - - do i = 1, len(str) - ctmp = str(i:i) - aseq = iachar(ctmp) - if ( aseq >= 97 .and. aseq <= 122 ) ctmp = achar(aseq - 32) - to_upper(i:i) = ctmp - end do - - end function to_upper - - !========================================================================================= - logical function is_restart( ) ! Determine if restart run if (nsrest == nsrContinue) then @@ -914,4 +845,15 @@ logical function is_restart( ) end if end function is_restart + !========================================================================================= + + subroutine chkrc(rc, mes) + integer, intent(in) :: rc ! return code from time management library + character(len=*), intent(in) :: mes ! error message + if ( rc == ESMF_SUCCESS ) return + write(iulog,*) mes + call shr_sys_abort ('CHKRC') + end subroutine chkrc + + end module mosart_timemanager diff --git a/src/riverroute/mosart_tspatialunit_type.F90 b/src/riverroute/mosart_tspatialunit_type.F90 index 7aadc5d..73be11f 100644 --- a/src/riverroute/mosart_tspatialunit_type.F90 +++ b/src/riverroute/mosart_tspatialunit_type.F90 @@ -8,8 +8,12 @@ module mosart_tspatialunit_type use mosart_io, only : ncd_pio_openfile, compDOF use mosart_vars, only : mainproc, mpicom_rof, iulog use nuopc_shr_methods, only : chkerr - use pio - use ESMF + use ESMF, only : ESMF_Field, ESMF_RouteHandle, ESMF_Mesh, ESMF_FieldCreate, & + ESMF_FieldSMMStore, ESMF_FieldGet, ESMF_FieldSMM, & + ESMF_SUCCESS, ESMF_TYPEKIND_R8, ESMF_MESHLOC_ELEMENT, ESMF_TERMORDER_SRCSEQ + use pio, only : iosystem_desc_t, var_desc_t, io_desc_t, file_desc_t, pio_seterrorhandling, & + pio_inq_varid, pio_inq_vardimid, pio_inq_dimlen, pio_initdecomp, pio_closefile, & + pio_int, pio_double, PIO_INTERNAL_ERROR, pio_read_darray, pio_freedecomp implicit none private diff --git a/src/riverroute/mosart_vars.F90 b/src/riverroute/mosart_vars.F90 index 5dd647d..daf2d60 100644 --- a/src/riverroute/mosart_vars.F90 +++ b/src/riverroute/mosart_vars.F90 @@ -1,9 +1,8 @@ module mosart_vars - use shr_kind_mod , only : r8 => shr_kind_r8, CL => SHR_KIND_CL + use shr_kind_mod , only : r8 => shr_kind_r8, CL => SHR_KIND_CL, CS => shr_kind_CS use shr_const_mod , only : SHR_CONST_CDAY,SHR_CONST_REARTH use shr_sys_mod , only : shr_sys_abort - use ESMF implicit none public @@ -34,9 +33,9 @@ module mosart_vars ! Namelist variables character(len=CL) :: frivinp ! MOSART input data file name logical :: ice_runoff ! true => runoff is split into liquid and ice, otherwise just liquid - character(len=32) :: decomp_option ! decomp option - character(len=32) :: bypass_routing_option ! bypass routing model method - character(len=32) :: qgwl_runoff_option ! method for handling qgwl runoff + character(len=CS) :: decomp_option ! decomp option + character(len=CS) :: bypass_routing_option ! bypass routing model method + character(len=CS) :: qgwl_runoff_option ! method for handling qgwl runoff ! Metadata variables used in history and restart generation character(len=CL) :: caseid = ' ' ! case id @@ -53,7 +52,7 @@ module mosart_vars ! Instance control integer :: inst_index - character(len=16) :: inst_name - character(len=16) :: inst_suffix + character(len=CS) :: inst_name + character(len=CS) :: inst_suffix end module mosart_vars From 7b5c49860da295531289244d69dde289af530d6d Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 2 Jan 2024 12:41:18 +0100 Subject: [PATCH 19/86] added only attributes to all use statements in mosart_io.F90 --- src/riverroute/mosart_io.F90 | 233 +++++++++++++++++------------------ 1 file changed, 115 insertions(+), 118 deletions(-) diff --git a/src/riverroute/mosart_io.F90 b/src/riverroute/mosart_io.F90 index 9afa99a..b2c89cd 100644 --- a/src/riverroute/mosart_io.F90 +++ b/src/riverroute/mosart_io.F90 @@ -2,14 +2,25 @@ module mosart_io ! Generic interfaces to write fields to netcdf files ! - use shr_kind_mod , only : r8 => shr_kind_r8, i8=>shr_kind_i8, shr_kind_cl, r4=>shr_kind_r4 + use shr_kind_mod , only : r8 => shr_kind_r8, i8=>shr_kind_i8, r4=>shr_kind_r4 + use shr_kind_mod , only : CS=>shr_kind_cs, CL=>shr_kind_cl use shr_sys_mod , only : shr_sys_flush, shr_sys_abort use shr_file_mod , only : shr_file_getunit, shr_file_freeunit use shr_pio_mod , only : shr_pio_getiosys, shr_pio_getiotype, shr_pio_getioformat use mosart_vars , only : spval, ispval, iulog, mainproc, mpicom_rof, iam, npes use perf_mod , only : t_startf, t_stopf - use pio - use mpi + use mpi , only : mpi_barrier, mpi_bcast, MPI_CHARACTER + use pio , only : file_desc_t, var_desc_t, io_desc_t, iosystem_desc_t, pio_initdecomp, & + pio_openfile, pio_iotask_rank, pio_closefile, pio_createfile, & + pio_seterrorhandling, pio_inq_dimid, pio_inq_dimlen, pio_inq_dimname, & + pio_def_dim, pio_inq_dimname, pio_enddef, pio_def_var, pio_put_att, & + pio_get_var, pio_put_var, pio_inq_varndims, pio_inq_vardimid, & + pio_inq_vartype, pio_inq_varname, pio_inq_varid, pio_inquire, & + pio_setframe, pio_read_darray, pio_write_darray, & + PIO_CLOBBER, PIO_IOTYPE_NETCDF, PIO_IOTYPE_PNETCDF, PIO_NOERR, & + PIO_BCAST_ERROR, PIO_OFFSET_KIND, pio_INTERNAL_ERROR, & + pio_int, pio_real, pio_double, pio_char, pio_global, & + pio_write, pio_nowrite, pio_noclobber, pio_nofill, pio_unlimited implicit none private @@ -51,9 +62,9 @@ module mosart_io integer, parameter, public :: ncd_unlimited = pio_unlimited ! PIO types needed for ncdio_pio interface calls - public file_desc_t - public var_desc_t - public io_desc_t + public :: file_desc_t + public :: var_desc_t + public :: io_desc_t ! !PRIVATE MEMBER FUNCTIONS: interface ncd_putatt @@ -101,8 +112,8 @@ module mosart_io type(iosystem_desc_t), pointer, public :: pio_subsystem type iodesc_plus_type - character(len=64) :: name - type(IO_desc_t) :: iodesc + character(len=CS) :: name + type(io_desc_t) :: iodesc integer :: type integer :: ndims integer :: dims(4) @@ -131,7 +142,7 @@ subroutine ncd_pio_init(rofid) character(len=*),parameter :: subname='ncd_pio_init' ! subroutine name !----------------------------------------------------------------------- - PIO_subsystem => shr_pio_getiosys(rofid) + pio_subsystem => shr_pio_getiosys(rofid) io_type = shr_pio_getiotype(rofid) io_format = shr_pio_getioformat(rofid) @@ -186,10 +197,10 @@ subroutine ncd_pio_openfile(file, fname, mode) ! Open a NetCDF PIO file ! ! !ARGUMENTS: - implicit none type(file_desc_t), intent(inout) :: file ! Output PIO file handle character(len=*) , intent(in) :: fname ! Input filename to open integer , intent(in) :: mode ! file mode + ! !LOCAL VARIABLES: integer :: ierr character(len=*),parameter :: subname='ncd_pio_openfile' ! subroutine name @@ -228,9 +239,9 @@ subroutine ncd_pio_createfile(file, fname) ! Create a new NetCDF file with PIO ! ! !ARGUMENTS: - implicit none type(file_desc_t), intent(inout) :: file ! PIO file descriptor character(len=*), intent(in) :: fname ! File name to create + ! !LOCAL VARIABLES: integer :: ierr integer :: iomode @@ -260,12 +271,12 @@ subroutine check_var(ncid, varname, vardesc, readvar, print_err ) ! Check if variable is on netcdf file ! ! !ARGUMENTS: - implicit none type(file_desc_t), intent(inout) :: ncid ! PIO file descriptor character(len=*) , intent(in) :: varname ! Varible name to check type(Var_desc_t) , intent(out) :: vardesc ! Output variable descriptor logical , intent(out) :: readvar ! If variable exists or not logical, optional, intent(in) :: print_err ! If should print about error + ! !LOCAL VARIABLES: integer :: ret ! return value logical :: log_err ! if should log error @@ -280,8 +291,8 @@ subroutine check_var(ncid, varname, vardesc, readvar, print_err ) end if readvar = .true. call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) - ret = PIO_inq_varid (ncid, varname, vardesc) - if (ret /= PIO_noerr) then + ret = pio_inq_varid (ncid, varname, vardesc) + if (ret /= PIO_NOERR) then readvar = .false. if (mainproc .and. log_err) & write(iulog,*) subname//': variable ',trim(varname),' is not on dataset' @@ -297,10 +308,10 @@ subroutine check_dim(ncid, dimname, value) ! Validity check on dimension ! ! !ARGUMENTS: - implicit none type(file_desc_t),intent(in) :: ncid ! PIO file handle character(len=*), intent(in) :: dimname ! Dimension name integer, intent(in) :: value ! Expected dimension size + ! !LOCAL VARIABLES: integer :: dimid, dimlen ! temporaries integer :: status ! error code @@ -325,14 +336,14 @@ subroutine ncd_enddef(ncid) ! enddef netcdf file ! ! !ARGUMENTS: - implicit none type(file_desc_t),intent(inout) :: ncid ! netcdf file id + ! !LOCAL VARIABLES: integer :: status ! error status character(len=*),parameter :: subname='ncd_enddef' ! subroutine name !----------------------------------------------------------------------- - status = PIO_enddef(ncid) + status = pio_enddef(ncid) end subroutine ncd_enddef @@ -344,11 +355,11 @@ subroutine ncd_inqdid(ncid,name,dimid,dimexist) ! inquire on a dimension id ! ! !ARGUMENTS: - implicit none type(file_desc_t),intent(inout) :: ncid ! netcdf file id character(len=*), intent(in) :: name ! dimension name integer , intent(out):: dimid ! dimension id logical,optional, intent(out):: dimexist ! if this dimension exists or not + ! !LOCAL VARIABLES: integer :: status !----------------------------------------------------------------------- @@ -376,7 +387,6 @@ subroutine ncd_inqdlen(ncid,dimid,len,name) ! enddef netcdf file ! ! !ARGUMENTS: - implicit none type(file_desc_t), intent(inout) :: ncid ! netcdf file id integer , intent(inout) :: dimid ! dimension id integer , intent(out) :: len ! dimension len @@ -390,7 +400,7 @@ subroutine ncd_inqdlen(ncid,dimid,len,name) call ncd_inqdid(ncid,name,dimid) end if len = -1 - status = PIO_inq_dimlen(ncid,dimid,len) + status = pio_inq_dimlen(ncid,dimid,len) end subroutine ncd_inqdlen @@ -402,15 +412,15 @@ subroutine ncd_inqdname(ncid,dimid,dname) ! inquire dim name ! ! !ARGUMENTS: - implicit none type(file_desc_t), intent(in) :: ncid ! netcdf file id integer , intent(in) :: dimid ! dimension id character(len=*) , intent(out):: dname ! dimension name + ! !LOCAL VARIABLES: integer :: status !----------------------------------------------------------------------- - status = PIO_inq_dimname(ncid,dimid,dname) + status = pio_inq_dimname(ncid,dimid,dname) end subroutine ncd_inqdname @@ -428,7 +438,7 @@ subroutine ncd_inqfdims(ncid, isgrid2d, ni, nj, ns) ! !LOCAL VARIABLES: integer :: dimid ! netCDF id integer :: ier ! error status - character(len=32) :: subname = 'surfrd_filedims' ! subroutine name + character(len=CS) :: subname = 'surfrd_filedims' ! subroutine name !----------------------------------------------------------------------- ni = 0 @@ -481,12 +491,12 @@ subroutine ncd_inqvid(ncid,name,varid,vardesc,readvar) ! Inquire on a variable ID ! ! !ARGUMENTS: - implicit none type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: name ! variable name integer , intent(out) :: varid ! variable id type(Var_desc_t) , intent(out) :: vardesc ! variable descriptor logical, optional, intent(out) :: readvar ! does variable exist + ! !LOCAL VARIABLES: integer :: ret ! return code character(len=*),parameter :: subname='ncd_inqvid' ! subroutine name @@ -495,8 +505,8 @@ subroutine ncd_inqvid(ncid,name,varid,vardesc,readvar) if (present(readvar)) then readvar = .false. call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) - ret = PIO_inq_varid(ncid,name,vardesc) - if (ret /= PIO_noerr) then + ret = pio_inq_varid(ncid,name,vardesc) + if (ret /= PIO_NOERR) then if (mainproc) write(iulog,*) subname//': variable ',trim(name),' is not on dataset' readvar = .false. else @@ -504,7 +514,7 @@ subroutine ncd_inqvid(ncid,name,varid,vardesc,readvar) end if call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) else - ret = PIO_inq_varid(ncid,name,vardesc) + ret = pio_inq_varid(ncid,name,vardesc) endif varid = vardesc%varid @@ -518,7 +528,6 @@ subroutine ncd_inqvdims(ncid,ndims,vardesc) ! inquire variable dimensions ! ! !ARGUMENTS: - implicit none type(file_desc_t), intent(in) :: ncid ! netcdf file id integer , intent(out) :: ndims ! variable ndims type(Var_desc_t) , intent(inout):: vardesc ! variable descriptor @@ -528,7 +537,7 @@ subroutine ncd_inqvdims(ncid,ndims,vardesc) !----------------------------------------------------------------------- ndims = -1 - status = PIO_inq_varndims(ncid,vardesc,ndims) + status = pio_inq_varndims(ncid,vardesc,ndims) end subroutine ncd_inqvdims @@ -540,17 +549,17 @@ subroutine ncd_inqvname(ncid,varid,vname,vardesc) ! inquire variable name ! ! !ARGUMENTS: - implicit none type(file_desc_t), intent(in) :: ncid ! netcdf file id integer , intent(in) :: varid ! variable id character(len=*) , intent(out) :: vname ! variable vname type(Var_desc_t) , intent(inout):: vardesc ! variable descriptor + ! !LOCAL VARIABLES: integer :: status !----------------------------------------------------------------------- vname = '' - status = PIO_inq_varname(ncid,vardesc,vname) + status = pio_inq_varname(ncid,vardesc,vname) end subroutine ncd_inqvname @@ -562,17 +571,16 @@ subroutine ncd_inqvdids(ncid,dids,vardesc) ! inquire variable dimension ids ! ! !ARGUMENTS: - implicit none type(file_desc_t),intent(in) :: ncid ! netcdf file id integer ,intent(out) :: dids(:) ! variable dids type(Var_desc_t),intent(inout):: vardesc ! variable descriptor - ! + ! !LOCAL VARIABLES: integer :: status !----------------------------------------------------------------------- dids = -1 - status = PIO_inq_vardimid(ncid,vardesc,dids) + status = pio_inq_vardimid(ncid,vardesc,dids) end subroutine ncd_inqvdids @@ -583,7 +591,6 @@ subroutine ncd_putatt_int(ncid,varid,attrib,value,xtype) ! put integer attributes ! ! !ARGUMENTS: - implicit none type(file_desc_t),intent(inout) :: ncid ! netcdf file id integer ,intent(in) :: varid ! netcdf var id character(len=*) ,intent(in) :: attrib ! netcdf attrib @@ -594,7 +601,7 @@ subroutine ncd_putatt_int(ncid,varid,attrib,value,xtype) integer :: status !----------------------------------------------------------------------- - status = PIO_put_att(ncid,varid,trim(attrib),value) + status = pio_put_att(ncid,varid,trim(attrib),value) end subroutine ncd_putatt_int @@ -606,7 +613,6 @@ subroutine ncd_putatt_char(ncid,varid,attrib,value,xtype) ! put character attributes ! ! !ARGUMENTS: - implicit none type(file_desc_t),intent(inout) :: ncid ! netcdf file id integer ,intent(in) :: varid ! netcdf var id character(len=*) ,intent(in) :: attrib ! netcdf attrib @@ -617,7 +623,7 @@ subroutine ncd_putatt_char(ncid,varid,attrib,value,xtype) integer :: status !----------------------------------------------------------------------- - status = PIO_put_att(ncid,varid,trim(attrib),value) + status = pio_put_att(ncid,varid,trim(attrib),value) end subroutine ncd_putatt_char @@ -629,7 +635,6 @@ subroutine ncd_putatt_real(ncid,varid,attrib,value,xtype) ! put real attributes ! ! !ARGUMENTS: - implicit none type(file_desc_t),intent(inout) :: ncid ! netcdf file id integer ,intent(in) :: varid ! netcdf var id character(len=*) ,intent(in) :: attrib ! netcdf attrib @@ -644,9 +649,9 @@ subroutine ncd_putatt_real(ncid,varid,attrib,value,xtype) value4 = real(value, kind=r4) if (xtype == pio_double) then - status = PIO_put_att(ncid,varid,trim(attrib),value) + status = pio_put_att(ncid,varid,trim(attrib),value) else - status = PIO_put_att(ncid,varid,trim(attrib),value4) + status = pio_put_att(ncid,varid,trim(attrib),value4) endif end subroutine ncd_putatt_real @@ -659,7 +664,6 @@ subroutine ncd_defdim(ncid,attrib,value,dimid) ! define dimension ! ! !ARGUMENTS: - implicit none type(file_desc_t), intent(in) :: ncid ! netcdf file id character(len=*) , intent(in) :: attrib ! netcdf attrib integer , intent(in) :: value ! netcdf attrib value @@ -684,23 +688,22 @@ subroutine ncd_defvar_bynf(ncid, varname, xtype, ndims, dimid, varid, & ! Define a netcdf variable ! ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: varname ! variable name - integer , intent(in) :: xtype ! external type - integer , intent(in) :: ndims ! number of dims - integer , intent(inout) :: varid ! returned var id - integer , intent(in), optional :: dimid(:) ! dimids - character(len=*) , intent(in), optional :: long_name ! attribute - character(len=*) , intent(in), optional :: units ! attribute - character(len=*) , intent(in), optional :: cell_method ! attribute - character(len=*) , intent(in), optional :: comment ! attribute + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: varname ! variable name + integer , intent(in) :: xtype ! external type + integer , intent(in) :: ndims ! number of dims + integer , intent(inout) :: varid ! returned var id + integer , intent(in), optional :: dimid(:) ! dimids + character(len=*) , intent(in), optional :: long_name ! attribute + character(len=*) , intent(in), optional :: units ! attribute + character(len=*) , intent(in), optional :: cell_method ! attribute + character(len=*) , intent(in), optional :: comment ! attribute character(len=*) , intent(in), optional :: flag_meanings(:) ! attribute - real(r8) , intent(in), optional :: missing_value ! attribute for real - real(r8) , intent(in), optional :: fill_value ! attribute for real - integer , intent(in), optional :: imissing_value ! attribute for int - integer , intent(in), optional :: ifill_value ! attribute for int - integer , intent(in), optional :: flag_values(:) ! attribute for int + real(r8) , intent(in), optional :: missing_value ! attribute for real + real(r8) , intent(in), optional :: fill_value ! attribute for real + integer , intent(in), optional :: imissing_value ! attribute for int + integer , intent(in), optional :: ifill_value ! attribute for int + integer , intent(in), optional :: flag_values(:) ! attribute for int integer , intent(in), optional :: nvalid_range(2) ! attribute for int ! @@ -711,8 +714,8 @@ subroutine ncd_defvar_bynf(ncid, varname, xtype, ndims, dimid, varid, & integer :: status ! error status integer :: lxtype ! local external type (in case logical variable) type(var_desc_t) :: vardesc ! local vardesc - character(len=255) :: dimname ! temporary - character(len=256) :: str ! temporary + character(len=CL) :: dimname ! temporary + character(len=CL) :: str ! temporary character(len=*),parameter :: subname='ncd_defvar_bynf' ! subroutine name !----------------------------------------------------------------------- @@ -745,9 +748,9 @@ subroutine ncd_defvar_bynf(ncid, varname, xtype, ndims, dimid, varid, & ! Define variable if (present(dimid)) then - status = PIO_def_var(ncid,trim(varname),lxtype,dimid(1:ndims),vardesc) + status = pio_def_var(ncid,trim(varname),lxtype,dimid(1:ndims),vardesc) else - status = PIO_def_var(ncid,trim(varname),lxtype,dimid0 ,vardesc) + status = pio_def_var(ncid,trim(varname),lxtype,dimid0 ,vardesc) endif varid = vardesc%varid ! @@ -757,7 +760,7 @@ subroutine ncd_defvar_bynf(ncid, varname, xtype, ndims, dimid, varid, & call ncd_putatt(ncid, varid, 'long_name', trim(long_name)) end if if (present(flag_values)) then - status = PIO_put_att(ncid,varid,'flag_values',flag_values) + status = pio_put_att(ncid,varid,'flag_values',flag_values) if ( .not. present(flag_meanings)) then write(iulog,*) 'Error in defining variable = ', trim(varname) call shr_sys_abort( subname//" ERROR:: flag_values set -- but not flag_meanings" ) @@ -780,7 +783,7 @@ subroutine ncd_defvar_bynf(ncid, varname, xtype, ndims, dimid, varid, & end if if ( n > 1 ) str = trim(str)//" "//flag_meanings(n) end do - status = PIO_put_att(ncid,varid,'flag_meanings', trim(str) ) + status = pio_put_att(ncid,varid,'flag_meanings', trim(str) ) end if if (present(comment)) then call ncd_putatt(ncid, varid, 'comment', trim(comment)) @@ -805,12 +808,12 @@ subroutine ncd_defvar_bynf(ncid, varname, xtype, ndims, dimid, varid, & call ncd_putatt(ncid, varid, 'missing_value', imissing_value, lxtype) end if if (present(nvalid_range)) then - status = PIO_put_att(ncid,varid,'valid_range', nvalid_range ) + status = pio_put_att(ncid,varid,'valid_range', nvalid_range ) end if if ( xtype == ncd_log )then - status = PIO_put_att(ncid,varid,'flag_values', (/0, 1/) ) - status = PIO_put_att(ncid,varid,'flag_meanings', "FALSE TRUE" ) - status = PIO_put_att(ncid,varid,'valid_range', (/0, 1/) ) + status = pio_put_att(ncid,varid,'flag_values', (/0, 1/) ) + status = pio_put_att(ncid,varid,'flag_meanings', "FALSE TRUE" ) + status = pio_put_att(ncid,varid,'valid_range', (/0, 1/) ) end if end subroutine ncd_defvar_bynf @@ -827,7 +830,6 @@ subroutine ncd_defvar_bygrid(ncid, varname, xtype, & ! Define a netcdf variable ! ! !ARGUMENTS: - implicit none type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*), intent(in) :: varname ! variable name integer , intent(in) :: xtype ! external type @@ -858,7 +860,7 @@ subroutine ncd_defvar_bygrid(ncid, varname, xtype, & integer :: dimid(5) ! dimension ids integer :: varid ! variable id integer :: itmp ! temporary - character(len=256) :: str ! temporary + character(len=CL) :: str ! temporary character(len=*),parameter :: subname='ncd_defvar_bygrid' ! subroutine name !----------------------------------------------------------------------- @@ -872,10 +874,7 @@ subroutine ncd_defvar_bygrid(ncid, varname, xtype, & if (present(dim4name)) call ncd_inqdid(ncid, dim4name, dimid(4)) if (present(dim5name)) call ncd_inqdid(ncid, dim5name, dimid(5)) - ! Permute dim1 and dim2 if necessary - ! Define variable - ndims = 0 if (present(dim1name)) then do n = 1, size(dimid) @@ -900,13 +899,13 @@ subroutine ncd_io_log_var0_nf(varname, data, flag, ncid, readvar, nt) ! netcdf I/O of global integer variable ! ! !ARGUMENTS: - implicit none type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: flag ! 'read' or 'write' character(len=*) , intent(in) :: varname ! variable name logical , intent(inout) :: data ! raw data logical, optional, intent(out) :: readvar ! was var read? integer, optional, intent(in) :: nt ! time sample index + ! ! !LOCAL VARIABLES: integer :: varid ! netCDF variable id integer :: start(1), count(1) ! output bounds @@ -914,7 +913,7 @@ subroutine ncd_io_log_var0_nf(varname, data, flag, ncid, readvar, nt) integer :: idata ! raw integer data logical :: varpresent ! if true, variable is on tape integer :: temp(1) ! temporary - character(len=32) :: vname ! variable error checking + character(len=CS) :: vname ! variable error checking type(var_desc_t) :: vardesc ! local vardesc pointer character(len=*),parameter :: subname='ncd_io_log_var0_nf' !----------------------------------------------------------------------- @@ -929,8 +928,7 @@ subroutine ncd_io_log_var0_nf(varname, data, flag, ncid, readvar, nt) else if ( idata == 1 )then data = .true. else - call shr_sys_abort( subname// & - ' ERROR: bad integer value for logical data' ) + call shr_sys_abort( subname//' ERROR: bad integer value for logical data' ) end if endif if (present(readvar)) readvar = varpresent @@ -964,20 +962,20 @@ subroutine ncd_io_int_var0_nf(varname, data, flag, ncid, readvar, nt) ! netcdf I/O of global integer variable ! ! !ARGUMENTS: - implicit none type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: flag ! 'read' or 'write' character(len=*) , intent(in) :: varname ! variable name integer , intent(inout) :: data ! raw data logical, optional, intent(out) :: readvar ! was var read? integer, optional, intent(in) :: nt ! time sample index + ! ! !LOCAL VARIABLES: integer :: varid ! netCDF variable id integer :: start(1), count(1) ! output bounds integer :: status ! error code logical :: varpresent ! if true, variable is on tape integer :: temp(1) ! temporary - character(len=32) :: vname ! variable error checking + character(len=CS) :: vname ! variable error checking type(var_desc_t) :: vardesc ! local vardesc pointer character(len=*),parameter :: subname='ncd_io_int_var0_nf' !----------------------------------------------------------------------- @@ -1014,20 +1012,20 @@ subroutine ncd_io_real_var0_nf(varname, data, flag, ncid, readvar, nt) ! netcdf I/O of global real variable ! ! !ARGUMENTS: - implicit none type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: flag ! 'read' or 'write' character(len=*) , intent(in) :: varname ! variable name real(r8) , intent(inout) :: data ! raw data logical, optional, intent(out) :: readvar ! was var read? integer, optional, intent(in) :: nt ! time sample index + ! ! !LOCAL VARIABLES: integer :: varid ! netCDF variable id integer :: start(1), count(1) ! output bounds integer :: status ! error code logical :: varpresent ! if true, variable is on tape real(r8):: temp(1) ! temporary - character(len=32) :: vname ! variable error checking + character(len=CS) :: vname ! variable error checking type(var_desc_t) :: vardesc ! local vardesc pointer character(len=*),parameter :: subname='ncd_io_real_var0_nf' !----------------------------------------------------------------------- @@ -1064,19 +1062,19 @@ subroutine ncd_io_int_var1_nf(varname, data, flag, ncid, readvar, nt) ! netcdf I/O of global integer array ! ! !ARGUMENTS: - implicit none type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: flag ! 'read' or 'write' character(len=*) , intent(in) :: varname ! variable name integer , intent(inout) :: data(:) ! raw data logical, optional, intent(out) :: readvar ! was var read? integer, optional, intent(in) :: nt ! time sample index + ! ! !LOCAL VARIABLES: integer :: varid ! netCDF variable id integer :: start(2), count(2) ! output bounds integer :: status ! error code logical :: varpresent ! if true, variable is on tape - character(len=32) :: vname ! variable error checking + character(len=CS) :: vname ! variable error checking type(var_desc_t) :: vardesc ! local vardesc pointer character(len=*),parameter :: subname='ncd_io_int_var1_nf' integer :: ndims @@ -1120,20 +1118,20 @@ subroutine ncd_io_log_var1_nf(varname, data, flag, ncid, readvar, nt) ! netcdf I/O of global integer array ! ! !ARGUMENTS: - implicit none type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: flag ! 'read' or 'write' character(len=*) , intent(in) :: varname ! variable name logical , intent(inout) :: data(:) ! raw data logical, optional, intent(out) :: readvar ! was var read? integer, optional, intent(in) :: nt ! time sample index + ! ! !LOCAL VARIABLES: integer :: varid ! netCDF variable id integer :: start(2), count(2) ! output bounds integer :: status ! error code integer, pointer :: idata(:) ! Temporary integer data to send to file logical :: varpresent ! if true, variable is on tape - character(len=32) :: vname ! variable error checking + character(len=CS) :: vname ! variable error checking type(var_desc_t) :: vardesc ! local vardesc pointer character(len=*),parameter :: subname='ncd_io_log_var1_nf' !----------------------------------------------------------------------- @@ -1187,19 +1185,19 @@ subroutine ncd_io_real_var1_nf(varname, data, flag, ncid, readvar, nt) ! netcdf I/O of global real array ! ! !ARGUMENTS: - implicit none type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: flag ! 'read' or 'write' character(len=*) , intent(in) :: varname ! variable name real(r8) , intent(inout) :: data(:) ! raw data logical , optional, intent(out):: readvar ! was var read? integer , optional, intent(in) :: nt ! time sample index + ! ! !LOCAL VARIABLES: integer :: varid ! netCDF variable id integer :: start(2), count(2) ! output bounds integer :: status ! error code logical :: varpresent ! if true, variable is on tape - character(len=32) :: vname ! variable error checking + character(len=CS) :: vname ! variable error checking type(var_desc_t) :: vardesc ! local vardesc pointer character(len=*),parameter :: subname='ncd_io_real_var1_nf' integer :: ndims @@ -1243,20 +1241,20 @@ subroutine ncd_io_char_var1_nf(varname, data, flag, ncid, readvar, nt ) ! netcdf I/O of global char array ! ! !ARGUMENTS: - implicit none type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: flag ! 'read' or 'write' character(len=*) , intent(in) :: varname ! variable name character(len=*) , intent(inout) :: data ! raw data logical , optional, intent(out):: readvar ! was var read? integer , optional, intent(in) :: nt ! time sample index + ! ! !LOCAL VARIABLES: integer :: varid ! netCDF variable id integer :: m ! indices integer :: status ! error code logical :: varpresent ! if true, variable is on tape - character(len=32) :: vname ! variable error checking - character(len=1) :: tmpString(255)! temp for manipulating output string + character(len=CS) :: vname ! variable error checking + character(len=1) :: tmpString(CL) ! temp for manipulating output string type(var_desc_t) :: vardesc ! local vardesc pointer character(len=*),parameter :: subname='ncd_io_char_var1_nf' !----------------------------------------------------------------------- @@ -1291,19 +1289,19 @@ subroutine ncd_io_int_var2_nf(varname, data, flag, ncid, readvar, nt) ! netcdf I/O of global integer 2D array ! ! !ARGUMENTS: - implicit none type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: flag ! 'read' or 'write' character(len=*) , intent(in) :: varname ! variable name integer , intent(inout) :: data(:,:) ! raw data logical , optional, intent(out):: readvar ! was var read? integer , optional, intent(in) :: nt ! time sample index + ! ! !LOCAL VARIABLES: integer :: varid ! netCDF variable id integer :: start(3), count(3) ! output bounds integer :: status ! error code logical :: varpresent ! if true, variable is on tape - character(len=32) :: vname ! variable error checking + character(len=CS) :: vname ! variable error checking type(var_desc_t) :: vardesc ! local vardesc pointer logical :: found ! if true, found lat/lon dims on file character(len=*),parameter :: subname='ncd_io_int_var2_nf' @@ -1352,19 +1350,19 @@ subroutine ncd_io_real_var2_nf(varname, data, flag, ncid, readvar, nt) ! netcdf I/O of global real 2D array ! ! !ARGUMENTS: - implicit none type(file_desc_t),intent(inout) :: ncid ! netcdf file id character(len=*), intent(in) :: flag ! 'read' or 'write' character(len=*), intent(in) :: varname ! variable name real(r8) , intent(inout) :: data(:,:) ! raw data logical , optional, intent(out):: readvar ! was var read? integer , optional, intent(in) :: nt ! time sample index + ! ! !LOCAL VARIABLES: integer :: varid ! netCDF variable id integer :: start(3), count(3) ! output bounds integer :: status ! error code logical :: varpresent ! if true, variable is on tape - character(len=32) :: vname ! variable error checking + character(len=CS) :: vname ! variable error checking type(var_desc_t) :: vardesc ! local vardesc pointer logical :: found ! if true, found lat/lon dims on file character(len=*),parameter :: subname='ncd_io_real_var2_nf' @@ -1410,19 +1408,19 @@ subroutine ncd_io_char_var2_nf(varname, data, flag, ncid, readvar, nt) ! netcdf I/O of global character array ! ! !ARGUMENTS: - implicit none type(file_desc_t),intent(inout) :: ncid ! netcdf file id character(len=*), intent(in) :: flag ! 'read' or 'write' character(len=*), intent(in) :: varname ! variable name character(len=*), intent(inout) :: data(:) ! raw data logical , optional, intent(out):: readvar ! was var read? integer , optional, intent(in) :: nt ! time sample index + ! ! !LOCAL VARIABLES: integer :: varid ! netCDF variable id integer :: start(3), count(3) ! output bounds integer :: status ! error code logical :: varpresent ! if true, variable is on tape - character(len=32) :: vname ! variable error checking + character(len=CS) :: vname ! variable error checking type(var_desc_t) :: vardesc ! local vardesc pointer logical :: found ! if true, found lat/lon dims on file character(len=*),parameter :: subname='ncd_io_char_var2_nf' @@ -1462,13 +1460,12 @@ subroutine ncd_io_char_varn_strt_nf(vardesc, data, flag, ncid, start ) ! netcdf I/O of global character array with start indices input ! ! !ARGUMENTS: - implicit none type(file_desc_t),intent(inout) :: ncid ! netcdf file id character(len=*), intent(in) :: flag ! 'read' or 'write' type(var_desc_t), intent(in) :: vardesc ! local vardesc pointer character(len=*), intent(inout) :: data ! raw data for this index integer , intent(in) :: start(:) ! output bounds - + ! ! !LOCAL VARIABLES: integer :: status ! error code character(len=*),parameter :: subname='ncd_io_char_varn_strt_nf' @@ -1490,7 +1487,6 @@ subroutine ncd_io_int_var1(varname, data, dim1name, flag, ncid, nt, readvar) ! I/O for 1d integer field ! ! !ARGUMENTS: - implicit none type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: flag ! 'read' or 'write' character(len=*) , intent(in) :: varname ! variable name @@ -1498,8 +1494,9 @@ subroutine ncd_io_int_var1(varname, data, dim1name, flag, ncid, nt, readvar) character(len=*) , intent(in) :: dim1name ! dimension name integer , optional, intent(in) :: nt ! time sample index logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + ! ! !LOCAL VARIABLES: - character(len=32) :: dimname ! temporary + character(len=CS) :: dimname ! temporary integer :: n ! index integer :: iodnum ! iodesc num in list integer :: varid ! varid @@ -1541,7 +1538,7 @@ subroutine ncd_io_int_var1(varname, data, dim1name, flag, ncid, nt, readvar) xtype, iodnum) iodesc_plus => iodesc_list(iodnum) if (present(nt)) then - call pio_setframe(ncid,vardesc, int(nt,kind=PIO_Offset_kind)) + call pio_setframe(ncid,vardesc, int(nt,kind=PIO_OFFSET_KIND)) end if call pio_read_darray(ncid, vardesc, iodesc_plus%iodesc, data, status) end if @@ -1566,7 +1563,7 @@ subroutine ncd_io_int_var1(varname, data, dim1name, flag, ncid, nt, readvar) xtype, iodnum) iodesc_plus => iodesc_list(iodnum) if (present(nt)) then - call pio_setframe(ncid, vardesc, int(nt,kind=PIO_Offset_kind)) + call pio_setframe(ncid, vardesc, int(nt,kind=PIO_OFFSET_KIND)) end if call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, data, status, fillval=ispval) @@ -1590,7 +1587,6 @@ subroutine ncd_io_log_var1(varname, data, dim1name, & ! I/O for 1d integer field ! ! !ARGUMENTS: - implicit none type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: flag ! 'read' or 'write' character(len=*) , intent(in) :: varname ! variable name @@ -1598,8 +1594,9 @@ subroutine ncd_io_log_var1(varname, data, dim1name, & character(len=*) , intent(in) :: dim1name ! dimension name integer , optional, intent(in) :: nt ! time sample index logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + ! ! !LOCAL VARIABLES: - character(len=32) :: dimname ! temporary + character(len=CS) :: dimname ! temporary integer :: n ! index integer :: iodnum ! iodesc num in list integer :: varid ! varid @@ -1643,7 +1640,7 @@ subroutine ncd_io_log_var1(varname, data, dim1name, & xtype, iodnum) iodesc_plus => iodesc_list(iodnum) if (present(nt)) then - call pio_setframe(ncid,vardesc, int(nt,kind=PIO_Offset_kind)) + call pio_setframe(ncid,vardesc, int(nt,kind=PIO_OFFSET_KIND)) end if call pio_read_darray(ncid, vardesc, iodesc_plus%iodesc, idata, status) data = (idata == 1) @@ -1673,7 +1670,7 @@ subroutine ncd_io_log_var1(varname, data, dim1name, & xtype, iodnum) iodesc_plus => iodesc_list(iodnum) if (present(nt)) then - call pio_setframe(ncid, vardesc, int(nt,kind=PIO_Offset_kind)) + call pio_setframe(ncid, vardesc, int(nt,kind=PIO_OFFSET_KIND)) end if allocate( idata(size(data)) ) where( data ) @@ -1704,7 +1701,6 @@ subroutine ncd_io_real_var1(varname, data, dim1name, & ! I/O for 1d real field ! ! !ARGUMENTS: - implicit none type(file_desc_t),intent(inout) :: ncid ! netcdf file id character(len=*), intent(in) :: flag ! 'read' or 'write' character(len=*), intent(in) :: varname ! variable name @@ -1712,8 +1708,9 @@ subroutine ncd_io_real_var1(varname, data, dim1name, & character(len=*), intent(in) :: dim1name ! dimension name integer , optional, intent(in) :: nt ! time sample index logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + ! ! !LOCAL VARIABLES: - character(len=32) :: dimname ! temporary + character(len=CS) :: dimname ! temporary integer :: iodnum ! iodesc num in list integer :: varid ! varid integer :: ndims ! ndims for var @@ -1755,7 +1752,7 @@ subroutine ncd_io_real_var1(varname, data, dim1name, & xtype, iodnum) iodesc_plus => iodesc_list(iodnum) if (present(nt)) then - call pio_setframe(ncid, vardesc, int(nt,kind=PIO_Offset_kind)) + call pio_setframe(ncid, vardesc, int(nt,kind=PIO_OFFSET_KIND)) end if call pio_read_darray(ncid, vardesc, iodesc_plus%iodesc, data, status) end if @@ -1780,7 +1777,7 @@ subroutine ncd_io_real_var1(varname, data, dim1name, & xtype, iodnum) iodesc_plus => iodesc_list(iodnum) if (present(nt)) then - call pio_setframe(ncid,vardesc, int(nt,kind=PIO_Offset_kind)) + call pio_setframe(ncid,vardesc, int(nt,kind=PIO_OFFSET_KIND)) end if if(xtype == ncd_float) then call shr_sys_abort( subname//' error: Attempt to write out single-precision data which is current NOT implemented (see issue #18)' ) @@ -1818,9 +1815,9 @@ subroutine ncd_getiodesc(ncid, ndims, dims, dimids, xtype, iodnum) integer :: status ! error status logical :: found ! true => found created iodescriptor integer :: ndims_file ! temporary - character(len=64) dimname_file ! dimension name on file - character(len=64) dimname_iodesc ! dimension name from io descriptor - character(len=32) :: subname = 'ncd_getiodesc' + character(len=CS) dimname_file ! dimension name on file + character(len=CS) dimname_iodesc ! dimension name from io descriptor + character(len=CS) :: subname = 'ncd_getiodesc' !------------------------------------------------------------------------ ! Determining if need to create a new io descriptor @@ -1841,13 +1838,13 @@ subroutine ncd_getiodesc(ncid, ndims, dims, dimids, xtype, iodnum) ! names associated with that iodescriptor if (found) then do m = 1,ndims - status = PIO_inq_dimname(ncid,dimids(m),dimname_file) - status = PIO_inquire(ncid, ndimensions=ndims_file) + status = pio_inq_dimname(ncid,dimids(m),dimname_file) + status = pio_inquire(ncid, ndimensions=ndims_file) if (iodesc_list(n)%dimids(m) > ndims_file) then found = .false. exit else - status = PIO_inq_dimname(ncid,iodesc_list(n)%dimids(m),dimname_iodesc) + status = pio_inq_dimname(ncid,iodesc_list(n)%dimids(m),dimname_iodesc) if (trim(dimname_file) .ne. trim(dimname_iodesc)) then found = .false. exit @@ -1900,8 +1897,8 @@ subroutine getdatetime (cdate, ctime) ! Get date and time ! ! Arguments - character(len=8), intent(out) :: cdate !current date - character(len=8), intent(out) :: ctime !current time + character(len=*), intent(out) :: cdate !current date + character(len=*), intent(out) :: ctime !current time ! ! Local variables character(len=8) :: date !current date From 46fa3c73efe87a9370519ba03414f229f431f350 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 2 Jan 2024 13:08:05 +0100 Subject: [PATCH 20/86] removed most hard-wired character lengths in mostart_histfile.F90 --- src/riverroute/mosart_histfile.F90 | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/riverroute/mosart_histfile.F90 b/src/riverroute/mosart_histfile.F90 index c1ee1a6..edad54b 100644 --- a/src/riverroute/mosart_histfile.F90 +++ b/src/riverroute/mosart_histfile.F90 @@ -2,7 +2,7 @@ module mosart_histfile ! Module containing methods to for MOSART history file handling. - use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_kind_mod , only : r8=>shr_kind_r8, CL=>shr_kind_cl, CS=>shr_kind_cs use shr_sys_mod , only : shr_sys_abort use shr_log_mod , only : errMsg => shr_log_errMsg use mosart_vars , only : spval, ispval, secspday, frivinp, & @@ -84,7 +84,7 @@ module mosart_histfile ! Subscript dimensions ! integer, parameter :: max_subs = 100 ! max number of subscripts - character(len=32) :: subs_name(max_subs) ! name of subscript + character(len=CS) :: subs_name(max_subs) ! name of subscript integer :: subs_dim(max_subs) ! dimension of subscript ! ! Derived types @@ -587,9 +587,9 @@ subroutine htape_create (t, histrest) type(file_desc_t), pointer :: lnfid ! local file id character(len= 8) :: curdate ! current date character(len= 8) :: curtime ! current time - character(len=256) :: name ! name of attribute - character(len=256) :: units ! units of attribute - character(len=256) :: str ! global attribute string + character(len= CL) :: name ! name of attribute + character(len= CL) :: units ! units of attribute + character(len= CL) :: str ! global attribute string character(len= 1) :: avgflag ! time averaging flag character(len=*),parameter :: subname = 'htape_create' !----------------------------------------------------- @@ -731,7 +731,7 @@ subroutine htape_timeconst(t, mode) character(len=max_namlen):: units ! variable units character(len=max_namlen):: cal ! calendar type from time-manager character(len=max_namlen):: caldesc ! calendar description to put on file - character(len=256):: str ! global attribute string + character(len= CL):: str ! global attribute string integer :: status character(len=*),parameter :: subname = 'htape_timeconst' !-------------------------------------------------------- @@ -877,12 +877,12 @@ subroutine mosart_hist_HtapesWrapup( rstwr, nlend ) integer :: yrm1 ! nstep-1 year (0 -> ...) integer :: mcsecm1 ! nstep-1 time of day [seconds] real(r8):: time ! current time - character(len=256):: str ! global attribute string + character(len= CL):: str ! global attribute string character(len=1) :: avgflag ! averaging flag real(r8), pointer :: histo(:) ! temporary real(r8), pointer :: hbuf(:) ! history buffer integer , pointer :: nacs(:) ! accumulation counter - character(len=32) :: avgstr ! time averaging type + character(len=CS) :: avgstr ! time averaging type character(len=max_chars) :: long_name ! long name character(len=max_chars) :: units ! units character(len=max_namlen):: varname ! variable name @@ -1576,7 +1576,7 @@ character(len=max_length_filename) function set_hist_filename (hist_freq, mfilt, integer, intent(in) :: hist_file !history file index ! !LOCAL VARIABLES: - character(len=256) :: cdate !date char string + character(len= CL) :: cdate !date char string character(len= 1) :: hist_index !p,1 or 2 (currently) integer :: day !day (1 -> 31) integer :: mon !month (1 -> 12) From e0205916d57c4df0a48b16ac44cdd318f015b5a0 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 2 Jan 2024 14:06:50 +0100 Subject: [PATCH 21/86] fixed issue with adding use only for mosart_io in mosart_histfile.F90 --- src/riverroute/mosart_histfile.F90 | 60 ++++++----- src/riverroute/mosart_io.F90 | 153 ++++++++++++++--------------- src/riverroute/mosart_restfile.F90 | 9 +- 3 files changed, 115 insertions(+), 107 deletions(-) diff --git a/src/riverroute/mosart_histfile.F90 b/src/riverroute/mosart_histfile.F90 index edad54b..bb2cabc 100644 --- a/src/riverroute/mosart_histfile.F90 +++ b/src/riverroute/mosart_histfile.F90 @@ -2,19 +2,24 @@ module mosart_histfile ! Module containing methods to for MOSART history file handling. - use shr_kind_mod , only : r8=>shr_kind_r8, CL=>shr_kind_cl, CS=>shr_kind_cs - use shr_sys_mod , only : shr_sys_abort - use shr_log_mod , only : errMsg => shr_log_errMsg - use mosart_vars , only : spval, ispval, secspday, frivinp, & + use shr_kind_mod, only : r8 => shr_kind_r8, CS => shr_kind_cs, CL => shr_kind_cl + use shr_sys_mod, only : shr_sys_abort + use shr_log_mod, only : errMsg => shr_log_errMsg + use mosart_vars, only : spval, ispval, secspday, frivinp, & iulog, nsrest, caseid, inst_suffix, nsrStartup, nsrBranch, & ctitle, version, hostname, username, conventions, source, & model_doi_url, mainproc, isecspday - use mosart_data , only : ctl, Tunit + use mosart_data, only : ctl, Tunit use mosart_fileutils, only : get_filename, getfil use mosart_timemanager, only : get_nstep, get_curr_date, get_curr_time, get_ref_date, & get_prev_time, get_prev_date, get_step_size, & get_calendar, NO_LEAP_C, GREGORIAN_C - use mosart_io + use pio, only : file_desc_t, var_desc_t + use mosart_io, only : ncd_pio_createfile, ncd_putatt, ncd_global, ncd_defdim, ncd_defvar, & + ncd_io, ncd_enddef, ncd_pio_closefile, ncd_pio_openfile, & + ncd_inqvid, ncd_inqdlen, ncd_nowrite, ncd_write, & + ncd_double, ncd_float, ncd_int, ncd_char, ncd_log, ncd_unlimited, & + ncd_getdatetime implicit none private @@ -84,7 +89,7 @@ module mosart_histfile ! Subscript dimensions ! integer, parameter :: max_subs = 100 ! max number of subscripts - character(len=CS) :: subs_name(max_subs) ! name of subscript + character(len=32) :: subs_name(max_subs) ! name of subscript integer :: subs_dim(max_subs) ! dimension of subscript ! ! Derived types @@ -585,12 +590,12 @@ subroutine htape_create (t, histrest) integer :: sec_hist_nhtfrq ! nhtfrq converted to seconds logical :: lhistrest ! local history restart flag type(file_desc_t), pointer :: lnfid ! local file id - character(len= 8) :: curdate ! current date - character(len= 8) :: curtime ! current time - character(len= CL) :: name ! name of attribute - character(len= CL) :: units ! units of attribute - character(len= CL) :: str ! global attribute string - character(len= 1) :: avgflag ! time averaging flag + character(len= 8) :: curdate ! current date + character(len= 8) :: curtime ! current time + character(len=CL) :: name ! name of attribute + character(len=CL) :: units ! units of attribute + character(len=CL) :: str ! global attribute string + character(len= 1) :: avgflag ! time averaging flag character(len=*),parameter :: subname = 'htape_create' !----------------------------------------------------- @@ -633,7 +638,7 @@ subroutine htape_create (t, histrest) ! data set as a whole, as opposed to a single variable call ncd_putatt(lnfid, ncd_global, 'Conventions', trim(conventions)) - call getdatetime(curdate, curtime) + call ncd_getdatetime(curdate, curtime) str = 'created on ' // curdate // ' ' // curtime call ncd_putatt(lnfid, ncd_global, 'history' , trim(str)) call ncd_putatt(lnfid, ncd_global, 'source' , trim(source)) @@ -641,12 +646,16 @@ subroutine htape_create (t, histrest) call ncd_putatt(lnfid, ncd_global, 'username' , trim(username)) call ncd_putatt(lnfid, ncd_global, 'version' , trim(version)) call ncd_putatt(lnfid, ncd_global, 'model_doi_url', trim(model_doi_url)) + write(6,*)'DEBUG: I am here7' call ncd_putatt(lnfid, ncd_global, 'case_title', trim(ctitle)) + write(6,*)'DEBUG: I am here8' call ncd_putatt(lnfid, ncd_global, 'case_id', trim(caseid)) + write(6,*)'DEBUG: I am here9' str = get_filename(frivinp) call ncd_putatt(lnfid, ncd_global, 'input_dataset', trim(str)) + write(6,*)'DEBUG: I am here10' ! ! add global attribute time_period_freq @@ -672,6 +681,7 @@ subroutine htape_create (t, histrest) 999 format(a,i0) call ncd_putatt(lnfid, ncd_global, 'time_period_freq', trim(time_period_freq)) + write(6,*)'DEBUG: I am here6' ! Define dimensions. ! Time is an unlimited dimension. Character string is treated as an array of characters. @@ -681,10 +691,12 @@ subroutine htape_create (t, histrest) call ncd_defdim(lnfid, 'lat' , ctl%nlat , dimid) call ncd_defdim(lnfid, 'allrof', ctl%numr , dimid) call ncd_defdim(lnfid, 'string_length', 8, strlen_dimid) + write(6,*)'DEBUG: I am here7' if ( .not. lhistrest )then call ncd_defdim(lnfid, 'hist_interval', 2, hist_interval_dimid) call ncd_defdim(lnfid, 'time', ncd_unlimited, time_dimid) + write(6,*)'DEBUG: I am here8' if (mainproc)then write(iulog,*) trim(subname),' : Successfully defined netcdf history file ',t end if @@ -731,7 +743,7 @@ subroutine htape_timeconst(t, mode) character(len=max_namlen):: units ! variable units character(len=max_namlen):: cal ! calendar type from time-manager character(len=max_namlen):: caldesc ! calendar description to put on file - character(len= CL):: str ! global attribute string + character(len=CL):: str ! global attribute string integer :: status character(len=*),parameter :: subname = 'htape_timeconst' !-------------------------------------------------------- @@ -815,7 +827,7 @@ subroutine htape_timeconst(t, mode) timedata(2) = time call ncd_io('time_bounds', timedata, 'write', nfid(t), nt=tape(t)%ntimes) - call getdatetime (cdate, ctime) + call ncd_getdatetime (cdate, ctime) call ncd_io('date_written', cdate, 'write', nfid(t), nt=tape(t)%ntimes) call ncd_io('time_written', ctime, 'write', nfid(t), nt=tape(t)%ntimes) @@ -877,12 +889,12 @@ subroutine mosart_hist_HtapesWrapup( rstwr, nlend ) integer :: yrm1 ! nstep-1 year (0 -> ...) integer :: mcsecm1 ! nstep-1 time of day [seconds] real(r8):: time ! current time - character(len= CL):: str ! global attribute string + character(len=CL) :: str ! global attribute string character(len=1) :: avgflag ! averaging flag real(r8), pointer :: histo(:) ! temporary real(r8), pointer :: hbuf(:) ! history buffer integer , pointer :: nacs(:) ! accumulation counter - character(len=CS) :: avgstr ! time averaging type + character(len=32) :: avgstr ! time averaging type character(len=max_chars) :: long_name ! long name character(len=max_chars) :: units ! units character(len=max_namlen):: varname ! variable name @@ -1576,12 +1588,12 @@ character(len=max_length_filename) function set_hist_filename (hist_freq, mfilt, integer, intent(in) :: hist_file !history file index ! !LOCAL VARIABLES: - character(len= CL) :: cdate !date char string - character(len= 1) :: hist_index !p,1 or 2 (currently) - integer :: day !day (1 -> 31) - integer :: mon !month (1 -> 12) - integer :: yr !year (0 -> ...) - integer :: sec !seconds into current day + character(len=CL) :: cdate !date char string + character(len= 1) :: hist_index !p,1 or 2 (currently) + integer :: day !day (1 -> 31) + integer :: mon !month (1 -> 12) + integer :: yr !year (0 -> ...) + integer :: sec !seconds into current day integer :: filename_length character(len=*),parameter :: subname = 'set_hist_filename' diff --git a/src/riverroute/mosart_io.F90 b/src/riverroute/mosart_io.F90 index b2c89cd..3dac3b1 100644 --- a/src/riverroute/mosart_io.F90 +++ b/src/riverroute/mosart_io.F90 @@ -46,7 +46,7 @@ module mosart_io public :: ncd_inqvdims ! inquire variable ndims public :: ncd_inqvdids ! inquire variable dimids public :: ncd_io ! write local data - public :: getdatetime + public :: ncd_getdatetime ! get date and time integer, parameter, public :: ncd_int = pio_int integer, parameter, public :: ncd_log =-pio_int @@ -61,11 +61,6 @@ module mosart_io integer, parameter, public :: ncd_nofill = pio_nofill integer, parameter, public :: ncd_unlimited = pio_unlimited - ! PIO types needed for ncdio_pio interface calls - public :: file_desc_t - public :: var_desc_t - public :: io_desc_t - ! !PRIVATE MEMBER FUNCTIONS: interface ncd_putatt module procedure ncd_putatt_int @@ -135,10 +130,10 @@ subroutine ncd_pio_init(rofid) !----------------------------------------------------------------------- ! Initialize mosart pio ! - ! !ARGUMENTS: + ! Arguments integer, intent(in) :: rofid - ! !LOCAL VARIABLES: + ! Local variables character(len=*),parameter :: subname='ncd_pio_init' ! subroutine name !----------------------------------------------------------------------- @@ -196,12 +191,12 @@ subroutine ncd_pio_openfile(file, fname, mode) !----------------------------------------------------------------------- ! Open a NetCDF PIO file ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(inout) :: file ! Output PIO file handle character(len=*) , intent(in) :: fname ! Input filename to open integer , intent(in) :: mode ! file mode - ! !LOCAL VARIABLES: + ! Local variables integer :: ierr character(len=*),parameter :: subname='ncd_pio_openfile' ! subroutine name !----------------------------------------------------------------------- @@ -223,7 +218,7 @@ subroutine ncd_pio_closefile(file) !----------------------------------------------------------------------- ! Close a NetCDF PIO file ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(inout) :: file ! PIO file handle to close !----------------------------------------------------------------------- @@ -238,11 +233,11 @@ subroutine ncd_pio_createfile(file, fname) !----------------------------------------------------------------------- ! Create a new NetCDF file with PIO ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(inout) :: file ! PIO file descriptor character(len=*), intent(in) :: fname ! File name to create - ! !LOCAL VARIABLES: + ! Local variables integer :: ierr integer :: iomode character(len=*),parameter :: subname='ncd_pio_createfile' ! subroutine name @@ -270,14 +265,14 @@ subroutine check_var(ncid, varname, vardesc, readvar, print_err ) !----------------------------------------------------------------------- ! Check if variable is on netcdf file ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(inout) :: ncid ! PIO file descriptor character(len=*) , intent(in) :: varname ! Varible name to check type(Var_desc_t) , intent(out) :: vardesc ! Output variable descriptor logical , intent(out) :: readvar ! If variable exists or not logical, optional, intent(in) :: print_err ! If should print about error - ! !LOCAL VARIABLES: + ! Local variables integer :: ret ! return value logical :: log_err ! if should log error character(len=*),parameter :: subname='check_var' ! subroutine name @@ -307,12 +302,12 @@ subroutine check_dim(ncid, dimname, value) ! Validity check on dimension ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t),intent(in) :: ncid ! PIO file handle character(len=*), intent(in) :: dimname ! Dimension name integer, intent(in) :: value ! Expected dimension size - ! !LOCAL VARIABLES: + ! Local variables integer :: dimid, dimlen ! temporaries integer :: status ! error code character(len=*),parameter :: subname='check_dim' ! subroutine name @@ -335,10 +330,10 @@ subroutine ncd_enddef(ncid) !----------------------------------------------------------------------- ! enddef netcdf file ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t),intent(inout) :: ncid ! netcdf file id - ! !LOCAL VARIABLES: + ! Local variables integer :: status ! error status character(len=*),parameter :: subname='ncd_enddef' ! subroutine name !----------------------------------------------------------------------- @@ -354,13 +349,13 @@ subroutine ncd_inqdid(ncid,name,dimid,dimexist) !----------------------------------------------------------------------- ! inquire on a dimension id ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t),intent(inout) :: ncid ! netcdf file id character(len=*), intent(in) :: name ! dimension name integer , intent(out):: dimid ! dimension id logical,optional, intent(out):: dimexist ! if this dimension exists or not - ! !LOCAL VARIABLES: + ! Local variables integer :: status !----------------------------------------------------------------------- @@ -386,13 +381,13 @@ subroutine ncd_inqdlen(ncid,dimid,len,name) !----------------------------------------------------------------------- ! enddef netcdf file ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(inout) :: ncid ! netcdf file id integer , intent(inout) :: dimid ! dimension id integer , intent(out) :: len ! dimension len character(len=*), optional, intent(in) :: name ! dimension name ! - ! !LOCAL VARIABLES: + ! Local variables integer :: status !----------------------------------------------------------------------- @@ -411,12 +406,12 @@ subroutine ncd_inqdname(ncid,dimid,dname) !----------------------------------------------------------------------- ! inquire dim name ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(in) :: ncid ! netcdf file id integer , intent(in) :: dimid ! dimension id character(len=*) , intent(out):: dname ! dimension name - ! !LOCAL VARIABLES: + ! Local variables integer :: status !----------------------------------------------------------------------- @@ -429,13 +424,13 @@ end subroutine ncd_inqdname subroutine ncd_inqfdims(ncid, isgrid2d, ni, nj, ns) !----------------------------------------------------------------------- - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(inout):: ncid logical , intent(out) :: isgrid2d integer , intent(out) :: ni integer , intent(out) :: nj integer , intent(out) :: ns - ! !LOCAL VARIABLES: + ! Local variables integer :: dimid ! netCDF id integer :: ier ! error status character(len=CS) :: subname = 'surfrd_filedims' ! subroutine name @@ -490,14 +485,14 @@ subroutine ncd_inqvid(ncid,name,varid,vardesc,readvar) !----------------------------------------------------------------------- ! Inquire on a variable ID ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: name ! variable name integer , intent(out) :: varid ! variable id type(Var_desc_t) , intent(out) :: vardesc ! variable descriptor logical, optional, intent(out) :: readvar ! does variable exist - ! !LOCAL VARIABLES: + ! Local variables integer :: ret ! return code character(len=*),parameter :: subname='ncd_inqvid' ! subroutine name !----------------------------------------------------------------------- @@ -527,12 +522,12 @@ subroutine ncd_inqvdims(ncid,ndims,vardesc) !----------------------------------------------------------------------- ! inquire variable dimensions ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(in) :: ncid ! netcdf file id integer , intent(out) :: ndims ! variable ndims type(Var_desc_t) , intent(inout):: vardesc ! variable descriptor ! - ! !LOCAL VARIABLES: + ! Local variables integer :: status !----------------------------------------------------------------------- @@ -548,13 +543,13 @@ subroutine ncd_inqvname(ncid,varid,vname,vardesc) !----------------------------------------------------------------------- ! inquire variable name ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(in) :: ncid ! netcdf file id integer , intent(in) :: varid ! variable id character(len=*) , intent(out) :: vname ! variable vname type(Var_desc_t) , intent(inout):: vardesc ! variable descriptor - ! !LOCAL VARIABLES: + ! Local variables integer :: status !----------------------------------------------------------------------- @@ -570,12 +565,12 @@ subroutine ncd_inqvdids(ncid,dids,vardesc) !----------------------------------------------------------------------- ! inquire variable dimension ids ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t),intent(in) :: ncid ! netcdf file id integer ,intent(out) :: dids(:) ! variable dids type(Var_desc_t),intent(inout):: vardesc ! variable descriptor - ! !LOCAL VARIABLES: + ! Local variables integer :: status !----------------------------------------------------------------------- @@ -590,14 +585,14 @@ subroutine ncd_putatt_int(ncid,varid,attrib,value,xtype) !----------------------------------------------------------------------- ! put integer attributes ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t),intent(inout) :: ncid ! netcdf file id integer ,intent(in) :: varid ! netcdf var id character(len=*) ,intent(in) :: attrib ! netcdf attrib integer ,intent(in) :: value ! netcdf attrib value integer,optional ,intent(in) :: xtype ! netcdf data type ! - ! !LOCAL VARIABLES: + ! Local variables integer :: status !----------------------------------------------------------------------- @@ -612,14 +607,14 @@ subroutine ncd_putatt_char(ncid,varid,attrib,value,xtype) !----------------------------------------------------------------------- ! put character attributes ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t),intent(inout) :: ncid ! netcdf file id integer ,intent(in) :: varid ! netcdf var id character(len=*) ,intent(in) :: attrib ! netcdf attrib character(len=*) ,intent(in) :: value ! netcdf attrib value integer,optional ,intent(in) :: xtype ! netcdf data type ! - ! !LOCAL VARIABLES: + ! Local variables integer :: status !----------------------------------------------------------------------- @@ -634,14 +629,14 @@ subroutine ncd_putatt_real(ncid,varid,attrib,value,xtype) !----------------------------------------------------------------------- ! put real attributes ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t),intent(inout) :: ncid ! netcdf file id integer ,intent(in) :: varid ! netcdf var id character(len=*) ,intent(in) :: attrib ! netcdf attrib real(r8) ,intent(in) :: value ! netcdf attrib value integer ,intent(in) :: xtype ! netcdf data type ! - ! !LOCAL VARIABLES: + ! Local variables integer :: status real(r4) :: value4 !----------------------------------------------------------------------- @@ -663,13 +658,13 @@ subroutine ncd_defdim(ncid,attrib,value,dimid) !----------------------------------------------------------------------- ! define dimension ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(in) :: ncid ! netcdf file id character(len=*) , intent(in) :: attrib ! netcdf attrib integer , intent(in) :: value ! netcdf attrib value integer , intent(out):: dimid ! netcdf dimension id ! - ! !LOCAL VARIABLES: + ! Local variables integer :: status !----------------------------------------------------------------------- @@ -687,7 +682,7 @@ subroutine ncd_defvar_bynf(ncid, varname, xtype, ndims, dimid, varid, & !----------------------------------------------------------------------- ! Define a netcdf variable ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: varname ! variable name integer , intent(in) :: xtype ! external type @@ -707,7 +702,7 @@ subroutine ncd_defvar_bynf(ncid, varname, xtype, ndims, dimid, varid, & integer , intent(in), optional :: nvalid_range(2) ! attribute for int ! - ! !LOCAL VARIABLES: + ! Local variables integer :: n ! indices integer :: ldimid(4) ! local dimid integer :: dimid0(1) ! local dimid @@ -829,7 +824,7 @@ subroutine ncd_defvar_bygrid(ncid, varname, xtype, & !------------------------------------------------------------------------ ! Define a netcdf variable ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*), intent(in) :: varname ! variable name integer , intent(in) :: xtype ! external type @@ -853,7 +848,7 @@ subroutine ncd_defvar_bygrid(ncid, varname, xtype, & ! !REVISION HISTORY: ! ! - ! !LOCAL VARIABLES: + ! Local variables !EOP integer :: n ! indices integer :: ndims ! dimension counter @@ -898,7 +893,7 @@ subroutine ncd_io_log_var0_nf(varname, data, flag, ncid, readvar, nt) !------------------------------------------------------------------------ ! netcdf I/O of global integer variable ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: flag ! 'read' or 'write' character(len=*) , intent(in) :: varname ! variable name @@ -906,7 +901,7 @@ subroutine ncd_io_log_var0_nf(varname, data, flag, ncid, readvar, nt) logical, optional, intent(out) :: readvar ! was var read? integer, optional, intent(in) :: nt ! time sample index ! - ! !LOCAL VARIABLES: + ! Local variables integer :: varid ! netCDF variable id integer :: start(1), count(1) ! output bounds integer :: status ! error code @@ -961,7 +956,7 @@ subroutine ncd_io_int_var0_nf(varname, data, flag, ncid, readvar, nt) !------------------------------------------------------------------------ ! netcdf I/O of global integer variable ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: flag ! 'read' or 'write' character(len=*) , intent(in) :: varname ! variable name @@ -969,7 +964,7 @@ subroutine ncd_io_int_var0_nf(varname, data, flag, ncid, readvar, nt) logical, optional, intent(out) :: readvar ! was var read? integer, optional, intent(in) :: nt ! time sample index ! - ! !LOCAL VARIABLES: + ! Local variables integer :: varid ! netCDF variable id integer :: start(1), count(1) ! output bounds integer :: status ! error code @@ -1011,7 +1006,7 @@ subroutine ncd_io_real_var0_nf(varname, data, flag, ncid, readvar, nt) !------------------------------------------------------------------------ ! netcdf I/O of global real variable ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: flag ! 'read' or 'write' character(len=*) , intent(in) :: varname ! variable name @@ -1019,7 +1014,7 @@ subroutine ncd_io_real_var0_nf(varname, data, flag, ncid, readvar, nt) logical, optional, intent(out) :: readvar ! was var read? integer, optional, intent(in) :: nt ! time sample index ! - ! !LOCAL VARIABLES: + ! Local variables integer :: varid ! netCDF variable id integer :: start(1), count(1) ! output bounds integer :: status ! error code @@ -1061,7 +1056,7 @@ subroutine ncd_io_int_var1_nf(varname, data, flag, ncid, readvar, nt) !------------------------------------------------------------------------ ! netcdf I/O of global integer array ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: flag ! 'read' or 'write' character(len=*) , intent(in) :: varname ! variable name @@ -1069,7 +1064,7 @@ subroutine ncd_io_int_var1_nf(varname, data, flag, ncid, readvar, nt) logical, optional, intent(out) :: readvar ! was var read? integer, optional, intent(in) :: nt ! time sample index ! - ! !LOCAL VARIABLES: + ! Local variables integer :: varid ! netCDF variable id integer :: start(2), count(2) ! output bounds integer :: status ! error code @@ -1117,7 +1112,7 @@ subroutine ncd_io_log_var1_nf(varname, data, flag, ncid, readvar, nt) !------------------------------------------------------------------------ ! netcdf I/O of global integer array ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: flag ! 'read' or 'write' character(len=*) , intent(in) :: varname ! variable name @@ -1125,7 +1120,7 @@ subroutine ncd_io_log_var1_nf(varname, data, flag, ncid, readvar, nt) logical, optional, intent(out) :: readvar ! was var read? integer, optional, intent(in) :: nt ! time sample index ! - ! !LOCAL VARIABLES: + ! Local variables integer :: varid ! netCDF variable id integer :: start(2), count(2) ! output bounds integer :: status ! error code @@ -1184,7 +1179,7 @@ subroutine ncd_io_real_var1_nf(varname, data, flag, ncid, readvar, nt) !------------------------------------------------------------------------ ! netcdf I/O of global real array ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: flag ! 'read' or 'write' character(len=*) , intent(in) :: varname ! variable name @@ -1192,7 +1187,7 @@ subroutine ncd_io_real_var1_nf(varname, data, flag, ncid, readvar, nt) logical , optional, intent(out):: readvar ! was var read? integer , optional, intent(in) :: nt ! time sample index ! - ! !LOCAL VARIABLES: + ! Local variables integer :: varid ! netCDF variable id integer :: start(2), count(2) ! output bounds integer :: status ! error code @@ -1240,7 +1235,7 @@ subroutine ncd_io_char_var1_nf(varname, data, flag, ncid, readvar, nt ) !------------------------------------------------------------------------ ! netcdf I/O of global char array ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: flag ! 'read' or 'write' character(len=*) , intent(in) :: varname ! variable name @@ -1248,7 +1243,7 @@ subroutine ncd_io_char_var1_nf(varname, data, flag, ncid, readvar, nt ) logical , optional, intent(out):: readvar ! was var read? integer , optional, intent(in) :: nt ! time sample index ! - ! !LOCAL VARIABLES: + ! Local variables integer :: varid ! netCDF variable id integer :: m ! indices integer :: status ! error code @@ -1288,7 +1283,7 @@ subroutine ncd_io_int_var2_nf(varname, data, flag, ncid, readvar, nt) !------------------------------------------------------------------------ ! netcdf I/O of global integer 2D array ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: flag ! 'read' or 'write' character(len=*) , intent(in) :: varname ! variable name @@ -1296,7 +1291,7 @@ subroutine ncd_io_int_var2_nf(varname, data, flag, ncid, readvar, nt) logical , optional, intent(out):: readvar ! was var read? integer , optional, intent(in) :: nt ! time sample index ! - ! !LOCAL VARIABLES: + ! Local variables integer :: varid ! netCDF variable id integer :: start(3), count(3) ! output bounds integer :: status ! error code @@ -1349,7 +1344,7 @@ subroutine ncd_io_real_var2_nf(varname, data, flag, ncid, readvar, nt) !------------------------------------------------------------------------ ! netcdf I/O of global real 2D array ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t),intent(inout) :: ncid ! netcdf file id character(len=*), intent(in) :: flag ! 'read' or 'write' character(len=*), intent(in) :: varname ! variable name @@ -1357,7 +1352,7 @@ subroutine ncd_io_real_var2_nf(varname, data, flag, ncid, readvar, nt) logical , optional, intent(out):: readvar ! was var read? integer , optional, intent(in) :: nt ! time sample index ! - ! !LOCAL VARIABLES: + ! Local variables integer :: varid ! netCDF variable id integer :: start(3), count(3) ! output bounds integer :: status ! error code @@ -1407,7 +1402,7 @@ subroutine ncd_io_char_var2_nf(varname, data, flag, ncid, readvar, nt) !------------------------------------------------------------------------ ! netcdf I/O of global character array ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t),intent(inout) :: ncid ! netcdf file id character(len=*), intent(in) :: flag ! 'read' or 'write' character(len=*), intent(in) :: varname ! variable name @@ -1415,7 +1410,7 @@ subroutine ncd_io_char_var2_nf(varname, data, flag, ncid, readvar, nt) logical , optional, intent(out):: readvar ! was var read? integer , optional, intent(in) :: nt ! time sample index ! - ! !LOCAL VARIABLES: + ! Local variables integer :: varid ! netCDF variable id integer :: start(3), count(3) ! output bounds integer :: status ! error code @@ -1459,14 +1454,14 @@ subroutine ncd_io_char_varn_strt_nf(vardesc, data, flag, ncid, start ) ! netcdf I/O of global character array with start indices input ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t),intent(inout) :: ncid ! netcdf file id character(len=*), intent(in) :: flag ! 'read' or 'write' type(var_desc_t), intent(in) :: vardesc ! local vardesc pointer character(len=*), intent(inout) :: data ! raw data for this index integer , intent(in) :: start(:) ! output bounds ! - ! !LOCAL VARIABLES: + ! Local variables integer :: status ! error code character(len=*),parameter :: subname='ncd_io_char_varn_strt_nf' !----------------------------------------------------------------------- @@ -1486,7 +1481,7 @@ subroutine ncd_io_int_var1(varname, data, dim1name, flag, ncid, nt, readvar) !----------------------------------------------------------------------- ! I/O for 1d integer field ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: flag ! 'read' or 'write' character(len=*) , intent(in) :: varname ! variable name @@ -1495,7 +1490,7 @@ subroutine ncd_io_int_var1(varname, data, dim1name, flag, ncid, nt, readvar) integer , optional, intent(in) :: nt ! time sample index logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) ! - ! !LOCAL VARIABLES: + ! Local variables character(len=CS) :: dimname ! temporary integer :: n ! index integer :: iodnum ! iodesc num in list @@ -1586,7 +1581,7 @@ subroutine ncd_io_log_var1(varname, data, dim1name, & !----------------------------------------------------------------------- ! I/O for 1d integer field ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(inout) :: ncid ! netcdf file id character(len=*) , intent(in) :: flag ! 'read' or 'write' character(len=*) , intent(in) :: varname ! variable name @@ -1595,7 +1590,7 @@ subroutine ncd_io_log_var1(varname, data, dim1name, & integer , optional, intent(in) :: nt ! time sample index logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) ! - ! !LOCAL VARIABLES: + ! Local variables character(len=CS) :: dimname ! temporary integer :: n ! index integer :: iodnum ! iodesc num in list @@ -1700,7 +1695,7 @@ subroutine ncd_io_real_var1(varname, data, dim1name, & !----------------------------------------------------------------------- ! I/O for 1d real field ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t),intent(inout) :: ncid ! netcdf file id character(len=*), intent(in) :: flag ! 'read' or 'write' character(len=*), intent(in) :: varname ! variable name @@ -1709,7 +1704,7 @@ subroutine ncd_io_real_var1(varname, data, dim1name, & integer , optional, intent(in) :: nt ! time sample index logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) ! - ! !LOCAL VARIABLES: + ! Local variables character(len=CS) :: dimname ! temporary integer :: iodnum ! iodesc num in list integer :: varid ! varid @@ -1802,7 +1797,7 @@ subroutine ncd_getiodesc(ncid, ndims, dims, dimids, xtype, iodnum) !------------------------------------------------------------------------ ! Returns an index to an io descriptor ! - ! !ARGUMENTS: + ! Arguments type(file_desc_t), intent(inout) :: ncid ! PIO file descriptor integer , intent(in) :: ndims ! ndims for var integer , intent(in) :: dims(:) ! dim sizes @@ -1810,7 +1805,7 @@ subroutine ncd_getiodesc(ncid, ndims, dims, dimids, xtype, iodnum) integer , intent(in) :: xtype ! file external type integer , intent(out) :: iodnum ! iodesc num in list - ! !LOCAL VARIABLES: + ! Local variables integer :: k,m,n ! indices integer :: status ! error status logical :: found ! true => found created iodescriptor @@ -1892,7 +1887,7 @@ end subroutine ncd_getiodesc !----------------------------------------------------------------------- - subroutine getdatetime (cdate, ctime) + subroutine ncd_getdatetime (cdate, ctime) ! ! Get date and time ! @@ -1927,6 +1922,6 @@ subroutine getdatetime (cdate, ctime) 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 subroutine ncd_getdatetime end module mosart_io diff --git a/src/riverroute/mosart_restfile.F90 b/src/riverroute/mosart_restfile.F90 index b208f5d..3e5c39d 100644 --- a/src/riverroute/mosart_restfile.F90 +++ b/src/riverroute/mosart_restfile.F90 @@ -12,7 +12,8 @@ module mosart_restfile use mosart_fileutils, only : getfil use mosart_timemanager, only : timemgr_restart, get_nstep, get_curr_date use mosart_io, only : ncd_pio_createfile, ncd_enddef, ncd_pio_openfile, ncd_pio_closefile, & - ncd_defdim, ncd_putatt, ncd_defvar, ncd_io, ncd_global, ncd_double + ncd_defdim, ncd_putatt, ncd_defvar, ncd_io, ncd_global, ncd_double, & + ncd_getdatetime use pio, only : file_desc_t implicit none @@ -317,8 +318,8 @@ subroutine restFile_dimset( ncid ) ! Local Variables: integer :: dimid ! netCDF dimension id integer :: ier ! error status - character(len=CS) :: curdate ! current date - character(len=CS) :: curtime ! current time + character(len= 8) :: curdate ! current date + character(len= 8) :: curtime ! current time character(len=CL) :: str character(len=*),parameter :: subname='restFile_dimset' !------------------------------------- @@ -332,7 +333,7 @@ subroutine restFile_dimset( ncid ) ! Define global attributes call ncd_putatt(ncid, NCD_GLOBAL, 'Conventions', trim(conventions)) - call getdatetime(curdate, curtime) + call ncd_getdatetime(curdate, curtime) str = 'created on ' // curdate // ' ' // curtime call ncd_putatt(ncid, NCD_GLOBAL, 'history' , trim(str)) call ncd_putatt(ncid, NCD_GLOBAL, 'username', trim(username)) From 290d1b70aa531f6121eb6e287c46acfba88860b7 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 2 Jan 2024 15:44:27 +0100 Subject: [PATCH 22/86] more cleanup of character string length --- src/riverroute/mosart_fileutils.F90 | 3 ++- src/riverroute/mosart_io.F90 | 5 ++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/riverroute/mosart_fileutils.F90 b/src/riverroute/mosart_fileutils.F90 index 743f4c8..f50032d 100644 --- a/src/riverroute/mosart_fileutils.F90 +++ b/src/riverroute/mosart_fileutils.F90 @@ -3,6 +3,7 @@ module mosart_fileutils ! Module containing file I/O utilities use shr_sys_mod , only : shr_sys_abort + use shr_kind_mod, only : CL=>shr_kind_cl use mosart_vars , only : iulog, mainproc implicit none @@ -16,7 +17,7 @@ module mosart_fileutils contains !----------------------------------------------------------------------- - character(len=256) function get_filename (fulpath) + character(len=CL) function get_filename (fulpath) ! Returns filename given full pathname ! diff --git a/src/riverroute/mosart_io.F90 b/src/riverroute/mosart_io.F90 index 3dac3b1..b258a82 100644 --- a/src/riverroute/mosart_io.F90 +++ b/src/riverroute/mosart_io.F90 @@ -99,9 +99,8 @@ module mosart_io private :: ncd_getiodesc ! obtain iodesc - integer , parameter, private :: debug = 0 ! local debug level - integer , parameter, public :: max_string_len = 256 ! length of strings - real(r8) , parameter, public :: fillvalue = 1.e36_r8 ! fill value for netcdf fields + integer , parameter, private :: debug = 0 ! local debug level + real(r8) , parameter, public :: fillvalue = 1.e36_r8 ! fill value for netcdf fields integer :: io_type, io_format type(iosystem_desc_t), pointer, public :: pio_subsystem From fcf757315ef6cef2bda9a24f8615cfed75c67939 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 2 Jan 2024 16:30:42 +0100 Subject: [PATCH 23/86] more character length fixes --- src/riverroute/mosart_histfile.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/riverroute/mosart_histfile.F90 b/src/riverroute/mosart_histfile.F90 index bb2cabc..24ec4eb 100644 --- a/src/riverroute/mosart_histfile.F90 +++ b/src/riverroute/mosart_histfile.F90 @@ -27,7 +27,7 @@ module mosart_histfile ! Constants integer , public, parameter :: max_tapes = 3 ! max number of history tapes integer , public, parameter :: max_flds = 1500 ! max number of history fields - integer , public, parameter :: max_namlen = 32 ! maximum number of characters for field name + integer , public, parameter :: max_namlen = CS ! maximum number of characters for field name ! Counters integer , public :: ntapes = 0 ! index of max history file requested From 5779c29c44f7ea45dc284c9e19dab594d34f1680 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 2 Jan 2024 16:39:58 +0100 Subject: [PATCH 24/86] yet more character length cleanup --- src/riverroute/mosart_histfile.F90 | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/riverroute/mosart_histfile.F90 b/src/riverroute/mosart_histfile.F90 index 24ec4eb..4872b34 100644 --- a/src/riverroute/mosart_histfile.F90 +++ b/src/riverroute/mosart_histfile.F90 @@ -81,10 +81,8 @@ module mosart_histfile ! !PRIVATE TYPES: ! Constants ! - integer, parameter :: max_length_filename = 255 ! max length of a filename. on most linux systems this - ! is 255. But this can't be increased until all hard - ! coded values throughout the i/o stack are updated. - integer, parameter :: max_chars = 255 ! max chars for char variables + integer, parameter :: max_length_filename = CL + integer, parameter :: max_chars = CL ! ! Subscript dimensions ! From d2a22202ce0136023e6ae9afd5aa98c6cd74ce85 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 3 Jan 2024 21:55:04 +0100 Subject: [PATCH 25/86] updated test suite --- cime_config/buildnml | 1 - cime_config/config_component.xml | 14 +-- cime_config/namelist_definition_mosart.xml | 14 --- cime_config/testdefs/testlist_mosart.xml | 48 ++++---- .../mosart/decompOpts/user_nl_mosart | 1 - src/cpl/nuopc/rof_import_export.F90 | 3 +- src/riverroute/RtmMod.F90 | 114 ++---------------- 7 files changed, 35 insertions(+), 160 deletions(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index 56c8cb7..44f24ea 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -52,7 +52,6 @@ def _create_namelists(case, confdir, inst_string, infile, nmlgen, data_list_path else: logger.warning( "WARNING::"+message ) - config['mosart_flood_mode'] = case.get_value("MOSART_FLOOD_MODE") config['rof_grid'] = case.get_value("ROF_GRID") config['lnd_grid'] = case.get_value("LND_GRID") config['rof_ncpl'] = case.get_value("ROF_NCPL") diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index 84b4619..ce5fbf1 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -14,7 +14,7 @@ MOSART model with flood: - + char mosart mosart @@ -44,18 +44,6 @@ If warnings in namelist setttings from buildnml should be ignored or not - - char - ACTIVE,NULL - NULL - - ACTIVE - - build_component_mosart - env_build.xml - mode for mosart flood feature, NULL means mosart flood is turned off - - char diff --git a/cime_config/namelist_definition_mosart.xml b/cime_config/namelist_definition_mosart.xml index f8843ef..556192c 100644 --- a/cime_config/namelist_definition_mosart.xml +++ b/cime_config/namelist_definition_mosart.xml @@ -8,20 +8,6 @@ - - logical - mosart - mosart_inparm - - .true. - .false. - - - If .true., turn on mosart flooding back to clm - Note that mosart flood is not supported in CESM1.1 - - - logical mosart diff --git a/cime_config/testdefs/testlist_mosart.xml b/cime_config/testdefs/testlist_mosart.xml index b70990a..4d2cbb5 100644 --- a/cime_config/testdefs/testlist_mosart.xml +++ b/cime_config/testdefs/testlist_mosart.xml @@ -3,8 +3,8 @@ - - + + @@ -13,7 +13,8 @@ - + + @@ -21,8 +22,8 @@ - - + + @@ -31,25 +32,18 @@ - + + - - - - - - - - - - + + @@ -58,7 +52,7 @@ - + @@ -67,8 +61,7 @@ - - + @@ -78,7 +71,7 @@ - + @@ -87,7 +80,8 @@ - + + @@ -96,7 +90,8 @@ - + + @@ -105,7 +100,8 @@ - + + @@ -113,7 +109,8 @@ - + + @@ -122,7 +119,8 @@ - + + 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/src/cpl/nuopc/rof_import_export.F90 b/src/cpl/nuopc/rof_import_export.F90 index 606ca3c..08fd822 100644 --- a/src/cpl/nuopc/rof_import_export.F90 +++ b/src/cpl/nuopc/rof_import_export.F90 @@ -53,12 +53,11 @@ module rof_import_export contains !=============================================================================== - subroutine advertise_fields(gcomp, flds_scalar_name, do_rtmflood, rc) + subroutine advertise_fields(gcomp, flds_scalar_name, rc) ! input/output variables type(ESMF_GridComp) :: gcomp character(len=*) , intent(in) :: flds_scalar_name - logical , intent(in) :: do_rtmflood integer , intent(out) :: rc ! local variables diff --git a/src/riverroute/RtmMod.F90 b/src/riverroute/RtmMod.F90 index 9b4f897..1c74f68 100644 --- a/src/riverroute/RtmMod.F90 +++ b/src/riverroute/RtmMod.F90 @@ -46,9 +46,8 @@ module RtmMod public :: MOSART_init1 ! Initialize MOSART grid public :: MOSART_init2 ! Initialize MOSART maps public :: MOSART_run ! River routing model - - ! private member functions - private :: MOSART_FloodInit + ! + ! !PRIVATE MEMBER FUNCTIONS: private :: MOSART_SubTimestep ! MOSART tracers @@ -83,7 +82,6 @@ module RtmMod 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' character(len=256) :: fnamer ! name of netcdf restart file character(*), parameter :: u_FILE_u = & @@ -93,13 +91,10 @@ module RtmMod contains !----------------------------------------------------------------------- - subroutine MOSART_read_namelist(flood_active) + subroutine MOSART_read_namelist() ! ! Read and distribute mosart namelist ! - ! arguments - logical, intent(out) :: flood_active - ! ! local variables integer :: i integer :: ier ! error code @@ -113,7 +108,7 @@ subroutine MOSART_read_namelist(flood_active) ! Read in mosart namelist !------------------------------------------------------- - namelist /mosart_inparm / ice_runoff, do_rtmflood, & + namelist /mosart_inparm / ice_runoff, & frivinp_rtm, finidat_rtm, nrevsn_rtm, coupling_period, & rtmhist_ndens, rtmhist_mfilt, rtmhist_nhtfrq, & rtmhist_fincl1, rtmhist_fincl2, rtmhist_fincl3, & @@ -123,7 +118,6 @@ subroutine MOSART_read_namelist(flood_active) delt_mosart ! Preset values - do_rtmflood = .false. ice_runoff = .true. finidat_rtm = ' ' nrevsn_rtm = ' ' @@ -162,7 +156,6 @@ subroutine MOSART_read_namelist(flood_active) 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) @@ -196,8 +189,6 @@ subroutine MOSART_read_namelist(flood_active) end if endif - flood_active = do_rtmflood - if (frivinp_rtm == ' ') then call shr_sys_abort( subname//' ERROR: frivinp_rtm NOT set' ) else @@ -902,19 +893,13 @@ subroutine MOSART_init1() ! 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 MOSART_FloodInit (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 + 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 - end if + enddo !------------------------------------------------------- ! Initialize runoff data type @@ -2223,85 +2208,6 @@ subroutine MOSART_run(rstwr, nlend, rdate, rc) end subroutine MOSART_run - !----------------------------------------------------------------------- - - subroutine MOSART_FloodInit(frivinp, begr, endr, fthresh, evel ) - - ! Arguments - 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 = '(MOSART_FloodInit) ' - !----------------------------------------------------------------------- - - 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 (mainproc) 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 MOSART_FloodInit - !---------------------------------------------------------------------------- subroutine MOSART_SubTimestep() From 3ecf2430ee12bab468a357bcc155b069a573efd7 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Thu, 4 Jan 2024 12:21:31 +0100 Subject: [PATCH 26/86] updated mosart testing --- cime_config/testdefs/testlist_mosart.xml | 74 +++++++++---------- .../mosart/decompOpts/include_user_mods | 1 + .../mosart/default/user_nl_mosart | 8 +- .../mosart/inplacethreshold/include_user_mods | 1 + .../mosart/qgrwlOpts/include_user_mods | 1 + src/cpl/nuopc/rof_comp_nuopc.F90 | 7 +- 6 files changed, 42 insertions(+), 50 deletions(-) create mode 100644 cime_config/testdefs/testmods_dirs/mosart/decompOpts/include_user_mods create mode 100644 cime_config/testdefs/testmods_dirs/mosart/inplacethreshold/include_user_mods create mode 100644 cime_config/testdefs/testmods_dirs/mosart/qgrwlOpts/include_user_mods diff --git a/cime_config/testdefs/testlist_mosart.xml b/cime_config/testdefs/testlist_mosart.xml index 4d2cbb5..3e53307 100644 --- a/cime_config/testdefs/testlist_mosart.xml +++ b/cime_config/testdefs/testlist_mosart.xml @@ -1,20 +1,30 @@ + + + + + + + + + + - - + + - + - - + + @@ -22,8 +32,8 @@ - - + + @@ -32,8 +42,8 @@ - - + + @@ -42,46 +52,28 @@ - - + + - - - - - - - - - - - + + - - - - - - - - - - - + + @@ -90,8 +82,8 @@ - - + + @@ -100,8 +92,8 @@ - - + + @@ -109,8 +101,8 @@ - - + + @@ -119,8 +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/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/src/cpl/nuopc/rof_comp_nuopc.F90 b/src/cpl/nuopc/rof_comp_nuopc.F90 index 5e75433..f716a54 100644 --- a/src/cpl/nuopc/rof_comp_nuopc.F90 +++ b/src/cpl/nuopc/rof_comp_nuopc.F90 @@ -55,10 +55,7 @@ module rof_comp_nuopc integer :: flds_scalar_index_nx = 0 integer :: flds_scalar_index_ny = 0 integer :: flds_scalar_index_nextsw_cday = 0._r8 - - logical :: do_flood integer :: nthrds - integer , parameter :: debug = 1 character(*), parameter :: modName = "(rof_comp_nuopc)" character(*), parameter :: u_FILE_u = & @@ -416,13 +413,13 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! - need to compute areas where they are not defined in input file ! - Initialize runoff datatype (rtmCTL) - call MOSART_read_namelist(do_flood) + call MOSART_read_namelist() !---------------------------------------------------------------------------- ! Now advertise fields !---------------------------------------------------------------------------- - call advertise_fields(gcomp, flds_scalar_name, do_flood, rc) + call advertise_fields(gcomp, flds_scalar_name, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---------------------------------------------------------------------------- From 4005853cc002de3db8d6b560d799ad6fd4ac097d Mon Sep 17 00:00:00 2001 From: Erik Kluzek Date: Mon, 8 Jan 2024 14:57:20 -0700 Subject: [PATCH 27/86] Start the entry for the next tag --- docs/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/docs/ChangeLog b/docs/ChangeLog index d1ce81d..9e7f58f 100644 --- a/docs/ChangeLog +++ b/docs/ChangeLog @@ -1,3 +1,9 @@ +=============================================================== +Tag name: mosart1_0_49 +Originator(s): erik +Date: Jan 08, 2024 +One-line Summary: Remove MCT + =============================================================== Tag name: mosart1_0_48 Originator(s): erik From 06fa17c4b6b70bf7d27830dfb54f4f237b6672df Mon Sep 17 00:00:00 2001 From: mvdebolskiy <80036033+mvdebolskiy@users.noreply.github.com> Date: Fri, 12 Jan 2024 14:09:11 +0100 Subject: [PATCH 28/86] Module description mosart_physics_mod.F90 --- src/riverroute/mosart_physics_mod.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/riverroute/mosart_physics_mod.F90 b/src/riverroute/mosart_physics_mod.F90 index 3699f71..414b708 100644 --- a/src/riverroute/mosart_physics_mod.F90 +++ b/src/riverroute/mosart_physics_mod.F90 @@ -2,6 +2,8 @@ MODULE MOSART_physics_mod !----------------------------------------------------------------------- ! Description: core code of MOSART. + ! Contains routines for solving diffusion wave and update the state of + ! hillslope, subnetwork and main channel variables ! Developed by Hongyi Li, 12/29/2011. !----------------------------------------------------------------------- From d27cef78fc31afb36bfa5674caf2ee533051d157 Mon Sep 17 00:00:00 2001 From: mvertens Date: Fri, 5 Jan 2024 06:15:33 -0700 Subject: [PATCH 29/86] updates to mosart from sean --- src/cpl/nuopc/rof_import_export.F90 | 31 +++++++++++ src/riverroute/mosart_control_type.F90 | 74 +++++++++++++++++--------- src/riverroute/mosart_histflds.F90 | 11 ++++ src/riverroute/mosart_io.F90 | 5 +- src/riverroute/mosart_mod.F90 | 3 +- src/riverroute/mosart_physics_mod.F90 | 4 +- 6 files changed, 99 insertions(+), 29 deletions(-) diff --git a/src/cpl/nuopc/rof_import_export.F90 b/src/cpl/nuopc/rof_import_export.F90 index 9cb67db..5512b2a 100644 --- a/src/cpl/nuopc/rof_import_export.F90 +++ b/src/cpl/nuopc/rof_import_export.F90 @@ -36,6 +36,8 @@ module rof_import_export integer :: fldsToRof_num = 0 integer :: fldsFrRof_num = 0 logical :: flds_r2l_stream_channel_depths = .false. ! If should pass the channel depth fields needed for the hillslope model + !scs + logical :: flds_r2l_intergrid_gw = .false. ! If should pass the intergridcell groundwater flux type (fld_list_type) :: fldsToRof(fldsMax) type (fld_list_type) :: fldsFrRof(fldsMax) @@ -82,6 +84,11 @@ subroutine advertise_fields(gcomp, flds_scalar_name, rc) isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) read(cvalue,*) flds_r2l_stream_channel_depths + !scs + call NUOPC_CompAttributeGet(gcomp, name="flds_r2l_intergrid_gw", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) read(cvalue,*) flds_r2l_intergrid_gw call fldlist_add(fldsFrRof_num, fldsFrRof, trim(flds_scalar_name)) call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofl') call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofi') @@ -92,6 +99,10 @@ subroutine advertise_fields(gcomp, flds_scalar_name, rc) call fldlist_add(fldsFrRof_num, fldsFrRof, 'Sr_tdepth') call fldlist_add(fldsFrRof_num, fldsFrRof, 'Sr_tdepth_max') end if + !scs + if ( flds_r2l_intergrid_gw )then + call fldlist_add(fldsFrRof_num, fldsFrRof, 'Flrr_intergrid_gw') + endif do n = 1,fldsFrRof_num call NUOPC_Advertise(exportState, standardName=fldsFrRof(n)%stdname, & @@ -109,6 +120,10 @@ subroutine advertise_fields(gcomp, flds_scalar_name, rc) call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_rofsub') call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_rofi') call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_irrig') + !scs + if ( flds_r2l_intergrid_gw )then + call fldlist_add(fldsToRof_num, fldsToRof, 'Sl_zwt') + endif do n = 1,fldsToRof_num call NUOPC_Advertise(importState, standardName=fldsToRof(n)%stdname, & @@ -285,6 +300,22 @@ subroutine import_fields( gcomp, begr, endr, rc ) do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + !scs + if ( flds_r2l_intergrid_gw )then + call state_getimport(importState, 'Sl_zwt', begr, endr, ctl%area, output=ctl%zwt(:), & + do_area_correction=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !scs: state_getimport multiplies variable by area; revert here + do n = begr,endr + ctl%zwt(n) = ctl%zwt(n)/(ctl%area(n)*0.001_r8) + ! this is b/c idk where 1e36 are coming from yet + if(ctl%zwt(n) > 100._r8) then + ctl%zwt(n) = 0._r8 + endif + end do + endif + ctl%qsub(begr:endr, nfrz) = 0.0_r8 ctl%qgwl(begr:endr, nfrz) = 0.0_r8 diff --git a/src/riverroute/mosart_control_type.F90 b/src/riverroute/mosart_control_type.F90 index 2d81391..143cc9b 100644 --- a/src/riverroute/mosart_control_type.F90 +++ b/src/riverroute/mosart_control_type.F90 @@ -55,6 +55,8 @@ module mosart_control_type real(r8), pointer :: direct(:,:) => null() ! coupler return direct flow [m3/s] real(r8), pointer :: qirrig(:) => null() ! coupler irrigation [m3/s] real(r8), pointer :: qirrig_actual(:) => null() ! minimum of irrigation and available main channel storage + !scs + real(r8), pointer :: zwt(:) => null() ! coupler water table depth [m] ! storage, runoff real(r8), pointer :: runofflnd(:,:) => null() ! runoff masked for land (m3 H2O/s) @@ -260,7 +262,6 @@ subroutine Init(this, locfn, decomp_option, use_halo_option, IDkey, rc) ! --------------------------------------------- ! memory for this%gindex, this%mask and this%dsig is allocated in init_decomp - call t_startf('mosarti_decomp') call this%init_decomp(locfn, decomp_option, use_halo_option, & nlon, nlat, this%begr, this%endr, this%lnumr, this%numr, IDkey, rc) @@ -296,6 +297,8 @@ subroutine Init(this, locfn, decomp_option, use_halo_option, IDkey, rc) this%qgwl(begr:endr,ntracers), & this%qirrig(begr:endr), & this%qirrig_actual(begr:endr), & + !scs + this%zwt(begr:endr), & ! this%evel(begr:endr,ntracers), & this%flow(begr:endr,ntracers), & @@ -322,6 +325,8 @@ subroutine Init(this, locfn, decomp_option, use_halo_option, IDkey, rc) this%direct(:,:) = 0._r8 this%qirrig(:) = 0._r8 this%qirrig_actual(:) = 0._r8 + !scs + this%zwt(:) = 0._r8 this%qsur(:,:) = 0._r8 this%qsub(:,:) = 0._r8 this%qgwl(:,:) = 0._r8 @@ -385,15 +390,15 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & ! Local variables integer :: n, nr, i, j, g ! indices integer :: nl,nloops ! used for decomp search - integer :: itempr(nlon,nlat) ! global temporary buffer - integer :: gmask(nlon*nlat) ! global mask - integer :: gdc2glo(nlon*nlat) ! temporary for initialization - integer :: glo2gdc(nlon*nlat) ! temporary for initialization - integer :: ID0_global(nlon*nlat) ! global (local) ID index - integer :: dnID_global(nlon*nlat) ! global downstream ID based on ID0 - integer :: idxocn(nlon*nlat) ! downstream ocean outlet cell - integer :: nupstrm(nlon*nlat) ! number of upstream cells including own cell - integer :: pocn(nlon*nlat) ! pe number assigned to basin + integer, allocatable :: itempr(:,:) ! global temporary buffer + integer, allocatable :: gmask(:) ! global mask + integer, allocatable :: gdc2glo(:) ! temporary for initialization + integer, allocatable :: glo2gdc(:) ! temporary for initialization + integer, allocatable :: ID0_global(:) ! global (local) ID index + integer, allocatable :: dnID_global(:) ! global downstream ID based on ID0 + 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 :: nop(0:npes-1) ! number of gridcells on a pe integer :: nba(0:npes-1) ! number of basins on each pe integer :: nrs(0:npes-1) ! begr on each pe @@ -419,10 +424,21 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & integer, pointer :: seqlist(:) integer, allocatable :: store_halo_index(:) integer :: nglob + !scs + real(r8),allocatable :: rtempr(:,:) ! global temporary buffer - real character(len=*),parameter :: subname = '(mosart_control_type: init_decomp) ' !----------------------------------------------------------------------- rc = ESMF_SUCCESS +!!$ !scs +!!$ write(iulog,*) 'checkfile1a ' +!!$ write(iulog,*) 'checkfile1b ',nlon +!!$ write(iulog,*) 'checkfile1c ',nlat +!!$ write(iulog,*) 'checkfile1d ',decomp_option +!!$ write(iulog,*) 'checkfile1e ',use_halo_option +!!$ write(iulog,*) 'checkfile1a ',trim(locfn) +!!$ +!!$ write(iulog,*) 'checkfile2 ',size(IDkey) !------------------------------------------------------- ! Read ID and DnID from routing file @@ -430,27 +446,31 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & call ncd_pio_openfile(ncid, trim(locfn), 0) - call ncd_io(ncid=ncid, varname='ID', flag='read', data=itempr, readvar=found) + !scs: use real input variables + allocate(rtempr(nlon,nlat)) + allocate(ID0_global(nlon*nlat),dnID_global(nlon*nlat)) + call ncd_io(ncid=ncid, varname='ID', flag='read', data=rtempr, readvar=found) if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart ID') - if (mainproc) write(iulog,*) 'Read ID ',minval(itempr),maxval(itempr) + if (mainproc) write(iulog,*) 'Read ID ',minval(rtempr),maxval(rtempr) do j=1,nlat do i=1,nlon n = (j-1)*nlon + i - ID0_global(n) = itempr(i,j) + ID0_global(n) = int(rtempr(i,j)) end do end do - if (mainproc) write(iulog,*) 'ID ',minval(itempr),maxval(itempr) + if (mainproc) write(iulog,*) 'ID ',minval(rtempr),maxval(rtempr) - call ncd_io(ncid=ncid, varname='dnID', flag='read', data=itempr, readvar=found) + call ncd_io(ncid=ncid, varname='dnID', flag='read', data=rtempr, readvar=found) if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart dnID') - if (mainproc) write(iulog,*) 'Read dnID ',minval(itempr),maxval(itempr) + if (mainproc) write(iulog,*) 'Read dnID ',minval(rtempr),maxval(rtempr) do j=1,nlat do i=1,nlon n = (j-1)*nlon + i - dnID_global(n) = itempr(i,j) + dnID_global(n) = int(rtempr(i,j)) end do end do - if (mainproc) write(iulog,*) 'dnID ',minval(itempr),maxval(itempr) + if (mainproc) write(iulog,*) 'dnID ',minval(rtempr),maxval(rtempr) + deallocate(rtempr) call ncd_pio_closefile(ncid) @@ -497,7 +517,7 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & !------------------------------------------------------- ! 1=land, 2=ocean, 3=ocean outlet from land - + allocate(gmask(nlon*nlat)) gmask(:) = 2 ! assume ocean point do n=1,nlon*nlat ! mark all downstream points as outlet nr = dnID_global(n) @@ -547,7 +567,7 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & ! idxocn = final downstream cell, index is global 1d ocean gridcell ! nupstrm = number of source gridcells upstream including self - + allocate(idxocn(nlon*nlat),nupstrm(nlon*nlat)) idxocn(:) = 0 nupstrm(:) = 0 do nr=1,nlon*nlat @@ -589,7 +609,7 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & ! this is the heart of the decomp, need to set pocn and nop by the end of this ! pocn is the pe that gets the basin associated with ocean outlet nr ! nop is a running count of the number of mosart cells/pe - + allocate(pocn(nlon*nlat)) pocn(:) = -99 nop(0:npes-1) = 0 if (trim(decomp_option) == 'basin') then @@ -694,7 +714,8 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & write(iulog,*) 'mosart cells per pe min/max = ',minval(nop),maxval(nop) write(iulog,*) 'mosart basins per pe min/max = ',minval(nba),maxval(nba) endif - + deallocate(nupstrm) + !------------------------------------------------------- ! Determine begr, endr, numr and lnumr !------------------------------------------------------- @@ -729,7 +750,8 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & ! so loop through the pes and determine begr on each pe nrs(n) = nrs(n-1) + nop(n-1) enddo - + + allocate(glo2gdc(nlon*nlat),gdc2glo(nlon*nlat)) glo2gdc(:) = 0 nba(:) = 0 do nr = 1,nlon*nlat @@ -866,7 +888,8 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & deallocate(halo_list) deallocate(store_halo_index) - + deallocate(gdc2glo,glo2gdc,pocn) + ! Now do a test of the halo operation call this%test_halo(rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -886,7 +909,8 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & this%dsig(nr) = dnID_global(n) endif end do - + deallocate(gmask,dnID_global,idxocn) + !------------------------------------------------------- ! Write per-processor runoff bounds depending on dbug level !------------------------------------------------------- diff --git a/src/riverroute/mosart_histflds.F90 b/src/riverroute/mosart_histflds.F90 index 31287df..41fb49f 100644 --- a/src/riverroute/mosart_histflds.F90 +++ b/src/riverroute/mosart_histflds.F90 @@ -31,6 +31,8 @@ module mosart_histflds type(hist_pointer_type), allocatable :: h_qgwl(:) real(r8), pointer :: h_volr_mch(:) + !scs + real(r8), pointer :: h_water_table(:) !------------------------------------------------------------------------ contains @@ -75,6 +77,8 @@ subroutine mosart_histflds_init(begr, endr, ntracers) end do allocate(h_volr_mch(begr:endr)) + !scs + allocate(h_water_table(begr:endr)) !------------------------------------------------------- ! Build master field list of all possible fields in a history file. @@ -138,6 +142,11 @@ subroutine mosart_histflds_init(begr, endr, ntracers) avgflag='A', long_name='Actual irrigation (if limited by river storage)', & ptr_rof=ctl%qirrig_actual, default='inactive') + !scs + call mosart_hist_addfld (fname='WATER_TABLE', units='m', & + avgflag='A', long_name='water table from land', & + ptr_rof=h_water_table, default='inactive') + ! print masterlist of history fields call mosart_hist_printflds() @@ -169,6 +178,8 @@ subroutine mosart_histflds_set(ntracers) h_qgwl(nt)%data(:) = ctl%qgwl(:,nt) end do h_volr_mch(:) = Trunoff%wr(:,1) + !scs +! h_water_table(:) = ctl%zwt(:) end subroutine mosart_histflds_set diff --git a/src/riverroute/mosart_io.F90 b/src/riverroute/mosart_io.F90 index b258a82..bd72c9a 100644 --- a/src/riverroute/mosart_io.F90 +++ b/src/riverroute/mosart_io.F90 @@ -9,7 +9,10 @@ module mosart_io use shr_pio_mod , only : shr_pio_getiosys, shr_pio_getiotype, shr_pio_getioformat use mosart_vars , only : spval, ispval, iulog, mainproc, mpicom_rof, iam, npes use perf_mod , only : t_startf, t_stopf - use mpi , only : mpi_barrier, mpi_bcast, MPI_CHARACTER +!scs use mpi , only : mpi_barrier, mpi_bcast, MPI_CHARACTER +!scs use mpi , only : mpi_bcast + use mpi , only : mpi_barrier, MPI_CHARACTER + use pio , only : file_desc_t, var_desc_t, io_desc_t, iosystem_desc_t, pio_initdecomp, & pio_openfile, pio_iotask_rank, pio_closefile, pio_createfile, & pio_seterrorhandling, pio_inq_dimid, pio_inq_dimlen, pio_inq_dimname, & diff --git a/src/riverroute/mosart_mod.F90 b/src/riverroute/mosart_mod.F90 index 0a45cb4..b85010a 100644 --- a/src/riverroute/mosart_mod.F90 +++ b/src/riverroute/mosart_mod.F90 @@ -30,7 +30,8 @@ module mosart_mod use mosart_io , only : ncd_pio_openfile, ncd_inqdid, ncd_inqdlen, ncd_pio_closefile, ncd_decomp_init, & pio_subsystem use pio , only : file_desc_t - use mpi , only : mpi_bcast, mpi_barrier, MPI_CHARACTER, MPI_LOGICAL, MPI_INTEGER + !use mpi , only : mpi_bcast, mpi_barrier, MPI_CHARACTER, MPI_LOGICAL, MPI_INTEGER + use mpi ! ! !PUBLIC TYPES: implicit none diff --git a/src/riverroute/mosart_physics_mod.F90 b/src/riverroute/mosart_physics_mod.F90 index 414b708..6cde2f7 100644 --- a/src/riverroute/mosart_physics_mod.F90 +++ b/src/riverroute/mosart_physics_mod.F90 @@ -582,9 +582,9 @@ function GRPR(hr_, rwidth_, rwidth0_,rdepth_) result(pr_) logical, save :: first_call = .true. SLOPE1 = SLOPE1def - if (first_call) then +!scs if (first_call) then sinatanSLOPE1defr = 1.0_r8/(sin(atan(SLOPE1def))) - endif +!scs endif first_call = .false. if(hr_ < TINYVALUE) then From 9113cd504e647e53016509839bf03e9f6a0a2bf4 Mon Sep 17 00:00:00 2001 From: mvertens Date: Thu, 11 Jan 2024 08:01:54 -0700 Subject: [PATCH 30/86] changes to compute gradient --- src/riverroute/mosart_control_type.F90 | 2268 +++++++++++--------- src/riverroute/mosart_mod.F90 | 1 - src/riverroute/mosart_physics_mod.F90 | 7 +- src/riverroute/mosart_tstatusflux_type.F90 | 22 +- 4 files changed, 1209 insertions(+), 1089 deletions(-) diff --git a/src/riverroute/mosart_control_type.F90 b/src/riverroute/mosart_control_type.F90 index 143cc9b..efc1ed8 100644 --- a/src/riverroute/mosart_control_type.F90 +++ b/src/riverroute/mosart_control_type.F90 @@ -1,97 +1,106 @@ module mosart_control_type - use shr_kind_mod, only : r8 => shr_kind_r8, CL => SHR_KIND_CL - use shr_sys_mod, only : shr_sys_abort - use shr_const_mod, only : shr_const_pi - use shr_mpi_mod, only : shr_mpi_sum, shr_mpi_max - use mosart_io, only : ncd_io, ncd_pio_openfile, ncd_pio_closefile - use mosart_vars, only : mainproc, iam, npes, mpicom_rof, iulog, spval, re - use pio, only : file_desc_t, PIO_BCAST_ERROR, pio_seterrorhandling - use ESMF, only : ESMF_DistGrid, ESMF_Array, ESMF_RouteHandle, ESMF_SUCCESS, & - ESMF_DistGridCreate, ESMF_ArrayCreate, ESMF_ArrayHaloStore, ESMF_ArrayHalo - use perf_mod, only : t_startf, t_stopf - use nuopc_shr_methods , only : chkerr - - implicit none - private - - type control_type - - ! grid sizes - integer :: lnumr ! local number of cells - integer :: numr ! global number of cells - integer :: nlon = -999 ! number of longitudes - integer :: nlat = -999 ! number of latitudes - - ! tracers - integer :: ntracers = -999 ! number of tracers - character(len=3), allocatable :: tracer_names(:)! tracer names - - ! decomp info - integer :: begr ! local start index - integer :: endr ! local stop indices - integer , pointer :: gindex(:) => null() ! global index consistent with map file - type(ESMF_DistGrid) :: distgrid ! esmf global index space descriptor - - ! grid - real(r8), pointer :: rlon(:) => null() ! longitude list, 1d - real(r8), pointer :: rlat(:) => null() ! latitude list, 1d - real(r8), pointer :: lonc(:) => null() ! lon of cell - real(r8), pointer :: latc(:) => null() ! lat of cell - integer , pointer :: dsig(:) => null() ! downstream index, global index - integer , pointer :: outletg(:) => null() ! outlet index, global index - real(r8), pointer :: area(:) => null() ! area of cell - integer , pointer :: mask(:) => null() ! general mask of cell 1=land, 2=ocean, 3=outlet - real(r8) :: totarea ! global area - - ! inputs to MOSART - real(r8), pointer :: qsur(:,:) => null() ! coupler surface forcing [m3/s] - real(r8), pointer :: qsub(:,:) => null() ! coupler subsurface forcing [m3/s] - real(r8), pointer :: qgwl(:,:) => null() ! coupler glacier/wetland/lake forcing [m3/s] - - ! outputs from MOSART - real(r8), pointer :: flood(:) => null() ! coupler return flood water sent back to clm [m3/s] - real(r8), pointer :: runoff(:,:) => null() ! coupler return mosart basin derived flow [m3/s] - real(r8), pointer :: direct(:,:) => null() ! coupler return direct flow [m3/s] - real(r8), pointer :: qirrig(:) => null() ! coupler irrigation [m3/s] - real(r8), pointer :: qirrig_actual(:) => null() ! minimum of irrigation and available main channel storage - !scs - real(r8), pointer :: zwt(:) => null() ! coupler water table depth [m] - - ! storage, runoff - real(r8), pointer :: runofflnd(:,:) => null() ! runoff masked for land (m3 H2O/s) - real(r8), pointer :: runoffocn(:,:) => null() ! runoff masked for ocn (m3 H2O/s) - real(r8), pointer :: runofftot(:,:) => null() ! total runoff masked for ocn (m3 H2O/s) - real(r8), pointer :: dvolrdt(:,:) => null() ! change in storage (mm/s) - real(r8), pointer :: dvolrdtlnd(:,:) => null() ! dvolrdt masked for land (mm/s) - real(r8), pointer :: dvolrdtocn(:,:) => null() ! dvolrdt masked for ocn (mm/s) - real(r8), pointer :: volr(:,:) => null() ! storage (m3) - real(r8), pointer :: fthresh(:) => null() ! water flood threshold - - ! flux variables - real(r8), pointer :: flow(:,:) => null() ! mosart flow (m3/s) - real(r8), pointer :: evel(:,:) => null() ! effective tracer velocity (m/s) - real(r8), pointer :: erout_prev(:,:) => null() ! erout previous timestep (m3/s) - real(r8), pointer :: eroutup_avg(:,:) => null() ! eroutup average over coupling period (m3/s) - real(r8), pointer :: erlat_avg(:,:) => null() ! erlateral average over coupling period (m3/s) - real(r8), pointer :: effvel(:) => null() - - ! halo operations - type(ESMF_Array) :: haloArray - type(ESMF_RouteHandle) :: haloHandle - real(r8), pointer :: halo_arrayptr(:) => null() ! preallocated memory for exclusive region plus halo - integer , pointer :: halo_arrayptr_index(:,:) ! index into halo_arrayptr that corresponds to a halo point + use shr_kind_mod, only : r8 => shr_kind_r8, CL => SHR_KIND_CL + use shr_sys_mod, only : shr_sys_abort + use shr_const_mod, only : shr_const_pi, shr_const_rearth + use shr_mpi_mod, only : shr_mpi_sum, shr_mpi_max + use mosart_io, only : ncd_io, ncd_pio_openfile, ncd_pio_closefile + use mosart_vars, only : mainproc, iam, npes, mpicom_rof, iulog, spval, re + use pio, only : file_desc_t, PIO_BCAST_ERROR, pio_seterrorhandling + use ESMF, only : ESMF_DistGrid, ESMF_Array, ESMF_RouteHandle, ESMF_SUCCESS, & + ESMF_DistGridCreate, ESMF_ArrayCreate, ESMF_ArrayHaloStore, & + ESMF_ArrayHalo, ESMF_ArrayGet + use perf_mod, only : t_startf, t_stopf + use nuopc_shr_methods , only : chkerr + + implicit none + private + + type control_type + + ! grid sizes + integer :: lnumr ! local number of cells + integer :: numr ! global number of cells + integer :: nlon = -999 ! number of longitudes + integer :: nlat = -999 ! number of latitudes + + ! tracers + integer :: ntracers = -999 ! number of tracers + character(len=3), allocatable :: tracer_names(:)! tracer names + + ! decomp info + integer :: begr ! local start index + integer :: endr ! local stop indices + integer , pointer :: gindex(:) => null() ! global index consistent with map file + type(ESMF_DistGrid) :: distgrid ! esmf global index space descriptor + + ! grid + real(r8), pointer :: rlon(:) => null() ! longitude list, 1d + real(r8), pointer :: rlat(:) => null() ! latitude list, 1d + real(r8), pointer :: lonc(:) => null() ! lon of cell + real(r8), pointer :: latc(:) => null() ! lat of cell + integer , pointer :: dsig(:) => null() ! downstream index, global index + integer , pointer :: outletg(:) => null() ! outlet index, global index + real(r8), pointer :: area(:) => null() ! area of cell + integer , pointer :: mask(:) => null() ! general mask of cell 1=land, 2=ocean, 3=outlet + real(r8) :: totarea ! global area + + ! inputs to MOSART + real(r8), pointer :: qsur(:,:) => null() ! coupler surface forcing [m3/s] + real(r8), pointer :: qsub(:,:) => null() ! coupler subsurface forcing [m3/s] + real(r8), pointer :: qgwl(:,:) => null() ! coupler glacier/wetland/lake forcing [m3/s] + + ! outputs from MOSART + real(r8), pointer :: flood(:) => null() ! coupler return flood water sent back to clm [m3/s] + real(r8), pointer :: runoff(:,:) => null() ! coupler return mosart basin derived flow [m3/s] + real(r8), pointer :: direct(:,:) => null() ! coupler return direct flow [m3/s] + real(r8), pointer :: qirrig(:) => null() ! coupler irrigation [m3/s] + real(r8), pointer :: qirrig_actual(:) => null() ! minimum of irrigation and available main channel storage + real(r8), pointer :: zwt(:) => null() ! coupler water table depth [m] + real(r8), pointer :: slope(:) => null() ! slope, using for testing currently + + ! storage, runoff + real(r8), pointer :: runofflnd(:,:) => null() ! runoff masked for land (m3 H2O/s) + real(r8), pointer :: runoffocn(:,:) => null() ! runoff masked for ocn (m3 H2O/s) + real(r8), pointer :: runofftot(:,:) => null() ! total runoff masked for ocn (m3 H2O/s) + real(r8), pointer :: dvolrdt(:,:) => null() ! change in storage (mm/s) + real(r8), pointer :: dvolrdtlnd(:,:) => null() ! dvolrdt masked for land (mm/s) + real(r8), pointer :: dvolrdtocn(:,:) => null() ! dvolrdt masked for ocn (mm/s) + real(r8), pointer :: volr(:,:) => null() ! storage (m3) + real(r8), pointer :: fthresh(:) => null() ! water flood threshold + + ! flux variables + real(r8), pointer :: flow(:,:) => null() ! mosart flow (m3/s) + real(r8), pointer :: evel(:,:) => null() ! effective tracer velocity (m/s) + real(r8), pointer :: erout_prev(:,:) => null() ! erout previous timestep (m3/s) + real(r8), pointer :: eroutup_avg(:,:) => null() ! eroutup average over coupling period (m3/s) + real(r8), pointer :: erlat_avg(:,:) => null() ! erlateral average over coupling period (m3/s) + real(r8), pointer :: effvel(:) => null() + + ! halo operations + type(ESMF_RouteHandle) :: haloHandle + integer , pointer :: halo_arrayptr_index(:,:) => null() ! index into halo_arrayptr that corresponds to a halo point + type(ESMF_Array) :: halo_array + real(r8), pointer :: halo_arrayptr(:) => null() ! preallocated memory for exclusive region plus halo + type(ESMF_Array) :: lon_halo_array + real(r8), pointer :: lon_halo_arrayptr(:) => null() ! preallocated memory for exclusive region plus halo + type(ESMF_Array) :: lat_halo_array + real(r8), pointer :: lat_halo_arrayptr(:) => null() ! preallocated memory for exclusive region plus halo + type(ESMF_Array) :: zwt_halo_array + real(r8), pointer :: zwt_halo_arrayptr(:) => null() ! preallocated memory for exclusive region plus halo contains procedure, public :: Init procedure, private :: init_decomp procedure, private :: test_halo + procedure, public :: calc_gradient end type control_type public :: control_type private :: init_decomp + public :: calc_gradient #ifdef NDEBUG integer,parameter :: dbug = 0 ! 0 = none, 1=normal, 2=much, 3=max @@ -99,1002 +108,1115 @@ module mosart_control_type integer,parameter :: dbug = 3 ! 0 = none, 1=normal, 2=much, 3=max #endif - integer :: max_num_halo = 8 - integer :: halo_sw = 1 - integer :: halo_s = 2 - integer :: halo_se = 3 - integer :: halo_e = 4 - integer :: halo_ne = 5 - integer :: halo_n = 6 - integer :: halo_nw = 7 - integer :: halo_w = 8 + integer, public :: max_num_halo = 8 + ! eight surrounding indices ordered as [N,NE,E,SE,S,SW,W,NW] + integer, public :: halo_n = 1 + integer, public :: halo_ne = 2 + integer, public :: halo_e = 3 + integer, public :: halo_se = 4 + integer, public :: halo_s = 5 + integer, public :: halo_sw = 6 + integer, public :: halo_w = 7 + integer, public :: halo_nw = 8 + + ! dimensions of halo array + integer :: halo_zwt = 1 + integer :: halo_lon = 2 + integer :: halo_att = 3 character(*), parameter :: u_FILE_u = & __FILE__ -!======================================================================== + !======================================================================== contains -!======================================================================== - - subroutine Init(this, locfn, decomp_option, use_halo_option, IDkey, rc) - - ! Arguments - class(control_type) :: this - character(len=*) , intent(in) :: locfn - character(len=*) , intent(in) :: decomp_option ! decomposition option - logical , intent(in) :: use_halo_option ! create ESMF array and route handle for halos - integer , intent(out) :: IDkey(:) ! translation key from ID to gindex - integer , intent(out) :: rc - - ! Local variables - real(r8) :: area_global(this%nlon*this%nlat) ! area - real(r8) :: tempr(this%nlon,this%nlat) ! temporary buffer - real(r8) :: rlats(this%nlat) ! latitude of 1d south grid cell edge (deg) - real(r8) :: rlatn(this%nlat) ! latitude of 1d north grid cell edge (deg) - real(r8) :: rlonw(this%nlon) ! longitude of 1d west grid cell edge (deg) - real(r8) :: rlone(this%nlon) ! longitude of 1d east grid cell edge (deg) - real(r8) :: larea ! tmp local sum of area - real(r8) :: deg2rad ! pi/180 - integer :: g, n, i, j, nr, nt ! iterators - real(r8) :: edgen ! North edge of the direction file - real(r8) :: edgee ! East edge of the direction file - real(r8) :: edges ! South edge of the direction file - real(r8) :: edgew ! West edge of the direction file - real(r8) :: dx ! lon dist. betn grid cells (m) - real(r8) :: dy ! lat dist. betn grid cells (m) - type(file_desc_t) :: ncid ! pio file desc - logical :: found ! flag - integer :: ntracers ! used to simplify code - integer :: begr, endr ! used to simplify code - integer :: ier ! error status - integer :: nlon,nlat - real(r8) :: effvel0 = 10.0_r8 ! default velocity (m/s) - character(len=*),parameter :: subname = '(mosart_control_type: Init)' - !----------------------------------------------------------------------- - - rc = ESMF_SUCCESS - - nlon = this%nlon - nlat = this%nlat - - !--------------------------------------- - ! Read the routing parameters - !--------------------------------------- - - call ncd_pio_openfile (ncid, trim(locfn), 0) - call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) - - call ncd_io(ncid=ncid, varname='longxy', flag='read', data=tempr, readvar=found) - if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart longitudes') - if (mainproc) write(iulog,*) 'Read longxy ',minval(tempr),maxval(tempr) - allocate(this%rlon(this%nlon)) - do i=1,nlon - this%rlon(i) = tempr(i,1) - enddo - if (mainproc) write(iulog,*) 'rlon center ',minval(this%rlon),maxval(this%rlon) - - call ncd_io(ncid=ncid, varname='latixy', flag='read', data=tempr, readvar=found) - if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart latitudes') - if (mainproc) write(iulog,*) 'Read latixy ',minval(tempr),maxval(tempr) - allocate(this%rlat(this%nlat)) - do j=1,this%nlat - this%rlat(j) = tempr(1,j) - end do - if (mainproc) write(iulog,*) 'rlat center ',minval(this%rlat),maxval(this%rlat) - - call ncd_io(ncid=ncid, varname='area', flag='read', data=tempr, readvar=found) - if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart area') - if (mainproc) write(iulog,*) 'Read area ',minval(tempr),maxval(tempr) - do j=1,this%nlat - do i=1,nlon - n = (j-1)*nlon + i - area_global(n) = tempr(i,j) - end do - end do - if (mainproc) write(iulog,*) 'area ',minval(area_global),maxval(area_global) - call ncd_pio_closefile(ncid) - - !------------------------------------------------------- - ! adjust area estimation from DRT algorithm for those outlet grids - ! useful for grid-based representation only - ! need to compute areas where they are not defined in input file - !------------------------------------------------------- - - ! Derive gridbox edges - ! assuming equispaced grid, calculate edges from nlat/nlon - ! w/o assuming a global grid - edgen = maxval(this%rlat) + 0.5*abs(this%rlat(1) - this%rlat(2)) - edges = minval(this%rlat) - 0.5*abs(this%rlat(1) - this%rlat(2)) - edgee = maxval(this%rlon) + 0.5*abs(this%rlon(1) - this%rlon(2)) - edgew = minval(this%rlon) - 0.5*abs(this%rlon(1) - this%rlon(2)) - if (edgen .ne. 90._r8)then - if (mainproc ) write(iulog,*) 'Regional grid: edgen = ', edgen - end if - if (edges .ne. -90._r8)then - if (mainproc ) write(iulog,*) 'Regional grid: edges = ', edges - end if - if (edgee .ne. 180._r8)then - if (mainproc ) write(iulog,*) 'Regional grid: edgee = ', edgee - end if - if (edgew .ne.-180._r8)then - if ( mainproc ) write(iulog,*) 'Regional grid: edgew = ', edgew - end if - - ! Set edge latitudes (assumes latitudes are constant for a given longitude) - rlats(:) = edges - rlatn(:) = edgen - do j = 2, nlat - if (this%rlat(2) > this%rlat(1)) then ! South to North grid - rlats(j) = (this%rlat(j-1) + this%rlat(j)) / 2._r8 - rlatn(j-1) = rlats(j) - else ! North to South grid - rlatn(j) = (this%rlat(j-1) + this%rlat(j)) / 2._r8 - rlats(j-1) = rlatn(j) - end if - end do - - ! Set edge longitudes - rlonw(:) = edgew - rlone(:) = edgee - dx = (edgee - edgew) / nlon - do i = 2, nlon - rlonw(i) = rlonw(i) + (i-1)*dx - rlone(i-1) = rlonw(i) - end do - - ! adjust area estimation from DRT algorithm for those outlet grids - deg2rad = shr_const_pi / 180._r8 - do n=1,nlon*nlat - if (area_global(n) <= 0._r8) then - i = mod(n-1,nlon) + 1 - j = (n-1)/nlon + 1 - dx = (rlone(i) - rlonw(i)) * deg2rad - dy = sin(rlatn(j)*deg2rad) - sin(rlats(j)*deg2rad) - area_global(n) = abs(1.e6_r8 * dx*dy*re*re) - if (mainproc .and. area_global(n) <= 0) then - write(iulog,*) 'Warning! Zero area for unit ', n, area_global(n),dx,dy,re - end if - end if - end do - - ! --------------------------------------------- - ! Determine decomposition - ! --------------------------------------------- - - ! memory for this%gindex, this%mask and this%dsig is allocated in init_decomp - call t_startf('mosarti_decomp') - call this%init_decomp(locfn, decomp_option, use_halo_option, & - nlon, nlat, this%begr, this%endr, this%lnumr, this%numr, IDkey, rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call t_stopf('mosarti_decomp') - - ! --------------------------------------------- - ! Allocate and initialize remaining variables - ! --------------------------------------------- - - begr = this%begr - endr = this%endr - ntracers = this%ntracers - - allocate(this%area(begr:endr), & - ! - this%volr(begr:endr,ntracers), & - this%dvolrdt(begr:endr,ntracers), & - this%dvolrdtlnd(begr:endr,ntracers), & - this%dvolrdtocn(begr:endr,ntracers), & - ! - this%runoff(begr:endr,ntracers), & - this%runofflnd(begr:endr,ntracers), & - this%runoffocn(begr:endr,ntracers), & - this%runofftot(begr:endr,ntracers), & - ! - this%fthresh(begr:endr), & - this%flood(begr:endr), & - ! - this%direct(begr:endr,ntracers), & - this%qsur(begr:endr,ntracers), & - this%qsub(begr:endr,ntracers), & - this%qgwl(begr:endr,ntracers), & - this%qirrig(begr:endr), & - this%qirrig_actual(begr:endr), & - !scs - this%zwt(begr:endr), & - ! - this%evel(begr:endr,ntracers), & - this%flow(begr:endr,ntracers), & - this%erout_prev(begr:endr,ntracers), & - this%eroutup_avg(begr:endr,ntracers),& - this%erlat_avg(begr:endr,ntracers), & - ! - this%effvel(ntracers), & - stat=ier) - if (ier /= 0) then - write(iulog,*)'mosarart_control_type allocation error' - call shr_sys_abort - end if - - this%runoff(:,:) = 0._r8 - this%runofflnd(:,:) = spval - this%runoffocn(:,:) = spval - this%runofftot(:,:) = spval - this%dvolrdt(:,:) = 0._r8 - this%dvolrdtlnd(:,:) = spval - this%dvolrdtocn(:,:) = spval - this%volr(:,:) = 0._r8 - this%flood(:) = 0._r8 - this%direct(:,:) = 0._r8 - this%qirrig(:) = 0._r8 - this%qirrig_actual(:) = 0._r8 - !scs - this%zwt(:) = 0._r8 - this%qsur(:,:) = 0._r8 - this%qsub(:,:) = 0._r8 - this%qgwl(:,:) = 0._r8 - ! - this%fthresh(:) = abs(spval) - this%flow(:,:) = 0._r8 - this%erout_prev(:,:) = 0._r8 - this%eroutup_avg(:,:) = 0._r8 - this%erlat_avg(:,:) = 0._r8 - - this%effvel(:) = effvel0 ! downstream velocity (m/s) - do nt = 1,ntracers - do nr = begr,endr - this%evel(nr,nt) = this%effvel(nt) - enddo - enddo - - do nr = begr,endr - n = this%gindex(nr) - i = mod(n-1,nlon) + 1 - j = (n-1)/nlon + 1 - this%lonc(nr) = this%rlon(i) - this%latc(nr) = this%rlat(j) - this%area(nr) = area_global(n) - enddo - - larea = 0.0_r8 - do nr = begr,endr - larea = larea + this%area(nr) - end do - if (minval(this%mask) < 1) then - write(iulog,*) subname,'ERROR this mask lt 1 ',minval(this%mask),maxval(this%mask) - call shr_sys_abort(subname//' ERROR this mask') - endif - call shr_mpi_sum(larea, this%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 ',this%totarea - end if - - end subroutine Init - - !======================================================================== - subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & - nlon, nlat, begr, endr, lnumr, numr, IDkey, rc) - - ! Arguments - class(control_type) :: this - character(len=*) , intent(in) :: locfn ! local routing filename - character(len=*) , intent(in) :: decomp_option - logical , intent(in) :: use_halo_option - integer , intent(in) :: nlon - integer , intent(in) :: nlat - integer , intent(out) :: begr - integer , intent(out) :: endr - integer , intent(out) :: lnumr - integer , intent(out) :: numr - integer , intent(out) :: IDkey(:) ! translation key from ID to gindex - integer , intent(out) :: rc - - ! Local variables - integer :: n, nr, i, j, g ! indices - integer :: nl,nloops ! used for decomp search - integer, allocatable :: itempr(:,:) ! global temporary buffer - integer, allocatable :: gmask(:) ! global mask - integer, allocatable :: gdc2glo(:) ! temporary for initialization - integer, allocatable :: glo2gdc(:) ! temporary for initialization - integer, allocatable :: ID0_global(:) ! global (local) ID index - integer, allocatable :: dnID_global(:) ! global downstream ID based on ID0 - 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 :: nop(0:npes-1) ! number of gridcells on a pe - integer :: nba(0:npes-1) ! number of basins on each pe - integer :: nrs(0:npes-1) ! begr on each pe - integer :: maxgcells_per_pe ! max num of points per pe for decomp - integer :: minbas,maxbas ! used for decomp search - integer :: pid,np,npmin,npmax,npint ! log loop control - integer :: nmos ! number of mosart points - integer :: nout ! number of basin with outlets - integer :: nbas ! number of basin/ocean points - integer :: nrof ! num of active mosart points - integer :: baspe ! pe with min number of mosart cells - logical :: found ! flag - integer :: ier ! error status - type(file_desc_t) :: ncid ! pio file desc - integer :: procid - integer :: im1,ip1 - integer :: jm1,jp1 - integer :: n_sw, n_s, n_se - integer :: n_nw, n_n, n_ne - integer :: n_e, n_w - integer :: num_halo - integer, pointer :: halo_list(:) - integer, pointer :: seqlist(:) - integer, allocatable :: store_halo_index(:) - integer :: nglob - !scs - real(r8),allocatable :: rtempr(:,:) ! global temporary buffer - real - character(len=*),parameter :: subname = '(mosart_control_type: init_decomp) ' - !----------------------------------------------------------------------- - - rc = ESMF_SUCCESS -!!$ !scs -!!$ write(iulog,*) 'checkfile1a ' -!!$ write(iulog,*) 'checkfile1b ',nlon -!!$ write(iulog,*) 'checkfile1c ',nlat -!!$ write(iulog,*) 'checkfile1d ',decomp_option -!!$ write(iulog,*) 'checkfile1e ',use_halo_option -!!$ write(iulog,*) 'checkfile1a ',trim(locfn) -!!$ -!!$ write(iulog,*) 'checkfile2 ',size(IDkey) - - !------------------------------------------------------- - ! Read ID and DnID from routing file - !------------------------------------------------------- - - call ncd_pio_openfile(ncid, trim(locfn), 0) - - !scs: use real input variables - allocate(rtempr(nlon,nlat)) - allocate(ID0_global(nlon*nlat),dnID_global(nlon*nlat)) - call ncd_io(ncid=ncid, varname='ID', flag='read', data=rtempr, readvar=found) - if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart ID') - if (mainproc) write(iulog,*) 'Read ID ',minval(rtempr),maxval(rtempr) - do j=1,nlat - do i=1,nlon - n = (j-1)*nlon + i - ID0_global(n) = int(rtempr(i,j)) - end do - end do - if (mainproc) write(iulog,*) 'ID ',minval(rtempr),maxval(rtempr) - - call ncd_io(ncid=ncid, varname='dnID', flag='read', data=rtempr, readvar=found) - if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart dnID') - if (mainproc) write(iulog,*) 'Read dnID ',minval(rtempr),maxval(rtempr) - do j=1,nlat - do i=1,nlon - n = (j-1)*nlon + i - dnID_global(n) = int(rtempr(i,j)) - end do - end do - if (mainproc) write(iulog,*) 'dnID ',minval(rtempr),maxval(rtempr) - deallocate(rtempr) - - 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 nlon*nlat is upper right. - ! ID0 is the "key", modify dnID based on that. keep the IDkey around - ! for as long as needed. This is a key that translates the ID0 value - ! to the gindex value. compute the key, then apply the key to dnID_global. - ! As part of this, check that each value of ID0 is unique and within - ! the range of 1 to nlon*nlat. - !------------------------------------------------------- - - IDkey = 0 - do n=1,nlon*nlat - if (ID0_global(n) < 0 .or. ID0_global(n) > nlon*nlat) 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,nlon*nlat - if (dnID_global(n) > 0 .and. dnID_global(n) <= nlon*nlat) then - if (IDkey(dnID_global(n)) > 0 .and. IDkey(dnID_global(n)) <= nlon*nlat) then - dnID_global(n) = IDkey(dnID_global(n)) - else - write(iulog,*) subname,' ERROR bad IDkey',n,dnID_global(n),IDkey(dnID_global(n)) - call shr_sys_abort(subname//' ERROR bad IDkey') - endif - endif - enddo - - !------------------------------------------------------- - ! Determine mosart ocn/land mask (global, all procs) - !------------------------------------------------------- - - ! 1=land, 2=ocean, 3=ocean outlet from land - allocate(gmask(nlon*nlat)) - gmask(:) = 2 ! assume ocean point - do n=1,nlon*nlat ! mark all downstream points as outlet - nr = dnID_global(n) - if ((nr > 0) .and. (nr <= nlon*nlat)) then - gmask(nr) = 3 ! <- nr - end if - enddo - do n=1,nlon*nlat ! now mark all points with downstream points as land - nr = dnID_global(n) - if ((nr > 0) .and. (nr <= nlon*nlat)) then - gmask(n) = 1 ! <- n - end if - enddo - - !------------------------------------------------------- - ! Compute total number of basins and runoff points - !------------------------------------------------------- - - nbas = 0 - nrof = 0 - nout = 0 - nmos = 0 - do nr=1,nlon*nlat - if (gmask(nr) == 3) then - nout = nout + 1 - nbas = nbas + 1 - nmos = nmos + 1 - nrof = nrof + 1 - elseif (gmask(nr) == 2) then - nbas = nbas + 1 - nrof = nrof + 1 - elseif (gmask(nr) == 1) then - nmos = nmos + 1 - nrof = nrof + 1 - endif - enddo - if (mainproc) then - write(iulog,*) 'Number of outlet basins = ',nout - write(iulog,*) 'Number of total basins = ',nbas - write(iulog,*) 'Number of mosart points = ',nmos - write(iulog,*) 'Number of runoff points = ',nrof - endif - - !------------------------------------------------------- - ! Compute river basins, actually compute ocean outlet gridcell - !------------------------------------------------------- - - ! idxocn = final downstream cell, index is global 1d ocean gridcell - ! nupstrm = number of source gridcells upstream including self - allocate(idxocn(nlon*nlat),nupstrm(nlon*nlat)) - idxocn(:) = 0 - nupstrm(:) = 0 - do nr=1,nlon*nlat - n = nr - if (abs(gmask(n)) == 1) then ! land - g = 0 - do while (abs(gmask(n)) == 1 .and. g < nlon*nlat) ! follow downstream - nupstrm(n) = nupstrm(n) + 1 - n = dnID_global(n) - g = g + 1 - end do - if (gmask(n) == 3) then ! found ocean outlet - nupstrm(n) = nupstrm(n) + 1 ! one more land cell for n - idxocn(nr) = n ! set ocean outlet or nr to n - elseif (abs(gmask(n)) == 1) then ! no ocean outlet, warn user, ignore cell - write(iulog,*) subname,' ERROR closed basin found', & - g,nr,gmask(nr),dnID_global(nr), & - n,gmask(n),dnID_global(n) - call shr_sys_abort(subname//' ERROR closed basin found') - elseif (gmask(n) == 2) then - write(iulog,*) subname,' ERROR found invalid ocean cell ',nr - call shr_sys_abort(subname//' ERROR found invalid ocean cell') - else - write(iulog,*) subname,' ERROR downstream cell is unknown', & - g,nr,gmask(nr),dnID_global(nr), & - n,gmask(n),dnID_global(n) - call shr_sys_abort(subname//' ERROR downstream cell is unknown') - endif - elseif (gmask(n) >= 2) then ! ocean, give to self - nupstrm(n) = nupstrm(n) + 1 - idxocn(nr) = n - endif - enddo - - !------------------------------------------------------- - !--- Now allocate those basins to pes - !------------------------------------------------------- - - ! this is the heart of the decomp, need to set pocn and nop by the end of this - ! pocn is the pe that gets the basin associated with ocean outlet nr - ! nop is a running count of the number of mosart cells/pe - allocate(pocn(nlon*nlat)) - pocn(:) = -99 - nop(0:npes-1) = 0 - if (trim(decomp_option) == 'basin') then - - baspe = 0 - maxgcells_per_pe = int(float(nrof)/float(npes)*0.445) + 1 - nloops = 3 - minbas = nrof - do nl=1,nloops - maxbas = minbas - 1 - minbas = maxval(nupstrm)/(2**nl) - if (nl == nloops) minbas = min(minbas,1) - do nr=1,nlon*nlat - if (gmask(nr) >= 2 .and. nupstrm(nr) > 0 .and. nupstrm(nr) >= minbas .and. nupstrm(nr) <= maxbas) then - ! Decomp options - ! find min pe (implemented but scales poorly) - ! use increasing thresholds (implemented, ok load balance for l2r or calc) - ! distribute basins using above methods but work from max to min basin size - ! find next pe below maxgcells_per_pe threshhold and increment - do while (nop(baspe) > maxgcells_per_pe) - baspe = baspe + 1 - if (baspe > npes-1) then - baspe = 0 - ! 3 loop, .445 and 1.5 chosen carefully - maxgcells_per_pe = max(maxgcells_per_pe*1.5, maxgcells_per_pe+1.0) - endif - enddo - if (baspe > npes-1 .or. baspe < 0) then - write(iulog,*) 'ERROR in decomp for mosart ',nr,npes,baspe - call shr_sys_abort('ERROR mosart decomp') - endif - nop(baspe) = nop(baspe) + nupstrm(nr) - pocn(nr) = baspe - endif - enddo ! nr - enddo ! nl - - ! set pocn for land cells, was set for ocean above - do nr=1,nlon*nlat - if (idxocn(nr) > 0) then - pocn(nr) = pocn(idxocn(nr)) - if (pocn(nr) < 0 .or. pocn(nr) > npes-1) then - write(iulog,*) subname,' ERROR pocn lnd setting ',& - nr,idxocn(nr),idxocn(idxocn(nr)),pocn(idxocn(nr)),pocn(nr),npes - call shr_sys_abort(subname//' ERROR pocn lnd') - endif - endif - enddo - - elseif (trim(decomp_option) == '1d') then - - ! distribute active points in 1d fashion to pes - ! baspe is the pe assignment - ! maxgcells_per_pe is the maximum number of points to assign to each pe - baspe = 0 - maxgcells_per_pe = (nrof-1)/npes + 1 - do nr=1,nlon*nlat - if (gmask(nr) >= 1) then - pocn(nr) = baspe - nop(baspe) = nop(baspe) + 1 - if (nop(baspe) >= maxgcells_per_pe) then - baspe = (mod(baspe+1,npes)) - if (baspe < 0 .or. baspe > npes-1) then - write(iulog,*) subname,' ERROR basepe ',baspe,npes - call shr_sys_abort(subname//' ERROR pocn lnd') - endif - endif - endif - enddo - - elseif (trim(decomp_option) == 'roundrobin') then - - ! distribute active points in roundrobin fashion to pes - ! baspe is the pe assignment - ! maxgcells_per_pe is the maximum number of points to assign to each pe - baspe = 0 - do nr=1,nlon*nlat - 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 - do nr = 1,nlon*nlat - if (pocn(nr) < 0) then - write(6,*)'WARNING: nr,pocn(nr) is < 0',nr,pocn(nr) - end if - end do - - else - write(iulog,*) subname,' ERROR decomp option unknown ',trim(decomp_option) - call shr_sys_abort(subname//' ERROR pocn lnd') - endif ! decomp_option - - if (mainproc) then - write(iulog,*) 'mosart cells and basins total = ',nrof,nbas - write(iulog,*) 'mosart cells per basin avg/max = ',nrof/nbas,maxval(nupstrm) - write(iulog,*) 'mosart cells per pe min/max = ',minval(nop),maxval(nop) - write(iulog,*) 'mosart basins per pe min/max = ',minval(nba),maxval(nba) - endif - deallocate(nupstrm) - - !------------------------------------------------------- - ! Determine begr, endr, numr and lnumr - !------------------------------------------------------- - - numr = 0 - do n = 0,npes-1 - if (iam == n) then - begr = numr + 1 - endr = begr + nop(n) - 1 - endif - numr = numr + nop(n) - enddo - lnumr = endr - begr + 1 - - !------------------------------------------------------- - ! Determine glo2gdc (global to local) and gdc2glo (local to global) - !------------------------------------------------------- - - ! pocn(nlon*nlat) pe number assigned to basin - ! nop(0:npes-1) number of gridcells on a pe - ! nba(0:npes-1) number of basins on each pe - ! nrs(0:npes-1) begr on each pe - - ! Determine glo2gdc - ! nrs is begr on each pe - ! reuse nba for nop-like counter here, pocn -99 is unused cell - - nrs(:) = 0 - nrs(0) = 1 - do n = 1,npes-1 - ! nop is number of cells per pe - ! so loop through the pes and determine begr on each pe - nrs(n) = nrs(n-1) + nop(n-1) - enddo - - allocate(glo2gdc(nlon*nlat),gdc2glo(nlon*nlat)) - glo2gdc(:) = 0 - nba(:) = 0 - do nr = 1,nlon*nlat - procid = pocn(nr) - if (procid >= 0) then - glo2gdc(nr) = nrs(procid) + nba(procid) - nba(procid) = nba(procid) + 1 - endif - enddo - do n = 0,npes-1 - if (nba(n) /= nop(n)) then - write(iulog,*) subname,' ERROR mosart cell count ',n,nba(n),nop(n) - call shr_sys_abort(subname//' ERROR mosart cell count') - endif - enddo - - ! Determine gdc2glo - local to global index space - do j = 1,nlat - do i = 1,nlon - n = (j-1)*nlon + i - nr = glo2gdc(n) - if (nr > 0) then - gdc2glo(nr) = n - endif - end do - end do - - !------------------------------------------------------- - ! Determine gindex - !------------------------------------------------------- - - allocate(this%gindex(begr:endr)) - do nr = begr,endr - this%gindex(nr) = gdc2glo(nr) - n = this%gindex(nr) - if (n <= 0 .or. n > nlon*nlat) then - write(iulog,*) subname,' ERROR in gindex, nr,ng= ',nr,n - call shr_sys_abort(subname//' ERROR gindex values values') - endif - if (dnID_global(n) > 0) then - if (glo2gdc(dnID_global(n)) == 0) then - write(iulog,*) subname,' ERROR glo2gdc dnID_global ',& - nr,n,dnID_global(n),glo2gdc(dnID_global(n)) - call shr_sys_abort(subname//' ERROT glo2gdc dnID_global') - end if - end if - end do - - !------------------------------------------------------- - ! Create distGrid from global index array - !------------------------------------------------------- - - allocate(seqlist(endr-begr+1)) - n = 0 - do nr = begr,endr - n = n + 1 - seqlist(n) = this%gindex(nr) - end do - this%DistGrid = ESMF_DistGridCreate(arbSeqIndexList=seqlist, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - deallocate(seqlist) - - !------------------------------------------------------- - ! Determine local lonc and latc - !------------------------------------------------------- - - allocate(this%lonc(begr:endr), this%latc(begr:endr)) - do nr = begr,endr - n = gdc2glo(nr) - i = mod(n-1,nlon) + 1 - j = (n-1)/nlon + 1 - this%lonc(nr) = this%rlon(i) - this%latc(nr) = this%rlat(j) - end do - - !------------------------------------------------------- - ! Determine halo points and create halo route handle - !------------------------------------------------------- - - ! each note that for each gridcell below there are 4 extra elements that need to be allocated - ! Need to keep track of the global index of each halo point - ! temporary allocatable array store_halo_index = size((endr-begr+1)*nhalo) (nhalo is the number of halo points) - ! - ! Allocate halo_arrayptr_index - local index (starting at 1) into this%halo_arrayptr on my pe - allocate(this%halo_arrayptr_index(endr-begr+1,max_num_halo)) - this%halo_arrayptr_index(:,:) = -999 - - allocate(store_halo_index((endr-begr+1)*max_num_halo)) - store_halo_index(:) = 0 - - do nr = begr,endr - n = gdc2glo(nr) - i = mod(n-1,nlon) + 1 - j = (n-1)/nlon + 1 - jm1 = j-1 - jp1 = j+1 - im1 = i-1 - ip1 = i+1 - if (i == 1) im1 = 1 - if (j == 1) jm1 = 1 - if (i == nlon) ip1 = nlon - if (j == nlat) jp1 = nlat - n_sw = (jm1-1)*nlon + im1 - n_s = (jm1-1)*nlon + i - n_se = (jm1-1)*nlon + ip1 - n_e = ( j-1)*nlon + ip1 - n_ne = (jp1-1)*nlon + ip1 - n_n = (jp1-1)*nlon + i - n_nw = (jp1-1)*nlon + im1 - n_w = ( j-1)*nlon + im1 - call set_halo_index(n_sw, halo_sw, glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - call set_halo_index(n_s , halo_s , glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - call set_halo_index(n_se, halo_se, glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - call set_halo_index(n_e , halo_e , glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - call set_halo_index(n_ne, halo_ne, glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - call set_halo_index(n_n , halo_n , glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - call set_halo_index(n_nw, halo_nw, glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - call set_halo_index(n_w , halo_w , glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - end do - - ! Allocate halo_list - global indices of the halo points on my pe - num_halo = count(store_halo_index /= 0) - allocate(halo_list(num_halo)) - halo_list(1:num_halo) = store_halo_index(1:num_halo) - - ! Create halo route handle using predefined allocatable memory - allocate(this%halo_arrayptr(endr-begr+1+num_halo)) - this%halo_arrayptr(:) = 0. - this%haloArray = ESMF_ArrayCreate(this%distgrid, this%halo_arrayptr, haloSeqIndexList=halo_list, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - call ESMF_ArrayHaloStore(this%haloArray, routehandle=this%haloHandle, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - deallocate(halo_list) - deallocate(store_halo_index) - deallocate(gdc2glo,glo2gdc,pocn) - - ! Now do a test of the halo operation - call this%test_halo(rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - !------------------------------------------------------- - ! Determine mask, outletg and dsig - !------------------------------------------------------- - - allocate(this%mask(begr:endr), this%outletg(begr:endr), this%dsig(begr:endr)) - do nr = begr,endr - n = this%gindex(nr) - this%mask(nr) = gmask(n) - this%outletg(nr) = idxocn(n) - if (dnID_global(n) <= 0) then - this%dsig(nr) = 0 - else - this%dsig(nr) = dnID_global(n) - endif - end do - deallocate(gmask,dnID_global,idxocn) - - !------------------------------------------------------- - ! Write per-processor runoff bounds depending on dbug level - !------------------------------------------------------- - - if (mainproc) then - write(iulog,*) 'total runoff cells numr = ',numr - endif - call mpi_barrier(mpicom_rof,ier) - npmin = 0 - npmax = npes-1 - npint = 1 - if (dbug == 0) then - npmax = 0 - elseif (dbug == 1) then - npmax = min(npes-1,4) - elseif (dbug == 2) then - npint = npes/8 - elseif (dbug == 3) then - npint = 1 - endif - do np = npmin,npmax,npint - pid = np - if (dbug == 1) then - if (np == 2) pid=npes/2-1 - if (np == 3) pid=npes-2 - if (np == 4) pid=npes-1 - endif - pid = max(pid,0) - pid = min(pid,npes-1) - if (iam == pid) then - write(iulog,'(2a,i9,a,i9,a,i9,a,i9)')' mosart decomp info',& - ' proc = ',iam,' begr = ',begr,' endr = ',endr,' numr = ',lnumr - endif - call mpi_barrier(mpicom_rof,ier) - enddo - - end subroutine init_decomp - - !======================================================================== - - subroutine set_halo_index(global_index, halo_index, glo2gdc, nr, begr, endr, pocn, store_halo_index, halo_arrayptr_index) - - ! Arguments - integer, intent(in) :: global_index - integer, intent(in) :: halo_index - integer, intent(in) :: glo2gdc(:) - integer, intent(in) :: nr - integer, intent(in) :: begr, endr - integer, intent(in) :: pocn(:) - integer, intent(inout) :: store_halo_index(:) - integer, intent(inout) :: halo_arrayptr_index(:,:) - - ! Local variables - integer :: n - logical :: found_index - integer :: nsize - integer :: num_halo - !----------------------------------------------------------------------- - - nsize = endr-begr+1 - if (pocn(global_index) /= iam) then - found_index = .false. - do n = 1,size(store_halo_index) - if (store_halo_index(n) == global_index) then - num_halo = n - found_index = .true. - exit - else if (store_halo_index(n) == 0) then - store_halo_index(n) = global_index - num_halo = n - found_index = .true. - exit - end if - end do - if (.not. found_index) then - call shr_sys_abort('ERROR: global halo index not found') - end if - halo_arrayptr_index(nr-begr+1,halo_index) = nsize + num_halo - else - halo_arrayptr_index(nr-begr+1,halo_index) = glo2gdc(global_index) - begr + 1 - end if - - end subroutine set_halo_index - - !======================================================================== - subroutine test_halo(this, rc) - - ! Arguments - class(control_type) :: this - integer, intent(out) :: rc - - ! Local variables - integer :: i,j - integer :: n, nr - integer :: nglob - integer :: halo_value - integer :: valid_value - real(r8) :: lon, lon_p1, lon_m1 - real(r8) :: lat, lat_p1, lat_m1 - !----------------------------------------------------------------------- - - rc = ESMF_SUCCESS - - n = 0 - do nr = this%begr,this%endr - n = n + 1 - this%halo_arrayptr(n) = this%latc(nr)*10. + this%lonc(nr)/100. - end do - - call ESMF_ArrayHalo(this%haloArray, routehandle=this%haloHandle, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - n = 0 - do nr = this%begr,this%endr - n = n+1 - nglob = this%gindex(nr) - i = mod(nglob-1,this%nlon) + 1 - j = (nglob-1)/this%nlon + 1 - if (j== 1) then - lat_m1 = this%rlat(1) - else - lat_m1 = this%rlat(j-1) - end if - if (j == this%nlat) then - lat_p1 = this%rlat(this%nlat) - else - lat_p1 = this%rlat(j+1) - end if - lat = this%rlat(j) - if (i == 1) then - lon_m1 = this%rlon(1) - else - lon_m1 = this%rlon(i-1) - end if - if (i == this%nlon) then - lon_p1 = this%rlon(this%nlon) - else - lon_p1 = this%rlon(i+1) - end if - lon = this%rlon(i) - ! - halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_sw)) - valid_value = lat_m1*10 + lon_m1/100. - if (halo_value /= valid_value) then - write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value - call shr_sys_abort('ERROR: invalid halo') - end if - ! - halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_s)) - valid_value = lat_m1*10 + lon/100. - if (halo_value /= valid_value) then - write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value - call shr_sys_abort('ERROR: invalid halo') - end if - ! - halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_se)) - valid_value = lat_m1*10 + lon_p1/100. - if (halo_value /= valid_value) then - write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value - call shr_sys_abort('ERROR: invalid halo') - end if - ! - halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_e)) - valid_value = lat*10 + lon_p1/100. - if (halo_value /= valid_value) then - write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value - call shr_sys_abort('ERROR: invalid halo') - end if - ! - halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_ne)) - valid_value = lat_p1*10 + lon_p1/100. - if (halo_value /= valid_value) then - write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value - call shr_sys_abort('ERROR: invalid halo') - end if - ! - halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_nw)) - valid_value = lat_p1*10 + lon_m1/100. - if (halo_value /= valid_value) then - write(6,*)'ERROR: halo, valid not the same = ',halo_value, valid_value - call shr_sys_abort('ERROR: invalid halo') - end if - end do - - end subroutine test_halo + !======================================================================== + + subroutine Init(this, locfn, decomp_option, use_halo_option, IDkey, rc) + + ! Arguments + class(control_type) :: this + character(len=*) , intent(in) :: locfn + character(len=*) , intent(in) :: decomp_option ! decomposition option + logical , intent(in) :: use_halo_option ! create ESMF array and route handle for halos + integer , intent(out) :: IDkey(:) ! translation key from ID to gindex + integer , intent(out) :: rc + + ! Local variables + real(r8) :: area_global(this%nlon*this%nlat) ! area + real(r8) :: tempr(this%nlon,this%nlat) ! temporary buffer + real(r8) :: rlats(this%nlat) ! latitude of 1d south grid cell edge (deg) + real(r8) :: rlatn(this%nlat) ! latitude of 1d north grid cell edge (deg) + real(r8) :: rlonw(this%nlon) ! longitude of 1d west grid cell edge (deg) + real(r8) :: rlone(this%nlon) ! longitude of 1d east grid cell edge (deg) + real(r8) :: larea ! tmp local sum of area + real(r8) :: deg2rad ! pi/180 + integer :: g, n, i, j, nr, nt ! iterators + real(r8) :: edgen ! North edge of the direction file + real(r8) :: edgee ! East edge of the direction file + real(r8) :: edges ! South edge of the direction file + real(r8) :: edgew ! West edge of the direction file + real(r8) :: dx ! lon dist. betn grid cells (m) + real(r8) :: dy ! lat dist. betn grid cells (m) + type(file_desc_t) :: ncid ! pio file desc + logical :: found ! flag + integer :: ntracers ! used to simplify code + integer :: ier ! error status + integer :: begr, endr ! used to simplify code + integer :: nlon,nlat + real(r8) :: effvel0 = 10.0_r8 ! default velocity (m/s) + character(len=*),parameter :: subname = '(mosart_control_type: Init)' + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + nlon = this%nlon + nlat = this%nlat + + !--------------------------------------- + ! Read the routing parameters + !--------------------------------------- + + call ncd_pio_openfile (ncid, trim(locfn), 0) + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + + call ncd_io(ncid=ncid, varname='longxy', flag='read', data=tempr, readvar=found) + if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart longitudes') + if (mainproc) write(iulog,*) 'Read longxy ',minval(tempr),maxval(tempr) + allocate(this%rlon(this%nlon)) + do i=1,nlon + this%rlon(i) = tempr(i,1) + enddo + if (mainproc) write(iulog,*) 'rlon center ',minval(this%rlon),maxval(this%rlon) + + call ncd_io(ncid=ncid, varname='latixy', flag='read', data=tempr, readvar=found) + if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart latitudes') + if (mainproc) write(iulog,*) 'Read latixy ',minval(tempr),maxval(tempr) + allocate(this%rlat(this%nlat)) + do j=1,this%nlat + this%rlat(j) = tempr(1,j) + end do + if (mainproc) write(iulog,*) 'rlat center ',minval(this%rlat),maxval(this%rlat) + + call ncd_io(ncid=ncid, varname='area', flag='read', data=tempr, readvar=found) + if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart area') + if (mainproc) write(iulog,*) 'Read area ',minval(tempr),maxval(tempr) + do j=1,this%nlat + do i=1,nlon + n = (j-1)*nlon + i + area_global(n) = tempr(i,j) + end do + end do + if (mainproc) write(iulog,*) 'area ',minval(area_global),maxval(area_global) + call ncd_pio_closefile(ncid) + + !------------------------------------------------------- + ! adjust area estimation from DRT algorithm for those outlet grids + ! useful for grid-based representation only + ! need to compute areas where they are not defined in input file + !------------------------------------------------------- + + ! Derive gridbox edges + ! assuming equispaced grid, calculate edges from nlat/nlon + ! w/o assuming a global grid + edgen = maxval(this%rlat) + 0.5*abs(this%rlat(1) - this%rlat(2)) + edges = minval(this%rlat) - 0.5*abs(this%rlat(1) - this%rlat(2)) + edgee = maxval(this%rlon) + 0.5*abs(this%rlon(1) - this%rlon(2)) + edgew = minval(this%rlon) - 0.5*abs(this%rlon(1) - this%rlon(2)) + if (edgen .ne. 90._r8)then + if (mainproc ) write(iulog,*) 'Regional grid: edgen = ', edgen + end if + if (edges .ne. -90._r8)then + if (mainproc ) write(iulog,*) 'Regional grid: edges = ', edges + end if + if (edgee .ne. 180._r8)then + if (mainproc ) write(iulog,*) 'Regional grid: edgee = ', edgee + end if + if (edgew .ne.-180._r8)then + if ( mainproc ) write(iulog,*) 'Regional grid: edgew = ', edgew + end if + + ! Set edge latitudes (assumes latitudes are constant for a given longitude) + rlats(:) = edges + rlatn(:) = edgen + do j = 2, nlat + if (this%rlat(2) > this%rlat(1)) then ! South to North grid + rlats(j) = (this%rlat(j-1) + this%rlat(j)) / 2._r8 + rlatn(j-1) = rlats(j) + else ! North to South grid + rlatn(j) = (this%rlat(j-1) + this%rlat(j)) / 2._r8 + rlats(j-1) = rlatn(j) + end if + end do + + ! Set edge longitudes + rlonw(:) = edgew + rlone(:) = edgee + dx = (edgee - edgew) / nlon + do i = 2, nlon + rlonw(i) = rlonw(i) + (i-1)*dx + rlone(i-1) = rlonw(i) + end do + + ! adjust area estimation from DRT algorithm for those outlet grids + deg2rad = shr_const_pi / 180._r8 + do n=1,nlon*nlat + if (area_global(n) <= 0._r8) then + i = mod(n-1,nlon) + 1 + j = (n-1)/nlon + 1 + dx = (rlone(i) - rlonw(i)) * deg2rad + dy = sin(rlatn(j)*deg2rad) - sin(rlats(j)*deg2rad) + area_global(n) = abs(1.e6_r8 * dx*dy*re*re) + if (mainproc .and. area_global(n) <= 0) then + write(iulog,*) 'Warning! Zero area for unit ', n, area_global(n),dx,dy,re + end if + end if + end do + + ! --------------------------------------------- + ! Determine decomposition + ! --------------------------------------------- + + ! memory for this%gindex, this%mask and this%dsig is allocated in init_decomp + call t_startf('mosarti_decomp') + call this%init_decomp(locfn, decomp_option, use_halo_option, & + nlon, nlat, this%begr, this%endr, this%lnumr, this%numr, IDkey, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call t_stopf('mosarti_decomp') + + ! --------------------------------------------- + ! Allocate and initialize remaining variables + ! --------------------------------------------- + + begr = this%begr + endr = this%endr + ntracers = this%ntracers + + allocate(this%area(begr:endr), & + ! + this%volr(begr:endr,ntracers), & + this%dvolrdt(begr:endr,ntracers), & + this%dvolrdtlnd(begr:endr,ntracers), & + this%dvolrdtocn(begr:endr,ntracers), & + ! + this%runoff(begr:endr,ntracers), & + this%runofflnd(begr:endr,ntracers), & + this%runoffocn(begr:endr,ntracers), & + this%runofftot(begr:endr,ntracers), & + ! + this%fthresh(begr:endr), & + this%flood(begr:endr), & + ! + this%direct(begr:endr,ntracers), & + this%qsur(begr:endr,ntracers), & + this%qsub(begr:endr,ntracers), & + this%qgwl(begr:endr,ntracers), & + this%qirrig(begr:endr), & + this%qirrig_actual(begr:endr), & + !scs + this%zwt(begr:endr), & + this%slope(begr:endr), & + ! + this%evel(begr:endr,ntracers), & + this%flow(begr:endr,ntracers), & + this%erout_prev(begr:endr,ntracers), & + this%eroutup_avg(begr:endr,ntracers),& + this%erlat_avg(begr:endr,ntracers), & + ! + this%effvel(ntracers), & + stat=ier) + if (ier /= 0) then + write(iulog,*)'mosarart_control_type allocation error' + call shr_sys_abort + end if + + this%runoff(:,:) = 0._r8 + this%runofflnd(:,:) = spval + this%runoffocn(:,:) = spval + this%runofftot(:,:) = spval + this%dvolrdt(:,:) = 0._r8 + this%dvolrdtlnd(:,:) = spval + this%dvolrdtocn(:,:) = spval + this%volr(:,:) = 0._r8 + this%flood(:) = 0._r8 + this%direct(:,:) = 0._r8 + this%qirrig(:) = 0._r8 + this%qirrig_actual(:) = 0._r8 + !scs + this%zwt(:) = 0._r8 + this%slope(:) = 0._r8 + + this%qsur(:,:) = 0._r8 + this%qsub(:,:) = 0._r8 + this%qgwl(:,:) = 0._r8 + ! + this%fthresh(:) = abs(spval) + this%flow(:,:) = 0._r8 + this%erout_prev(:,:) = 0._r8 + this%eroutup_avg(:,:) = 0._r8 + this%erlat_avg(:,:) = 0._r8 + + this%effvel(:) = effvel0 ! downstream velocity (m/s) + do nt = 1,ntracers + do nr = begr,endr + this%evel(nr,nt) = this%effvel(nt) + enddo + enddo + + do nr = begr,endr + n = this%gindex(nr) + i = mod(n-1,nlon) + 1 + j = (n-1)/nlon + 1 + this%lonc(nr) = this%rlon(i) + this%latc(nr) = this%rlat(j) + this%area(nr) = area_global(n) + enddo + + larea = 0.0_r8 + do nr = begr,endr + larea = larea + this%area(nr) + end do + if (minval(this%mask) < 1) then + write(iulog,*) subname,'ERROR this mask lt 1 ',minval(this%mask),maxval(this%mask) + call shr_sys_abort(subname//' ERROR this mask') + endif + call shr_mpi_sum(larea, this%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 ',this%totarea + end if + + end subroutine Init + + !======================================================================== + subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & + nlon, nlat, begr, endr, lnumr, numr, IDkey, rc) + + ! Arguments + class(control_type) :: this + character(len=*) , intent(in) :: locfn ! local routing filename + character(len=*) , intent(in) :: decomp_option + logical , intent(in) :: use_halo_option + integer , intent(in) :: nlon + integer , intent(in) :: nlat + integer , intent(out) :: begr + integer , intent(out) :: endr + integer , intent(out) :: lnumr + integer , intent(out) :: numr + integer , intent(out) :: IDkey(:) ! translation key from ID to gindex + integer , intent(out) :: rc + + ! Local variables + integer :: n, nr, i, j, g ! indices + integer :: nl,nloops ! used for decomp search + integer, allocatable :: itempr(:,:) ! global temporary buffer + integer, allocatable :: gmask(:) ! global mask + integer, allocatable :: loc2glo(:) ! global local->global mapping + integer, allocatable :: glo2loc(:) ! global global->local mapping + integer, allocatable :: ID0_global(:) ! global (local) ID index + integer, allocatable :: dnID_global(:) ! global downstream ID based on ID0 + integer, allocatable :: idxocn(:) ! global downstream ocean outlet cell + integer, allocatable :: nupstrm(:) ! number of upstream cells including own cell + integer, allocatable :: pocn(:) ! pe number assigned to basin + integer :: nop(0:npes-1) ! number of gridcells on a pe + integer :: nba(0:npes-1) ! number of basins on each pe + integer :: nrs(0:npes-1) ! begr on each pe + integer :: maxgcells_per_pe ! max num of points per pe for decomp + integer :: minbas,maxbas ! used for decomp search + integer :: pid,np,npmin,npmax,npint ! log loop control + integer :: nmos ! number of mosart points + integer :: nout ! number of basin with outlets + integer :: nbas ! number of basin/ocean points + integer :: nrof ! num of active mosart points + integer :: baspe ! pe with min number of mosart cells + logical :: found ! flag + integer :: ier ! error status + type(file_desc_t) :: ncid ! pio file desc + integer :: procid + integer :: im1,ip1 + integer :: jm1,jp1 + integer :: n_sw, n_s, n_se + integer :: n_nw, n_n, n_ne + integer :: n_e, n_w + integer :: num_halo + integer, pointer :: halo_list(:) + integer, pointer :: seqlist(:) + integer, allocatable :: store_halo_index(:) + integer :: nglob + !scs + real(r8),allocatable :: rtempr(:,:) ! global temporary buffer - real + character(len=*),parameter :: subname = '(mosart_control_type: init_decomp) ' + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + !------------------------------------------------------- + ! Read ID and DnID from routing file + !------------------------------------------------------- + + call ncd_pio_openfile(ncid, trim(locfn), 0) + + !scs: use real input variables + allocate(rtempr(nlon,nlat)) + allocate(ID0_global(nlon*nlat),dnID_global(nlon*nlat)) + call ncd_io(ncid=ncid, varname='ID', flag='read', data=rtempr, readvar=found) + if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart ID') + if (mainproc) write(iulog,*) 'Read ID ',minval(rtempr),maxval(rtempr) + do j=1,nlat + do i=1,nlon + n = (j-1)*nlon + i + ID0_global(n) = int(rtempr(i,j)) + end do + end do + if (mainproc) write(iulog,*) 'ID ',minval(rtempr),maxval(rtempr) + + call ncd_io(ncid=ncid, varname='dnID', flag='read', data=rtempr, readvar=found) + if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart dnID') + if (mainproc) write(iulog,*) 'Read dnID ',minval(rtempr),maxval(rtempr) + do j=1,nlat + do i=1,nlon + n = (j-1)*nlon + i + dnID_global(n) = int(rtempr(i,j)) + end do + end do + if (mainproc) write(iulog,*) 'dnID ',minval(rtempr),maxval(rtempr) + deallocate(rtempr) + + 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 nlon*nlat is upper right. + ! ID0 is the "key", modify dnID based on that. keep the IDkey around + ! for as long as needed. This is a key that translates the ID0 value + ! to the gindex value. compute the key, then apply the key to dnID_global. + ! As part of this, check that each value of ID0 is unique and within + ! the range of 1 to nlon*nlat. + !------------------------------------------------------- + + IDkey = 0 + do n=1,nlon*nlat + if (ID0_global(n) < 0 .or. ID0_global(n) > nlon*nlat) 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,nlon*nlat + if (dnID_global(n) > 0 .and. dnID_global(n) <= nlon*nlat) then + if (IDkey(dnID_global(n)) > 0 .and. IDkey(dnID_global(n)) <= nlon*nlat) then + dnID_global(n) = IDkey(dnID_global(n)) + else + write(iulog,*) subname,' ERROR bad IDkey',n,dnID_global(n),IDkey(dnID_global(n)) + call shr_sys_abort(subname//' ERROR bad IDkey') + endif + endif + enddo + + !------------------------------------------------------- + ! Determine mosart ocn/land mask (global, all procs) + !------------------------------------------------------- + + ! 1=land, 2=ocean, 3=ocean outlet from land + allocate(gmask(nlon*nlat)) + gmask(:) = 2 ! assume ocean point + do n=1,nlon*nlat ! mark all downstream points as outlet + nr = dnID_global(n) + if ((nr > 0) .and. (nr <= nlon*nlat)) then + gmask(nr) = 3 ! <- nr + end if + enddo + do n=1,nlon*nlat ! now mark all points with downstream points as land + nr = dnID_global(n) + if ((nr > 0) .and. (nr <= nlon*nlat)) then + gmask(n) = 1 ! <- n + end if + enddo + + !------------------------------------------------------- + ! Compute total number of basins and runoff points + !------------------------------------------------------- + + nbas = 0 + nrof = 0 + nout = 0 + nmos = 0 + do nr=1,nlon*nlat + if (gmask(nr) == 3) then + nout = nout + 1 + nbas = nbas + 1 + nmos = nmos + 1 + nrof = nrof + 1 + elseif (gmask(nr) == 2) then + nbas = nbas + 1 + nrof = nrof + 1 + elseif (gmask(nr) == 1) then + nmos = nmos + 1 + nrof = nrof + 1 + endif + enddo + if (mainproc) then + write(iulog,*) 'Number of outlet basins = ',nout + write(iulog,*) 'Number of total basins = ',nbas + write(iulog,*) 'Number of mosart points = ',nmos + write(iulog,*) 'Number of runoff points = ',nrof + endif + + !------------------------------------------------------- + ! Compute river basins, actually compute ocean outlet gridcell + !------------------------------------------------------- + + ! idxocn = final downstream cell, index is global 1d ocean gridcell + ! nupstrm = number of source gridcells upstream including self + allocate(idxocn(nlon*nlat)) + allocate(nupstrm(nlon*nlat)) + idxocn(:) = 0 + nupstrm(:) = 0 + do nr=1,nlon*nlat + n = nr + if (abs(gmask(n)) == 1) then ! land + g = 0 + do while (abs(gmask(n)) == 1 .and. g < nlon*nlat) ! follow downstream + nupstrm(n) = nupstrm(n) + 1 + n = dnID_global(n) + g = g + 1 + end do + if (gmask(n) == 3) then ! found ocean outlet + nupstrm(n) = nupstrm(n) + 1 ! one more land cell for n + idxocn(nr) = n ! set ocean outlet or nr to n + elseif (abs(gmask(n)) == 1) then ! no ocean outlet, warn user, ignore cell + write(iulog,*) subname,' ERROR closed basin found', & + g,nr,gmask(nr),dnID_global(nr),n,gmask(n),dnID_global(n) + call shr_sys_abort(subname//' ERROR closed basin found') + elseif (gmask(n) == 2) then + write(iulog,*) subname,' ERROR found invalid ocean cell ',nr + call shr_sys_abort(subname//' ERROR found invalid ocean cell') + else + write(iulog,*) subname,' ERROR downstream cell is unknown', & + g,nr,gmask(nr),dnID_global(nr),n,gmask(n),dnID_global(n) + call shr_sys_abort(subname//' ERROR downstream cell is unknown') + endif + elseif (gmask(n) >= 2) then ! ocean, give to self + nupstrm(n) = nupstrm(n) + 1 + idxocn(nr) = n + endif + enddo + + !------------------------------------------------------- + !--- Now allocate those basins to pes + !------------------------------------------------------- + + ! this is the heart of the decomp, need to set pocn and nop by the end of this + ! pocn is the pe that gets the basin associated with ocean outlet nr + ! nop is a running count of the number of mosart cells/pe + allocate(pocn(nlon*nlat)) + pocn(:) = -99 + nop(0:npes-1) = 0 + if (trim(decomp_option) == 'basin') then + + baspe = 0 + maxgcells_per_pe = int(float(nrof)/float(npes)*0.445) + 1 + nloops = 3 + minbas = nrof + do nl=1,nloops + maxbas = minbas - 1 + minbas = maxval(nupstrm)/(2**nl) + if (nl == nloops) minbas = min(minbas,1) + do nr=1,nlon*nlat + if (gmask(nr) >= 2 .and. nupstrm(nr) > 0 .and. nupstrm(nr) >= minbas .and. nupstrm(nr) <= maxbas) then + ! Decomp options + ! find min pe (implemented but scales poorly) + ! use increasing thresholds (implemented, ok load balance for l2r or calc) + ! distribute basins using above methods but work from max to min basin size + ! find next pe below maxgcells_per_pe threshhold and increment + do while (nop(baspe) > maxgcells_per_pe) + baspe = baspe + 1 + if (baspe > npes-1) then + baspe = 0 + ! 3 loop, .445 and 1.5 chosen carefully + maxgcells_per_pe = max(maxgcells_per_pe*1.5, maxgcells_per_pe+1.0) + endif + enddo + if (baspe > npes-1 .or. baspe < 0) then + write(iulog,*) 'ERROR in decomp for mosart ',nr,npes,baspe + call shr_sys_abort('ERROR mosart decomp') + endif + nop(baspe) = nop(baspe) + nupstrm(nr) + pocn(nr) = baspe + endif + enddo ! nr + enddo ! nl + + ! set pocn for land cells, was set for ocean above + do nr=1,nlon*nlat + if (idxocn(nr) > 0) then + pocn(nr) = pocn(idxocn(nr)) + if (pocn(nr) < 0 .or. pocn(nr) > npes-1) then + write(iulog,*) subname,' ERROR pocn lnd setting ',& + nr,idxocn(nr),idxocn(idxocn(nr)),pocn(idxocn(nr)),pocn(nr),npes + call shr_sys_abort(subname//' ERROR pocn lnd') + endif + endif + enddo + + elseif (trim(decomp_option) == '1d') then + + ! distribute active points in 1d fashion to pes + ! baspe is the pe assignment + ! maxgcells_per_pe is the maximum number of points to assign to each pe + baspe = 0 + maxgcells_per_pe = (nrof-1)/npes + 1 + do nr=1,nlon*nlat + pocn(nr) = baspe + nop(baspe) = nop(baspe) + 1 + if (nop(baspe) >= maxgcells_per_pe) then + baspe = (mod(baspe+1,npes)) + if (baspe < 0 .or. baspe > npes-1) then + write(iulog,*) subname,' ERROR basepe ',baspe,npes + call shr_sys_abort(subname//' ERROR pocn lnd') + endif + endif + enddo + + elseif (trim(decomp_option) == 'roundrobin') then + + ! distribute active points in roundrobin fashion to pes + ! baspe is the pe assignment + ! maxgcells_per_pe is the maximum number of points to assign to each pe + baspe = 0 + do nr=1,nlon*nlat + pocn(nr) = baspe + nop(baspe) = nop(baspe) + 1 + baspe = (mod(baspe+1,npes)) + if (baspe < 0 .or. baspe > npes-1) then + write(iulog,*) subname,' ERROR basepe ',baspe,npes + call shr_sys_abort(subname//' ERROR pocn lnd') + endif + enddo + do nr = 1,nlon*nlat + if (pocn(nr) < 0) then + write(6,*)'WARNING: nr,pocn(nr) is < 0',nr,pocn(nr) + end if + end do + + else + write(iulog,*) subname,' ERROR decomp option unknown ',trim(decomp_option) + call shr_sys_abort(subname//' ERROR pocn lnd') + endif ! decomp_option + + if (mainproc) then + write(iulog,*) 'mosart cells and basins total = ',nrof,nbas + write(iulog,*) 'mosart cells per basin avg/max = ',nrof/nbas,maxval(nupstrm) + write(iulog,*) 'mosart cells per pe min/max = ',minval(nop),maxval(nop) + write(iulog,*) 'mosart basins per pe min/max = ',minval(nba),maxval(nba) + endif + deallocate(nupstrm) + + !------------------------------------------------------- + ! Determine begr, endr, numr and lnumr + !------------------------------------------------------- + + numr = 0 + do n = 0,npes-1 + if (iam == n) then + begr = numr + 1 + endr = begr + nop(n) - 1 + endif + numr = numr + nop(n) + enddo + lnumr = endr - begr + 1 + + !------------------------------------------------------- + ! Determine glo2loc (global to local) and loc2glo (local to global) + !------------------------------------------------------- + + ! pocn(nlon*nlat) pe number assigned to basin + ! nop(0:npes-1) number of gridcells on a pe + ! nba(0:npes-1) number of basins on each pe + ! nrs(0:npes-1) begr on each pe + + ! Determine glo2loc + ! nrs is begr on each pe + ! reuse nba for nop-like counter here, pocn -99 is unused cell + + nrs(:) = 0 + nrs(0) = 1 + do n = 1,npes-1 + ! nop is number of cells per pe + ! so loop through the pes and determine begr on each pe + nrs(n) = nrs(n-1) + nop(n-1) + enddo + + allocate(glo2loc(nlon*nlat),loc2glo(nlon*nlat)) + glo2loc(:) = 0 + nba(:) = 0 + do nr = 1,nlon*nlat + procid = pocn(nr) + if (procid >= 0) then + glo2loc(nr) = nrs(procid) + nba(procid) + nba(procid) = nba(procid) + 1 + endif + enddo + do n = 0,npes-1 + if (nba(n) /= nop(n)) then + write(iulog,*) subname,' ERROR mosart cell count ',n,nba(n),nop(n) + call shr_sys_abort(subname//' ERROR mosart cell count') + endif + enddo + + ! Determine loc2glo - local to global index space + do j = 1,nlat + do i = 1,nlon + n = (j-1)*nlon + i + nr = glo2loc(n) + if (nr > 0) then + loc2glo(nr) = n + endif + end do + end do + + !------------------------------------------------------- + ! Determine gindex + !------------------------------------------------------- + + allocate(this%gindex(begr:endr)) + do nr = begr,endr + this%gindex(nr) = loc2glo(nr) + n = this%gindex(nr) + if (n <= 0 .or. n > nlon*nlat) then + write(iulog,*) subname,' ERROR in gindex, nr,ng= ',nr,n + call shr_sys_abort(subname//' ERROR gindex values values') + endif + if (dnID_global(n) > 0) then + if (glo2loc(dnID_global(n)) == 0) then + write(iulog,*) subname,' ERROR glo2loc dnID_global ',& + nr,n,dnID_global(n),glo2loc(dnID_global(n)) + call shr_sys_abort(subname//' ERROT glo2loc dnID_global') + end if + end if + end do + + !------------------------------------------------------- + ! Create distGrid from global index array + !------------------------------------------------------- + + allocate(seqlist(endr-begr+1)) + n = 0 + do nr = begr,endr + n = n + 1 + seqlist(n) = this%gindex(nr) + end do + this%DistGrid = ESMF_DistGridCreate(arbSeqIndexList=seqlist, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + deallocate(seqlist) + + !------------------------------------------------------- + ! Determine local lonc and latc + !------------------------------------------------------- + + allocate(this%lonc(begr:endr), this%latc(begr:endr)) + do nr = begr,endr + n = loc2glo(nr) + i = mod(n-1,nlon) + 1 + j = (n-1)/nlon + 1 + this%lonc(nr) = this%rlon(i) + this%latc(nr) = this%rlat(j) + end do + + !------------------------------------------------------- + ! Determine halo points and create halo route handle + !------------------------------------------------------- + if( use_halo_option ) then + ! note that for each gridcell below there are nhalo extra elements that need to be allocated + ! Need to keep track of the global index of each halo point + ! temporary allocatable array store_halo_index = size((endr-begr+1)*nhalo) (nhalo is the number of halo points) + ! + ! Allocate halo_arrayptr_index - local index (starting at 1) into this%halo_arrayptr on my pe + allocate(this%halo_arrayptr_index(endr-begr+1,max_num_halo)) + this%halo_arrayptr_index(:,:) = -999 + + allocate(store_halo_index((endr-begr+1)*max_num_halo)) + store_halo_index(:) = 0 + + do nr = begr,endr + n = loc2glo(nr) + i = mod(n-1,nlon) + 1 + j = (n-1)/nlon + 1 + jm1 = j-1 + jp1 = j+1 + im1 = i-1 + ip1 = i+1 + if (i == 1) im1 = 1 + if (j == 1) jm1 = 1 + if (i == nlon) ip1 = nlon + if (j == nlat) jp1 = nlat + n_sw = (jm1-1)*nlon + im1 + n_s = (jm1-1)*nlon + i + n_se = (jm1-1)*nlon + ip1 + n_e = ( j-1)*nlon + ip1 + n_ne = (jp1-1)*nlon + ip1 + n_n = (jp1-1)*nlon + i + n_nw = (jp1-1)*nlon + im1 + n_w = ( j-1)*nlon + im1 + call set_halo_index(n_sw, halo_sw, glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_s , halo_s , glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_se, halo_se, glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_e , halo_e , glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_ne, halo_ne, glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_n , halo_n , glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_nw, halo_nw, glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_w , halo_w , glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + end do + + ! Allocate halo_list - global indices of the halo points on my pe + num_halo = count(store_halo_index /= 0) + allocate(halo_list(num_halo)) + halo_list(1:num_halo) = store_halo_index(1:num_halo) + + ! Create halo route handle using predefined allocatable memory + allocate(this%halo_arrayptr(endr-begr+1+num_halo)) + this%halo_arrayptr(:) = 0. + this%halo_array = ESMF_ArrayCreate(this%distgrid, this%halo_arrayptr, haloSeqIndexList=halo_list, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Create a halo route handle - only need one + call ESMF_ArrayHaloStore(this%halo_array, routehandle=this%haloHandle, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Create ESMF arrays for lon, lat and fld + allocate(this%lon_halo_arrayptr(endr-begr+1+num_halo)) + this%lon_halo_arrayptr(:) = 0. + this%lon_halo_array = ESMF_ArrayCreate(this%distgrid, this%lon_halo_arrayptr, haloSeqIndexList=halo_list, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + allocate(this%lat_halo_arrayptr(endr-begr+1+num_halo)) + this%lat_halo_arrayptr(:) = 0. + this%lat_halo_array = ESMF_ArrayCreate(this%distgrid, this%lat_halo_arrayptr, haloSeqIndexList=halo_list, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Set halo array for lon and lat - these do not change with time + n = 0 + do nr = this%begr,this%endr + n = n + 1 + this%lon_halo_arrayptr(n) = this%lonc(nr) + this%lat_halo_arrayptr(n) = this%latc(nr) + end do + call ESMF_ArrayHalo(this%lon_halo_array, routehandle=this%haloHandle, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_ArrayHalo(this%lat_halo_array, routehandle=this%haloHandle, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Create ESMF array for zwt - this will be time dependent + allocate(this%zwt_halo_arrayptr(endr-begr+1+num_halo)) + this%zwt_halo_arrayptr(:) = 0. + this%zwt_halo_array = ESMF_ArrayCreate(this%distgrid, this%zwt_halo_arrayptr, haloSeqIndexList=halo_list, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Deallocate memory + deallocate(halo_list) + deallocate(store_halo_index) + + ! Now do a test of the halo operation + call this%test_halo(rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + endif + deallocate(loc2glo,glo2loc,pocn) + + !------------------------------------------------------- + ! Determine mask, outletg and dsig + !------------------------------------------------------- + + allocate(this%mask(begr:endr), this%outletg(begr:endr), this%dsig(begr:endr)) + do nr = begr,endr + n = this%gindex(nr) + this%mask(nr) = gmask(n) + this%outletg(nr) = idxocn(n) + if (dnID_global(n) <= 0) then + this%dsig(nr) = 0 + else + this%dsig(nr) = dnID_global(n) + endif + end do + deallocate(gmask,dnID_global,idxocn) + + !------------------------------------------------------- + ! Write per-processor runoff bounds depending on dbug level + !------------------------------------------------------- + + if (mainproc) then + write(iulog,*) 'total runoff cells numr = ',numr + endif + call mpi_barrier(mpicom_rof,ier) + npmin = 0 + npmax = npes-1 + npint = 1 + if (dbug == 0) then + npmax = 0 + elseif (dbug == 1) then + npmax = min(npes-1,4) + elseif (dbug == 2) then + npint = npes/8 + elseif (dbug == 3) then + npint = 1 + endif + do np = npmin,npmax,npint + pid = np + if (dbug == 1) then + if (np == 2) pid=npes/2-1 + if (np == 3) pid=npes-2 + if (np == 4) pid=npes-1 + endif + pid = max(pid,0) + pid = min(pid,npes-1) + if (iam == pid) then + write(iulog,'(2a,i9,a,i9,a,i9,a,i9)')' mosart decomp info',& + ' proc = ',iam,' begr = ',begr,' endr = ',endr,' numr = ',lnumr + endif + call mpi_barrier(mpicom_rof,ier) + enddo + + end subroutine init_decomp + + !======================================================================== + + subroutine set_halo_index(global_index, halo_index, glo2loc, nr, begr, endr, pocn, store_halo_index, halo_arrayptr_index) + + ! Arguments + integer, intent(in) :: global_index + integer, intent(in) :: halo_index + integer, intent(in) :: glo2loc(:) + integer, intent(in) :: nr + integer, intent(in) :: begr, endr + integer, intent(in) :: pocn(:) + integer, intent(inout) :: store_halo_index(:) + integer, intent(inout) :: halo_arrayptr_index(:,:) + + ! Local variables + integer :: n + logical :: found_index + integer :: nsize + integer :: num_halo + !----------------------------------------------------------------------- + + nsize = endr-begr+1 + if (pocn(global_index) /= iam) then + found_index = .false. + do n = 1,size(store_halo_index) + if (store_halo_index(n) == global_index) then + num_halo = n + found_index = .true. + exit + else if (store_halo_index(n) == 0) then + store_halo_index(n) = global_index + num_halo = n + found_index = .true. + exit + end if + end do + if (.not. found_index) then + call shr_sys_abort('ERROR: global halo index not found') + end if + halo_arrayptr_index(nr-begr+1,halo_index) = nsize + num_halo + else + halo_arrayptr_index(nr-begr+1,halo_index) = glo2loc(global_index) - begr + 1 + end if + + end subroutine set_halo_index + + !======================================================================== + subroutine test_halo(this, rc) + + ! Arguments + class(control_type) :: this + integer, intent(out) :: rc + + ! Local variables + integer :: i,j + integer :: n, nr + integer :: nglob + integer :: halo_value + integer :: valid_value + real(r8) :: lon, lon_p1, lon_m1 + real(r8) :: lat, lat_p1, lat_m1 + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + n = 0 + do nr = this%begr,this%endr + n = n + 1 + this%halo_arrayptr(n) = this%latc(nr)*10. + this%lonc(nr)/100. + end do + + call ESMF_ArrayHalo(this%halo_array, routehandle=this%haloHandle, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + n = 0 + do nr = this%begr,this%endr + n = n+1 + nglob = this%gindex(nr) + i = mod(nglob-1,this%nlon) + 1 + j = (nglob-1)/this%nlon + 1 + if (j== 1) then + lat_m1 = this%rlat(1) + else + lat_m1 = this%rlat(j-1) + end if + if (j == this%nlat) then + lat_p1 = this%rlat(this%nlat) + else + lat_p1 = this%rlat(j+1) + end if + lat = this%rlat(j) + if (i == 1) then + lon_m1 = this%rlon(1) + else + lon_m1 = this%rlon(i-1) + end if + if (i == this%nlon) then + lon_p1 = this%rlon(this%nlon) + else + lon_p1 = this%rlon(i+1) + end if + lon = this%rlon(i) + ! + halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_sw)) + valid_value = lat_m1*10 + lon_m1/100. + if (halo_value /= valid_value) then + write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + ! + halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_s)) + valid_value = lat_m1*10 + lon/100. + if (halo_value /= valid_value) then + write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + ! + halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_se)) + valid_value = lat_m1*10 + lon_p1/100. + if (halo_value /= valid_value) then + write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + ! + halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_e)) + valid_value = lat*10 + lon_p1/100. + if (halo_value /= valid_value) then + write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + ! + halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_ne)) + valid_value = lat_p1*10 + lon_p1/100. + if (halo_value /= valid_value) then + write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + ! + halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_nw)) + valid_value = lat_p1*10 + lon_m1/100. + if (halo_value /= valid_value) then + write(6,*)'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + end do + + end subroutine test_halo + + !======================================================================== + + subroutine calc_gradient(this, fld, fld_halo_array, dfld_dx, dfld_dy, rc) + + ! Calculate head gradient from nine gridcells (center and surrounding) + + ! Arguments: + class(control_type) :: this + real(r8), intent(in) :: fld(this%begr:this%endr) + type(ESMF_Array) :: fld_halo_array + real(r8), intent(out) :: dfld_dx(:) ! gradient x component + real(r8), intent(out) :: dfld_dy(:) ! gradient y component + integer , intent(out) :: rc + + ! Local variables + integer :: i, m, n, nr ! local indices + real(r8) :: deg2rad + real(r8) :: mean_dx, mean_dy, dlon, dlat + real(r8) :: ax_indices(4) = (/2,3,3,4/) ! x indices to add + real(r8) :: sx_indices(4) = (/6,7,7,8/) ! x indices to subtract + real(r8) :: ay_indices(4) = (/1,1,2,8/) ! y indices to add + real(r8) :: sy_indices(4) = (/2,5,5,6/) ! y indices to subtract + integer :: surrounding_pts(max_num_halo) + real(r8) :: fld_surrounding(max_num_halo) + real(r8) :: dx(max_num_halo) + real(r8) :: dy(max_num_halo) + integer :: index + real(r8), pointer :: fld_halo_arrayptr(:) + !----------------------------------------------------------------------- + + call t_startf('gw_gradient') + + rc = ESMF_SUCCESS + + ! Define order of surround points (clockwise starting at north) + surrounding_pts(:) = (/halo_n, halo_ne, halo_e, halo_se, halo_s, halo_sw, halo_w, halo_nw/) + + ! degrees to radians + deg2rad = SHR_CONST_PI / 180._r8 + + ! Get pointer to data in ESMF array + call ESMF_ArrayGet(fld_halo_array, farrayPtr=fld_halo_arrayptr, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! update halo array for fld + n = 0 + do nr = this%begr,this%endr + n = n + 1 + fld_halo_arrayptr(n) = fld(nr) + end do + call ESMF_ArrayHalo(fld_halo_array, routehandle=this%haloHandle, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Initialize gradient components + dfld_dx(:) = 0._r8 + dfld_dy(:) = 0._r8 + + n = 0 + do nr = this%begr,this%endr + n = n+1 + + ! extract neighbors from halo array + do i = 1,max_num_halo + m = surrounding_pts(i) + index = this%halo_arrayptr_index(n,m) + fld_surrounding(i) = fld_halo_arrayptr(index) + dlon = (this%lon_halo_arrayptr(n) - this%lon_halo_arrayptr(index)) + dlat = (this%lat_halo_arrayptr(n) - this%lat_halo_arrayptr(index)) + dx(i) = SHR_CONST_REARTH * abs(dlon) * cos(deg2rad*this%latc(nr)) + dy(i) = SHR_CONST_REARTH * abs(dlat) + enddo + + ! calculate mean spacing + mean_dx = 0.5_r8 * (dx(halo_w)+dx(halo_e)) ! average dx west and east + mean_dy = 0.5_r8 * (dy(halo_s)+dy(halo_n)) ! average dy south and north + + ! compute gradient values + do i = 1,4 + dfld_dx(n) = (fld_surrounding(ax_indices(i)) - fld_surrounding(sx_indices(i))) / (8._r8*mean_dx) + dfld_dy(n) = (fld_surrounding(ay_indices(i)) - fld_surrounding(sy_indices(i))) / (8._r8*mean_dy) + enddo + + enddo ! end of nr loop + + end subroutine calc_gradient end module mosart_control_type diff --git a/src/riverroute/mosart_mod.F90 b/src/riverroute/mosart_mod.F90 index b85010a..266db7d 100644 --- a/src/riverroute/mosart_mod.F90 +++ b/src/riverroute/mosart_mod.F90 @@ -30,7 +30,6 @@ module mosart_mod use mosart_io , only : ncd_pio_openfile, ncd_inqdid, ncd_inqdlen, ncd_pio_closefile, ncd_decomp_init, & pio_subsystem use pio , only : file_desc_t - !use mpi , only : mpi_bcast, mpi_barrier, MPI_CHARACTER, MPI_LOGICAL, MPI_INTEGER use mpi ! ! !PUBLIC TYPES: diff --git a/src/riverroute/mosart_physics_mod.F90 b/src/riverroute/mosart_physics_mod.F90 index 6cde2f7..d5f5bca 100644 --- a/src/riverroute/mosart_physics_mod.F90 +++ b/src/riverroute/mosart_physics_mod.F90 @@ -175,6 +175,7 @@ subroutine Euler(rc) localDeltaT = Tctl%DeltaT/Tctl%DLevelH2R/TUnit%numDT_r(nr) temp_erout = 0._r8 do k=1,TUnit%numDT_r(nr) + ! TODO: is it positive (TRunoff%wr) and negative afterwards call mainchannelRouting(nr,nt,localDeltaT) TRunoff%wr(nr,nt) = TRunoff%wr(nr,nt) + TRunoff%dwr(nr,nt) * localDeltaT ! check for negative channel storage @@ -310,8 +311,7 @@ subroutine Routing_KW(nr, nt, theDeltaT) TRunoff%erout(nr,nt) = -TRunoff%vr(nr,nt) * TRunoff%mr(nr,nt) if(-TRunoff%erout(nr,nt) > TINYVALUE .and. TRunoff%wr(nr,nt) + & (TRunoff%erlateral(nr,nt) + TRunoff%erin(nr,nt) + TRunoff%erout(nr,nt)) * theDeltaT < TINYVALUE) then - TRunoff%erout(nr,nt) = & - -(TRunoff%erlateral(nr,nt) + TRunoff%erin(nr,nt) + TRunoff%wr(nr,nt) / theDeltaT) + TRunoff%erout(nr,nt) = -(TRunoff%erlateral(nr,nt) + TRunoff%erin(nr,nt) + TRunoff%wr(nr,nt) / theDeltaT) if(TRunoff%mr(nr,nt) > 0._r8) then TRunoff%vr(nr,nt) = -TRunoff%erout(nr,nt) / TRunoff%mr(nr,nt) end if @@ -323,8 +323,7 @@ subroutine Routing_KW(nr, nt, theDeltaT) TRunoff%dwr(nr,nt) = TRunoff%erlateral(nr,nt) + TRunoff%erin(nr,nt) + TRunoff%erout(nr,nt) + temp_gwl - if((TRunoff%wr(nr,nt)/theDeltaT & - + TRunoff%dwr(nr,nt)) < -TINYVALUE) then + if ((TRunoff%wr(nr,nt)/theDeltaT + TRunoff%dwr(nr,nt)) < -TINYVALUE) then write(iulog,*) 'mosart: ERROR main channel going negative: ', nr, nt write(iulog,*) theDeltaT, TRunoff%wr(nr,nt), & TRunoff%wr(nr,nt)/theDeltaT, TRunoff%dwr(nr,nt), temp_gwl diff --git a/src/riverroute/mosart_tstatusflux_type.F90 b/src/riverroute/mosart_tstatusflux_type.F90 index 583819b..a72e06f 100644 --- a/src/riverroute/mosart_tstatusflux_type.F90 +++ b/src/riverroute/mosart_tstatusflux_type.F90 @@ -54,18 +54,18 @@ module mosart_tstatusflux_type real(r8), pointer :: vr(:,:) ! flow velocity, [m/s] real(r8), pointer :: tr(:,:) ! mean travel time of the water within the channel, [s] !! exchange fluxes - real(r8), pointer :: erlg(:,:) ! evaporation, [m/s] - real(r8), pointer :: erlateral(:,:) ! lateral flow from hillslope, including surface and subsurface runoff generation components, [m3/s] - real(r8), pointer :: erin(:,:) ! inflow from upstream links, [m3/s] - real(r8), pointer :: erout(:,:) ! outflow into downstream links, [m3/s] - real(r8), pointer :: erout_prev(:,:) ! outflow into downstream links from previous timestep, [m3/s] - real(r8), pointer :: eroutUp(:,:) ! outflow sum of upstream gridcells, instantaneous (m3/s) + real(r8), pointer :: erlg(:,:) ! evaporation, [m/s] + real(r8), pointer :: erlateral(:,:) ! lateral flow from hillslope, including surface and subsurface runoff generation components, [m3/s] + real(r8), pointer :: erin(:,:) ! inflow from upstream links, [m3/s] + real(r8), pointer :: erout(:,:) ! outflow into downstream links, [m3/s] + real(r8), pointer :: erout_prev(:,:) ! outflow into downstream links from previous timestep, [m3/s] + real(r8), pointer :: eroutUp(:,:) ! outflow sum of upstream gridcells, instantaneous (m3/s) real(r8), pointer :: eroutUp_avg(:,:) ! outflow sum of upstream gridcells, average [m3/s] - real(r8), pointer :: erlat_avg(:,:) ! erlateral average [m3/s] - real(r8), pointer :: flow(:,:) ! streamflow from the outlet of the reach, [m3/s] - real(r8), pointer :: erin1(:,:) ! inflow from upstream links during previous step, used for Muskingum method, [m3/s] - real(r8), pointer :: erin2(:,:) ! inflow from upstream links during current step, used for Muskingum method, [m3/s] - real(r8), pointer :: ergwl(:,:) ! flux item for the adjustment of water balance residual in glacie, wetlands and lakes dynamics [m3/s] + real(r8), pointer :: erlat_avg(:,:) ! erlateral average [m3/s] + real(r8), pointer :: flow(:,:) ! streamflow from the outlet of the reach, [m3/s] + real(r8), pointer :: erin1(:,:) ! inflow from upstream links during previous step, used for Muskingum method, [m3/s] + real(r8), pointer :: erin2(:,:) ! inflow from upstream links during current step, used for Muskingum method, [m3/s] + real(r8), pointer :: ergwl(:,:) ! flux item for the adjustment of water balance residual in glacie, wetlands and lakes dynamics [m3/s] !! for Runge-Kutta algorithm real(r8), pointer :: wrtemp(:,:) ! temporary storage item, for 4th order Runge-Kutta algorithm; From ff80ba270ed7927c937e10f33d49f90e4cae33fb Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Fri, 12 Jan 2024 17:57:53 +0100 Subject: [PATCH 31/86] removal of some global arrays in initialization and addition of namelist for tracer specification --- cime_config/namelist_definition_mosart.xml | 12 ++ src/cpl/nuopc/rof_import_export.F90 | 31 ----- src/riverroute/mosart_control_type.F90 | 155 +++++++++------------ src/riverroute/mosart_histflds.F90 | 11 -- src/riverroute/mosart_io.F90 | 5 +- src/riverroute/mosart_mod.F90 | 20 ++- 6 files changed, 93 insertions(+), 141 deletions(-) diff --git a/cime_config/namelist_definition_mosart.xml b/cime_config/namelist_definition_mosart.xml index dea084e..c9a4049 100644 --- a/cime_config/namelist_definition_mosart.xml +++ b/cime_config/namelist_definition_mosart.xml @@ -254,4 +254,16 @@ + + char + mosart + mosart_inparm + + LIQ:ICE + + + Colon delimited string of mosart tracers. + + + diff --git a/src/cpl/nuopc/rof_import_export.F90 b/src/cpl/nuopc/rof_import_export.F90 index 5512b2a..9cb67db 100644 --- a/src/cpl/nuopc/rof_import_export.F90 +++ b/src/cpl/nuopc/rof_import_export.F90 @@ -36,8 +36,6 @@ module rof_import_export integer :: fldsToRof_num = 0 integer :: fldsFrRof_num = 0 logical :: flds_r2l_stream_channel_depths = .false. ! If should pass the channel depth fields needed for the hillslope model - !scs - logical :: flds_r2l_intergrid_gw = .false. ! If should pass the intergridcell groundwater flux type (fld_list_type) :: fldsToRof(fldsMax) type (fld_list_type) :: fldsFrRof(fldsMax) @@ -84,11 +82,6 @@ subroutine advertise_fields(gcomp, flds_scalar_name, rc) isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) read(cvalue,*) flds_r2l_stream_channel_depths - !scs - call NUOPC_CompAttributeGet(gcomp, name="flds_r2l_intergrid_gw", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) read(cvalue,*) flds_r2l_intergrid_gw call fldlist_add(fldsFrRof_num, fldsFrRof, trim(flds_scalar_name)) call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofl') call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofi') @@ -99,10 +92,6 @@ subroutine advertise_fields(gcomp, flds_scalar_name, rc) call fldlist_add(fldsFrRof_num, fldsFrRof, 'Sr_tdepth') call fldlist_add(fldsFrRof_num, fldsFrRof, 'Sr_tdepth_max') end if - !scs - if ( flds_r2l_intergrid_gw )then - call fldlist_add(fldsFrRof_num, fldsFrRof, 'Flrr_intergrid_gw') - endif do n = 1,fldsFrRof_num call NUOPC_Advertise(exportState, standardName=fldsFrRof(n)%stdname, & @@ -120,10 +109,6 @@ subroutine advertise_fields(gcomp, flds_scalar_name, rc) call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_rofsub') call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_rofi') call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_irrig') - !scs - if ( flds_r2l_intergrid_gw )then - call fldlist_add(fldsToRof_num, fldsToRof, 'Sl_zwt') - endif do n = 1,fldsToRof_num call NUOPC_Advertise(importState, standardName=fldsToRof(n)%stdname, & @@ -300,22 +285,6 @@ subroutine import_fields( gcomp, begr, endr, rc ) do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - !scs - if ( flds_r2l_intergrid_gw )then - call state_getimport(importState, 'Sl_zwt', begr, endr, ctl%area, output=ctl%zwt(:), & - do_area_correction=.true., rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - !scs: state_getimport multiplies variable by area; revert here - do n = begr,endr - ctl%zwt(n) = ctl%zwt(n)/(ctl%area(n)*0.001_r8) - ! this is b/c idk where 1e36 are coming from yet - if(ctl%zwt(n) > 100._r8) then - ctl%zwt(n) = 0._r8 - endif - end do - endif - ctl%qsub(begr:endr, nfrz) = 0.0_r8 ctl%qgwl(begr:endr, nfrz) = 0.0_r8 diff --git a/src/riverroute/mosart_control_type.F90 b/src/riverroute/mosart_control_type.F90 index efc1ed8..a688015 100644 --- a/src/riverroute/mosart_control_type.F90 +++ b/src/riverroute/mosart_control_type.F90 @@ -291,37 +291,37 @@ subroutine Init(this, locfn, decomp_option, use_halo_option, IDkey, rc) endr = this%endr ntracers = this%ntracers - allocate(this%area(begr:endr), & - ! + allocate(this%area(begr:endr), & + ! this%volr(begr:endr,ntracers), & this%dvolrdt(begr:endr,ntracers), & this%dvolrdtlnd(begr:endr,ntracers), & this%dvolrdtocn(begr:endr,ntracers), & - ! + ! this%runoff(begr:endr,ntracers), & this%runofflnd(begr:endr,ntracers), & this%runoffocn(begr:endr,ntracers), & this%runofftot(begr:endr,ntracers), & - ! + ! this%fthresh(begr:endr), & this%flood(begr:endr), & - ! + ! this%direct(begr:endr,ntracers), & this%qsur(begr:endr,ntracers), & this%qsub(begr:endr,ntracers), & this%qgwl(begr:endr,ntracers), & this%qirrig(begr:endr), & this%qirrig_actual(begr:endr), & - !scs + ! this%zwt(begr:endr), & - this%slope(begr:endr), & - ! + this%slope(begr:endr), & + ! this%evel(begr:endr,ntracers), & this%flow(begr:endr,ntracers), & this%erout_prev(begr:endr,ntracers), & this%eroutup_avg(begr:endr,ntracers),& this%erlat_avg(begr:endr,ntracers), & - ! + ! this%effvel(ntracers), & stat=ier) if (ier /= 0) then @@ -341,14 +341,11 @@ subroutine Init(this, locfn, decomp_option, use_halo_option, IDkey, rc) this%direct(:,:) = 0._r8 this%qirrig(:) = 0._r8 this%qirrig_actual(:) = 0._r8 - !scs this%zwt(:) = 0._r8 this%slope(:) = 0._r8 - this%qsur(:,:) = 0._r8 this%qsub(:,:) = 0._r8 this%qgwl(:,:) = 0._r8 - ! this%fthresh(:) = abs(spval) this%flow(:,:) = 0._r8 this%erout_prev(:,:) = 0._r8 @@ -408,15 +405,14 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & ! Local variables integer :: n, nr, i, j, g ! indices integer :: nl,nloops ! used for decomp search - integer, allocatable :: itempr(:,:) ! global temporary buffer + real(r8),allocatable :: rtempr(:,:) ! global temporary buffer - real integer, allocatable :: gmask(:) ! global mask - integer, allocatable :: loc2glo(:) ! global local->global mapping integer, allocatable :: glo2loc(:) ! global global->local mapping - integer, allocatable :: ID0_global(:) ! global (local) ID index integer, allocatable :: dnID_global(:) ! global downstream ID based on ID0 integer, allocatable :: idxocn(:) ! global downstream ocean outlet cell integer, allocatable :: nupstrm(:) ! number of upstream cells including own cell integer, allocatable :: pocn(:) ! pe number assigned to basin + integer :: ID0_global ! global (local) ID index integer :: nop(0:npes-1) ! number of gridcells on a pe integer :: nba(0:npes-1) ! number of basins on each pe integer :: nrs(0:npes-1) ! begr on each pe @@ -442,8 +438,6 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & integer, pointer :: seqlist(:) integer, allocatable :: store_halo_index(:) integer :: nglob - !scs - real(r8),allocatable :: rtempr(:,:) ! global temporary buffer - real character(len=*),parameter :: subname = '(mosart_control_type: init_decomp) ' !----------------------------------------------------------------------- @@ -453,21 +447,44 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & ! Read ID and DnID from routing file !------------------------------------------------------- + ! RESET dnID indices based on ID0 + ! rename the dnID values to be consistent with global grid indexing. + ! where 1 = lower left of grid and nlon*nlat is upper right. + ! ID0 is the "key", modify dnID based on that. keep the IDkey around + ! for as long as needed. This is a key that translates the ID0 value + ! to the gindex value. compute the key, then apply the key to dnID_global. + ! As part of this, check that each value of ID0 is unique and within + ! the range of 1 to nlon*nlat. + call ncd_pio_openfile(ncid, trim(locfn), 0) - !scs: use real input variables allocate(rtempr(nlon,nlat)) - allocate(ID0_global(nlon*nlat),dnID_global(nlon*nlat)) + allocate(dnID_global(nlon*nlat)) + call ncd_io(ncid=ncid, varname='ID', flag='read', data=rtempr, readvar=found) if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart ID') if (mainproc) write(iulog,*) 'Read ID ',minval(rtempr),maxval(rtempr) + + IDkey(:) = 0 do j=1,nlat do i=1,nlon n = (j-1)*nlon + i - ID0_global(n) = int(rtempr(i,j)) + ID0_global = int(rtempr(i,j)) + if (ID0_global < 0 .or. ID0_global > nlon*nlat) then + write(iulog,*) subname,' ERROR ID0 out of range',n,ID0_global + call shr_sys_abort(subname//' ERROR error ID0 out of range') + endif + if (IDkey(ID0_global) /= 0) then + write(iulog,*) subname,' ERROR ID0 value occurs twice',n,ID0_global + call shr_sys_abort(subname//' ERROR ID0 value occurs twice') + endif + IDkey(ID0_global) = n end do end do - if (mainproc) write(iulog,*) 'ID ',minval(rtempr),maxval(rtempr) + if (minval(IDkey) < 1) then + write(iulog,*) subname,' ERROR IDkey incomplete' + call shr_sys_abort(subname//' ERROR IDkey incomplete') + endif call ncd_io(ncid=ncid, varname='dnID', flag='read', data=rtempr, readvar=found) if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart dnID') @@ -476,6 +493,14 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & do i=1,nlon n = (j-1)*nlon + i dnID_global(n) = int(rtempr(i,j)) + if (dnID_global(n) > 0 .and. dnID_global(n) <= nlon*nlat) then + if (IDkey(dnID_global(n)) > 0 .and. IDkey(dnID_global(n)) <= nlon*nlat) then + dnID_global(n) = IDkey(dnID_global(n)) + else + write(iulog,*) subname,' ERROR bad IDkey',n,dnID_global(n),IDkey(dnID_global(n)) + call shr_sys_abort(subname//' ERROR bad IDkey') + endif + endif end do end do if (mainproc) write(iulog,*) 'dnID ',minval(rtempr),maxval(rtempr) @@ -483,44 +508,6 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & 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 nlon*nlat is upper right. - ! ID0 is the "key", modify dnID based on that. keep the IDkey around - ! for as long as needed. This is a key that translates the ID0 value - ! to the gindex value. compute the key, then apply the key to dnID_global. - ! As part of this, check that each value of ID0 is unique and within - ! the range of 1 to nlon*nlat. - !------------------------------------------------------- - - IDkey = 0 - do n=1,nlon*nlat - if (ID0_global(n) < 0 .or. ID0_global(n) > nlon*nlat) 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,nlon*nlat - if (dnID_global(n) > 0 .and. dnID_global(n) <= nlon*nlat) then - if (IDkey(dnID_global(n)) > 0 .and. IDkey(dnID_global(n)) <= nlon*nlat) then - dnID_global(n) = IDkey(dnID_global(n)) - else - write(iulog,*) subname,' ERROR bad IDkey',n,dnID_global(n),IDkey(dnID_global(n)) - call shr_sys_abort(subname//' ERROR bad IDkey') - endif - endif - enddo - !------------------------------------------------------- ! Determine mosart ocn/land mask (global, all procs) !------------------------------------------------------- @@ -735,7 +722,7 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & lnumr = endr - begr + 1 !------------------------------------------------------- - ! Determine glo2loc (global to local) and loc2glo (local to global) + ! Determine glo2loc (global to local) !------------------------------------------------------- ! pocn(nlon*nlat) pe number assigned to basin @@ -755,7 +742,7 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & nrs(n) = nrs(n-1) + nop(n-1) enddo - allocate(glo2loc(nlon*nlat),loc2glo(nlon*nlat)) + allocate(glo2loc(nlon*nlat)) glo2loc(:) = 0 nba(:) = 0 do nr = 1,nlon*nlat @@ -772,38 +759,25 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & endif enddo - ! Determine loc2glo - local to global index space + ! Determine gindex + allocate(this%gindex(begr:endr)) do j = 1,nlat do i = 1,nlon n = (j-1)*nlon + i + if (dnID_global(n) > 0) then + if (glo2loc(dnID_global(n)) == 0) then + write(iulog,*) subname,' ERROR glo2loc dnID_global ',& + nr,n,dnID_global(n),glo2loc(dnID_global(n)) + call shr_sys_abort(subname//' ERROT glo2loc dnID_global') + end if + end if nr = glo2loc(n) - if (nr > 0) then - loc2glo(nr) = n + if (nr >= begr .and. nr <= endr) then + this%gindex(nr) = n endif end do end do - !------------------------------------------------------- - ! Determine gindex - !------------------------------------------------------- - - allocate(this%gindex(begr:endr)) - do nr = begr,endr - this%gindex(nr) = loc2glo(nr) - n = this%gindex(nr) - if (n <= 0 .or. n > nlon*nlat) then - write(iulog,*) subname,' ERROR in gindex, nr,ng= ',nr,n - call shr_sys_abort(subname//' ERROR gindex values values') - endif - if (dnID_global(n) > 0) then - if (glo2loc(dnID_global(n)) == 0) then - write(iulog,*) subname,' ERROR glo2loc dnID_global ',& - nr,n,dnID_global(n),glo2loc(dnID_global(n)) - call shr_sys_abort(subname//' ERROT glo2loc dnID_global') - end if - end if - end do - !------------------------------------------------------- ! Create distGrid from global index array !------------------------------------------------------- @@ -824,7 +798,7 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & allocate(this%lonc(begr:endr), this%latc(begr:endr)) do nr = begr,endr - n = loc2glo(nr) + n = this%gindex(nr) i = mod(n-1,nlon) + 1 j = (n-1)/nlon + 1 this%lonc(nr) = this%rlon(i) @@ -847,7 +821,7 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & store_halo_index(:) = 0 do nr = begr,endr - n = loc2glo(nr) + n = this%gindex(nr) i = mod(n-1,nlon) + 1 j = (n-1)/nlon + 1 jm1 = j-1 @@ -928,7 +902,8 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & call this%test_halo(rc) if (chkerr(rc,__LINE__,u_FILE_u)) return endif - deallocate(loc2glo,glo2loc,pocn) + deallocate(glo2loc) + deallocate(pocn) !------------------------------------------------------- ! Determine mask, outletg and dsig @@ -945,7 +920,9 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & this%dsig(nr) = dnID_global(n) endif end do - deallocate(gmask,dnID_global,idxocn) + deallocate(gmask) + deallocate(dnID_global) + deallocate(idxocn) !------------------------------------------------------- ! Write per-processor runoff bounds depending on dbug level diff --git a/src/riverroute/mosart_histflds.F90 b/src/riverroute/mosart_histflds.F90 index 41fb49f..31287df 100644 --- a/src/riverroute/mosart_histflds.F90 +++ b/src/riverroute/mosart_histflds.F90 @@ -31,8 +31,6 @@ module mosart_histflds type(hist_pointer_type), allocatable :: h_qgwl(:) real(r8), pointer :: h_volr_mch(:) - !scs - real(r8), pointer :: h_water_table(:) !------------------------------------------------------------------------ contains @@ -77,8 +75,6 @@ subroutine mosart_histflds_init(begr, endr, ntracers) end do allocate(h_volr_mch(begr:endr)) - !scs - allocate(h_water_table(begr:endr)) !------------------------------------------------------- ! Build master field list of all possible fields in a history file. @@ -142,11 +138,6 @@ subroutine mosart_histflds_init(begr, endr, ntracers) avgflag='A', long_name='Actual irrigation (if limited by river storage)', & ptr_rof=ctl%qirrig_actual, default='inactive') - !scs - call mosart_hist_addfld (fname='WATER_TABLE', units='m', & - avgflag='A', long_name='water table from land', & - ptr_rof=h_water_table, default='inactive') - ! print masterlist of history fields call mosart_hist_printflds() @@ -178,8 +169,6 @@ subroutine mosart_histflds_set(ntracers) h_qgwl(nt)%data(:) = ctl%qgwl(:,nt) end do h_volr_mch(:) = Trunoff%wr(:,1) - !scs -! h_water_table(:) = ctl%zwt(:) end subroutine mosart_histflds_set diff --git a/src/riverroute/mosart_io.F90 b/src/riverroute/mosart_io.F90 index bd72c9a..15ae9f9 100644 --- a/src/riverroute/mosart_io.F90 +++ b/src/riverroute/mosart_io.F90 @@ -9,10 +9,6 @@ module mosart_io use shr_pio_mod , only : shr_pio_getiosys, shr_pio_getiotype, shr_pio_getioformat use mosart_vars , only : spval, ispval, iulog, mainproc, mpicom_rof, iam, npes use perf_mod , only : t_startf, t_stopf -!scs use mpi , only : mpi_barrier, mpi_bcast, MPI_CHARACTER -!scs use mpi , only : mpi_bcast - use mpi , only : mpi_barrier, MPI_CHARACTER - use pio , only : file_desc_t, var_desc_t, io_desc_t, iosystem_desc_t, pio_initdecomp, & pio_openfile, pio_iotask_rank, pio_closefile, pio_createfile, & pio_seterrorhandling, pio_inq_dimid, pio_inq_dimlen, pio_inq_dimname, & @@ -24,6 +20,7 @@ module mosart_io PIO_BCAST_ERROR, PIO_OFFSET_KIND, pio_INTERNAL_ERROR, & pio_int, pio_real, pio_double, pio_char, pio_global, & pio_write, pio_nowrite, pio_noclobber, pio_nofill, pio_unlimited + use mpi implicit none private diff --git a/src/riverroute/mosart_mod.F90 b/src/riverroute/mosart_mod.F90 index 266db7d..05e9c86 100644 --- a/src/riverroute/mosart_mod.F90 +++ b/src/riverroute/mosart_mod.F90 @@ -8,6 +8,7 @@ module mosart_mod 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 shr_string_mod , only : shr_string_listGetNum, shr_string_listGetName use mosart_vars , only : re, spval, iulog, ice_runoff, & frivinp, nsrContinue, nsrBranch, nsrStartup, nsrest, & inst_index, inst_suffix, inst_name, decomp_option, & @@ -46,6 +47,7 @@ module mosart_mod integer :: coupling_period ! mosart coupling period integer :: delt_mosart ! mosart internal timestep (->nsub) logical :: use_halo_option ! enable halo capability using ESMF + character(len=CL) :: mosart_tracers ! colon delimited string of tracer names ! subcycling integer :: nsub_save ! previous nsub @@ -88,12 +90,7 @@ subroutine mosart_read_namelist() namelist /mosart_inparm / frivinp, finidat, nrevsn, coupling_period, ice_runoff, & ndens, mfilt, nhtfrq, fincl1, fincl2, fincl3, fexcl1, fexcl2, fexcl3, & avgflag_pertape, decomp_option, bypass_routing_option, qgwl_runoff_option, & - use_halo_option, delt_mosart - - ! TODO: add the following as namelists - ctl%ntracers = 2 ! number of tracers - allocate(ctl%tracer_names(ctl%ntracers)) - ctl%tracer_names(:) = (/'LIQ','ICE'/) ! tracer names + use_halo_option, delt_mosart, mosart_tracers ! Preset values ice_runoff = .true. @@ -105,6 +102,7 @@ subroutine mosart_read_namelist() bypass_routing_option = 'direct_in_place' qgwl_runoff_option = 'threshold' use_halo_option = .false. + mosart_tracers = 'LIQ:ICE' ! TODO - add DOMC nlfilename_rof = "mosart_in" // trim(inst_suffix) inquire (file = trim(nlfilename_rof), exist = lexist) @@ -145,6 +143,15 @@ subroutine mosart_read_namelist() call mpi_bcast (fincl2, (max_namlen+2)*size(fincl2), MPI_CHARACTER, 0, mpicom_rof, ier) call mpi_bcast (fincl3, (max_namlen+2)*size(fincl3), MPI_CHARACTER, 0, mpicom_rof, ier) call mpi_bcast (avgflag_pertape, size(avgflag_pertape), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (mosart_tracers, CL, MPI_CHARACTER, 0, mpicom_rof, ier) + + ! Determine number of tracers and array of tracer names + ctl%ntracers = shr_string_listGetNum(mosart_tracers) + allocate(ctl%tracer_names(ctl%ntracers)) + do i = 1,ctl%ntracers + call shr_string_listGetName(mosart_tracers, i, ctl%tracer_names(i)) + end do + !ctl%tracer_names(:) = (/'LIQ','ICE','DOMC'/) ! tracer names runtyp(:) = 'missing' runtyp(nsrStartup + 1) = 'initial' @@ -160,6 +167,7 @@ subroutine mosart_read_namelist() write(iulog,*) ' use_halo_optoin = ',use_halo_option write(iulog,*) ' bypass_routing option = ',trim(bypass_routing_option) write(iulog,*) ' qgwl runoff option = ',trim(qgwl_runoff_option) + write(iulog,*) ' mosart tracers = ',trim(mosart_tracers) if (nsrest == nsrStartup .and. finidat /= ' ') then write(iulog,*) ' mosart initial data = ',trim(finidat) end if From 0be8c832bcfe1eb5081704c6c6b586b98ddd3e0c Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 15 Jan 2024 21:33:53 +0100 Subject: [PATCH 32/86] remamed fiels mosart_mod.F90 and mosart_physics_mod.F90 --- src/cpl/nuopc/rof_comp_nuopc.F90 | 2 +- .../{mosart_mod.F90 => mosart_driver.F90} | 20 +++++++++---------- ...art_physics_mod.F90 => mosart_physics.F90} | 9 ++++----- 3 files changed, 14 insertions(+), 17 deletions(-) rename src/riverroute/{mosart_mod.F90 => mosart_driver.F90} (99%) rename src/riverroute/{mosart_physics_mod.F90 => mosart_physics.F90} (99%) diff --git a/src/cpl/nuopc/rof_comp_nuopc.F90 b/src/cpl/nuopc/rof_comp_nuopc.F90 index 9cf190e..cbb633f 100644 --- a/src/cpl/nuopc/rof_comp_nuopc.F90 +++ b/src/cpl/nuopc/rof_comp_nuopc.F90 @@ -35,7 +35,7 @@ module rof_comp_nuopc mainproc, mpicom_rof, iam, npes, iulog, & nsrest, caseid, ctitle, version, hostname, username use mosart_data , only : ctl - use mosart_mod , only : mosart_read_namelist, mosart_init1, mosart_init2, mosart_run + use mosart_driver , only : mosart_read_namelist, mosart_init1, mosart_init2, mosart_run use mosart_timemanager , only : timemgr_setup, get_curr_date, get_step_size, advance_timestep use mosart_io , only : ncd_pio_init use mosart_restfile , only : brnch_retain_casename diff --git a/src/riverroute/mosart_mod.F90 b/src/riverroute/mosart_driver.F90 similarity index 99% rename from src/riverroute/mosart_mod.F90 rename to src/riverroute/mosart_driver.F90 index 05e9c86..49e6bfc 100644 --- a/src/riverroute/mosart_mod.F90 +++ b/src/riverroute/mosart_driver.F90 @@ -1,9 +1,9 @@ -module mosart_mod +module mosart_driver !----------------------------------------------------------------------- ! Mosart Routing Model - ! - ! !USES: + !----------------------------------------------------------------------- + use shr_kind_mod , only : r8 => shr_kind_r8, CS => shr_kind_cs, CL => shr_kind_CL use shr_sys_mod , only : shr_sys_abort use shr_mpi_mod , only : shr_mpi_sum, shr_mpi_max @@ -23,7 +23,7 @@ module mosart_mod fincl1, fincl2, fincl3, fexcl1, fexcl2, fexcl3, max_tapes, max_namlen use mosart_restfile , only : mosart_rest_timemanager, mosart_rest_getfile, mosart_rest_fileread, & mosart_rest_filewrite, mosart_rest_filename, finidat, nrevsn - use mosart_physics_mod , only : updatestate_hillslope, updatestate_subnetwork, updatestate_mainchannel, Euler + use mosart_physics , only : updatestate_hillslope, updatestate_subnetwork, updatestate_mainchannel, Euler use perf_mod , only : t_startf, t_stopf use nuopc_shr_methods , only : chkerr use ESMF , only : ESMF_SUCCESS, ESMF_FieldGet, ESMF_FieldSMMStore, ESMF_FieldSMM, & @@ -32,17 +32,16 @@ module mosart_mod pio_subsystem use pio , only : file_desc_t use mpi - ! - ! !PUBLIC TYPES: + implicit none private - ! - ! !PUBLIC MEMBER FUNCTIONS: + + ! public member functions: public :: mosart_read_namelist ! Read in mosart namelist public :: mosart_init1 ! Initialize mosart grid public :: mosart_init2 ! Initialize mosart maps public :: mosart_run ! River routing model - ! + ! mosart namelists integer :: coupling_period ! mosart coupling period integer :: delt_mosart ! mosart internal timestep (->nsub) @@ -151,7 +150,6 @@ subroutine mosart_read_namelist() do i = 1,ctl%ntracers call shr_string_listGetName(mosart_tracers, i, ctl%tracer_names(i)) end do - !ctl%tracer_names(:) = (/'LIQ','ICE','DOMC'/) ! tracer names runtyp(:) = 'missing' runtyp(nsrStartup + 1) = 'initial' @@ -989,4 +987,4 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) end subroutine mosart_run -end module mosart_mod +end module mosart_driver diff --git a/src/riverroute/mosart_physics_mod.F90 b/src/riverroute/mosart_physics.F90 similarity index 99% rename from src/riverroute/mosart_physics_mod.F90 rename to src/riverroute/mosart_physics.F90 index d5f5bca..b038927 100644 --- a/src/riverroute/mosart_physics_mod.F90 +++ b/src/riverroute/mosart_physics.F90 @@ -1,8 +1,8 @@ -MODULE MOSART_physics_mod +module mosart_physics !----------------------------------------------------------------------- ! Description: core code of MOSART. - ! Contains routines for solving diffusion wave and update the state of + ! Contains routines for solving diffusion wave and update the state of ! hillslope, subnetwork and main channel variables ! Developed by Hongyi Li, 12/29/2011. !----------------------------------------------------------------------- @@ -65,7 +65,6 @@ subroutine Euler(rc) if(TUnit%mask(nr) > 0) then call hillslopeRouting(nr,nt,Tctl%DeltaT) TRunoff%wh(nr,nt) = TRunoff%wh(nr,nt) + TRunoff%dwh(nr,nt) * Tctl%DeltaT - call UpdateState_hillslope(nr,nt) TRunoff%etin(nr,nt) = (-TRunoff%ehout(nr,nt) + TRunoff%qsub(nr,nt)) * TUnit%area(nr) * TUnit%frac(nr) endif @@ -89,7 +88,7 @@ subroutine Euler(rc) do m=1,Tctl%DLevelH2R - !--- accumulate/average erout at prior timestep (used in eroutUp calc) for budget analysis + ! accumulate/average erout at prior timestep (used in eroutUp calc) for budget analysis do nt=1,ctl%ntracers if (TUnit%euler_calc(nt)) then do nr=ctl%begr,ctl%endr @@ -602,4 +601,4 @@ function GRPR(hr_, rwidth_, rwidth0_,rdepth_) result(pr_) end if end function GRPR -end MODULE MOSART_physics_mod +end module mosart_physics From 67e7b35370297b91fbc661153293e47eb9739266 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 16 Jan 2024 12:15:50 +0100 Subject: [PATCH 33/86] added namelist input for euler calculation option --- cime_config/namelist_definition_mosart.xml | 13 ++++++++ src/riverroute/mosart_driver.F90 | 36 ++++++++++++--------- src/riverroute/mosart_tspatialunit_type.F90 | 18 +++++++++-- 3 files changed, 50 insertions(+), 17 deletions(-) diff --git a/cime_config/namelist_definition_mosart.xml b/cime_config/namelist_definition_mosart.xml index c9a4049..5b8e2e5 100644 --- a/cime_config/namelist_definition_mosart.xml +++ b/cime_config/namelist_definition_mosart.xml @@ -266,4 +266,17 @@ + + char + mosart + mosart_inparm + + T:F + + + Colon delimited string of toggle to turn on Euler algorithm for + tracer name in mosart_tracers. + + + diff --git a/src/riverroute/mosart_driver.F90 b/src/riverroute/mosart_driver.F90 index 49e6bfc..dc20a40 100644 --- a/src/riverroute/mosart_driver.F90 +++ b/src/riverroute/mosart_driver.F90 @@ -46,7 +46,8 @@ module mosart_driver integer :: coupling_period ! mosart coupling period integer :: delt_mosart ! mosart internal timestep (->nsub) logical :: use_halo_option ! enable halo capability using ESMF - character(len=CL) :: mosart_tracers ! colon delimited string of tracer names + character(len=CS) :: mosart_tracers ! colon delimited string of tracer names + character(len=CS) :: mosart_euler_calc ! colon delimited string of logicals for using Euler algorithm ! subcycling integer :: nsub_save ! previous nsub @@ -79,6 +80,7 @@ subroutine mosart_read_namelist() integer :: unitn ! unit for namelist file logical :: lexist ! File exists character(len=CS) :: runtyp(4) ! run type + logical, allocatable :: do_euler_calc(:) ! turn on euler algorithm character(len=*),parameter :: subname = '(mosart_read_namelist) ' !----------------------------------------------------------------------- @@ -89,7 +91,7 @@ subroutine mosart_read_namelist() namelist /mosart_inparm / frivinp, finidat, nrevsn, coupling_period, ice_runoff, & ndens, mfilt, nhtfrq, fincl1, fincl2, fincl3, fexcl1, fexcl2, fexcl3, & avgflag_pertape, decomp_option, bypass_routing_option, qgwl_runoff_option, & - use_halo_option, delt_mosart, mosart_tracers + use_halo_option, delt_mosart, mosart_tracers, mosart_euler_calc ! Preset values ice_runoff = .true. @@ -101,7 +103,8 @@ subroutine mosart_read_namelist() bypass_routing_option = 'direct_in_place' qgwl_runoff_option = 'threshold' use_halo_option = .false. - mosart_tracers = 'LIQ:ICE' ! TODO - add DOMC + mosart_tracers = 'LIQ:ICE' + mosart_euler_calc = 'T:F' nlfilename_rof = "mosart_in" // trim(inst_suffix) inquire (file = trim(nlfilename_rof), exist = lexist) @@ -142,7 +145,8 @@ subroutine mosart_read_namelist() call mpi_bcast (fincl2, (max_namlen+2)*size(fincl2), MPI_CHARACTER, 0, mpicom_rof, ier) call mpi_bcast (fincl3, (max_namlen+2)*size(fincl3), MPI_CHARACTER, 0, mpicom_rof, ier) call mpi_bcast (avgflag_pertape, size(avgflag_pertape), MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (mosart_tracers, CL, MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (mosart_tracers, CS, MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (mosart_euler_calc, CS, MPI_CHARACTER, 0, mpicom_rof, ier) ! Determine number of tracers and array of tracer names ctl%ntracers = shr_string_listGetNum(mosart_tracers) @@ -158,16 +162,17 @@ subroutine mosart_read_namelist() if (mainproc) then write(iulog,*) 'define run:' - write(iulog,*) ' run type = ',trim(runtyp(nsrest+1)) - write(iulog,*) ' coupling_period = ',coupling_period - write(iulog,*) ' delt_mosart = ',delt_mosart - write(iulog,*) ' decomp option = ',trim(decomp_option) - write(iulog,*) ' use_halo_optoin = ',use_halo_option - write(iulog,*) ' bypass_routing option = ',trim(bypass_routing_option) - write(iulog,*) ' qgwl runoff option = ',trim(qgwl_runoff_option) - write(iulog,*) ' mosart tracers = ',trim(mosart_tracers) + write(iulog,'(a)' ) ' run type = '//trim(runtyp(nsrest+1)) + write(iulog,'(a,i8)') ' coupling_period = ',coupling_period + write(iulog,'(a,i8)') ' delt_mosart = ',delt_mosart + write(iulog,'(a)' ) ' decomp option = '//trim(decomp_option) + write(iulog,'(a,l)' ) ' use_halo_optoin = ',use_halo_option + write(iulog,'(a)' ) ' bypass_routing option = '//trim(bypass_routing_option) + write(iulog,'(a)' ) ' qgwl runoff option = '//trim(qgwl_runoff_option) + write(iulog,'(a)' ) ' mosart tracers = '//trim(mosart_tracers) + write(iulog,'(a)' ) ' mosart euler calc = '//trim(mosart_euler_calc) if (nsrest == nsrStartup .and. finidat /= ' ') then - write(iulog,*) ' mosart initial data = ',trim(finidat) + write(iulog,'(a)') ' mosart initial data = '//trim(finidat) end if endif @@ -324,8 +329,9 @@ subroutine mosart_init2(Emesh, rc) call TRunoff%Init(begr, endr, ntracers) - call Tunit%Init(begr, endr, ntracers, ctl%nlon, ctl%nlat, Emesh, & - trim(frivinp), IDKey, Tpara%c_twid, Tctl%DLevelR, ctl%area, ctl%gindex, ctl%outletg, pio_subsystem, rc) + call Tunit%Init(begr, endr, ntracers, & + mosart_euler_calc, ctl%nlon, ctl%nlat, Emesh, trim(frivinp), IDKey, & + Tpara%c_twid, Tctl%DLevelR, ctl%area, ctl%gindex, ctl%outletg, pio_subsystem, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return !------------------------------------------------------- diff --git a/src/riverroute/mosart_tspatialunit_type.F90 b/src/riverroute/mosart_tspatialunit_type.F90 index 73be11f..095fa3f 100644 --- a/src/riverroute/mosart_tspatialunit_type.F90 +++ b/src/riverroute/mosart_tspatialunit_type.F90 @@ -2,9 +2,10 @@ module mosart_tspatialunit_type ! Topographic and geometric properties, applicable for both grid- and subbasin-based representations - use shr_kind_mod, only : r8 => shr_kind_r8, CL => SHR_KIND_CL + use shr_kind_mod, only : r8=>shr_kind_r8, CL=>SHR_KIND_CL, CS=>SHR_KIND_CS use shr_sys_mod, only : shr_sys_abort use shr_mpi_mod, only : shr_mpi_sum, shr_mpi_max + use shr_string_mod, only : shr_string_listGetName use mosart_io, only : ncd_pio_openfile, compDOF use mosart_vars, only : mainproc, mpicom_rof, iulog use nuopc_shr_methods, only : chkerr @@ -88,13 +89,14 @@ module mosart_tspatialunit_type contains !----------------------------------------------------------------------- - subroutine Init(this, begr, endr, ntracers, nlon, nlat, EMesh, & + subroutine Init(this, begr, endr, ntracers, mosart_euler_calc, nlon, nlat, EMesh, & frivinp, IDkey, c_twid, DLevelR, area, gindex, outletg, pio_subsystem, rc) ! Arguments class(Tspatialunit_type) :: this integer , intent(in) :: begr, endr integer , intent(in) :: ntracers + character(len=*) , intent(in) :: mosart_euler_calc real(r8) , intent(in) :: area(begr:endr) integer , intent(in) :: nlon, nlat character(len=*) , intent(in) :: frivinp @@ -117,6 +119,7 @@ subroutine Init(this, begr, endr, ntracers, nlon, nlat, EMesh, & integer :: dids(2) ! variable dimension ids integer :: dsizes(2) ! variable dimension lengths real(r8) :: hlen_max, rlen_min + character(len=CS) :: ctemp character(len=*),parameter :: FORMI = '(2A,2i10)' character(len=*),parameter :: FORMR = '(2A,2g15.7)' character(len=*),parameter :: subname = '(mosart_tspatialunit_type_init) ' @@ -137,6 +140,17 @@ subroutine Init(this, begr, endr, ntracers, nlon, nlat, EMesh, & call pio_initdecomp(pio_subsystem, pio_int , dsizes, compDOF, iodesc_int) allocate(this%euler_calc(ntracers)) + do n = 1,ntracers + call shr_string_listGetName(mosart_euler_calc, n, ctemp) + if (trim(ctemp) == 'T') then + this%euler_calc = .true. + else if (trim(ctemp) == 'F') then + this%euler_calc = .false. + else + call shr_sys_abort(trim(subname)//' mosart_euler_calc can only be T or F') + end if + end do + this%euler_calc = .true. allocate(this%frac(begr:endr)) From 33f5314f139220b017efd2552fba6d8cf58c831e Mon Sep 17 00:00:00 2001 From: Sean Swenson Date: Wed, 17 Jan 2024 09:56:32 -0700 Subject: [PATCH 34/86] fix gradient --- src/riverroute/mosart_control_type.F90 | 345 +++++++++++++++++-------- 1 file changed, 240 insertions(+), 105 deletions(-) diff --git a/src/riverroute/mosart_control_type.F90 b/src/riverroute/mosart_control_type.F90 index 2d81391..c55b5c6 100644 --- a/src/riverroute/mosart_control_type.F90 +++ b/src/riverroute/mosart_control_type.F90 @@ -75,21 +75,28 @@ module mosart_control_type real(r8), pointer :: effvel(:) => null() ! halo operations - type(ESMF_Array) :: haloArray type(ESMF_RouteHandle) :: haloHandle - real(r8), pointer :: halo_arrayptr(:) => null() ! preallocated memory for exclusive region plus halo - integer , pointer :: halo_arrayptr_index(:,:) ! index into halo_arrayptr that corresponds to a halo point + type(ESMF_Array) :: lon_haloArray + type(ESMF_Array) :: lat_haloArray + type(ESMF_Array) :: fld_haloArray + integer , pointer :: halo_arrayptr_index(:,:) => null() ! index into halo_arrayptr that corresponds to a halo point + real(r8), pointer :: fld_halo_arrayptr(:) => null() ! preallocated memory for exclusive region plus halo + real(r8), pointer :: lon_halo_arrayptr(:) => null() ! preallocated memory for exclusive region plus halo + real(r8), pointer :: lat_halo_arrayptr(:) => null() ! preallocated memory for exclusive region plus halo contains procedure, public :: Init procedure, private :: init_decomp procedure, private :: test_halo + procedure, public :: Gradient end type control_type public :: control_type private :: init_decomp + public :: Gradient + #ifdef NDEBUG integer,parameter :: dbug = 0 ! 0 = none, 1=normal, 2=much, 3=max @@ -97,15 +104,21 @@ module mosart_control_type integer,parameter :: dbug = 3 ! 0 = none, 1=normal, 2=much, 3=max #endif - integer :: max_num_halo = 8 - integer :: halo_sw = 1 - integer :: halo_s = 2 - integer :: halo_se = 3 - integer :: halo_e = 4 - integer :: halo_ne = 5 - integer :: halo_n = 6 - integer :: halo_nw = 7 - integer :: halo_w = 8 + integer, public :: max_num_halo = 8 + ! eight surrounding indices ordered as [N,NE,E,SE,S,SW,W,NW] + integer, public :: halo_n = 1 + integer, public :: halo_ne = 2 + integer, public :: halo_e = 3 + integer, public :: halo_se = 4 + integer, public :: halo_s = 5 + integer, public :: halo_sw = 6 + integer, public :: halo_w = 7 + integer, public :: halo_nw = 8 + + ! dimensions of halo array + integer :: halo_zwt = 1 + integer :: halo_lon = 2 + integer :: halo_att = 3 character(*), parameter :: u_FILE_u = & __FILE__ @@ -260,7 +273,6 @@ subroutine Init(this, locfn, decomp_option, use_halo_option, IDkey, rc) ! --------------------------------------------- ! memory for this%gindex, this%mask and this%dsig is allocated in init_decomp - call t_startf('mosarti_decomp') call this%init_decomp(locfn, decomp_option, use_halo_option, & nlon, nlat, this%begr, this%endr, this%lnumr, this%numr, IDkey, rc) @@ -322,6 +334,7 @@ subroutine Init(this, locfn, decomp_option, use_halo_option, IDkey, rc) this%direct(:,:) = 0._r8 this%qirrig(:) = 0._r8 this%qirrig_actual(:) = 0._r8 + this%qsur(:,:) = 0._r8 this%qsub(:,:) = 0._r8 this%qgwl(:,:) = 0._r8 @@ -385,15 +398,14 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & ! Local variables integer :: n, nr, i, j, g ! indices integer :: nl,nloops ! used for decomp search - integer :: itempr(nlon,nlat) ! global temporary buffer - integer :: gmask(nlon*nlat) ! global mask - integer :: gdc2glo(nlon*nlat) ! temporary for initialization - integer :: glo2gdc(nlon*nlat) ! temporary for initialization - integer :: ID0_global(nlon*nlat) ! global (local) ID index - integer :: dnID_global(nlon*nlat) ! global downstream ID based on ID0 - integer :: idxocn(nlon*nlat) ! downstream ocean outlet cell - integer :: nupstrm(nlon*nlat) ! number of upstream cells including own cell - integer :: pocn(nlon*nlat) ! pe number assigned to basin + integer, allocatable :: gmask(:) ! global mask + integer, allocatable :: gdc2glo(:) ! temporary for initialization + integer, allocatable :: glo2gdc(:) ! temporary for initialization + integer, allocatable :: ID0_global(:) ! global (local) ID index + integer, allocatable :: dnID_global(:) ! global downstream ID based on ID0 + 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 :: nop(0:npes-1) ! number of gridcells on a pe integer :: nba(0:npes-1) ! number of basins on each pe integer :: nrs(0:npes-1) ! begr on each pe @@ -419,6 +431,7 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & integer, pointer :: seqlist(:) integer, allocatable :: store_halo_index(:) integer :: nglob + real(r8),allocatable :: rtempr(:,:) ! global temporary buffer - real character(len=*),parameter :: subname = '(mosart_control_type: init_decomp) ' !----------------------------------------------------------------------- @@ -430,27 +443,30 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & call ncd_pio_openfile(ncid, trim(locfn), 0) - call ncd_io(ncid=ncid, varname='ID', flag='read', data=itempr, readvar=found) + allocate(rtempr(nlon,nlat)) + allocate(ID0_global(nlon*nlat),dnID_global(nlon*nlat)) + call ncd_io(ncid=ncid, varname='ID', flag='read', data=rtempr, readvar=found) if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart ID') - if (mainproc) write(iulog,*) 'Read ID ',minval(itempr),maxval(itempr) + if (mainproc) write(iulog,*) 'Read ID ',minval(rtempr),maxval(rtempr) do j=1,nlat do i=1,nlon n = (j-1)*nlon + i - ID0_global(n) = itempr(i,j) + ID0_global(n) = int(rtempr(i,j)) end do end do - if (mainproc) write(iulog,*) 'ID ',minval(itempr),maxval(itempr) + if (mainproc) write(iulog,*) 'ID ',minval(rtempr),maxval(rtempr) - call ncd_io(ncid=ncid, varname='dnID', flag='read', data=itempr, readvar=found) + call ncd_io(ncid=ncid, varname='dnID', flag='read', data=rtempr, readvar=found) if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart dnID') - if (mainproc) write(iulog,*) 'Read dnID ',minval(itempr),maxval(itempr) + if (mainproc) write(iulog,*) 'Read dnID ',minval(rtempr),maxval(rtempr) do j=1,nlat do i=1,nlon n = (j-1)*nlon + i - dnID_global(n) = itempr(i,j) + dnID_global(n) = int(rtempr(i,j)) end do end do - if (mainproc) write(iulog,*) 'dnID ',minval(itempr),maxval(itempr) + if (mainproc) write(iulog,*) 'dnID ',minval(rtempr),maxval(rtempr) + deallocate(rtempr) call ncd_pio_closefile(ncid) @@ -497,7 +513,7 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & !------------------------------------------------------- ! 1=land, 2=ocean, 3=ocean outlet from land - + allocate(gmask(nlon*nlat)) gmask(:) = 2 ! assume ocean point do n=1,nlon*nlat ! mark all downstream points as outlet nr = dnID_global(n) @@ -547,7 +563,7 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & ! idxocn = final downstream cell, index is global 1d ocean gridcell ! nupstrm = number of source gridcells upstream including self - + allocate(idxocn(nlon*nlat),nupstrm(nlon*nlat)) idxocn(:) = 0 nupstrm(:) = 0 do nr=1,nlon*nlat @@ -589,7 +605,7 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & ! this is the heart of the decomp, need to set pocn and nop by the end of this ! pocn is the pe that gets the basin associated with ocean outlet nr ! nop is a running count of the number of mosart cells/pe - + allocate(pocn(nlon*nlat)) pocn(:) = -99 nop(0:npes-1) = 0 if (trim(decomp_option) == 'basin') then @@ -694,7 +710,8 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & write(iulog,*) 'mosart cells per pe min/max = ',minval(nop),maxval(nop) write(iulog,*) 'mosart basins per pe min/max = ',minval(nba),maxval(nba) endif - + deallocate(nupstrm) + !------------------------------------------------------- ! Determine begr, endr, numr and lnumr !------------------------------------------------------- @@ -729,7 +746,8 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & ! so loop through the pes and determine begr on each pe nrs(n) = nrs(n-1) + nop(n-1) enddo - + + allocate(glo2gdc(nlon*nlat),gdc2glo(nlon*nlat)) glo2gdc(:) = 0 nba(:) = 0 do nr = 1,nlon*nlat @@ -808,69 +826,93 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & !------------------------------------------------------- ! Determine halo points and create halo route handle !------------------------------------------------------- + if( use_halo_option ) then + ! note that for each gridcell below there are nhalo extra elements that need to be allocated + ! Need to keep track of the global index of each halo point + ! temporary allocatable array store_halo_index = size((endr-begr+1)*nhalo) (nhalo is the number of halo points) + ! + ! Allocate halo_arrayptr_index - local index (starting at 1) into this%halo_arrayptr on my pe + allocate(this%halo_arrayptr_index(endr-begr+1,max_num_halo)) + this%halo_arrayptr_index(:,:) = -999 - ! each note that for each gridcell below there are 4 extra elements that need to be allocated - ! Need to keep track of the global index of each halo point - ! temporary allocatable array store_halo_index = size((endr-begr+1)*nhalo) (nhalo is the number of halo points) - ! - ! Allocate halo_arrayptr_index - local index (starting at 1) into this%halo_arrayptr on my pe - allocate(this%halo_arrayptr_index(endr-begr+1,max_num_halo)) - this%halo_arrayptr_index(:,:) = -999 - - allocate(store_halo_index((endr-begr+1)*max_num_halo)) - store_halo_index(:) = 0 - - do nr = begr,endr - n = gdc2glo(nr) - i = mod(n-1,nlon) + 1 - j = (n-1)/nlon + 1 - jm1 = j-1 - jp1 = j+1 - im1 = i-1 - ip1 = i+1 - if (i == 1) im1 = 1 - if (j == 1) jm1 = 1 - if (i == nlon) ip1 = nlon - if (j == nlat) jp1 = nlat - n_sw = (jm1-1)*nlon + im1 - n_s = (jm1-1)*nlon + i - n_se = (jm1-1)*nlon + ip1 - n_e = ( j-1)*nlon + ip1 - n_ne = (jp1-1)*nlon + ip1 - n_n = (jp1-1)*nlon + i - n_nw = (jp1-1)*nlon + im1 - n_w = ( j-1)*nlon + im1 - call set_halo_index(n_sw, halo_sw, glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - call set_halo_index(n_s , halo_s , glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - call set_halo_index(n_se, halo_se, glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - call set_halo_index(n_e , halo_e , glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - call set_halo_index(n_ne, halo_ne, glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - call set_halo_index(n_n , halo_n , glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - call set_halo_index(n_nw, halo_nw, glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - call set_halo_index(n_w , halo_w , glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - end do - - ! Allocate halo_list - global indices of the halo points on my pe - num_halo = count(store_halo_index /= 0) - allocate(halo_list(num_halo)) - halo_list(1:num_halo) = store_halo_index(1:num_halo) - - ! Create halo route handle using predefined allocatable memory - allocate(this%halo_arrayptr(endr-begr+1+num_halo)) - this%halo_arrayptr(:) = 0. - this%haloArray = ESMF_ArrayCreate(this%distgrid, this%halo_arrayptr, haloSeqIndexList=halo_list, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - call ESMF_ArrayHaloStore(this%haloArray, routehandle=this%haloHandle, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - deallocate(halo_list) - deallocate(store_halo_index) + allocate(store_halo_index((endr-begr+1)*max_num_halo)) + store_halo_index(:) = 0 - ! Now do a test of the halo operation - call this%test_halo(rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + do nr = begr,endr + n = gdc2glo(nr) + i = mod(n-1,nlon) + 1 + j = (n-1)/nlon + 1 + jm1 = j-1 + jp1 = j+1 + im1 = i-1 + ip1 = i+1 + if (i == 1) im1 = 1 + if (j == 1) jm1 = 1 + if (i == nlon) ip1 = nlon + if (j == nlat) jp1 = nlat + n_sw = (jm1-1)*nlon + im1 + n_s = (jm1-1)*nlon + i + n_se = (jm1-1)*nlon + ip1 + n_e = ( j-1)*nlon + ip1 + n_ne = (jp1-1)*nlon + ip1 + n_n = (jp1-1)*nlon + i + n_nw = (jp1-1)*nlon + im1 + n_w = ( j-1)*nlon + im1 + call set_halo_index(n_sw, halo_sw, glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_s , halo_s , glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_se, halo_se, glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_e , halo_e , glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_ne, halo_ne, glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_n , halo_n , glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_nw, halo_nw, glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_w , halo_w , glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + end do + ! Allocate halo_list - global indices of the halo points on my pe + num_halo = count(store_halo_index /= 0) + allocate(halo_list(num_halo)) + halo_list(1:num_halo) = store_halo_index(1:num_halo) + + ! Create halo route handle using predefined allocatable memory + ! Create ESMF array for field - this will be time dependent + allocate(this%fld_halo_arrayptr(endr-begr+1+num_halo)) + this%fld_halo_arrayptr(:) = 0. + this%fld_haloArray = ESMF_ArrayCreate(this%distgrid, this%fld_halo_arrayptr, haloSeqIndexList=halo_list, rc=rc) + call ESMF_ArrayHaloStore(this%fld_haloArray, routehandle=this%haloHandle, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Create ESMF arrays for lon, lat and fld + allocate(this%lon_halo_arrayptr(endr-begr+1+num_halo)) + this%lon_halo_arrayptr(:) = 0. + this%lon_haloArray = ESMF_ArrayCreate(this%distgrid, this%lon_halo_arrayptr, haloSeqIndexList=halo_list, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + allocate(this%lat_halo_arrayptr(endr-begr+1+num_halo)) + this%lat_halo_arrayptr(:) = 0. + this%lat_haloArray = ESMF_ArrayCreate(this%distgrid, this%lat_halo_arrayptr, haloSeqIndexList=halo_list, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Set halo array for lon and lat - these do not change with time + n = 0 + do nr = this%begr,this%endr + n = n + 1 + this%lon_halo_arrayptr(n) = this%lonc(nr) + this%lat_halo_arrayptr(n) = this%latc(nr) + end do + call ESMF_ArrayHalo(this%lon_haloArray, routehandle=this%haloHandle, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_ArrayHalo(this%lat_haloArray, routehandle=this%haloHandle, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + deallocate(halo_list) + deallocate(store_halo_index) + + ! Now do a test of the halo operation + call this%test_halo(rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + endif + deallocate(gdc2glo,glo2gdc,pocn) + !------------------------------------------------------- ! Determine mask, outletg and dsig !------------------------------------------------------- @@ -886,7 +928,8 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & this%dsig(nr) = dnID_global(n) endif end do - + deallocate(gmask,dnID_global,idxocn) + !------------------------------------------------------- ! Write per-processor runoff bounds depending on dbug level !------------------------------------------------------- @@ -993,10 +1036,10 @@ subroutine test_halo(this, rc) n = 0 do nr = this%begr,this%endr n = n + 1 - this%halo_arrayptr(n) = this%latc(nr)*10. + this%lonc(nr)/100. + this%fld_halo_arrayptr(n) = this%latc(nr)*10. + this%lonc(nr)/100. end do - call ESMF_ArrayHalo(this%haloArray, routehandle=this%haloHandle, rc=rc) + call ESMF_ArrayHalo(this%fld_haloArray, routehandle=this%haloHandle, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return n = 0 @@ -1028,42 +1071,42 @@ subroutine test_halo(this, rc) end if lon = this%rlon(i) ! - halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_sw)) + halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_sw)) valid_value = lat_m1*10 + lon_m1/100. if (halo_value /= valid_value) then write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value call shr_sys_abort('ERROR: invalid halo') end if ! - halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_s)) + halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_s)) valid_value = lat_m1*10 + lon/100. if (halo_value /= valid_value) then write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value call shr_sys_abort('ERROR: invalid halo') end if ! - halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_se)) + halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_se)) valid_value = lat_m1*10 + lon_p1/100. if (halo_value /= valid_value) then write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value call shr_sys_abort('ERROR: invalid halo') end if ! - halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_e)) + halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_e)) valid_value = lat*10 + lon_p1/100. if (halo_value /= valid_value) then write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value call shr_sys_abort('ERROR: invalid halo') end if ! - halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_ne)) + halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_ne)) valid_value = lat_p1*10 + lon_p1/100. if (halo_value /= valid_value) then write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value call shr_sys_abort('ERROR: invalid halo') end if ! - halo_value = this%halo_arrayptr(this%halo_arrayptr_index(n,halo_nw)) + halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_nw)) valid_value = lat_p1*10 + lon_m1/100. if (halo_value /= valid_value) then write(6,*)'ERROR: halo, valid not the same = ',halo_value, valid_value @@ -1071,6 +1114,98 @@ subroutine test_halo(this, rc) end if end do - end subroutine test_halo + end subroutine test_halo + + !======================================================================== + + subroutine Gradient(this, begr, endr, fld, dfld_dx, dfld_dy, rc) + + ! Calculate head gradient from nine gridcells (center and surrounding) + + ! Uses + use shr_const_mod, only : SHR_CONST_REARTH, SHR_CONST_PI + + ! Arguments: + class(control_type) :: this + integer , intent(in) :: begr, endr + real(r8), intent(in) :: fld(begr:endr) + real(r8), intent(out) :: dfld_dx(:) ! gradient x component + real(r8), intent(out) :: dfld_dy(:) ! gradient y component + integer , intent(out) :: rc + + ! Local variables + integer :: i, n, nr ! local indices + real(r8) :: deg2rad + real(r8) :: mean_dx, mean_dy, dlon, dlat + real(r8) :: ax_indices(4) ! x indices to add + real(r8) :: sx_indices(4) ! x indices to subtract + real(r8) :: ay_indices(4) ! y indices to add + real(r8) :: sy_indices(4) ! y indices to subtract + real(r8) :: fld_surrounding(max_num_halo) + real(r8) :: dx(max_num_halo) + real(r8) :: dy(max_num_halo) + integer :: index + !----------------------------------------------------------------------- + + call t_startf('gradient') + + rc = ESMF_SUCCESS + + ! Define indices for addition/subtraction + ax_indices(:) = (/halo_ne,halo_e,halo_e,halo_se/) ! x indices to add + sx_indices(:) = (/halo_nw,halo_w,halo_w,halo_sw/) ! x indices to subtract + ay_indices(:) = (/halo_ne,halo_n,halo_n,halo_nw/) ! y indices to add + sy_indices(:) = (/halo_se,halo_s,halo_s,halo_sw/) ! y indices to subtract + + ! degrees to radians + deg2rad = SHR_CONST_PI / 180._r8 + + ! update halo array for zwt + n = 0 + do nr = begr,endr + n = n + 1 + this%fld_halo_arrayptr(n) = fld(nr) + end do + call ESMF_ArrayHalo(this%fld_haloArray, routehandle=this%haloHandle, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Initialize gradient components + dfld_dx(:) = 0._r8 + dfld_dy(:) = 0._r8 + + n = 0 + do nr = begr,endr + n = n+1 + + ! extract neighbors from halo array + do i = 1,max_num_halo + index = this%halo_arrayptr_index(n,i) + fld_surrounding(i) = this%fld_halo_arrayptr(index) + dlon = (this%lon_halo_arrayptr(n) - this%lon_halo_arrayptr(index)) + dlat = (this%lat_halo_arrayptr(n) - this%lat_halo_arrayptr(index)) + dx(i) = SHR_CONST_REARTH * abs(deg2rad*dlon) * cos(deg2rad*this%latc(nr)) + dy(i) = SHR_CONST_REARTH * abs(deg2rad*dlat) + enddo + + ! calculate mean spacing + mean_dx = 0.5_r8 * (dx(halo_w)+dx(halo_e)) ! average dx west and east + mean_dy = 0.5_r8 * (dy(halo_s)+dy(halo_n)) ! average dy south and north + + ! compute gradient values + ! for x gradient sum [NE,2xE,SE,-NW,-2xW,-SW] + ! for y gradient sum [NE,2xN,NW,-SE,-2xS,-SW] + do i = 1,4 + dfld_dx(n) = dfld_dx(n) + (fld_surrounding(ax_indices(i)) - fld_surrounding(sx_indices(i))) + dfld_dy(n) = dfld_dy(n) + (fld_surrounding(ay_indices(i)) - fld_surrounding(sy_indices(i))) + enddo + + dfld_dx(n) = dfld_dx(n) / (8._r8*mean_dx) + dfld_dy(n) = dfld_dy(n) / (8._r8*mean_dy) + + enddo ! end of nr loop + + call t_stopf('gradient') + + end subroutine Gradient end module mosart_control_type From 72dddbf19e4f91c8bc65592e6a750f532024e3c2 Mon Sep 17 00:00:00 2001 From: Erik Kluzek Date: Wed, 17 Jan 2024 10:20:48 -0700 Subject: [PATCH 35/86] Change test list name back to mosart --- cime_config/testdefs/testlist_mosart.xml | 48 ++++++++++++------------ 1 file changed, 24 insertions(+), 24 deletions(-) diff --git a/cime_config/testdefs/testlist_mosart.xml b/cime_config/testdefs/testlist_mosart.xml index 3e53307..1605952 100644 --- a/cime_config/testdefs/testlist_mosart.xml +++ b/cime_config/testdefs/testlist_mosart.xml @@ -3,8 +3,8 @@ - - + + @@ -13,8 +13,8 @@ - - + + @@ -23,8 +23,8 @@ - - + + @@ -32,8 +32,8 @@ - - + + @@ -42,8 +42,8 @@ - - + + @@ -52,8 +52,8 @@ - - + + @@ -62,8 +62,8 @@ - - + + @@ -72,8 +72,8 @@ - - + + @@ -82,8 +82,8 @@ - - + + @@ -92,8 +92,8 @@ - - + + @@ -101,8 +101,8 @@ - - + + @@ -111,8 +111,8 @@ - - + + From 36ef673090ee29e979ccd53804ef1e2879f90568 Mon Sep 17 00:00:00 2001 From: Sean Swenson Date: Wed, 17 Jan 2024 14:12:53 -0700 Subject: [PATCH 36/86] 2nd attempt --- src/riverroute/mosart_control_type.F90 | 2117 ++++++++++++------------ 1 file changed, 1050 insertions(+), 1067 deletions(-) diff --git a/src/riverroute/mosart_control_type.F90 b/src/riverroute/mosart_control_type.F90 index 46c52cd..bcb7977 100644 --- a/src/riverroute/mosart_control_type.F90 +++ b/src/riverroute/mosart_control_type.F90 @@ -1,86 +1,87 @@ module mosart_control_type - use shr_kind_mod, only : r8 => shr_kind_r8, CL => SHR_KIND_CL - use shr_sys_mod, only : shr_sys_abort - use shr_const_mod, only : shr_const_pi - use shr_mpi_mod, only : shr_mpi_sum, shr_mpi_max - use mosart_io, only : ncd_io, ncd_pio_openfile, ncd_pio_closefile - use mosart_vars, only : mainproc, iam, npes, mpicom_rof, iulog, spval, re - use pio, only : file_desc_t, PIO_BCAST_ERROR, pio_seterrorhandling - use ESMF, only : ESMF_DistGrid, ESMF_Array, ESMF_RouteHandle, ESMF_SUCCESS, & - ESMF_DistGridCreate, ESMF_ArrayCreate, ESMF_ArrayHaloStore, ESMF_ArrayHalo - use perf_mod, only : t_startf, t_stopf - use nuopc_shr_methods , only : chkerr - - implicit none - private - - type control_type - - ! grid sizes - integer :: lnumr ! local number of cells - integer :: numr ! global number of cells - integer :: nlon = -999 ! number of longitudes - integer :: nlat = -999 ! number of latitudes - - ! tracers - integer :: ntracers = -999 ! number of tracers - character(len=3), allocatable :: tracer_names(:)! tracer names - - ! decomp info - integer :: begr ! local start index - integer :: endr ! local stop indices - integer , pointer :: gindex(:) => null() ! global index consistent with map file - type(ESMF_DistGrid) :: distgrid ! esmf global index space descriptor - - ! grid - real(r8), pointer :: rlon(:) => null() ! longitude list, 1d - real(r8), pointer :: rlat(:) => null() ! latitude list, 1d - real(r8), pointer :: lonc(:) => null() ! lon of cell - real(r8), pointer :: latc(:) => null() ! lat of cell - integer , pointer :: dsig(:) => null() ! downstream index, global index - integer , pointer :: outletg(:) => null() ! outlet index, global index - real(r8), pointer :: area(:) => null() ! area of cell - integer , pointer :: mask(:) => null() ! general mask of cell 1=land, 2=ocean, 3=outlet - real(r8) :: totarea ! global area - - ! inputs to MOSART - real(r8), pointer :: qsur(:,:) => null() ! coupler surface forcing [m3/s] - real(r8), pointer :: qsub(:,:) => null() ! coupler subsurface forcing [m3/s] - real(r8), pointer :: qgwl(:,:) => null() ! coupler glacier/wetland/lake forcing [m3/s] - - ! outputs from MOSART - real(r8), pointer :: flood(:) => null() ! coupler return flood water sent back to clm [m3/s] - real(r8), pointer :: runoff(:,:) => null() ! coupler return mosart basin derived flow [m3/s] - real(r8), pointer :: direct(:,:) => null() ! coupler return direct flow [m3/s] - real(r8), pointer :: qirrig(:) => null() ! coupler irrigation [m3/s] - real(r8), pointer :: qirrig_actual(:) => null() ! minimum of irrigation and available main channel storage - - ! storage, runoff - real(r8), pointer :: runofflnd(:,:) => null() ! runoff masked for land (m3 H2O/s) - real(r8), pointer :: runoffocn(:,:) => null() ! runoff masked for ocn (m3 H2O/s) - real(r8), pointer :: runofftot(:,:) => null() ! total runoff masked for ocn (m3 H2O/s) - real(r8), pointer :: dvolrdt(:,:) => null() ! change in storage (mm/s) - real(r8), pointer :: dvolrdtlnd(:,:) => null() ! dvolrdt masked for land (mm/s) - real(r8), pointer :: dvolrdtocn(:,:) => null() ! dvolrdt masked for ocn (mm/s) - real(r8), pointer :: volr(:,:) => null() ! storage (m3) - real(r8), pointer :: fthresh(:) => null() ! water flood threshold - - ! flux variables - real(r8), pointer :: flow(:,:) => null() ! mosart flow (m3/s) - real(r8), pointer :: evel(:,:) => null() ! effective tracer velocity (m/s) - real(r8), pointer :: erout_prev(:,:) => null() ! erout previous timestep (m3/s) - real(r8), pointer :: eroutup_avg(:,:) => null() ! eroutup average over coupling period (m3/s) - real(r8), pointer :: erlat_avg(:,:) => null() ! erlateral average over coupling period (m3/s) - real(r8), pointer :: effvel(:) => null() - - ! halo operations - type(ESMF_RouteHandle) :: haloHandle - type(ESMF_Array) :: lon_haloArray - type(ESMF_Array) :: lat_haloArray - type(ESMF_Array) :: fld_haloArray + use shr_kind_mod, only : r8 => shr_kind_r8, CL => SHR_KIND_CL + use shr_sys_mod, only : shr_sys_abort + use shr_const_mod, only : shr_const_pi, shr_const_rearth + use shr_mpi_mod, only : shr_mpi_sum, shr_mpi_max + use mosart_io, only : ncd_io, ncd_pio_openfile, ncd_pio_closefile + use mosart_vars, only : mainproc, iam, npes, mpicom_rof, iulog, spval, re + use pio, only : file_desc_t, PIO_BCAST_ERROR, pio_seterrorhandling + use ESMF, only : ESMF_DistGrid, ESMF_Array, ESMF_RouteHandle, ESMF_SUCCESS, & + ESMF_DistGridCreate, ESMF_ArrayCreate, ESMF_ArrayHaloStore, & + ESMF_ArrayHalo, ESMF_ArrayGet + use perf_mod, only : t_startf, t_stopf + use nuopc_shr_methods , only : chkerr + + implicit none + private + + type control_type + + ! grid sizes + integer :: lnumr ! local number of cells + integer :: numr ! global number of cells + integer :: nlon = -999 ! number of longitudes + integer :: nlat = -999 ! number of latitudes + + ! tracers + integer :: ntracers = -999 ! number of tracers + character(len=3), allocatable :: tracer_names(:)! tracer names + + ! decomp info + integer :: begr ! local start index + integer :: endr ! local stop indices + integer , pointer :: gindex(:) => null() ! global index consistent with map file + type(ESMF_DistGrid) :: distgrid ! esmf global index space descriptor + + ! grid + real(r8), pointer :: rlon(:) => null() ! longitude list, 1d + real(r8), pointer :: rlat(:) => null() ! latitude list, 1d + real(r8), pointer :: lonc(:) => null() ! lon of cell + real(r8), pointer :: latc(:) => null() ! lat of cell + integer , pointer :: dsig(:) => null() ! downstream index, global index + integer , pointer :: outletg(:) => null() ! outlet index, global index + real(r8), pointer :: area(:) => null() ! area of cell + integer , pointer :: mask(:) => null() ! general mask of cell 1=land, 2=ocean, 3=outlet + real(r8) :: totarea ! global area + + ! inputs to MOSART + real(r8), pointer :: qsur(:,:) => null() ! coupler surface forcing [m3/s] + real(r8), pointer :: qsub(:,:) => null() ! coupler subsurface forcing [m3/s] + real(r8), pointer :: qgwl(:,:) => null() ! coupler glacier/wetland/lake forcing [m3/s] + + ! outputs from MOSART + real(r8), pointer :: flood(:) => null() ! coupler return flood water sent back to clm [m3/s] + real(r8), pointer :: runoff(:,:) => null() ! coupler return mosart basin derived flow [m3/s] + real(r8), pointer :: direct(:,:) => null() ! coupler return direct flow [m3/s] + real(r8), pointer :: qirrig(:) => null() ! coupler irrigation [m3/s] + real(r8), pointer :: qirrig_actual(:) => null() ! minimum of irrigation and available main channel storage + + ! storage, runoff + real(r8), pointer :: runofflnd(:,:) => null() ! runoff masked for land (m3 H2O/s) + real(r8), pointer :: runoffocn(:,:) => null() ! runoff masked for ocn (m3 H2O/s) + real(r8), pointer :: runofftot(:,:) => null() ! total runoff masked for ocn (m3 H2O/s) + real(r8), pointer :: dvolrdt(:,:) => null() ! change in storage (mm/s) + real(r8), pointer :: dvolrdtlnd(:,:) => null() ! dvolrdt masked for land (mm/s) + real(r8), pointer :: dvolrdtocn(:,:) => null() ! dvolrdt masked for ocn (mm/s) + real(r8), pointer :: volr(:,:) => null() ! storage (m3) + real(r8), pointer :: fthresh(:) => null() ! water flood threshold + + ! flux variables + real(r8), pointer :: flow(:,:) => null() ! mosart flow (m3/s) + real(r8), pointer :: evel(:,:) => null() ! effective tracer velocity (m/s) + real(r8), pointer :: erout_prev(:,:) => null() ! erout previous timestep (m3/s) + real(r8), pointer :: eroutup_avg(:,:) => null() ! eroutup average over coupling period (m3/s) + real(r8), pointer :: erlat_avg(:,:) => null() ! erlateral average over coupling period (m3/s) + real(r8), pointer :: effvel(:) => null() + + ! halo operations + type(ESMF_RouteHandle) :: haloHandle + type(ESMF_Array) :: fld_halo_array + type(ESMF_Array) :: lon_halo_array + type(ESMF_Array) :: lat_halo_array integer , pointer :: halo_arrayptr_index(:,:) => null() ! index into halo_arrayptr that corresponds to a halo point - real(r8), pointer :: fld_halo_arrayptr(:) => null() ! preallocated memory for exclusive region plus halo + real(r8), pointer :: fld_halo_arrayptr(:) => null() ! preallocated memory for exclusive region plus halo real(r8), pointer :: lon_halo_arrayptr(:) => null() ! preallocated memory for exclusive region plus halo real(r8), pointer :: lat_halo_arrayptr(:) => null() ! preallocated memory for exclusive region plus halo @@ -89,14 +90,13 @@ module mosart_control_type procedure, public :: Init procedure, private :: init_decomp procedure, private :: test_halo - procedure, public :: Gradient + procedure, public :: calc_gradient end type control_type public :: control_type private :: init_decomp - public :: Gradient - + public :: calc_gradient #ifdef NDEBUG integer,parameter :: dbug = 0 ! 0 = none, 1=normal, 2=much, 3=max @@ -118,1012 +118,990 @@ module mosart_control_type character(*), parameter :: u_FILE_u = & __FILE__ -!======================================================================== + !======================================================================== contains -!======================================================================== - - subroutine Init(this, locfn, decomp_option, use_halo_option, IDkey, rc) - - ! Arguments - class(control_type) :: this - character(len=*) , intent(in) :: locfn - character(len=*) , intent(in) :: decomp_option ! decomposition option - logical , intent(in) :: use_halo_option ! create ESMF array and route handle for halos - integer , intent(out) :: IDkey(:) ! translation key from ID to gindex - integer , intent(out) :: rc - - ! Local variables - real(r8) :: area_global(this%nlon*this%nlat) ! area - real(r8) :: tempr(this%nlon,this%nlat) ! temporary buffer - real(r8) :: rlats(this%nlat) ! latitude of 1d south grid cell edge (deg) - real(r8) :: rlatn(this%nlat) ! latitude of 1d north grid cell edge (deg) - real(r8) :: rlonw(this%nlon) ! longitude of 1d west grid cell edge (deg) - real(r8) :: rlone(this%nlon) ! longitude of 1d east grid cell edge (deg) - real(r8) :: larea ! tmp local sum of area - real(r8) :: deg2rad ! pi/180 - integer :: g, n, i, j, nr, nt ! iterators - real(r8) :: edgen ! North edge of the direction file - real(r8) :: edgee ! East edge of the direction file - real(r8) :: edges ! South edge of the direction file - real(r8) :: edgew ! West edge of the direction file - real(r8) :: dx ! lon dist. betn grid cells (m) - real(r8) :: dy ! lat dist. betn grid cells (m) - type(file_desc_t) :: ncid ! pio file desc - logical :: found ! flag - integer :: ntracers ! used to simplify code - integer :: begr, endr ! used to simplify code - integer :: ier ! error status - integer :: nlon,nlat - real(r8) :: effvel0 = 10.0_r8 ! default velocity (m/s) - character(len=*),parameter :: subname = '(mosart_control_type: Init)' - !----------------------------------------------------------------------- - - rc = ESMF_SUCCESS - - nlon = this%nlon - nlat = this%nlat - - !--------------------------------------- - ! Read the routing parameters - !--------------------------------------- - - call ncd_pio_openfile (ncid, trim(locfn), 0) - call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) - - call ncd_io(ncid=ncid, varname='longxy', flag='read', data=tempr, readvar=found) - if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart longitudes') - if (mainproc) write(iulog,*) 'Read longxy ',minval(tempr),maxval(tempr) - allocate(this%rlon(this%nlon)) - do i=1,nlon - this%rlon(i) = tempr(i,1) - enddo - if (mainproc) write(iulog,*) 'rlon center ',minval(this%rlon),maxval(this%rlon) - - call ncd_io(ncid=ncid, varname='latixy', flag='read', data=tempr, readvar=found) - if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart latitudes') - if (mainproc) write(iulog,*) 'Read latixy ',minval(tempr),maxval(tempr) - allocate(this%rlat(this%nlat)) - do j=1,this%nlat - this%rlat(j) = tempr(1,j) - end do - if (mainproc) write(iulog,*) 'rlat center ',minval(this%rlat),maxval(this%rlat) - - call ncd_io(ncid=ncid, varname='area', flag='read', data=tempr, readvar=found) - if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart area') - if (mainproc) write(iulog,*) 'Read area ',minval(tempr),maxval(tempr) - do j=1,this%nlat - do i=1,nlon - n = (j-1)*nlon + i - area_global(n) = tempr(i,j) - end do - end do - if (mainproc) write(iulog,*) 'area ',minval(area_global),maxval(area_global) - call ncd_pio_closefile(ncid) - - !------------------------------------------------------- - ! adjust area estimation from DRT algorithm for those outlet grids - ! useful for grid-based representation only - ! need to compute areas where they are not defined in input file - !------------------------------------------------------- - - ! Derive gridbox edges - ! assuming equispaced grid, calculate edges from nlat/nlon - ! w/o assuming a global grid - edgen = maxval(this%rlat) + 0.5*abs(this%rlat(1) - this%rlat(2)) - edges = minval(this%rlat) - 0.5*abs(this%rlat(1) - this%rlat(2)) - edgee = maxval(this%rlon) + 0.5*abs(this%rlon(1) - this%rlon(2)) - edgew = minval(this%rlon) - 0.5*abs(this%rlon(1) - this%rlon(2)) - if (edgen .ne. 90._r8)then - if (mainproc ) write(iulog,*) 'Regional grid: edgen = ', edgen - end if - if (edges .ne. -90._r8)then - if (mainproc ) write(iulog,*) 'Regional grid: edges = ', edges - end if - if (edgee .ne. 180._r8)then - if (mainproc ) write(iulog,*) 'Regional grid: edgee = ', edgee - end if - if (edgew .ne.-180._r8)then - if ( mainproc ) write(iulog,*) 'Regional grid: edgew = ', edgew - end if - - ! Set edge latitudes (assumes latitudes are constant for a given longitude) - rlats(:) = edges - rlatn(:) = edgen - do j = 2, nlat - if (this%rlat(2) > this%rlat(1)) then ! South to North grid - rlats(j) = (this%rlat(j-1) + this%rlat(j)) / 2._r8 - rlatn(j-1) = rlats(j) - else ! North to South grid - rlatn(j) = (this%rlat(j-1) + this%rlat(j)) / 2._r8 - rlats(j-1) = rlatn(j) - end if - end do - - ! Set edge longitudes - rlonw(:) = edgew - rlone(:) = edgee - dx = (edgee - edgew) / nlon - do i = 2, nlon - rlonw(i) = rlonw(i) + (i-1)*dx - rlone(i-1) = rlonw(i) - end do - - ! adjust area estimation from DRT algorithm for those outlet grids - deg2rad = shr_const_pi / 180._r8 - do n=1,nlon*nlat - if (area_global(n) <= 0._r8) then - i = mod(n-1,nlon) + 1 - j = (n-1)/nlon + 1 - dx = (rlone(i) - rlonw(i)) * deg2rad - dy = sin(rlatn(j)*deg2rad) - sin(rlats(j)*deg2rad) - area_global(n) = abs(1.e6_r8 * dx*dy*re*re) - if (mainproc .and. area_global(n) <= 0) then - write(iulog,*) 'Warning! Zero area for unit ', n, area_global(n),dx,dy,re - end if - end if - end do - - ! --------------------------------------------- - ! Determine decomposition - ! --------------------------------------------- - - ! memory for this%gindex, this%mask and this%dsig is allocated in init_decomp - call t_startf('mosarti_decomp') - call this%init_decomp(locfn, decomp_option, use_halo_option, & - nlon, nlat, this%begr, this%endr, this%lnumr, this%numr, IDkey, rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call t_stopf('mosarti_decomp') - - ! --------------------------------------------- - ! Allocate and initialize remaining variables - ! --------------------------------------------- - - begr = this%begr - endr = this%endr - ntracers = this%ntracers - - allocate(this%area(begr:endr), & - ! - this%volr(begr:endr,ntracers), & - this%dvolrdt(begr:endr,ntracers), & - this%dvolrdtlnd(begr:endr,ntracers), & - this%dvolrdtocn(begr:endr,ntracers), & - ! - this%runoff(begr:endr,ntracers), & - this%runofflnd(begr:endr,ntracers), & - this%runoffocn(begr:endr,ntracers), & - this%runofftot(begr:endr,ntracers), & - ! - this%fthresh(begr:endr), & - this%flood(begr:endr), & - ! - this%direct(begr:endr,ntracers), & - this%qsur(begr:endr,ntracers), & - this%qsub(begr:endr,ntracers), & - this%qgwl(begr:endr,ntracers), & - this%qirrig(begr:endr), & - this%qirrig_actual(begr:endr), & - ! - this%evel(begr:endr,ntracers), & - this%flow(begr:endr,ntracers), & - this%erout_prev(begr:endr,ntracers), & - this%eroutup_avg(begr:endr,ntracers),& - this%erlat_avg(begr:endr,ntracers), & - ! - this%effvel(ntracers), & - stat=ier) - if (ier /= 0) then - write(iulog,*)'mosarart_control_type allocation error' - call shr_sys_abort - end if - - this%runoff(:,:) = 0._r8 - this%runofflnd(:,:) = spval - this%runoffocn(:,:) = spval - this%runofftot(:,:) = spval - this%dvolrdt(:,:) = 0._r8 - this%dvolrdtlnd(:,:) = spval - this%dvolrdtocn(:,:) = spval - this%volr(:,:) = 0._r8 - this%flood(:) = 0._r8 - this%direct(:,:) = 0._r8 - this%qirrig(:) = 0._r8 - this%qirrig_actual(:) = 0._r8 - - this%qsur(:,:) = 0._r8 - this%qsub(:,:) = 0._r8 - this%qgwl(:,:) = 0._r8 - ! - this%fthresh(:) = abs(spval) - this%flow(:,:) = 0._r8 - this%erout_prev(:,:) = 0._r8 - this%eroutup_avg(:,:) = 0._r8 - this%erlat_avg(:,:) = 0._r8 - - this%effvel(:) = effvel0 ! downstream velocity (m/s) - do nt = 1,ntracers - do nr = begr,endr - this%evel(nr,nt) = this%effvel(nt) - enddo - enddo - - do nr = begr,endr - n = this%gindex(nr) - i = mod(n-1,nlon) + 1 - j = (n-1)/nlon + 1 - this%lonc(nr) = this%rlon(i) - this%latc(nr) = this%rlat(j) - this%area(nr) = area_global(n) - enddo - - larea = 0.0_r8 - do nr = begr,endr - larea = larea + this%area(nr) - end do - if (minval(this%mask) < 1) then - write(iulog,*) subname,'ERROR this mask lt 1 ',minval(this%mask),maxval(this%mask) - call shr_sys_abort(subname//' ERROR this mask') - endif - call shr_mpi_sum(larea, this%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 ',this%totarea - end if - - end subroutine Init - - !======================================================================== - subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & - nlon, nlat, begr, endr, lnumr, numr, IDkey, rc) - - ! Arguments - class(control_type) :: this - character(len=*) , intent(in) :: locfn ! local routing filename - character(len=*) , intent(in) :: decomp_option - logical , intent(in) :: use_halo_option - integer , intent(in) :: nlon - integer , intent(in) :: nlat - integer , intent(out) :: begr - integer , intent(out) :: endr - integer , intent(out) :: lnumr - integer , intent(out) :: numr - integer , intent(out) :: IDkey(:) ! translation key from ID to gindex - integer , intent(out) :: rc - - ! Local variables - integer :: n, nr, i, j, g ! indices - integer :: nl,nloops ! used for decomp search - integer, allocatable :: gmask(:) ! global mask - integer, allocatable :: gdc2glo(:) ! temporary for initialization - integer, allocatable :: glo2gdc(:) ! temporary for initialization - integer, allocatable :: ID0_global(:) ! global (local) ID index - integer, allocatable :: dnID_global(:) ! global downstream ID based on ID0 - 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 :: nop(0:npes-1) ! number of gridcells on a pe - integer :: nba(0:npes-1) ! number of basins on each pe - integer :: nrs(0:npes-1) ! begr on each pe - integer :: maxgcells_per_pe ! max num of points per pe for decomp - integer :: minbas,maxbas ! used for decomp search - integer :: pid,np,npmin,npmax,npint ! log loop control - integer :: nmos ! number of mosart points - integer :: nout ! number of basin with outlets - integer :: nbas ! number of basin/ocean points - integer :: nrof ! num of active mosart points - integer :: baspe ! pe with min number of mosart cells - logical :: found ! flag - integer :: ier ! error status - type(file_desc_t) :: ncid ! pio file desc - integer :: procid - integer :: im1,ip1 - integer :: jm1,jp1 - integer :: n_sw, n_s, n_se - integer :: n_nw, n_n, n_ne - integer :: n_e, n_w - integer :: num_halo - integer, pointer :: halo_list(:) - integer, pointer :: seqlist(:) - integer, allocatable :: store_halo_index(:) - integer :: nglob - real(r8),allocatable :: rtempr(:,:) ! global temporary buffer - real - character(len=*),parameter :: subname = '(mosart_control_type: init_decomp) ' - !----------------------------------------------------------------------- - - rc = ESMF_SUCCESS - - !------------------------------------------------------- - ! Read ID and DnID from routing file - !------------------------------------------------------- - - call ncd_pio_openfile(ncid, trim(locfn), 0) - - allocate(rtempr(nlon,nlat)) - allocate(ID0_global(nlon*nlat),dnID_global(nlon*nlat)) - call ncd_io(ncid=ncid, varname='ID', flag='read', data=rtempr, readvar=found) - if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart ID') - if (mainproc) write(iulog,*) 'Read ID ',minval(rtempr),maxval(rtempr) - do j=1,nlat - do i=1,nlon - n = (j-1)*nlon + i - ID0_global(n) = int(rtempr(i,j)) - end do - end do - if (mainproc) write(iulog,*) 'ID ',minval(rtempr),maxval(rtempr) - - call ncd_io(ncid=ncid, varname='dnID', flag='read', data=rtempr, readvar=found) - if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart dnID') - if (mainproc) write(iulog,*) 'Read dnID ',minval(rtempr),maxval(rtempr) - do j=1,nlat - do i=1,nlon - n = (j-1)*nlon + i - dnID_global(n) = int(rtempr(i,j)) - end do - end do - if (mainproc) write(iulog,*) 'dnID ',minval(rtempr),maxval(rtempr) - deallocate(rtempr) - - 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 nlon*nlat is upper right. - ! ID0 is the "key", modify dnID based on that. keep the IDkey around - ! for as long as needed. This is a key that translates the ID0 value - ! to the gindex value. compute the key, then apply the key to dnID_global. - ! As part of this, check that each value of ID0 is unique and within - ! the range of 1 to nlon*nlat. - !------------------------------------------------------- - - IDkey = 0 - do n=1,nlon*nlat - if (ID0_global(n) < 0 .or. ID0_global(n) > nlon*nlat) 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,nlon*nlat - if (dnID_global(n) > 0 .and. dnID_global(n) <= nlon*nlat) then - if (IDkey(dnID_global(n)) > 0 .and. IDkey(dnID_global(n)) <= nlon*nlat) then - dnID_global(n) = IDkey(dnID_global(n)) - else - write(iulog,*) subname,' ERROR bad IDkey',n,dnID_global(n),IDkey(dnID_global(n)) - call shr_sys_abort(subname//' ERROR bad IDkey') - endif - endif - enddo - - !------------------------------------------------------- - ! Determine mosart ocn/land mask (global, all procs) - !------------------------------------------------------- - - ! 1=land, 2=ocean, 3=ocean outlet from land - allocate(gmask(nlon*nlat)) - gmask(:) = 2 ! assume ocean point - do n=1,nlon*nlat ! mark all downstream points as outlet - nr = dnID_global(n) - if ((nr > 0) .and. (nr <= nlon*nlat)) then - gmask(nr) = 3 ! <- nr - end if - enddo - do n=1,nlon*nlat ! now mark all points with downstream points as land - nr = dnID_global(n) - if ((nr > 0) .and. (nr <= nlon*nlat)) then - gmask(n) = 1 ! <- n - end if - enddo - - !------------------------------------------------------- - ! Compute total number of basins and runoff points - !------------------------------------------------------- - - nbas = 0 - nrof = 0 - nout = 0 - nmos = 0 - do nr=1,nlon*nlat - if (gmask(nr) == 3) then - nout = nout + 1 - nbas = nbas + 1 - nmos = nmos + 1 - nrof = nrof + 1 - elseif (gmask(nr) == 2) then - nbas = nbas + 1 - nrof = nrof + 1 - elseif (gmask(nr) == 1) then - nmos = nmos + 1 - nrof = nrof + 1 - endif - enddo - if (mainproc) then - write(iulog,*) 'Number of outlet basins = ',nout - write(iulog,*) 'Number of total basins = ',nbas - write(iulog,*) 'Number of mosart points = ',nmos - write(iulog,*) 'Number of runoff points = ',nrof - endif - - !------------------------------------------------------- - ! Compute river basins, actually compute ocean outlet gridcell - !------------------------------------------------------- - - ! idxocn = final downstream cell, index is global 1d ocean gridcell - ! nupstrm = number of source gridcells upstream including self - allocate(idxocn(nlon*nlat),nupstrm(nlon*nlat)) - idxocn(:) = 0 - nupstrm(:) = 0 - do nr=1,nlon*nlat - n = nr - if (abs(gmask(n)) == 1) then ! land - g = 0 - do while (abs(gmask(n)) == 1 .and. g < nlon*nlat) ! follow downstream - nupstrm(n) = nupstrm(n) + 1 - n = dnID_global(n) - g = g + 1 - end do - if (gmask(n) == 3) then ! found ocean outlet - nupstrm(n) = nupstrm(n) + 1 ! one more land cell for n - idxocn(nr) = n ! set ocean outlet or nr to n - elseif (abs(gmask(n)) == 1) then ! no ocean outlet, warn user, ignore cell - write(iulog,*) subname,' ERROR closed basin found', & - g,nr,gmask(nr),dnID_global(nr), & - n,gmask(n),dnID_global(n) - call shr_sys_abort(subname//' ERROR closed basin found') - elseif (gmask(n) == 2) then - write(iulog,*) subname,' ERROR found invalid ocean cell ',nr - call shr_sys_abort(subname//' ERROR found invalid ocean cell') - else - write(iulog,*) subname,' ERROR downstream cell is unknown', & - g,nr,gmask(nr),dnID_global(nr), & - n,gmask(n),dnID_global(n) - call shr_sys_abort(subname//' ERROR downstream cell is unknown') - endif - elseif (gmask(n) >= 2) then ! ocean, give to self - nupstrm(n) = nupstrm(n) + 1 - idxocn(nr) = n - endif - enddo - - !------------------------------------------------------- - !--- Now allocate those basins to pes - !------------------------------------------------------- - - ! this is the heart of the decomp, need to set pocn and nop by the end of this - ! pocn is the pe that gets the basin associated with ocean outlet nr - ! nop is a running count of the number of mosart cells/pe - allocate(pocn(nlon*nlat)) - pocn(:) = -99 - nop(0:npes-1) = 0 - if (trim(decomp_option) == 'basin') then - - baspe = 0 - maxgcells_per_pe = int(float(nrof)/float(npes)*0.445) + 1 - nloops = 3 - minbas = nrof - do nl=1,nloops - maxbas = minbas - 1 - minbas = maxval(nupstrm)/(2**nl) - if (nl == nloops) minbas = min(minbas,1) - do nr=1,nlon*nlat - if (gmask(nr) >= 2 .and. nupstrm(nr) > 0 .and. nupstrm(nr) >= minbas .and. nupstrm(nr) <= maxbas) then - ! Decomp options - ! find min pe (implemented but scales poorly) - ! use increasing thresholds (implemented, ok load balance for l2r or calc) - ! distribute basins using above methods but work from max to min basin size - ! find next pe below maxgcells_per_pe threshhold and increment - do while (nop(baspe) > maxgcells_per_pe) - baspe = baspe + 1 - if (baspe > npes-1) then - baspe = 0 - ! 3 loop, .445 and 1.5 chosen carefully - maxgcells_per_pe = max(maxgcells_per_pe*1.5, maxgcells_per_pe+1.0) - endif - enddo - if (baspe > npes-1 .or. baspe < 0) then - write(iulog,*) 'ERROR in decomp for mosart ',nr,npes,baspe - call shr_sys_abort('ERROR mosart decomp') - endif - nop(baspe) = nop(baspe) + nupstrm(nr) - pocn(nr) = baspe - endif - enddo ! nr - enddo ! nl - - ! set pocn for land cells, was set for ocean above - do nr=1,nlon*nlat - if (idxocn(nr) > 0) then - pocn(nr) = pocn(idxocn(nr)) - if (pocn(nr) < 0 .or. pocn(nr) > npes-1) then - write(iulog,*) subname,' ERROR pocn lnd setting ',& - nr,idxocn(nr),idxocn(idxocn(nr)),pocn(idxocn(nr)),pocn(nr),npes - call shr_sys_abort(subname//' ERROR pocn lnd') - endif - endif - enddo - - elseif (trim(decomp_option) == '1d') then - - ! distribute active points in 1d fashion to pes - ! baspe is the pe assignment - ! maxgcells_per_pe is the maximum number of points to assign to each pe - baspe = 0 - maxgcells_per_pe = (nrof-1)/npes + 1 - do nr=1,nlon*nlat - if (gmask(nr) >= 1) then - pocn(nr) = baspe - nop(baspe) = nop(baspe) + 1 - if (nop(baspe) >= maxgcells_per_pe) then - baspe = (mod(baspe+1,npes)) - if (baspe < 0 .or. baspe > npes-1) then - write(iulog,*) subname,' ERROR basepe ',baspe,npes - call shr_sys_abort(subname//' ERROR pocn lnd') - endif - endif - endif - enddo - - elseif (trim(decomp_option) == 'roundrobin') then - - ! distribute active points in roundrobin fashion to pes - ! baspe is the pe assignment - ! maxgcells_per_pe is the maximum number of points to assign to each pe - baspe = 0 - do nr=1,nlon*nlat - 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 - do nr = 1,nlon*nlat - if (pocn(nr) < 0) then - write(6,*)'WARNING: nr,pocn(nr) is < 0',nr,pocn(nr) - end if - end do - - else - write(iulog,*) subname,' ERROR decomp option unknown ',trim(decomp_option) - call shr_sys_abort(subname//' ERROR pocn lnd') - endif ! decomp_option - - if (mainproc) then - write(iulog,*) 'mosart cells and basins total = ',nrof,nbas - write(iulog,*) 'mosart cells per basin avg/max = ',nrof/nbas,maxval(nupstrm) - write(iulog,*) 'mosart cells per pe min/max = ',minval(nop),maxval(nop) - write(iulog,*) 'mosart basins per pe min/max = ',minval(nba),maxval(nba) - endif - deallocate(nupstrm) - - !------------------------------------------------------- - ! Determine begr, endr, numr and lnumr - !------------------------------------------------------- - - numr = 0 - do n = 0,npes-1 - if (iam == n) then - begr = numr + 1 - endr = begr + nop(n) - 1 - endif - numr = numr + nop(n) - enddo - lnumr = endr - begr + 1 - - !------------------------------------------------------- - ! Determine glo2gdc (global to local) and gdc2glo (local to global) - !------------------------------------------------------- - - ! pocn(nlon*nlat) pe number assigned to basin - ! nop(0:npes-1) number of gridcells on a pe - ! nba(0:npes-1) number of basins on each pe - ! nrs(0:npes-1) begr on each pe - - ! Determine glo2gdc - ! nrs is begr on each pe - ! reuse nba for nop-like counter here, pocn -99 is unused cell - - nrs(:) = 0 - nrs(0) = 1 - do n = 1,npes-1 - ! nop is number of cells per pe - ! so loop through the pes and determine begr on each pe - nrs(n) = nrs(n-1) + nop(n-1) - enddo - - allocate(glo2gdc(nlon*nlat),gdc2glo(nlon*nlat)) - glo2gdc(:) = 0 - nba(:) = 0 - do nr = 1,nlon*nlat - procid = pocn(nr) - if (procid >= 0) then - glo2gdc(nr) = nrs(procid) + nba(procid) - nba(procid) = nba(procid) + 1 - endif - enddo - do n = 0,npes-1 - if (nba(n) /= nop(n)) then - write(iulog,*) subname,' ERROR mosart cell count ',n,nba(n),nop(n) - call shr_sys_abort(subname//' ERROR mosart cell count') - endif - enddo - - ! Determine gdc2glo - local to global index space - do j = 1,nlat - do i = 1,nlon - n = (j-1)*nlon + i - nr = glo2gdc(n) - if (nr > 0) then - gdc2glo(nr) = n - endif - end do - end do - - !------------------------------------------------------- - ! Determine gindex - !------------------------------------------------------- - - allocate(this%gindex(begr:endr)) - do nr = begr,endr - this%gindex(nr) = gdc2glo(nr) - n = this%gindex(nr) - if (n <= 0 .or. n > nlon*nlat) then - write(iulog,*) subname,' ERROR in gindex, nr,ng= ',nr,n - call shr_sys_abort(subname//' ERROR gindex values values') - endif - if (dnID_global(n) > 0) then - if (glo2gdc(dnID_global(n)) == 0) then - write(iulog,*) subname,' ERROR glo2gdc dnID_global ',& - nr,n,dnID_global(n),glo2gdc(dnID_global(n)) - call shr_sys_abort(subname//' ERROT glo2gdc dnID_global') - end if - end if - end do - - !------------------------------------------------------- - ! Create distGrid from global index array - !------------------------------------------------------- - - allocate(seqlist(endr-begr+1)) - n = 0 - do nr = begr,endr - n = n + 1 - seqlist(n) = this%gindex(nr) - end do - this%DistGrid = ESMF_DistGridCreate(arbSeqIndexList=seqlist, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - deallocate(seqlist) - - !------------------------------------------------------- - ! Determine local lonc and latc - !------------------------------------------------------- - - allocate(this%lonc(begr:endr), this%latc(begr:endr)) - do nr = begr,endr - n = gdc2glo(nr) - i = mod(n-1,nlon) + 1 - j = (n-1)/nlon + 1 - this%lonc(nr) = this%rlon(i) - this%latc(nr) = this%rlat(j) - end do - - !------------------------------------------------------- - ! Determine halo points and create halo route handle - !------------------------------------------------------- - if( use_halo_option ) then - ! note that for each gridcell below there are nhalo extra elements that need to be allocated - ! Need to keep track of the global index of each halo point - ! temporary allocatable array store_halo_index = size((endr-begr+1)*nhalo) (nhalo is the number of halo points) + !======================================================================== + + subroutine Init(this, locfn, decomp_option, use_halo_option, IDkey, rc) + + ! Arguments + class(control_type) :: this + character(len=*) , intent(in) :: locfn + character(len=*) , intent(in) :: decomp_option ! decomposition option + logical , intent(in) :: use_halo_option ! create ESMF array and route handle for halos + integer , intent(out) :: IDkey(:) ! translation key from ID to gindex + integer , intent(out) :: rc + + ! Local variables + real(r8) :: area_global(this%nlon*this%nlat) ! area + real(r8) :: tempr(this%nlon,this%nlat) ! temporary buffer + real(r8) :: rlats(this%nlat) ! latitude of 1d south grid cell edge (deg) + real(r8) :: rlatn(this%nlat) ! latitude of 1d north grid cell edge (deg) + real(r8) :: rlonw(this%nlon) ! longitude of 1d west grid cell edge (deg) + real(r8) :: rlone(this%nlon) ! longitude of 1d east grid cell edge (deg) + real(r8) :: larea ! tmp local sum of area + real(r8) :: deg2rad ! pi/180 + integer :: g, n, i, j, nr, nt ! iterators + real(r8) :: edgen ! North edge of the direction file + real(r8) :: edgee ! East edge of the direction file + real(r8) :: edges ! South edge of the direction file + real(r8) :: edgew ! West edge of the direction file + real(r8) :: dx ! lon dist. betn grid cells (m) + real(r8) :: dy ! lat dist. betn grid cells (m) + type(file_desc_t) :: ncid ! pio file desc + logical :: found ! flag + integer :: ntracers ! used to simplify code + integer :: ier ! error status + integer :: begr, endr ! used to simplify code + integer :: nlon,nlat + real(r8) :: effvel0 = 10.0_r8 ! default velocity (m/s) + character(len=*),parameter :: subname = '(mosart_control_type: Init)' + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + nlon = this%nlon + nlat = this%nlat + + !--------------------------------------- + ! Read the routing parameters + !--------------------------------------- + + call ncd_pio_openfile (ncid, trim(locfn), 0) + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + + call ncd_io(ncid=ncid, varname='longxy', flag='read', data=tempr, readvar=found) + if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart longitudes') + if (mainproc) write(iulog,*) 'Read longxy ',minval(tempr),maxval(tempr) + allocate(this%rlon(this%nlon)) + do i=1,nlon + this%rlon(i) = tempr(i,1) + enddo + if (mainproc) write(iulog,*) 'rlon center ',minval(this%rlon),maxval(this%rlon) + + call ncd_io(ncid=ncid, varname='latixy', flag='read', data=tempr, readvar=found) + if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart latitudes') + if (mainproc) write(iulog,*) 'Read latixy ',minval(tempr),maxval(tempr) + allocate(this%rlat(this%nlat)) + do j=1,this%nlat + this%rlat(j) = tempr(1,j) + end do + if (mainproc) write(iulog,*) 'rlat center ',minval(this%rlat),maxval(this%rlat) + + call ncd_io(ncid=ncid, varname='area', flag='read', data=tempr, readvar=found) + if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart area') + if (mainproc) write(iulog,*) 'Read area ',minval(tempr),maxval(tempr) + do j=1,this%nlat + do i=1,nlon + n = (j-1)*nlon + i + area_global(n) = tempr(i,j) + end do + end do + if (mainproc) write(iulog,*) 'area ',minval(area_global),maxval(area_global) + call ncd_pio_closefile(ncid) + + !------------------------------------------------------- + ! adjust area estimation from DRT algorithm for those outlet grids + ! useful for grid-based representation only + ! need to compute areas where they are not defined in input file + !------------------------------------------------------- + + ! Derive gridbox edges + ! assuming equispaced grid, calculate edges from nlat/nlon + ! w/o assuming a global grid + edgen = maxval(this%rlat) + 0.5*abs(this%rlat(1) - this%rlat(2)) + edges = minval(this%rlat) - 0.5*abs(this%rlat(1) - this%rlat(2)) + edgee = maxval(this%rlon) + 0.5*abs(this%rlon(1) - this%rlon(2)) + edgew = minval(this%rlon) - 0.5*abs(this%rlon(1) - this%rlon(2)) + if (edgen .ne. 90._r8)then + if (mainproc ) write(iulog,*) 'Regional grid: edgen = ', edgen + end if + if (edges .ne. -90._r8)then + if (mainproc ) write(iulog,*) 'Regional grid: edges = ', edges + end if + if (edgee .ne. 180._r8)then + if (mainproc ) write(iulog,*) 'Regional grid: edgee = ', edgee + end if + if (edgew .ne.-180._r8)then + if ( mainproc ) write(iulog,*) 'Regional grid: edgew = ', edgew + end if + + ! Set edge latitudes (assumes latitudes are constant for a given longitude) + rlats(:) = edges + rlatn(:) = edgen + do j = 2, nlat + if (this%rlat(2) > this%rlat(1)) then ! South to North grid + rlats(j) = (this%rlat(j-1) + this%rlat(j)) / 2._r8 + rlatn(j-1) = rlats(j) + else ! North to South grid + rlatn(j) = (this%rlat(j-1) + this%rlat(j)) / 2._r8 + rlats(j-1) = rlatn(j) + end if + end do + + ! Set edge longitudes + rlonw(:) = edgew + rlone(:) = edgee + dx = (edgee - edgew) / nlon + do i = 2, nlon + rlonw(i) = rlonw(i) + (i-1)*dx + rlone(i-1) = rlonw(i) + end do + + ! adjust area estimation from DRT algorithm for those outlet grids + deg2rad = shr_const_pi / 180._r8 + do n=1,nlon*nlat + if (area_global(n) <= 0._r8) then + i = mod(n-1,nlon) + 1 + j = (n-1)/nlon + 1 + dx = (rlone(i) - rlonw(i)) * deg2rad + dy = sin(rlatn(j)*deg2rad) - sin(rlats(j)*deg2rad) + area_global(n) = abs(1.e6_r8 * dx*dy*re*re) + if (mainproc .and. area_global(n) <= 0) then + write(iulog,*) 'Warning! Zero area for unit ', n, area_global(n),dx,dy,re + end if + end if + end do + + ! --------------------------------------------- + ! Determine decomposition + ! --------------------------------------------- + + ! memory for this%gindex, this%mask and this%dsig is allocated in init_decomp + call t_startf('mosarti_decomp') + call this%init_decomp(locfn, decomp_option, use_halo_option, & + nlon, nlat, this%begr, this%endr, this%lnumr, this%numr, IDkey, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call t_stopf('mosarti_decomp') + + ! --------------------------------------------- + ! Allocate and initialize remaining variables + ! --------------------------------------------- + + begr = this%begr + endr = this%endr + ntracers = this%ntracers + + allocate(this%area(begr:endr), & + ! + this%volr(begr:endr,ntracers), & + this%dvolrdt(begr:endr,ntracers), & + this%dvolrdtlnd(begr:endr,ntracers), & + this%dvolrdtocn(begr:endr,ntracers), & + ! + this%runoff(begr:endr,ntracers), & + this%runofflnd(begr:endr,ntracers), & + this%runoffocn(begr:endr,ntracers), & + this%runofftot(begr:endr,ntracers), & + ! + this%fthresh(begr:endr), & + this%flood(begr:endr), & + ! + this%direct(begr:endr,ntracers), & + this%qsur(begr:endr,ntracers), & + this%qsub(begr:endr,ntracers), & + this%qgwl(begr:endr,ntracers), & + this%qirrig(begr:endr), & + this%qirrig_actual(begr:endr), & + ! + this%evel(begr:endr,ntracers), & + this%flow(begr:endr,ntracers), & + this%erout_prev(begr:endr,ntracers), & + this%eroutup_avg(begr:endr,ntracers),& + this%erlat_avg(begr:endr,ntracers), & ! - ! Allocate halo_arrayptr_index - local index (starting at 1) into this%halo_arrayptr on my pe - allocate(this%halo_arrayptr_index(endr-begr+1,max_num_halo)) - this%halo_arrayptr_index(:,:) = -999 - - allocate(store_halo_index((endr-begr+1)*max_num_halo)) - store_halo_index(:) = 0 - - do nr = begr,endr - n = gdc2glo(nr) - i = mod(n-1,nlon) + 1 - j = (n-1)/nlon + 1 - jm1 = j-1 - jp1 = j+1 - im1 = i-1 - ip1 = i+1 - if (i == 1) im1 = 1 - if (j == 1) jm1 = 1 - if (i == nlon) ip1 = nlon - if (j == nlat) jp1 = nlat - n_sw = (jm1-1)*nlon + im1 - n_s = (jm1-1)*nlon + i - n_se = (jm1-1)*nlon + ip1 - n_e = ( j-1)*nlon + ip1 - n_ne = (jp1-1)*nlon + ip1 - n_n = (jp1-1)*nlon + i - n_nw = (jp1-1)*nlon + im1 - n_w = ( j-1)*nlon + im1 - call set_halo_index(n_sw, halo_sw, glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - call set_halo_index(n_s , halo_s , glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - call set_halo_index(n_se, halo_se, glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - call set_halo_index(n_e , halo_e , glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - call set_halo_index(n_ne, halo_ne, glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - call set_halo_index(n_n , halo_n , glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - call set_halo_index(n_nw, halo_nw, glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - call set_halo_index(n_w , halo_w , glo2gdc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) - end do - - ! Allocate halo_list - global indices of the halo points on my pe - num_halo = count(store_halo_index /= 0) - allocate(halo_list(num_halo)) - halo_list(1:num_halo) = store_halo_index(1:num_halo) - - ! Create halo route handle using predefined allocatable memory - ! Create ESMF array for field - this will be time dependent + this%effvel(ntracers), & + stat=ier) + if (ier /= 0) then + write(iulog,*)'mosarart_control_type allocation error' + call shr_sys_abort + end if + + this%runoff(:,:) = 0._r8 + this%runofflnd(:,:) = spval + this%runoffocn(:,:) = spval + this%runofftot(:,:) = spval + this%dvolrdt(:,:) = 0._r8 + this%dvolrdtlnd(:,:) = spval + this%dvolrdtocn(:,:) = spval + this%volr(:,:) = 0._r8 + this%flood(:) = 0._r8 + this%direct(:,:) = 0._r8 + this%qirrig(:) = 0._r8 + this%qirrig_actual(:) = 0._r8 + this%qsur(:,:) = 0._r8 + this%qsub(:,:) = 0._r8 + this%qgwl(:,:) = 0._r8 + this%fthresh(:) = abs(spval) + this%flow(:,:) = 0._r8 + this%erout_prev(:,:) = 0._r8 + this%eroutup_avg(:,:) = 0._r8 + this%erlat_avg(:,:) = 0._r8 + + this%effvel(:) = effvel0 ! downstream velocity (m/s) + do nt = 1,ntracers + do nr = begr,endr + this%evel(nr,nt) = this%effvel(nt) + enddo + enddo + + do nr = begr,endr + n = this%gindex(nr) + i = mod(n-1,nlon) + 1 + j = (n-1)/nlon + 1 + this%lonc(nr) = this%rlon(i) + this%latc(nr) = this%rlat(j) + this%area(nr) = area_global(n) + enddo + + larea = 0.0_r8 + do nr = begr,endr + larea = larea + this%area(nr) + end do + if (minval(this%mask) < 1) then + write(iulog,*) subname,'ERROR this mask lt 1 ',minval(this%mask),maxval(this%mask) + call shr_sys_abort(subname//' ERROR this mask') + endif + call shr_mpi_sum(larea, this%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 ',this%totarea + end if + + end subroutine Init + + !======================================================================== + subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & + nlon, nlat, begr, endr, lnumr, numr, IDkey, rc) + + ! Arguments + class(control_type) :: this + character(len=*) , intent(in) :: locfn ! local routing filename + character(len=*) , intent(in) :: decomp_option + logical , intent(in) :: use_halo_option + integer , intent(in) :: nlon + integer , intent(in) :: nlat + integer , intent(out) :: begr + integer , intent(out) :: endr + integer , intent(out) :: lnumr + integer , intent(out) :: numr + integer , intent(out) :: IDkey(:) ! translation key from ID to gindex + integer , intent(out) :: rc + + ! Local variables + integer :: n, nr, i, j, g ! indices + integer :: nl,nloops ! used for decomp search + real(r8),allocatable :: rtempr(:,:) ! global temporary buffer - real + integer, allocatable :: gmask(:) ! global mask + integer, allocatable :: glo2loc(:) ! global global->local mapping + integer, allocatable :: dnID_global(:) ! global downstream ID based on ID0 + integer, allocatable :: idxocn(:) ! global downstream ocean outlet cell + integer, allocatable :: nupstrm(:) ! number of upstream cells including own cell + integer, allocatable :: pocn(:) ! pe number assigned to basin + integer :: ID0_global ! global (local) ID index + integer :: nop(0:npes-1) ! number of gridcells on a pe + integer :: nba(0:npes-1) ! number of basins on each pe + integer :: nrs(0:npes-1) ! begr on each pe + integer :: maxgcells_per_pe ! max num of points per pe for decomp + integer :: minbas,maxbas ! used for decomp search + integer :: pid,np,npmin,npmax,npint ! log loop control + integer :: nmos ! number of mosart points + integer :: nout ! number of basin with outlets + integer :: nbas ! number of basin/ocean points + integer :: nrof ! num of active mosart points + integer :: baspe ! pe with min number of mosart cells + logical :: found ! flag + integer :: ier ! error status + type(file_desc_t) :: ncid ! pio file desc + integer :: procid + integer :: im1,ip1 + integer :: jm1,jp1 + integer :: n_sw, n_s, n_se + integer :: n_nw, n_n, n_ne + integer :: n_e, n_w + integer :: num_halo + integer, pointer :: halo_list(:) + integer, pointer :: seqlist(:) + integer, allocatable :: store_halo_index(:) + integer :: nglob + character(len=*),parameter :: subname = '(mosart_control_type: init_decomp) ' + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + !------------------------------------------------------- + ! Read ID and DnID from routing file + !------------------------------------------------------- + + ! RESET dnID indices based on ID0 + ! rename the dnID values to be consistent with global grid indexing. + ! where 1 = lower left of grid and nlon*nlat is upper right. + ! ID0 is the "key", modify dnID based on that. keep the IDkey around + ! for as long as needed. This is a key that translates the ID0 value + ! to the gindex value. compute the key, then apply the key to dnID_global. + ! As part of this, check that each value of ID0 is unique and within + ! the range of 1 to nlon*nlat. + + call ncd_pio_openfile(ncid, trim(locfn), 0) + + allocate(rtempr(nlon,nlat)) + allocate(dnID_global(nlon*nlat)) + + call ncd_io(ncid=ncid, varname='ID', flag='read', data=rtempr, readvar=found) + if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart ID') + if (mainproc) write(iulog,*) 'Read ID ',minval(rtempr),maxval(rtempr) + + IDkey(:) = 0 + do j=1,nlat + do i=1,nlon + n = (j-1)*nlon + i + ID0_global = int(rtempr(i,j)) + if (ID0_global < 0 .or. ID0_global > nlon*nlat) then + write(iulog,*) subname,' ERROR ID0 out of range',n,ID0_global + call shr_sys_abort(subname//' ERROR error ID0 out of range') + endif + if (IDkey(ID0_global) /= 0) then + write(iulog,*) subname,' ERROR ID0 value occurs twice',n,ID0_global + call shr_sys_abort(subname//' ERROR ID0 value occurs twice') + endif + IDkey(ID0_global) = n + end do + end do + if (minval(IDkey) < 1) then + write(iulog,*) subname,' ERROR IDkey incomplete' + call shr_sys_abort(subname//' ERROR IDkey incomplete') + endif + + call ncd_io(ncid=ncid, varname='dnID', flag='read', data=rtempr, readvar=found) + if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart dnID') + if (mainproc) write(iulog,*) 'Read dnID ',minval(rtempr),maxval(rtempr) + do j=1,nlat + do i=1,nlon + n = (j-1)*nlon + i + dnID_global(n) = int(rtempr(i,j)) + if (dnID_global(n) > 0 .and. dnID_global(n) <= nlon*nlat) then + if (IDkey(dnID_global(n)) > 0 .and. IDkey(dnID_global(n)) <= nlon*nlat) then + dnID_global(n) = IDkey(dnID_global(n)) + else + write(iulog,*) subname,' ERROR bad IDkey',n,dnID_global(n),IDkey(dnID_global(n)) + call shr_sys_abort(subname//' ERROR bad IDkey') + endif + endif + end do + end do + if (mainproc) write(iulog,*) 'dnID ',minval(rtempr),maxval(rtempr) + deallocate(rtempr) + + call ncd_pio_closefile(ncid) + + !------------------------------------------------------- + ! Determine mosart ocn/land mask (global, all procs) + !------------------------------------------------------- + + ! 1=land, 2=ocean, 3=ocean outlet from land + allocate(gmask(nlon*nlat)) + gmask(:) = 2 ! assume ocean point + do n=1,nlon*nlat ! mark all downstream points as outlet + nr = dnID_global(n) + if ((nr > 0) .and. (nr <= nlon*nlat)) then + gmask(nr) = 3 ! <- nr + end if + enddo + do n=1,nlon*nlat ! now mark all points with downstream points as land + nr = dnID_global(n) + if ((nr > 0) .and. (nr <= nlon*nlat)) then + gmask(n) = 1 ! <- n + end if + enddo + + !------------------------------------------------------- + ! Compute total number of basins and runoff points + !------------------------------------------------------- + + nbas = 0 + nrof = 0 + nout = 0 + nmos = 0 + do nr=1,nlon*nlat + if (gmask(nr) == 3) then + nout = nout + 1 + nbas = nbas + 1 + nmos = nmos + 1 + nrof = nrof + 1 + elseif (gmask(nr) == 2) then + nbas = nbas + 1 + nrof = nrof + 1 + elseif (gmask(nr) == 1) then + nmos = nmos + 1 + nrof = nrof + 1 + endif + enddo + if (mainproc) then + write(iulog,*) 'Number of outlet basins = ',nout + write(iulog,*) 'Number of total basins = ',nbas + write(iulog,*) 'Number of mosart points = ',nmos + write(iulog,*) 'Number of runoff points = ',nrof + endif + + !------------------------------------------------------- + ! Compute river basins, actually compute ocean outlet gridcell + !------------------------------------------------------- + + ! idxocn = final downstream cell, index is global 1d ocean gridcell + ! nupstrm = number of source gridcells upstream including self + allocate(idxocn(nlon*nlat)) + allocate(nupstrm(nlon*nlat)) + idxocn(:) = 0 + nupstrm(:) = 0 + do nr=1,nlon*nlat + n = nr + if (abs(gmask(n)) == 1) then ! land + g = 0 + do while (abs(gmask(n)) == 1 .and. g < nlon*nlat) ! follow downstream + nupstrm(n) = nupstrm(n) + 1 + n = dnID_global(n) + g = g + 1 + end do + if (gmask(n) == 3) then ! found ocean outlet + nupstrm(n) = nupstrm(n) + 1 ! one more land cell for n + idxocn(nr) = n ! set ocean outlet or nr to n + elseif (abs(gmask(n)) == 1) then ! no ocean outlet, warn user, ignore cell + write(iulog,*) subname,' ERROR closed basin found', & + g,nr,gmask(nr),dnID_global(nr),n,gmask(n),dnID_global(n) + call shr_sys_abort(subname//' ERROR closed basin found') + elseif (gmask(n) == 2) then + write(iulog,*) subname,' ERROR found invalid ocean cell ',nr + call shr_sys_abort(subname//' ERROR found invalid ocean cell') + else + write(iulog,*) subname,' ERROR downstream cell is unknown', & + g,nr,gmask(nr),dnID_global(nr),n,gmask(n),dnID_global(n) + call shr_sys_abort(subname//' ERROR downstream cell is unknown') + endif + elseif (gmask(n) >= 2) then ! ocean, give to self + nupstrm(n) = nupstrm(n) + 1 + idxocn(nr) = n + endif + enddo + + !------------------------------------------------------- + !--- Now allocate those basins to pes + !------------------------------------------------------- + + ! this is the heart of the decomp, need to set pocn and nop by the end of this + ! pocn is the pe that gets the basin associated with ocean outlet nr + ! nop is a running count of the number of mosart cells/pe + allocate(pocn(nlon*nlat)) + pocn(:) = -99 + nop(0:npes-1) = 0 + if (trim(decomp_option) == 'basin') then + + baspe = 0 + maxgcells_per_pe = int(float(nrof)/float(npes)*0.445) + 1 + nloops = 3 + minbas = nrof + do nl=1,nloops + maxbas = minbas - 1 + minbas = maxval(nupstrm)/(2**nl) + if (nl == nloops) minbas = min(minbas,1) + do nr=1,nlon*nlat + if (gmask(nr) >= 2 .and. nupstrm(nr) > 0 .and. nupstrm(nr) >= minbas .and. nupstrm(nr) <= maxbas) then + ! Decomp options + ! find min pe (implemented but scales poorly) + ! use increasing thresholds (implemented, ok load balance for l2r or calc) + ! distribute basins using above methods but work from max to min basin size + ! find next pe below maxgcells_per_pe threshhold and increment + do while (nop(baspe) > maxgcells_per_pe) + baspe = baspe + 1 + if (baspe > npes-1) then + baspe = 0 + ! 3 loop, .445 and 1.5 chosen carefully + maxgcells_per_pe = max(maxgcells_per_pe*1.5, maxgcells_per_pe+1.0) + endif + enddo + if (baspe > npes-1 .or. baspe < 0) then + write(iulog,*) 'ERROR in decomp for mosart ',nr,npes,baspe + call shr_sys_abort('ERROR mosart decomp') + endif + nop(baspe) = nop(baspe) + nupstrm(nr) + pocn(nr) = baspe + endif + enddo ! nr + enddo ! nl + + ! set pocn for land cells, was set for ocean above + do nr=1,nlon*nlat + if (idxocn(nr) > 0) then + pocn(nr) = pocn(idxocn(nr)) + if (pocn(nr) < 0 .or. pocn(nr) > npes-1) then + write(iulog,*) subname,' ERROR pocn lnd setting ',& + nr,idxocn(nr),idxocn(idxocn(nr)),pocn(idxocn(nr)),pocn(nr),npes + call shr_sys_abort(subname//' ERROR pocn lnd') + endif + endif + enddo + + elseif (trim(decomp_option) == '1d') then + + ! distribute active points in 1d fashion to pes + ! baspe is the pe assignment + ! maxgcells_per_pe is the maximum number of points to assign to each pe + baspe = 0 + maxgcells_per_pe = (nrof-1)/npes + 1 + do nr=1,nlon*nlat + pocn(nr) = baspe + nop(baspe) = nop(baspe) + 1 + if (nop(baspe) >= maxgcells_per_pe) then + baspe = (mod(baspe+1,npes)) + if (baspe < 0 .or. baspe > npes-1) then + write(iulog,*) subname,' ERROR basepe ',baspe,npes + call shr_sys_abort(subname//' ERROR pocn lnd') + endif + endif + enddo + + elseif (trim(decomp_option) == 'roundrobin') then + + ! distribute active points in roundrobin fashion to pes + ! baspe is the pe assignment + ! maxgcells_per_pe is the maximum number of points to assign to each pe + baspe = 0 + do nr=1,nlon*nlat + pocn(nr) = baspe + nop(baspe) = nop(baspe) + 1 + baspe = (mod(baspe+1,npes)) + if (baspe < 0 .or. baspe > npes-1) then + write(iulog,*) subname,' ERROR basepe ',baspe,npes + call shr_sys_abort(subname//' ERROR pocn lnd') + endif + enddo + do nr = 1,nlon*nlat + if (pocn(nr) < 0) then + write(6,*)'WARNING: nr,pocn(nr) is < 0',nr,pocn(nr) + end if + end do + + else + write(iulog,*) subname,' ERROR decomp option unknown ',trim(decomp_option) + call shr_sys_abort(subname//' ERROR pocn lnd') + endif ! decomp_option + + if (mainproc) then + write(iulog,*) 'mosart cells and basins total = ',nrof,nbas + write(iulog,*) 'mosart cells per basin avg/max = ',nrof/nbas,maxval(nupstrm) + write(iulog,*) 'mosart cells per pe min/max = ',minval(nop),maxval(nop) + write(iulog,*) 'mosart basins per pe min/max = ',minval(nba),maxval(nba) + endif + deallocate(nupstrm) + + !------------------------------------------------------- + ! Determine begr, endr, numr and lnumr + !------------------------------------------------------- + + numr = 0 + do n = 0,npes-1 + if (iam == n) then + begr = numr + 1 + endr = begr + nop(n) - 1 + endif + numr = numr + nop(n) + enddo + lnumr = endr - begr + 1 + + !------------------------------------------------------- + ! Determine glo2loc (global to local) + !------------------------------------------------------- + + ! pocn(nlon*nlat) pe number assigned to basin + ! nop(0:npes-1) number of gridcells on a pe + ! nba(0:npes-1) number of basins on each pe + ! nrs(0:npes-1) begr on each pe + + ! Determine glo2loc + ! nrs is begr on each pe + ! reuse nba for nop-like counter here, pocn -99 is unused cell + + nrs(:) = 0 + nrs(0) = 1 + do n = 1,npes-1 + ! nop is number of cells per pe + ! so loop through the pes and determine begr on each pe + nrs(n) = nrs(n-1) + nop(n-1) + enddo + + allocate(glo2loc(nlon*nlat)) + glo2loc(:) = 0 + nba(:) = 0 + do nr = 1,nlon*nlat + procid = pocn(nr) + if (procid >= 0) then + glo2loc(nr) = nrs(procid) + nba(procid) + nba(procid) = nba(procid) + 1 + endif + enddo + do n = 0,npes-1 + if (nba(n) /= nop(n)) then + write(iulog,*) subname,' ERROR mosart cell count ',n,nba(n),nop(n) + call shr_sys_abort(subname//' ERROR mosart cell count') + endif + enddo + + ! Determine gindex + allocate(this%gindex(begr:endr)) + do j = 1,nlat + do i = 1,nlon + n = (j-1)*nlon + i + if (dnID_global(n) > 0) then + if (glo2loc(dnID_global(n)) == 0) then + write(iulog,*) subname,' ERROR glo2loc dnID_global ',& + nr,n,dnID_global(n),glo2loc(dnID_global(n)) + call shr_sys_abort(subname//' ERROT glo2loc dnID_global') + end if + end if + nr = glo2loc(n) + if (nr >= begr .and. nr <= endr) then + this%gindex(nr) = n + endif + end do + end do + + !------------------------------------------------------- + ! Create distGrid from global index array + !------------------------------------------------------- + + allocate(seqlist(endr-begr+1)) + n = 0 + do nr = begr,endr + n = n + 1 + seqlist(n) = this%gindex(nr) + end do + this%DistGrid = ESMF_DistGridCreate(arbSeqIndexList=seqlist, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + deallocate(seqlist) + + !------------------------------------------------------- + ! Determine local lonc and latc + !------------------------------------------------------- + + allocate(this%lonc(begr:endr), this%latc(begr:endr)) + do nr = begr,endr + n = this%gindex(nr) + i = mod(n-1,nlon) + 1 + j = (n-1)/nlon + 1 + this%lonc(nr) = this%rlon(i) + this%latc(nr) = this%rlat(j) + end do + + !------------------------------------------------------- + ! Determine halo points and create halo route handle + !------------------------------------------------------- + if( use_halo_option ) then + ! note that for each gridcell below there are nhalo extra elements that need to be allocated + ! Need to keep track of the global index of each halo point + ! temporary allocatable array store_halo_index = size((endr-begr+1)*nhalo) (nhalo is the number of halo points) + ! + ! Allocate halo_arrayptr_index - local index (starting at 1) into this%halo_arrayptr on my pe + allocate(this%halo_arrayptr_index(endr-begr+1,max_num_halo)) + this%halo_arrayptr_index(:,:) = -999 + + allocate(store_halo_index((endr-begr+1)*max_num_halo)) + store_halo_index(:) = 0 + + do nr = begr,endr + n = this%gindex(nr) + i = mod(n-1,nlon) + 1 + j = (n-1)/nlon + 1 + jm1 = j-1 + jp1 = j+1 + im1 = i-1 + ip1 = i+1 + if (i == 1) im1 = 1 + if (j == 1) jm1 = 1 + if (i == nlon) ip1 = nlon + if (j == nlat) jp1 = nlat + n_sw = (jm1-1)*nlon + im1 + n_s = (jm1-1)*nlon + i + n_se = (jm1-1)*nlon + ip1 + n_e = ( j-1)*nlon + ip1 + n_ne = (jp1-1)*nlon + ip1 + n_n = (jp1-1)*nlon + i + n_nw = (jp1-1)*nlon + im1 + n_w = ( j-1)*nlon + im1 + call set_halo_index(n_sw, halo_sw, glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_s , halo_s , glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_se, halo_se, glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_e , halo_e , glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_ne, halo_ne, glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_n , halo_n , glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_nw, halo_nw, glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_w , halo_w , glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + end do + + ! Allocate halo_list - global indices of the halo points on my pe + num_halo = count(store_halo_index /= 0) + allocate(halo_list(num_halo)) + halo_list(1:num_halo) = store_halo_index(1:num_halo) + + ! Create halo route handle using predefined allocatable memory allocate(this%fld_halo_arrayptr(endr-begr+1+num_halo)) this%fld_halo_arrayptr(:) = 0. - this%fld_haloArray = ESMF_ArrayCreate(this%distgrid, this%fld_halo_arrayptr, haloSeqIndexList=halo_list, rc=rc) - call ESMF_ArrayHaloStore(this%fld_haloArray, routehandle=this%haloHandle, rc=rc) + this%fld_halo_array = ESMF_ArrayCreate(this%distgrid, this%fld_halo_arrayptr, haloSeqIndexList=halo_list, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Create a halo route handle - only need one + call ESMF_ArrayHaloStore(this%fld_halo_array, routehandle=this%haloHandle, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return ! Create ESMF arrays for lon, lat and fld allocate(this%lon_halo_arrayptr(endr-begr+1+num_halo)) this%lon_halo_arrayptr(:) = 0. - this%lon_haloArray = ESMF_ArrayCreate(this%distgrid, this%lon_halo_arrayptr, haloSeqIndexList=halo_list, rc=rc) + this%lon_halo_array = ESMF_ArrayCreate(this%distgrid, this%lon_halo_arrayptr, haloSeqIndexList=halo_list, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return allocate(this%lat_halo_arrayptr(endr-begr+1+num_halo)) this%lat_halo_arrayptr(:) = 0. - this%lat_haloArray = ESMF_ArrayCreate(this%distgrid, this%lat_halo_arrayptr, haloSeqIndexList=halo_list, rc=rc) + this%lat_halo_array = ESMF_ArrayCreate(this%distgrid, this%lat_halo_arrayptr, haloSeqIndexList=halo_list, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return ! Set halo array for lon and lat - these do not change with time - n = 0 + n = 0 do nr = this%begr,this%endr n = n + 1 this%lon_halo_arrayptr(n) = this%lonc(nr) this%lat_halo_arrayptr(n) = this%latc(nr) end do - call ESMF_ArrayHalo(this%lon_haloArray, routehandle=this%haloHandle, rc=rc) + call ESMF_ArrayHalo(this%lon_halo_array, routehandle=this%haloHandle, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_ArrayHalo(this%lat_haloArray, routehandle=this%haloHandle, rc=rc) + call ESMF_ArrayHalo(this%lat_halo_array, routehandle=this%haloHandle, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - - deallocate(halo_list) - deallocate(store_halo_index) - - ! Now do a test of the halo operation - call this%test_halo(rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - endif - deallocate(gdc2glo,glo2gdc,pocn) - - !------------------------------------------------------- - ! Determine mask, outletg and dsig - !------------------------------------------------------- - - allocate(this%mask(begr:endr), this%outletg(begr:endr), this%dsig(begr:endr)) - do nr = begr,endr - n = this%gindex(nr) - this%mask(nr) = gmask(n) - this%outletg(nr) = idxocn(n) - if (dnID_global(n) <= 0) then - this%dsig(nr) = 0 - else - this%dsig(nr) = dnID_global(n) - endif - end do - deallocate(gmask,dnID_global,idxocn) - - !------------------------------------------------------- - ! Write per-processor runoff bounds depending on dbug level - !------------------------------------------------------- - - if (mainproc) then - write(iulog,*) 'total runoff cells numr = ',numr - endif - call mpi_barrier(mpicom_rof,ier) - npmin = 0 - npmax = npes-1 - npint = 1 - if (dbug == 0) then - npmax = 0 - elseif (dbug == 1) then - npmax = min(npes-1,4) - elseif (dbug == 2) then - npint = npes/8 - elseif (dbug == 3) then - npint = 1 - endif - do np = npmin,npmax,npint - pid = np - if (dbug == 1) then - if (np == 2) pid=npes/2-1 - if (np == 3) pid=npes-2 - if (np == 4) pid=npes-1 - endif - pid = max(pid,0) - pid = min(pid,npes-1) - if (iam == pid) then - write(iulog,'(2a,i9,a,i9,a,i9,a,i9)')' mosart decomp info',& - ' proc = ',iam,' begr = ',begr,' endr = ',endr,' numr = ',lnumr - endif - call mpi_barrier(mpicom_rof,ier) - enddo - - end subroutine init_decomp - - !======================================================================== - - subroutine set_halo_index(global_index, halo_index, glo2gdc, nr, begr, endr, pocn, store_halo_index, halo_arrayptr_index) - - ! Arguments - integer, intent(in) :: global_index - integer, intent(in) :: halo_index - integer, intent(in) :: glo2gdc(:) - integer, intent(in) :: nr - integer, intent(in) :: begr, endr - integer, intent(in) :: pocn(:) - integer, intent(inout) :: store_halo_index(:) - integer, intent(inout) :: halo_arrayptr_index(:,:) - - ! Local variables - integer :: n - logical :: found_index - integer :: nsize - integer :: num_halo - !----------------------------------------------------------------------- - - nsize = endr-begr+1 - if (pocn(global_index) /= iam) then - found_index = .false. - do n = 1,size(store_halo_index) - if (store_halo_index(n) == global_index) then - num_halo = n - found_index = .true. - exit - else if (store_halo_index(n) == 0) then - store_halo_index(n) = global_index - num_halo = n - found_index = .true. - exit - end if - end do - if (.not. found_index) then - call shr_sys_abort('ERROR: global halo index not found') - end if - halo_arrayptr_index(nr-begr+1,halo_index) = nsize + num_halo - else - halo_arrayptr_index(nr-begr+1,halo_index) = glo2gdc(global_index) - begr + 1 - end if - - end subroutine set_halo_index - - !======================================================================== - subroutine test_halo(this, rc) - - ! Arguments - class(control_type) :: this - integer, intent(out) :: rc - - ! Local variables - integer :: i,j - integer :: n, nr - integer :: nglob - integer :: halo_value - integer :: valid_value - real(r8) :: lon, lon_p1, lon_m1 - real(r8) :: lat, lat_p1, lat_m1 - !----------------------------------------------------------------------- - - rc = ESMF_SUCCESS - - n = 0 - do nr = this%begr,this%endr - n = n + 1 - this%fld_halo_arrayptr(n) = this%latc(nr)*10. + this%lonc(nr)/100. - end do - - call ESMF_ArrayHalo(this%fld_haloArray, routehandle=this%haloHandle, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - n = 0 - do nr = this%begr,this%endr - n = n+1 - nglob = this%gindex(nr) - i = mod(nglob-1,this%nlon) + 1 - j = (nglob-1)/this%nlon + 1 - if (j== 1) then - lat_m1 = this%rlat(1) - else - lat_m1 = this%rlat(j-1) - end if - if (j == this%nlat) then - lat_p1 = this%rlat(this%nlat) - else - lat_p1 = this%rlat(j+1) - end if - lat = this%rlat(j) - if (i == 1) then - lon_m1 = this%rlon(1) - else - lon_m1 = this%rlon(i-1) - end if - if (i == this%nlon) then - lon_p1 = this%rlon(this%nlon) - else - lon_p1 = this%rlon(i+1) - end if - lon = this%rlon(i) - ! - halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_sw)) - valid_value = lat_m1*10 + lon_m1/100. - if (halo_value /= valid_value) then - write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value - call shr_sys_abort('ERROR: invalid halo') - end if - ! - halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_s)) - valid_value = lat_m1*10 + lon/100. - if (halo_value /= valid_value) then - write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value - call shr_sys_abort('ERROR: invalid halo') - end if - ! - halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_se)) - valid_value = lat_m1*10 + lon_p1/100. - if (halo_value /= valid_value) then - write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value - call shr_sys_abort('ERROR: invalid halo') - end if - ! - halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_e)) - valid_value = lat*10 + lon_p1/100. - if (halo_value /= valid_value) then - write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value - call shr_sys_abort('ERROR: invalid halo') - end if - ! - halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_ne)) - valid_value = lat_p1*10 + lon_p1/100. - if (halo_value /= valid_value) then - write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value - call shr_sys_abort('ERROR: invalid halo') - end if - ! - halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_nw)) - valid_value = lat_p1*10 + lon_m1/100. - if (halo_value /= valid_value) then - write(6,*)'ERROR: halo, valid not the same = ',halo_value, valid_value - call shr_sys_abort('ERROR: invalid halo') - end if - end do - end subroutine test_halo + ! Deallocate memory + deallocate(halo_list) + deallocate(store_halo_index) + + ! Now do a test of the halo operation + call this%test_halo(rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + endif + deallocate(glo2loc) + deallocate(pocn) + + !------------------------------------------------------- + ! Determine mask, outletg and dsig + !------------------------------------------------------- + + allocate(this%mask(begr:endr), this%outletg(begr:endr), this%dsig(begr:endr)) + do nr = begr,endr + n = this%gindex(nr) + this%mask(nr) = gmask(n) + this%outletg(nr) = idxocn(n) + if (dnID_global(n) <= 0) then + this%dsig(nr) = 0 + else + this%dsig(nr) = dnID_global(n) + endif + end do + deallocate(gmask) + deallocate(dnID_global) + deallocate(idxocn) + + !------------------------------------------------------- + ! Write per-processor runoff bounds depending on dbug level + !------------------------------------------------------- + + if (mainproc) then + write(iulog,*) 'total runoff cells numr = ',numr + endif + call mpi_barrier(mpicom_rof,ier) + npmin = 0 + npmax = npes-1 + npint = 1 + if (dbug == 0) then + npmax = 0 + elseif (dbug == 1) then + npmax = min(npes-1,4) + elseif (dbug == 2) then + npint = npes/8 + elseif (dbug == 3) then + npint = 1 + endif + do np = npmin,npmax,npint + pid = np + if (dbug == 1) then + if (np == 2) pid=npes/2-1 + if (np == 3) pid=npes-2 + if (np == 4) pid=npes-1 + endif + pid = max(pid,0) + pid = min(pid,npes-1) + if (iam == pid) then + write(iulog,'(2a,i9,a,i9,a,i9,a,i9)')' mosart decomp info',& + ' proc = ',iam,' begr = ',begr,' endr = ',endr,' numr = ',lnumr + endif + call mpi_barrier(mpicom_rof,ier) + enddo + + end subroutine init_decomp + + !======================================================================== + + subroutine set_halo_index(global_index, halo_index, glo2loc, nr, begr, endr, pocn, store_halo_index, halo_arrayptr_index) + + ! Arguments + integer, intent(in) :: global_index + integer, intent(in) :: halo_index + integer, intent(in) :: glo2loc(:) + integer, intent(in) :: nr + integer, intent(in) :: begr, endr + integer, intent(in) :: pocn(:) + integer, intent(inout) :: store_halo_index(:) + integer, intent(inout) :: halo_arrayptr_index(:,:) + + ! Local variables + integer :: n + logical :: found_index + integer :: nsize + integer :: num_halo + !----------------------------------------------------------------------- + + nsize = endr-begr+1 + if (pocn(global_index) /= iam) then + found_index = .false. + do n = 1,size(store_halo_index) + if (store_halo_index(n) == global_index) then + num_halo = n + found_index = .true. + exit + else if (store_halo_index(n) == 0) then + store_halo_index(n) = global_index + num_halo = n + found_index = .true. + exit + end if + end do + if (.not. found_index) then + call shr_sys_abort('ERROR: global halo index not found') + end if + halo_arrayptr_index(nr-begr+1,halo_index) = nsize + num_halo + else + halo_arrayptr_index(nr-begr+1,halo_index) = glo2loc(global_index) - begr + 1 + end if + + end subroutine set_halo_index + + !======================================================================== + subroutine test_halo(this, rc) + + ! Arguments + class(control_type) :: this + integer, intent(out) :: rc + + ! Local variables + integer :: i,j + integer :: n, nr + integer :: nglob + integer :: halo_value + integer :: valid_value + real(r8) :: lon, lon_p1, lon_m1 + real(r8) :: lat, lat_p1, lat_m1 + !----------------------------------------------------------------------- - !======================================================================== + rc = ESMF_SUCCESS - subroutine Gradient(this, begr, endr, fld, dfld_dx, dfld_dy, rc) + n = 0 + do nr = this%begr,this%endr + n = n + 1 + this%fld_halo_arrayptr(n) = this%latc(nr)*10. + this%lonc(nr)/100. + end do - ! Calculate head gradient from nine gridcells (center and surrounding) + call ESMF_ArrayHalo(this%fld_halo_array, routehandle=this%haloHandle, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + n = 0 + do nr = this%begr,this%endr + n = n+1 + nglob = this%gindex(nr) + i = mod(nglob-1,this%nlon) + 1 + j = (nglob-1)/this%nlon + 1 + if (j== 1) then + lat_m1 = this%rlat(1) + else + lat_m1 = this%rlat(j-1) + end if + if (j == this%nlat) then + lat_p1 = this%rlat(this%nlat) + else + lat_p1 = this%rlat(j+1) + end if + lat = this%rlat(j) + if (i == 1) then + lon_m1 = this%rlon(1) + else + lon_m1 = this%rlon(i-1) + end if + if (i == this%nlon) then + lon_p1 = this%rlon(this%nlon) + else + lon_p1 = this%rlon(i+1) + end if + lon = this%rlon(i) + ! + halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_sw)) + valid_value = lat_m1*10 + lon_m1/100. + if (halo_value /= valid_value) then + write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + ! + halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_s)) + valid_value = lat_m1*10 + lon/100. + if (halo_value /= valid_value) then + write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + ! + halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_se)) + valid_value = lat_m1*10 + lon_p1/100. + if (halo_value /= valid_value) then + write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + ! + halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_e)) + valid_value = lat*10 + lon_p1/100. + if (halo_value /= valid_value) then + write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + ! + halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_ne)) + valid_value = lat_p1*10 + lon_p1/100. + if (halo_value /= valid_value) then + write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + ! + halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_nw)) + valid_value = lat_p1*10 + lon_m1/100. + if (halo_value /= valid_value) then + write(6,*)'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + end do + + end subroutine test_halo + + !======================================================================== + + subroutine calc_gradient(this, fld, fld_halo_array, dfld_dx, dfld_dy, rc) + + ! Calculate gradient from nine gridcells (center and surrounding) ! Uses - use shr_const_mod, only : SHR_CONST_REARTH, SHR_CONST_PI ! Arguments: class(control_type) :: this - integer , intent(in) :: begr, endr - real(r8), intent(in) :: fld(begr:endr) + real(r8), intent(in) :: fld(this%begr:this%endr) + type(ESMF_Array) :: fld_halo_array real(r8), intent(out) :: dfld_dx(:) ! gradient x component real(r8), intent(out) :: dfld_dy(:) ! gradient y component integer , intent(out) :: rc @@ -1140,6 +1118,7 @@ subroutine Gradient(this, begr, endr, fld, dfld_dx, dfld_dy, rc) real(r8) :: dx(max_num_halo) real(r8) :: dy(max_num_halo) integer :: index + real(r8), pointer :: fld_halo_arrayptr(:) !----------------------------------------------------------------------- call t_startf('gradient') @@ -1153,15 +1132,19 @@ subroutine Gradient(this, begr, endr, fld, dfld_dx, dfld_dy, rc) sy_indices(:) = (/halo_se,halo_s,halo_s,halo_sw/) ! y indices to subtract ! degrees to radians - deg2rad = SHR_CONST_PI / 180._r8 + deg2rad = shr_const_pi / 180._r8 + + ! Get pointer to data in ESMF array + call ESMF_ArrayGet(fld_halo_array, farrayPtr=fld_halo_arrayptr, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return ! update halo array for fld n = 0 - do nr = begr,endr + do nr = this%begr,this%endr n = n + 1 - this%fld_halo_arrayptr(n) = fld(nr) + fld_halo_arrayptr(n) = fld(nr) end do - call ESMF_ArrayHalo(this%fld_haloArray, routehandle=this%haloHandle, rc=rc) + call ESMF_ArrayHalo(fld_halo_array, routehandle=this%haloHandle, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return ! Initialize gradient components @@ -1169,17 +1152,17 @@ subroutine Gradient(this, begr, endr, fld, dfld_dx, dfld_dy, rc) dfld_dy(:) = 0._r8 n = 0 - do nr = begr,endr + do nr = this%begr,this%endr n = n+1 ! extract neighbors from halo array do i = 1,max_num_halo index = this%halo_arrayptr_index(n,i) - fld_surrounding(i) = this%fld_halo_arrayptr(index) + fld_surrounding(i) = fld_halo_arrayptr(index) dlon = (this%lon_halo_arrayptr(n) - this%lon_halo_arrayptr(index)) dlat = (this%lat_halo_arrayptr(n) - this%lat_halo_arrayptr(index)) - dx(i) = SHR_CONST_REARTH * abs(deg2rad*dlon) * cos(deg2rad*this%latc(nr)) - dy(i) = SHR_CONST_REARTH * abs(deg2rad*dlat) + dx(i) = shr_const_rearth * abs(deg2rad*dlon) * cos(deg2rad*this%latc(nr)) + dy(i) = shr_const_rearth * abs(deg2rad*dlat) enddo ! calculate mean spacing @@ -1200,7 +1183,7 @@ subroutine Gradient(this, begr, endr, fld, dfld_dx, dfld_dy, rc) enddo ! end of nr loop call t_stopf('gradient') - - end subroutine Gradient + + end subroutine calc_gradient end module mosart_control_type From 221b9537386705ba6545493305a38bc81eb2aa52 Mon Sep 17 00:00:00 2001 From: Erik Kluzek Date: Sun, 21 Jan 2024 20:10:12 -0700 Subject: [PATCH 37/86] Add back flooding so it can be turned on with source mods which is needed for @swensosc work --- cime_config/buildnml | 1 + cime_config/config_component.xml | 14 +++++++++++++- cime_config/namelist_definition_mosart.xml | 14 ++++++++++++++ 3 files changed, 28 insertions(+), 1 deletion(-) diff --git a/cime_config/buildnml b/cime_config/buildnml index 44f24ea..56c8cb7 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -52,6 +52,7 @@ def _create_namelists(case, confdir, inst_string, infile, nmlgen, data_list_path else: logger.warning( "WARNING::"+message ) + config['mosart_flood_mode'] = case.get_value("MOSART_FLOOD_MODE") config['rof_grid'] = case.get_value("ROF_GRID") config['lnd_grid'] = case.get_value("LND_GRID") config['rof_ncpl'] = case.get_value("ROF_NCPL") diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index ce5fbf1..84b4619 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -14,7 +14,7 @@ MOSART model with flood: - + char mosart mosart @@ -44,6 +44,18 @@ If warnings in namelist setttings from buildnml should be ignored or not + + char + ACTIVE,NULL + NULL + + ACTIVE + + build_component_mosart + env_build.xml + mode for mosart flood feature, NULL means mosart flood is turned off + + char diff --git a/cime_config/namelist_definition_mosart.xml b/cime_config/namelist_definition_mosart.xml index 556192c..f8843ef 100644 --- a/cime_config/namelist_definition_mosart.xml +++ b/cime_config/namelist_definition_mosart.xml @@ -8,6 +8,20 @@ + + logical + mosart + mosart_inparm + + .true. + .false. + + + If .true., turn on mosart flooding back to clm + Note that mosart flood is not supported in CESM1.1 + + + logical mosart From d0a49a0c36a27457ae4d8f902d6a1e5f6d690a71 Mon Sep 17 00:00:00 2001 From: Erik Kluzek Date: Mon, 22 Jan 2024 02:26:14 -0700 Subject: [PATCH 38/86] Add back flooding in the code, so @swensosc has a chance of turning it on with code mods, this resolves #80 --- src/cpl/nuopc/rof_comp_nuopc.F90 | 6 ++++-- src/cpl/nuopc/rof_import_export.F90 | 3 ++- src/riverroute/RtmMod.F90 | 29 +++++++++++++++++++++-------- 3 files changed, 27 insertions(+), 11 deletions(-) diff --git a/src/cpl/nuopc/rof_comp_nuopc.F90 b/src/cpl/nuopc/rof_comp_nuopc.F90 index f716a54..d97d2b7 100644 --- a/src/cpl/nuopc/rof_comp_nuopc.F90 +++ b/src/cpl/nuopc/rof_comp_nuopc.F90 @@ -55,6 +55,8 @@ module rof_comp_nuopc integer :: flds_scalar_index_nx = 0 integer :: flds_scalar_index_ny = 0 integer :: flds_scalar_index_nextsw_cday = 0._r8 + + logical :: do_rtmflood ! If flooding is active integer :: nthrds integer , parameter :: debug = 1 character(*), parameter :: modName = "(rof_comp_nuopc)" @@ -413,13 +415,13 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! - need to compute areas where they are not defined in input file ! - Initialize runoff datatype (rtmCTL) - call MOSART_read_namelist() + call MOSART_read_namelist(do_rtmflood) !---------------------------------------------------------------------------- ! Now advertise fields !---------------------------------------------------------------------------- - call advertise_fields(gcomp, flds_scalar_name, rc) + call advertise_fields(gcomp, flds_scalar_name, do_rtmflood, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---------------------------------------------------------------------------- diff --git a/src/cpl/nuopc/rof_import_export.F90 b/src/cpl/nuopc/rof_import_export.F90 index 08fd822..fd66a67 100644 --- a/src/cpl/nuopc/rof_import_export.F90 +++ b/src/cpl/nuopc/rof_import_export.F90 @@ -53,11 +53,12 @@ module rof_import_export contains !=============================================================================== - subroutine advertise_fields(gcomp, flds_scalar_name, rc) + 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 ! Flooding is active integer , intent(out) :: rc ! local variables diff --git a/src/riverroute/RtmMod.F90 b/src/riverroute/RtmMod.F90 index 1c74f68..b435b2a 100644 --- a/src/riverroute/RtmMod.F90 +++ b/src/riverroute/RtmMod.F90 @@ -82,6 +82,8 @@ module RtmMod 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 = & @@ -91,7 +93,10 @@ module RtmMod contains !----------------------------------------------------------------------- - subroutine MOSART_read_namelist() + subroutine MOSART_read_namelist(flood_active) + ! Read and distribute mosart namelist + ! + logical, intent(out) :: flood_active ! ! Read and distribute mosart namelist ! @@ -108,7 +113,7 @@ subroutine MOSART_read_namelist() ! Read in mosart namelist !------------------------------------------------------- - namelist /mosart_inparm / ice_runoff, & + 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, & @@ -155,6 +160,7 @@ subroutine MOSART_read_namelist() 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) @@ -189,6 +195,8 @@ subroutine MOSART_read_namelist() end if endif + flood_active = do_rtmflood + if (frivinp_rtm == ' ') then call shr_sys_abort( subname//' ERROR: frivinp_rtm NOT set' ) else @@ -893,13 +901,18 @@ subroutine MOSART_init1() ! Initialize mosart flood - rtmCTL%fthresh and evel !------------------------------------------------------- - 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) + 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 - enddo + end if !------------------------------------------------------- ! Initialize runoff data type From fcc37a7733e3e321e80b8a8504fecf69afa7f08c Mon Sep 17 00:00:00 2001 From: Erik Kluzek Date: Mon, 22 Jan 2024 02:48:19 -0700 Subject: [PATCH 39/86] Don't write out negative channel errors if bypass_routing is none, this fixes #79 --- src/riverroute/MOSART_physics_mod.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/riverroute/MOSART_physics_mod.F90 b/src/riverroute/MOSART_physics_mod.F90 index e7349d4..f9099f8 100644 --- a/src/riverroute/MOSART_physics_mod.F90 +++ b/src/riverroute/MOSART_physics_mod.F90 @@ -17,7 +17,7 @@ module MOSART_physics_mod 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 + 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 @@ -283,6 +283,7 @@ 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 @@ -319,7 +320,7 @@ subroutine Routing_KW(iunit, nt, theDeltaT) 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 + + 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 From 8899b2ba3be1114bc5421bcdb3475b70e742f648 Mon Sep 17 00:00:00 2001 From: Erik Kluzek Date: Thu, 25 Jan 2024 01:46:27 -0700 Subject: [PATCH 40/86] Update README about MOSART being obscelensent --- README.rst | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/README.rst b/README.rst index 43311a4..c240025 100644 --- a/README.rst +++ b/README.rst @@ -5,6 +5,18 @@ Model for Scale Adaptive River Transport The Model for Scale Adaptive River Transport, Mosart, is part of the Community Earth System Model. +IMPORTANT NOTE: MOSART is Obsolescent! + +MOSART is part of CESM3, but is obsolescent. + +We do not have support for creating input datasets for MOSART and +as such can NOT use MOSART for Paleo work. + +Longer term MOSART will be removed in future versions of CESM and the new model +mizuRoute will be used for Paleo work as well as present day. +It's also possible that external collaborators will support the use of MOSART +for present day climate even as mizuRoute becomes the default model for CESM. + See the CESM web site for documentation and information: http://www.cesm.ucar.edu From 8c682b1b7f15d146816de302e0d359da3e957056 Mon Sep 17 00:00:00 2001 From: Erik Kluzek Date: Fri, 2 Feb 2024 11:10:07 -0700 Subject: [PATCH 41/86] Update ChangeLog Add notes about mosart1_0_49 from @mvertens --- docs/ChangeLog | 48 +++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 45 insertions(+), 3 deletions(-) diff --git a/docs/ChangeLog b/docs/ChangeLog index 9e7f58f..670f9b2 100644 --- a/docs/ChangeLog +++ b/docs/ChangeLog @@ -1,8 +1,50 @@ =============================================================== Tag name: mosart1_0_49 -Originator(s): erik -Date: Jan 08, 2024 -One-line Summary: Remove MCT +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 From 37d06f2a4034736114c7c2439412e2e9285a51b7 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 20 Feb 2024 10:18:54 +0100 Subject: [PATCH 42/86] added missing includ_user_mods files --- cime_config/testdefs/testlist_mosart.xml | 76 ++++++++----------- .../mosart/decompOpts/include_user_mods | 1 + .../mosart/decompOpts/user_nl_mosart | 1 - .../mosart/inplacethreshold/include_user_mods | 1 + .../mosart/mosartCold/user_nl_mosart | 2 +- .../mosart/qgrwlOpts/include_user_mods | 1 + 6 files changed, 37 insertions(+), 45 deletions(-) create mode 100644 cime_config/testdefs/testmods_dirs/mosart/decompOpts/include_user_mods create mode 100644 cime_config/testdefs/testmods_dirs/mosart/inplacethreshold/include_user_mods create mode 100644 cime_config/testdefs/testmods_dirs/mosart/qgrwlOpts/include_user_mods diff --git a/cime_config/testdefs/testlist_mosart.xml b/cime_config/testdefs/testlist_mosart.xml index b70990a..fc06036 100644 --- a/cime_config/testdefs/testlist_mosart.xml +++ b/cime_config/testdefs/testlist_mosart.xml @@ -1,93 +1,79 @@ - + - - + + - + - + - + + + - + - - + + - - + - + + - + - + - + + - + - + + - - - - - - - - - - - - + + - - - - - - - - - - + + @@ -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/inplacethreshold/include_user_mods b/cime_config/testdefs/testmods_dirs/mosart/inplacethreshold/include_user_mods new file mode 100644 index 0000000..fe0e18c --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/mosart/inplacethreshold/include_user_mods @@ -0,0 +1 @@ +../default diff --git a/cime_config/testdefs/testmods_dirs/mosart/mosartCold/user_nl_mosart b/cime_config/testdefs/testmods_dirs/mosart/mosartCold/user_nl_mosart index 84b6ee6..449ffb8 100644 --- a/cime_config/testdefs/testmods_dirs/mosart/mosartCold/user_nl_mosart +++ b/cime_config/testdefs/testmods_dirs/mosart/mosartCold/user_nl_mosart @@ -1 +1 @@ - finidat_rtm = ' ' + finidat = ' ' diff --git a/cime_config/testdefs/testmods_dirs/mosart/qgrwlOpts/include_user_mods b/cime_config/testdefs/testmods_dirs/mosart/qgrwlOpts/include_user_mods new file mode 100644 index 0000000..fe0e18c --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/mosart/qgrwlOpts/include_user_mods @@ -0,0 +1 @@ +../default From 02b33fefcffd5887295cf9ff907ba7141cc6077c Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 21 Feb 2024 11:37:09 +0100 Subject: [PATCH 43/86] fixed compilation problem --- src/riverroute/mosart_physics.F90 | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/riverroute/mosart_physics.F90 b/src/riverroute/mosart_physics.F90 index 102cd7e..4350f64 100644 --- a/src/riverroute/mosart_physics.F90 +++ b/src/riverroute/mosart_physics.F90 @@ -10,7 +10,7 @@ module mosart_physics use shr_kind_mod , only : r8 => shr_kind_r8 use shr_const_mod , only : SHR_CONST_REARTH, SHR_CONST_PI use shr_sys_mod , only : shr_sys_abort - use mosart_vars , only : iulog, barrier_timers, mpicom_rof + use mosart_vars , only : iulog, barrier_timers, mpicom_rof, bypass_routing_option use mosart_data , only : Tctl, TUnit, TRunoff, TPara, ctl use perf_mod , only : t_startf, t_stopf use nuopc_shr_methods , only : chkerr @@ -287,7 +287,6 @@ end subroutine mainchannelRouting subroutine Routing_KW(nr, nt, theDeltaT) ! classic kinematic wave routing method - use RtmVar , only : bypass_routing_option ! Arguments integer, intent(in) :: nr, nt real(r8), intent(in) :: theDeltaT @@ -324,8 +323,7 @@ subroutine Routing_KW(nr, nt, theDeltaT) TRunoff%dwr(nr,nt) = TRunoff%erlateral(nr,nt) + TRunoff%erin(nr,nt) + TRunoff%erout(nr,nt) + temp_gwl - if((TRunoff%wr(iunit,nt)/theDeltaT + TRunoff%dwr(iunit,nt)) < -TINYVALUE & - .and. (trim(bypass_routing_option) /= 'none') ) then + if ((TRunoff%wr(nr,nt)/theDeltaT + TRunoff%dwr(nr,nt)) < -TINYVALUE .and. (trim(bypass_routing_option)/='none') ) then write(iulog,*) 'mosart: ERROR main channel going negative: ', nr, nt write(iulog,*) theDeltaT, TRunoff%wr(nr,nt), & TRunoff%wr(nr,nt)/theDeltaT, TRunoff%dwr(nr,nt), temp_gwl From a57cdb16f0b827f6307eab872ce98ea401447165 Mon Sep 17 00:00:00 2001 From: mvdebolskiy Date: Wed, 21 Feb 2024 14:01:38 +0100 Subject: [PATCH 44/86] typo and nl desc for finidat --- cime_config/namelist_definition_mosart.xml | 3 ++- src/riverroute/mosart_driver.F90 | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/cime_config/namelist_definition_mosart.xml b/cime_config/namelist_definition_mosart.xml index 5b8e2e5..23aee8f 100644 --- a/cime_config/namelist_definition_mosart.xml +++ b/cime_config/namelist_definition_mosart.xml @@ -110,7 +110,8 @@ UNSET - Full pathname of initialfile + Full pathname of initial conditions file. If blank or UNSET Mosart will startup from + cold start initial conditions. diff --git a/src/riverroute/mosart_driver.F90 b/src/riverroute/mosart_driver.F90 index dc20a40..1d74b45 100644 --- a/src/riverroute/mosart_driver.F90 +++ b/src/riverroute/mosart_driver.F90 @@ -166,7 +166,7 @@ subroutine mosart_read_namelist() write(iulog,'(a,i8)') ' coupling_period = ',coupling_period write(iulog,'(a,i8)') ' delt_mosart = ',delt_mosart write(iulog,'(a)' ) ' decomp option = '//trim(decomp_option) - write(iulog,'(a,l)' ) ' use_halo_optoin = ',use_halo_option + write(iulog,'(a,l)' ) ' use_halo_option = ',use_halo_option write(iulog,'(a)' ) ' bypass_routing option = '//trim(bypass_routing_option) write(iulog,'(a)' ) ' qgwl runoff option = '//trim(qgwl_runoff_option) write(iulog,'(a)' ) ' mosart tracers = '//trim(mosart_tracers) @@ -386,6 +386,7 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) ! Local variables ! BUDGET terms 1-10 are for volumes (m3) ! BUDGET terms 11-30 are for flows (m3/s) + ! even (2n) budget terms refer to current state odd terms (2n-1) rever to previous state. integer :: i, j, n, nr, ns, nt, n2, nf ! indices real(r8) :: budget_terms(30,ntracers) ! BUDGET terms real(r8) :: budget_input From 73e2a012870122e0f91edb2305f6da9e61669f1c Mon Sep 17 00:00:00 2001 From: mvdebolskiy Date: Wed, 21 Feb 2024 14:38:36 +0100 Subject: [PATCH 45/86] remove unused evaporation fluxes --- src/riverroute/mosart_tstatusflux_type.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/riverroute/mosart_tstatusflux_type.F90 b/src/riverroute/mosart_tstatusflux_type.F90 index a72e06f..79a255e 100644 --- a/src/riverroute/mosart_tstatusflux_type.F90 +++ b/src/riverroute/mosart_tstatusflux_type.F90 @@ -38,7 +38,6 @@ module mosart_tstatusflux_type real(r8), pointer :: vt(:,:) ! flow velocity, [m/s] real(r8), pointer :: tt(:,:) ! mean travel time of the water within the channel, [s] !! fluxes - real(r8), pointer :: tevap(:,:) ! evaporation, [m/s] real(r8), pointer :: etin(:,:) ! lateral inflow from hillslope, including surface and subsurface runoff generation components, [m3/s] real(r8), pointer :: etout(:,:) ! discharge from sub-network into the main reach, [m3/s] @@ -54,7 +53,6 @@ module mosart_tstatusflux_type real(r8), pointer :: vr(:,:) ! flow velocity, [m/s] real(r8), pointer :: tr(:,:) ! mean travel time of the water within the channel, [s] !! exchange fluxes - real(r8), pointer :: erlg(:,:) ! evaporation, [m/s] real(r8), pointer :: erlateral(:,:) ! lateral flow from hillslope, including surface and subsurface runoff generation components, [m3/s] real(r8), pointer :: erin(:,:) ! inflow from upstream links, [m3/s] real(r8), pointer :: erout(:,:) ! outflow into downstream links, [m3/s] @@ -140,8 +138,6 @@ subroutine Init(this, begr, endr, ntracers) this%vr = 0._r8 allocate (this%tr(begr:endr,ntracers)) this%tr = 0._r8 - allocate (this%erlg(begr:endr,ntracers)) - this%erlg = 0._r8 allocate (this%erlateral(begr:endr,ntracers)) this%erlateral = 0._r8 allocate (this%erin(begr:endr,ntracers)) From 7bf49efa8aa5e1afc5ad982db3a373942649bded Mon Sep 17 00:00:00 2001 From: mvdebolskiy Date: Wed, 21 Feb 2024 16:08:50 +0100 Subject: [PATCH 46/86] mark variables to delete with NOT_USED, verbose comments --- src/riverroute/mosart_control_type.F90 | 28 +++++++++++----------- src/riverroute/mosart_tstatusflux_type.F90 | 16 ++++++------- 2 files changed, 22 insertions(+), 22 deletions(-) diff --git a/src/riverroute/mosart_control_type.F90 b/src/riverroute/mosart_control_type.F90 index bcb7977..9d98de3 100644 --- a/src/riverroute/mosart_control_type.F90 +++ b/src/riverroute/mosart_control_type.F90 @@ -46,21 +46,21 @@ module mosart_control_type real(r8) :: totarea ! global area ! inputs to MOSART - real(r8), pointer :: qsur(:,:) => null() ! coupler surface forcing [m3/s] - real(r8), pointer :: qsub(:,:) => null() ! coupler subsurface forcing [m3/s] - real(r8), pointer :: qgwl(:,:) => null() ! coupler glacier/wetland/lake forcing [m3/s] + real(r8), pointer :: qsur(:,:) => null() ! surface runoff from coupler [m3/s] (lnd) + real(r8), pointer :: qsub(:,:) => null() ! subsurfacer runoff from coupler [m3/s] (lnd) + real(r8), pointer :: qgwl(:,:) => null() ! glacier/wetland/lake runoff from coupler [m3/s] (lnd) ! outputs from MOSART - real(r8), pointer :: flood(:) => null() ! coupler return flood water sent back to clm [m3/s] - real(r8), pointer :: runoff(:,:) => null() ! coupler return mosart basin derived flow [m3/s] - real(r8), pointer :: direct(:,:) => null() ! coupler return direct flow [m3/s] - real(r8), pointer :: qirrig(:) => null() ! coupler irrigation [m3/s] - real(r8), pointer :: qirrig_actual(:) => null() ! minimum of irrigation and available main channel storage + real(r8), pointer :: flood(:) => null() ! flood water to coupler [m3/s] (lnd) + real(r8), pointer :: runoff(:,:) => null() ! runoff (from outlet to reach) to coupler [m3/s] + real(r8), pointer :: direct(:,:) => null() ! direct flow to coupler [m3/s] + real(r8), pointer :: qirrig(:) => null() ! irrigation flow to coupler [m3/s] + real(r8), pointer :: qirrig_actual(:) => null() ! minimum of irrigation and available main channel storage [m3/s] ! storage, runoff - real(r8), pointer :: runofflnd(:,:) => null() ! runoff masked for land (m3 H2O/s) - real(r8), pointer :: runoffocn(:,:) => null() ! runoff masked for ocn (m3 H2O/s) - real(r8), pointer :: runofftot(:,:) => null() ! total runoff masked for ocn (m3 H2O/s) + real(r8), pointer :: runofflnd(:,:) => null() ! runoff masked for land [m3/s] + real(r8), pointer :: runoffocn(:,:) => null() ! runoff masked for ocn [m3/s] + real(r8), pointer :: runofftot(:,:) => null() ! total runoff masked for ocn [m3/s] real(r8), pointer :: dvolrdt(:,:) => null() ! change in storage (mm/s) real(r8), pointer :: dvolrdtlnd(:,:) => null() ! dvolrdt masked for land (mm/s) real(r8), pointer :: dvolrdtocn(:,:) => null() ! dvolrdt masked for ocn (mm/s) @@ -68,12 +68,12 @@ module mosart_control_type real(r8), pointer :: fthresh(:) => null() ! water flood threshold ! flux variables - real(r8), pointer :: flow(:,:) => null() ! mosart flow (m3/s) - real(r8), pointer :: evel(:,:) => null() ! effective tracer velocity (m/s) + real(r8), pointer :: flow(:,:) => null() ! stream flow out of gridcell (m3/s) + real(r8), pointer :: evel(:,:) => null() ! effective tracer velocity (m/s) NOT_USED real(r8), pointer :: erout_prev(:,:) => null() ! erout previous timestep (m3/s) real(r8), pointer :: eroutup_avg(:,:) => null() ! eroutup average over coupling period (m3/s) real(r8), pointer :: erlat_avg(:,:) => null() ! erlateral average over coupling period (m3/s) - real(r8), pointer :: effvel(:) => null() + real(r8), pointer :: effvel(:) => null() ! effective velocity for a tracer NOT_USED ! halo operations type(ESMF_RouteHandle) :: haloHandle diff --git a/src/riverroute/mosart_tstatusflux_type.F90 b/src/riverroute/mosart_tstatusflux_type.F90 index 79a255e..1b478fd 100644 --- a/src/riverroute/mosart_tstatusflux_type.F90 +++ b/src/riverroute/mosart_tstatusflux_type.F90 @@ -16,8 +16,8 @@ module mosart_tstatusflux_type real(r8), pointer :: yh(:,:) ! depth of surface water, [m] real(r8), pointer :: wsat(:,:) ! storage of surface water within saturated area at hillslope [m] real(r8), pointer :: wunsat(:,:) ! storage of surface water within unsaturated area at hillslope [m] - real(r8), pointer :: qhorton(:,:) ! Infiltration excess runoff generated from hillslope, [m/s] - real(r8), pointer :: qdunne(:,:) ! Saturation excess runoff generated from hillslope, [m/s] + real(r8), pointer :: qhorton(:,:) ! Infiltration excess runoff generated from hillslope, [m/s] NOT_USED + real(r8), pointer :: qdunne(:,:) ! Saturation excess runoff generated from hillslope, [m/s] NOT_USED real(r8), pointer :: qsur(:,:) ! Surface runoff generated from hillslope, [m/s] real(r8), pointer :: qsub(:,:) ! Subsurface runoff generated from hillslope, [m/s] real(r8), pointer :: qgwl(:,:) ! gwl runoff term from glacier, wetlands and lakes, [m/s] @@ -36,7 +36,7 @@ module mosart_tstatusflux_type real(r8), pointer :: rt(:,:) ! hydraulic radii, [m] real(r8), pointer :: pt(:,:) ! wetness perimeter, [m] real(r8), pointer :: vt(:,:) ! flow velocity, [m/s] - real(r8), pointer :: tt(:,:) ! mean travel time of the water within the channel, [s] + real(r8), pointer :: tt(:,:) ! mean travel time of the water within the channel, [s] NOT_USED !! fluxes real(r8), pointer :: etin(:,:) ! lateral inflow from hillslope, including surface and subsurface runoff generation components, [m3/s] real(r8), pointer :: etout(:,:) ! discharge from sub-network into the main reach, [m3/s] @@ -51,7 +51,7 @@ module mosart_tstatusflux_type real(r8), pointer :: rr(:,:) ! hydraulic radius, [m] real(r8), pointer :: pr(:,:) ! wetness perimeter, [m] real(r8), pointer :: vr(:,:) ! flow velocity, [m/s] - real(r8), pointer :: tr(:,:) ! mean travel time of the water within the channel, [s] + real(r8), pointer :: tr(:,:) ! mean travel time of the water within the channel, [s] NOT_USED !! exchange fluxes real(r8), pointer :: erlateral(:,:) ! lateral flow from hillslope, including surface and subsurface runoff generation components, [m3/s] real(r8), pointer :: erin(:,:) ! inflow from upstream links, [m3/s] @@ -61,11 +61,11 @@ module mosart_tstatusflux_type real(r8), pointer :: eroutUp_avg(:,:) ! outflow sum of upstream gridcells, average [m3/s] real(r8), pointer :: erlat_avg(:,:) ! erlateral average [m3/s] real(r8), pointer :: flow(:,:) ! streamflow from the outlet of the reach, [m3/s] - real(r8), pointer :: erin1(:,:) ! inflow from upstream links during previous step, used for Muskingum method, [m3/s] - real(r8), pointer :: erin2(:,:) ! inflow from upstream links during current step, used for Muskingum method, [m3/s] - real(r8), pointer :: ergwl(:,:) ! flux item for the adjustment of water balance residual in glacie, wetlands and lakes dynamics [m3/s] + real(r8), pointer :: erin1(:,:) ! inflow from upstream links during previous step, used for Muskingum method, [m3/s] NOT_USED + real(r8), pointer :: erin2(:,:) ! inflow from upstream links during current step, used for Muskingum method, [m3/s] NOT_USED + real(r8), pointer :: ergwl(:,:) ! flux item for the adjustment of water balance residual in glacie, wetlands and lakes dynamics [m3/s] NOT_USED - !! for Runge-Kutta algorithm + !! for Runge-Kutta algorithm NOT_USED real(r8), pointer :: wrtemp(:,:) ! temporary storage item, for 4th order Runge-Kutta algorithm; real(r8), pointer :: erintemp(:,:) real(r8), pointer :: erouttemp(:,:) From ed42666deffe95324bebef9695acd30f36a1aa33 Mon Sep 17 00:00:00 2001 From: mvdebolskiy Date: Wed, 21 Feb 2024 17:13:19 +0100 Subject: [PATCH 47/86] add TODOs and more NOT_USED --- src/riverroute/mosart_driver.F90 | 2 ++ src/riverroute/mosart_tparameter_type.F90 | 4 ++-- src/riverroute/mosart_tspatialunit_type.F90 | 1 + 3 files changed, 5 insertions(+), 2 deletions(-) diff --git a/src/riverroute/mosart_driver.F90 b/src/riverroute/mosart_driver.F90 index 1d74b45..b66653e 100644 --- a/src/riverroute/mosart_driver.F90 +++ b/src/riverroute/mosart_driver.F90 @@ -448,6 +448,7 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) end if budget_check = .false. + !TODO make budget check frequency adjustable if (day == 1 .and. mon == 1) budget_check = .true. if (tod == 0) budget_check = .true. budget_terms = 0._r8 @@ -579,6 +580,7 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) dst_direct(:,:) = 0._r8 ! set euler_calc = false for frozen runoff + ! TODO: will be reworked after addition of multiple tracers Tunit%euler_calc(nt) = .false. cnt = 0 diff --git a/src/riverroute/mosart_tparameter_type.F90 b/src/riverroute/mosart_tparameter_type.F90 index 8133e89..005e290 100644 --- a/src/riverroute/mosart_tparameter_type.F90 +++ b/src/riverroute/mosart_tparameter_type.F90 @@ -9,8 +9,8 @@ module mosart_tparameter_type public :: Tparameter_type type Tparameter_type - 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_nr(:) ! coefficient to adjust the manning's roughness of channels NOT_USED + real(r8), pointer :: c_nh(:) ! coefficient to adjust the manning's roughness of overland flow across hillslopes NOT_USED real(r8), pointer :: c_twid(:) ! coefficient to adjust the width of sub-reach channel contains procedure, public :: Init diff --git a/src/riverroute/mosart_tspatialunit_type.F90 b/src/riverroute/mosart_tspatialunit_type.F90 index 095fa3f..f2f9c0f 100644 --- a/src/riverroute/mosart_tspatialunit_type.F90 +++ b/src/riverroute/mosart_tspatialunit_type.F90 @@ -151,6 +151,7 @@ subroutine Init(this, begr, endr, ntracers, mosart_euler_calc, nlon, nlat, EMesh end if end do + ! TODO: Will be reworked after addition of extra tracers this%euler_calc = .true. allocate(this%frac(begr:endr)) From 5a66730849a91279ae7db15bac09f4f456f34b4c Mon Sep 17 00:00:00 2001 From: mvdebolskiy Date: Fri, 23 Feb 2024 19:27:54 +0100 Subject: [PATCH 48/86] refactor mosart budget code --- cime_config/namelist_definition_mosart.xml | 14 ++ src/riverroute/mosart_budget_type.F90 | 249 +++++++++++++++++++++ src/riverroute/mosart_driver.F90 | 197 ++++------------ src/riverroute/mosart_vars.F90 | 1 + 4 files changed, 308 insertions(+), 153 deletions(-) create mode 100644 src/riverroute/mosart_budget_type.F90 diff --git a/cime_config/namelist_definition_mosart.xml b/cime_config/namelist_definition_mosart.xml index 23aee8f..a6ad704 100644 --- a/cime_config/namelist_definition_mosart.xml +++ b/cime_config/namelist_definition_mosart.xml @@ -280,4 +280,18 @@ + + integer(6) + mosart + mosart_inparm + + -24 + + + Frequency to perform budget check. Similar to nhtfrq, + positive means in time steps, 0=monthly, negative means hours + (i.e. 24 means every 24 time-steps and -24 means every day + + + diff --git a/src/riverroute/mosart_budget_type.F90 b/src/riverroute/mosart_budget_type.F90 new file mode 100644 index 0000000..258155f --- /dev/null +++ b/src/riverroute/mosart_budget_type.F90 @@ -0,0 +1,249 @@ +module mosart_budget_type + + ! Variables and routines used for + ! calculating and checking tracer global and local budgets + + use shr_kind_mod, only: r8 => shr_kind_r8, CL => SHR_KIND_CL + use shr_sys_mod, only: shr_sys_abort + use shr_mpi_mod, only: shr_mpi_sum, shr_mpi_max + use mosart_vars, only: re, spval, barrier_timers, iulog, & + mainproc, npes, iam, mpicom_rof + use mosart_timemanager, only: get_nstep, get_curr_date + use mpi + + implicit none + private + + type budget_type + ! accumulated budget over run (not used for now) + real(r8), pointer :: accum_grc(:, :) ! Gridcell level budget accumulator per tracer over the run (m3) + real(r8), pointer :: accum_glob(:) ! Global budget accumulator (1e6 m3) + + ! budget terms per gridcell + real(r8), pointer :: beg_vol_grc(:, :) ! volume begining of the timestep (m3) + real(r8), pointer :: end_vol_grc(:, :) ! volume end of the timestep (m3) + real(r8), pointer :: in_grc(:, :) ! budget in terms (m3) + real(r8), pointer :: out_grc(:, :) ! budget out terms (m3) + real(r8), pointer :: net_grc(:, :) ! net budget (dvolume + inputs - outputs) (m3) + real(r8), pointer :: lag_grc(:, :) ! euler erout lagged (m3) + ! budget global terms + real(r8), pointer :: beg_vol_glob(:) ! volume begining of the timestep (1e6 m3) + real(r8), pointer :: end_vol_glob(:) ! volume end of the timestep (1e6 m3) + real(r8), pointer :: in_glob(:) ! budget in terms (1e6 m3) + real(r8), pointer :: out_glob(:) ! budget out terms (1e6 m3) + real(r8), pointer :: net_glob(:) ! net budget (dvolume + inputs - outputs) (1e6 m3) + real(r8), pointer :: lag_glob(:) ! euler erout lagged (1e6 m3) + ! budget parameters + real(r8) :: tolerance = 1e-6_r8 ! budget absolute tolerance + real(r8) :: rel_tolerance = 1e-6_r8 ! budget relative tolerance + logical(r8), pointer :: do_budget(:) ! if budget should be checked (per tracer) + contains + procedure, public :: Init + procedure, public :: set_budget + procedure, public :: check_budget + end type budget_type + public :: budget_type + + character(*), parameter :: u_FILE_u = & + __FILE__ + !----------------------------------------------------------------------- +contains + + subroutine Init(this, begr, endr, ntracers) + + ! USES: + + ! ARGUMENTS: + class(budget_type) :: this + integer, intent(in) :: begr, endr, ntracers + + ! LOCAL VARIABLES: + + ! gridcell level: + allocate (this%accum_grc(begr:endr, ntracers)) + this%accum_grc = 0._r8 + + allocate (this%beg_vol_grc(begr:endr, ntracers)) + this%beg_vol_grc = 0._r8 + + allocate (this%end_vol_grc(begr:endr, ntracers)) + this%end_vol_grc = 0._r8 + + allocate (this%in_grc(begr:endr, ntracers)) + this%in_grc = 0._r8 + + allocate (this%out_grc(begr:endr, ntracers)) + this%out_grc = 0._r8 + + allocate (this%net_grc(begr:endr, ntracers)) + this%net_grc = 0._r8 + + allocate (this%lag_grc(begr:endr, ntracers)) + this%lag_grc = 0._r8 + + ! global level: + allocate (this%accum_glob(ntracers)) + this%accum_glob = 0._r8 + + allocate (this%beg_vol_glob(ntracers)) + this%beg_vol_glob = 0._r8 + + allocate (this%end_vol_glob(ntracers)) + this%end_vol_glob = 0._r8 + + allocate (this%in_glob(ntracers)) + this%in_glob = 0._r8 + + allocate (this%out_glob(ntracers)) + this%out_glob = 0._r8 + + allocate (this%net_glob(ntracers)) + this%net_glob = 0._r8 + + allocate (this%lag_glob(ntracers)) + this%lag_glob = 0._r8 + + allocate (this%do_budget(ntracers)) + this%do_budget = .true. + + end subroutine Init + + subroutine set_budget(this, begr, endr, ntracers, dt) + + !USES: + use mosart_data, only: ctl, Tctl, Tunit, TRunoff, Tpara + !ARGUMENTS: + class(budget_type) :: this + integer, intent(in) :: begr, endr, ntracers + real(r8), intent(in) :: dt + + !LOCAL VARIABLES: + integer nr, nt !indecies + + do nr = begr, endr + do nt = 1, ntracers + this%beg_vol_grc(nr, nt) = ctl%volr(nr, nt) + this%in_grc(nr, nt) = (ctl%qsur(nr, nt) + ctl%qsub(nr, nt) + ctl%qgwl(nr, nt)) * dt + ! this was for budget_terms(17) + !if (nt==1) then + ! this%in_grc(nr,nt)=this%in_grc(nr,nt) +ctl%qirrig(nr) + !endif + end do + end do + + this%end_vol_grc = 0.0_r8 + this%out_grc = 0.0_r8 + this%net_grc = 0.0_r8 + this%lag_grc = 0.0_r8 + + this%beg_vol_glob = 0.0_r8 + this%end_vol_glob = 0.0_r8 + this%in_glob = 0.0_r8 + this%out_glob = 0.0_r8 + this%net_glob = 0.0_r8 + this%lag_glob = 0.0_r8 + + end subroutine set_budget + + subroutine check_budget(this, begr, endr, ntracers, dt) + !USES: + use mosart_data, only: ctl, Tctl, Tunit, TRunoff, Tpara + !ARGUMENTS: + class(budget_type) :: this + integer, intent(in) :: begr, endr, ntracers + real(r8), intent(in) :: dt + + !LOCAL VARIABLES: + integer nr, nt !indecies + integer yr,mon,day,ymd,tod !time vars + real(r8) :: tmp_in(6, ntracers) ! array to pass to mpi_sum + real(r8) :: tmp_glob(6, ntracers) ! array from mpi_sum + logical :: error_budget ! flag for an error + real(r8) :: abserr, relerr + + call get_curr_date(yr, mon, day, tod) + ymd = yr*10000 + mon*100 + day + tmp_in = 0.0_r8 + tmp_glob = 0.0_r8 + + do nr = begr, endr + do nt = 1, ntracers + this%end_vol_grc(nr, nt) = ctl%volr(nr, nt) + this%out_grc(nr, nt) = this%out_grc(nr, nt) + ctl%direct(nr, nt) + if (nt == 1) then + this%out_grc(nr, nt) = this%out_grc(nr, nt) + ctl%flood(nr) + end if + if (ctl%mask(nr) >= 2) then + this%out_grc(nr, nt) = this%out_grc(nr, nt) + ctl%runoff(nr, nt) + else + this%lag_grc(nr, nt) = this%lag_grc(nr, nt) - ctl%erout_prev(nr, nt) & + - ctl%flow(nr, nt) + end if + this%out_grc(nr,nt) = this%out_grc(nr,nt) * dt + this%lag_grc(nr,nt) = this%lag_grc(nr,nt) * dt + this%net_grc(nr, nt) = this%end_vol_grc(nr, nt) - this%beg_vol_grc(nr, nt) & + - (this%in_grc(nr, nt) - this%out_grc(nr, nt)) + this%accum_grc(nr, nt) = this%accum_grc(nr, nt) + this%net_grc(nr, nt) + end do + end do + + do nt = 1, ntracers + tmp_in(1, nt) = sum(this%beg_vol_grc(:, nt)) + tmp_in(2, nt) = sum(this%end_vol_grc(:, nt)) + tmp_in(3, nt) = sum(this%in_grc(:, nt)) + tmp_in(4, nt) = sum(this%out_grc(:, nt)) + tmp_in(5, nt) = sum(this%net_grc(:, nt)) + tmp_in(6, nt) = sum(this%lag_grc(:, nt)) + end do + + tmp_in = tmp_in*1e-6_r8 !convert to million m3 + call shr_mpi_sum(tmp_in, tmp_glob, mpicom_rof, 'mosart global budget', all=.false.) + + do nt = 1, ntracers + error_budget = .false. + abserr = 0.0_r8 + relerr = 0.0_r8 + this%beg_vol_glob(nt) = tmp_glob(1, nt) + this%end_vol_glob(nt) = tmp_glob(2, nt) + this%in_glob(nt) = tmp_glob(3, nt) + this%out_glob(nt) = tmp_glob(4, nt) + this%net_glob(nt) = tmp_glob(5, nt) + this%lag_glob(nt) = tmp_glob(6, nt) + if (this%do_budget(nt)) then + if (abs(this%net_glob(nt) - this%lag_glob(nt)*dt) > this%tolerance) then + error_budget = .true. + abserr = abs(this%net_glob(nt) - this%lag_glob(nt)) + end if + if (abs(this%net_glob(nt) + this%lag_glob(nt)) > 1e-6) then + if (abs(this%net_glob(nt) - this%lag_glob(nt)) & + /abs(this%net_glob(nt) + this%lag_glob(nt)) > this%rel_tolerance) then + error_budget = .true. + relerr = abs(this%net_glob(nt) - this%lag_glob(nt)) & + /abs(this%net_glob(nt) + this%lag_glob(nt)) + end if + end if + if (mainproc) then + write (iulog, '(a)') '-----------------------------------' + write (iulog, '(a)') '*****MOSART BUDGET DIAGNOSTICS*****' + write (iulog,'(a,i10,i6)') ' diagnostics for ', ymd, tod + write (iulog, '(a,i4,2a)') ' tracer = ', nt, ' ', ctl%tracer_names(nt) + write (iulog, '(a,f22.6,a)') ' time step size = ', dt, ' sec' + write (iulog, '(a,f22.6,a)') ' volume begining of the step = ', this%beg_vol_glob(nt), ' (mil m3)' + write (iulog, '(a,f22.6,a)') ' volume end of the step = ', this%end_vol_glob(nt), ' (mil m3)' + write (iulog, '(a,f22.6,a)') ' inputs = ', this%in_glob(nt), ' (mil m3)' + write (iulog, '(a,f22.6,a)') ' outputs = ', this%out_glob(nt), ' (mil m3)' + write (iulog, '(a,f22.6,a)') ' net budget (dv -i + o) = ', this%net_glob(nt), ' (mil m3)' + write (iulog, '(a,f22.6,a)') ' eul erout lag = ', this%lag_glob(nt), '(mil m3)' + write (iulog, '(a,f22.6)') ' absolute budget error = ', abserr + write (iulog, '(a,f22.6)') ' relative budget error = ', relerr + if (error_budget) then + write(iulog,'(a)') ' BUDGET OUT OF BALANCE WARNING ' + endif + write (iulog, '(a)') '-----------------------------------' + end if + end if + end do + + end subroutine check_budget + +end module mosart_budget_type diff --git a/src/riverroute/mosart_driver.F90 b/src/riverroute/mosart_driver.F90 index b66653e..eacfe25 100644 --- a/src/riverroute/mosart_driver.F90 +++ b/src/riverroute/mosart_driver.F90 @@ -13,8 +13,9 @@ module mosart_driver frivinp, nsrContinue, nsrBranch, nsrStartup, nsrest, & inst_index, inst_suffix, inst_name, decomp_option, & bypass_routing_option, qgwl_runoff_option, barrier_timers, & - mainproc, npes, iam, mpicom_rof + mainproc, npes, iam, mpicom_rof, budget_frq, isecspday use mosart_data , only : ctl, Tctl, Tunit, TRunoff, Tpara + use mosart_budget_type , only : budget_type use mosart_fileutils , only : getfil use mosart_timemanager , only : timemgr_init, get_nstep, get_curr_date use mosart_histflds , only : mosart_histflds_init, mosart_histflds_set @@ -56,9 +57,8 @@ module mosart_driver ! global (glo) integer , allocatable :: IDkey(:) ! translation key from ID to gindex - ! budget accumulation - real(r8), allocatable :: budget_accum(:) ! BUDGET accumulator over run - integer :: budget_accum_cnt ! counter for budget_accum + ! budget + type(budget_type), public :: budget ! type containing vars and routines for budget checking character(len=CL) :: nlfilename_rof = 'mosart_in' character(len=CL) :: fnamer ! name of netcdf restart file @@ -91,7 +91,7 @@ subroutine mosart_read_namelist() namelist /mosart_inparm / frivinp, finidat, nrevsn, coupling_period, ice_runoff, & ndens, mfilt, nhtfrq, fincl1, fincl2, fincl3, fexcl1, fexcl2, fexcl3, & avgflag_pertape, decomp_option, bypass_routing_option, qgwl_runoff_option, & - use_halo_option, delt_mosart, mosart_tracers, mosart_euler_calc + use_halo_option, delt_mosart, mosart_tracers, mosart_euler_calc, budget_frq ! Preset values ice_runoff = .true. @@ -147,6 +147,7 @@ subroutine mosart_read_namelist() call mpi_bcast (avgflag_pertape, size(avgflag_pertape), MPI_CHARACTER, 0, mpicom_rof, ier) call mpi_bcast (mosart_tracers, CS, MPI_CHARACTER, 0, mpicom_rof, ier) call mpi_bcast (mosart_euler_calc, CS, MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (budget_frq,1,MPI_INTEGER,0,mpicom_rof,ier) ! Determine number of tracers and array of tracer names ctl%ntracers = shr_string_listGetNum(mosart_tracers) @@ -368,6 +369,14 @@ subroutine mosart_init2(Emesh, rc) if (mainproc) write(iulog,*) subname,' done' call t_stopf('mosarti_histinit') + !------------------------------------------------------- + ! Initialize mosart budget + !------------------------------------------------------- + + call t_startf('mosarti_budgetinit') + call budget%Init(begr, endr, ntracers) + call t_stopf('mosarti_budgetinit') + end subroutine mosart_init2 !----------------------------------------------------------------------- @@ -384,20 +393,8 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) integer , intent(out) :: rc ! ! Local variables - ! BUDGET terms 1-10 are for volumes (m3) - ! BUDGET terms 11-30 are for flows (m3/s) - ! even (2n) budget terms refer to current state odd terms (2n-1) rever to previous state. integer :: i, j, n, nr, ns, nt, n2, nf ! indices - real(r8) :: budget_terms(30,ntracers) ! BUDGET terms - real(r8) :: budget_input - real(r8) :: budget_output - real(r8) :: budget_volume - real(r8) :: budget_total - real(r8) :: budget_euler - real(r8) :: budget_eroutlag - real(r8) :: budget_global(30,ntracers) ! global budget sum - logical :: budget_check ! do global budget check - real(r8),parameter :: budget_tolerance = 1.0e-6 ! budget tolerance, m3/day + logical :: budget_check ! if budget check needs to be performed real(r8) :: volr_init ! temporary storage to compute dvolrdt integer :: yr, mon, day, ymd, tod ! time information integer :: nsub ! subcyling for cfl @@ -438,42 +435,38 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) delt_coupling = coupling_period*1.0_r8 if (first_call) then - budget_accum = 0._r8 - budget_accum_cnt = 0 delt_save = delt_mosart - allocate(budget_accum(ntracers)) if (mainproc) then write(iulog,'(2a,g20.12)') trim(subname),' mosart coupling period ',delt_coupling end if end if - budget_check = .false. - !TODO make budget check frequency adjustable - if (day == 1 .and. mon == 1) budget_check = .true. - if (tod == 0) budget_check = .true. - budget_terms = 0._r8 ! 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,ntracers - do nr = begr,endr - budget_terms( 1,nt) = budget_terms( 1,nt) + ctl%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)*ctl%area(nr) - budget_terms(13,nt) = budget_terms(13,nt) + ctl%qsur(nr,nt) - budget_terms(14,nt) = budget_terms(14,nt) + ctl%qsub(nr,nt) - budget_terms(15,nt) = budget_terms(15,nt) + ctl%qgwl(nr,nt) - budget_terms(17,nt) = budget_terms(17,nt) + ctl%qsur(nr,nt) + ctl%qsub(nr,nt)+ ctl%qgwl(nr,nt) - if (nt==1) then - budget_terms(16,nt) = budget_terms(16,nt) + ctl%qirrig(nr) - budget_terms(17,nt) = budget_terms(17,nt) + ctl%qirrig(nr) - endif - enddo - enddo - call t_stopf('mosartr_budget') + + budget_check = .false. + if (budget_frq == 0) then + if (day == 1 .and. tod == 0) then + budget_check = .true. + endif + else if (budget_frq < 0) then + if (mod(get_nstep() * coupling_period, abs(budget_frq) * 3600) == 0) then + budget_check = .true. + endif + else + if (mod(get_nstep() , budget_frq) == 0) then + budget_check = .true. + endif + endif + if (first_call) then ! ignore budget during the first timestep + budget_check = .false. + endif + if (budget_check) then + call t_startf('mosartr_budgetset') + call budget%set_budget(begr,endr,ntracers, delt_coupling) + call t_stopf('mosartr_budgetset') + endif + ! data for euler solver, in m3/s here do nr = begr,endr @@ -786,15 +779,6 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) ! mosart euler solver !----------------------------------- - call t_startf('mosartr_budget') - do nt = 1,ntracers - do nr = begr,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,ntracers do nr = begr,endr @@ -863,104 +847,11 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) !----------------------------------- ! 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,ntracers - do nr = begr,endr - budget_terms( 2,nt) = budget_terms( 2,nt) + ctl%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)*ctl%area(nr) - budget_terms(21,nt) = budget_terms(21,nt) + ctl%direct(nr,nt) - if (ctl%mask(nr) >= 2) then - budget_terms(18,nt) = budget_terms(18,nt) + ctl%runoff(nr,nt) - budget_terms(26,nt) = budget_terms(26,nt) - ctl%erout_prev(nr,nt) - budget_terms(27,nt) = budget_terms(27,nt) + ctl%flow(nr,nt) - else - budget_terms(23,nt) = budget_terms(23,nt) - ctl%erout_prev(nr,nt) - budget_terms(24,nt) = budget_terms(24,nt) + ctl%flow(nr,nt) - endif - budget_terms(25,nt) = budget_terms(25,nt) - ctl%eroutup_avg(nr,nt) - budget_terms(28,nt) = budget_terms(28,nt) - ctl%erlat_avg(nr,nt) - budget_terms(22,nt) = budget_terms(22,nt) + ctl%runoff(nr,nt) + ctl%direct(nr,nt) + ctl%eroutup_avg(nr,nt) - enddo - enddo - nt = 1 - do nr = begr,endr - budget_terms(19,nt) = budget_terms(19,nt) + ctl%flood(nr) - budget_terms(22,nt) = budget_terms(22,nt) + ctl%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,ntracers - 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,ntracers - 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 - - call t_stopf('mosartr_budget') - endif ! budget_check + if (budget_check) then + call t_startf('mosartr_budgetcheck') + call budget%check_budget(begr,endr,ntracers,delt_coupling) + call t_stopf('mosartr_budgetcheck') + endif !----------------------------------- ! Write out mosart history file diff --git a/src/riverroute/mosart_vars.F90 b/src/riverroute/mosart_vars.F90 index daf2d60..cc0cc48 100644 --- a/src/riverroute/mosart_vars.F90 +++ b/src/riverroute/mosart_vars.F90 @@ -36,6 +36,7 @@ module mosart_vars character(len=CS) :: decomp_option ! decomp option character(len=CS) :: bypass_routing_option ! bypass routing model method character(len=CS) :: qgwl_runoff_option ! method for handling qgwl runoff + integer :: budget_frq = -24 ! budget check frequency ! Metadata variables used in history and restart generation character(len=CL) :: caseid = ' ' ! case id From 6fc1de7cfc0a6d8fc3024b6a59d4a6e958ecf04a Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 27 May 2024 02:43:09 -0600 Subject: [PATCH 49/86] first set of changes to have glc->rof coupling --- src/cpl/nuopc/rof_import_export.F90 | 10 ++++++++++ src/riverroute/mosart_control_type.F90 | 10 ++++++++-- 2 files changed, 18 insertions(+), 2 deletions(-) diff --git a/src/cpl/nuopc/rof_import_export.F90 b/src/cpl/nuopc/rof_import_export.F90 index 9cb67db..4c84346 100644 --- a/src/cpl/nuopc/rof_import_export.F90 +++ b/src/cpl/nuopc/rof_import_export.F90 @@ -109,6 +109,8 @@ subroutine advertise_fields(gcomp, flds_scalar_name, rc) call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_rofsub') call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_rofi') call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_irrig') + call fldlist_add(fldsToRof_num, fldsToRof, 'Fgrg_liq') ! liq runoff from glc + call fldlist_add(fldsToRof_num, fldsToRof, 'Fgrg_ice') ! ice runoff from glc do n = 1,fldsToRof_num call NUOPC_Advertise(importState, standardName=fldsToRof(n)%stdname, & @@ -288,6 +290,14 @@ subroutine import_fields( gcomp, begr, endr, rc ) ctl%qsub(begr:endr, nfrz) = 0.0_r8 ctl%qgwl(begr:endr, nfrz) = 0.0_r8 + call state_getimport(importState, 'Fgrg_liq', begr, endr, ctl%area, output=ctl%qglc_liq(:), & + do_area_correction=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call state_getimport(importState, 'Fgrg_ice', begr, endr, ctl%area, output=ctl%qglc_ice(:), & + do_area_correction=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end subroutine import_fields !==================================================================================== diff --git a/src/riverroute/mosart_control_type.F90 b/src/riverroute/mosart_control_type.F90 index 9d98de3..ddb17fd 100644 --- a/src/riverroute/mosart_control_type.F90 +++ b/src/riverroute/mosart_control_type.F90 @@ -49,12 +49,14 @@ module mosart_control_type real(r8), pointer :: qsur(:,:) => null() ! surface runoff from coupler [m3/s] (lnd) real(r8), pointer :: qsub(:,:) => null() ! subsurfacer runoff from coupler [m3/s] (lnd) real(r8), pointer :: qgwl(:,:) => null() ! glacier/wetland/lake runoff from coupler [m3/s] (lnd) + real(r8), pointer :: qirrig(:) => null() ! irrigation flow from coupler [m3/s] + real(r8), pointer :: qglc_liq(:) => null() ! glacier liquid runoff from coupler [m3/s] (glc) + real(r8), pointer :: qglc_ice(:) => null() ! glacier ice runoff from coupler [m3/s] (glc) ! outputs from MOSART real(r8), pointer :: flood(:) => null() ! flood water to coupler [m3/s] (lnd) real(r8), pointer :: runoff(:,:) => null() ! runoff (from outlet to reach) to coupler [m3/s] real(r8), pointer :: direct(:,:) => null() ! direct flow to coupler [m3/s] - real(r8), pointer :: qirrig(:) => null() ! irrigation flow to coupler [m3/s] real(r8), pointer :: qirrig_actual(:) => null() ! minimum of irrigation and available main channel storage [m3/s] ! storage, runoff @@ -303,6 +305,8 @@ subroutine Init(this, locfn, decomp_option, use_halo_option, IDkey, rc) this%qgwl(begr:endr,ntracers), & this%qirrig(begr:endr), & this%qirrig_actual(begr:endr), & + this%qglc_liq(begr:endr), & + this%qglc_ice(begr:endr), & ! this%evel(begr:endr,ntracers), & this%flow(begr:endr,ntracers), & @@ -332,6 +336,8 @@ subroutine Init(this, locfn, decomp_option, use_halo_option, IDkey, rc) this%qsur(:,:) = 0._r8 this%qsub(:,:) = 0._r8 this%qgwl(:,:) = 0._r8 + this%qglc_liq(:) = 0._r8 + this%qglc_ice(:) = 0._r8 this%fthresh(:) = abs(spval) this%flow(:,:) = 0._r8 this%erout_prev(:,:) = 0._r8 @@ -1176,7 +1182,7 @@ subroutine calc_gradient(this, fld, fld_halo_array, dfld_dx, dfld_dy, rc) dfld_dx(n) = dfld_dx(n) + (fld_surrounding(ax_indices(i)) - fld_surrounding(sx_indices(i))) dfld_dy(n) = dfld_dy(n) + (fld_surrounding(ay_indices(i)) - fld_surrounding(sy_indices(i))) enddo - + dfld_dx(n) = dfld_dx(n) / (8._r8*mean_dx) dfld_dy(n) = dfld_dy(n) / (8._r8*mean_dy) From f0fe9ac5b4da823a4945a49c227f05b81a7b133c Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 29 May 2024 02:14:28 -0600 Subject: [PATCH 50/86] more updates for cism->mosart --- src/cpl/nuopc/rof_import_export.F90 | 8 +- src/riverroute/mosart_budget_type.F90 | 131 +++++++++++++------------ src/riverroute/mosart_driver.F90 | 132 +++++++++++++++----------- src/riverroute/mosart_histfile.F90 | 7 -- src/riverroute/mosart_histflds.F90 | 14 +++ 5 files changed, 169 insertions(+), 123 deletions(-) diff --git a/src/cpl/nuopc/rof_import_export.F90 b/src/cpl/nuopc/rof_import_export.F90 index 4c84346..1846f08 100644 --- a/src/cpl/nuopc/rof_import_export.F90 +++ b/src/cpl/nuopc/rof_import_export.F90 @@ -109,8 +109,8 @@ subroutine advertise_fields(gcomp, flds_scalar_name, rc) call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_rofsub') call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_rofi') call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_irrig') - call fldlist_add(fldsToRof_num, fldsToRof, 'Fgrg_liq') ! liq runoff from glc - call fldlist_add(fldsToRof_num, fldsToRof, 'Fgrg_ice') ! ice runoff from glc + call fldlist_add(fldsToRof_num, fldsToRof, 'Fgrg_rofl') ! liq runoff from glc + call fldlist_add(fldsToRof_num, fldsToRof, 'Fgrg_rofi') ! ice runoff from glc do n = 1,fldsToRof_num call NUOPC_Advertise(importState, standardName=fldsToRof(n)%stdname, & @@ -290,11 +290,11 @@ subroutine import_fields( gcomp, begr, endr, rc ) ctl%qsub(begr:endr, nfrz) = 0.0_r8 ctl%qgwl(begr:endr, nfrz) = 0.0_r8 - call state_getimport(importState, 'Fgrg_liq', begr, endr, ctl%area, output=ctl%qglc_liq(:), & + call state_getimport(importState, 'Fgrg_rofl', begr, endr, ctl%area, output=ctl%qglc_liq(:), & do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'Fgrg_ice', begr, endr, ctl%area, output=ctl%qglc_ice(:), & + call state_getimport(importState, 'Fgrg_rofi', begr, endr, ctl%area, output=ctl%qglc_ice(:), & do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return diff --git a/src/riverroute/mosart_budget_type.F90 b/src/riverroute/mosart_budget_type.F90 index 258155f..f25c21f 100644 --- a/src/riverroute/mosart_budget_type.F90 +++ b/src/riverroute/mosart_budget_type.F90 @@ -3,11 +3,11 @@ module mosart_budget_type ! Variables and routines used for ! calculating and checking tracer global and local budgets - use shr_kind_mod, only: r8 => shr_kind_r8, CL => SHR_KIND_CL - use shr_sys_mod, only: shr_sys_abort - use shr_mpi_mod, only: shr_mpi_sum, shr_mpi_max - use mosart_vars, only: re, spval, barrier_timers, iulog, & - mainproc, npes, iam, mpicom_rof + use shr_kind_mod, only: r8 => shr_kind_r8, CL => SHR_KIND_CL + use shr_sys_mod, only: shr_sys_abort + use shr_mpi_mod, only: shr_mpi_sum, shr_mpi_max + use mosart_vars, only: re, spval, barrier_timers, iulog, mainproc, npes, iam, mpicom_rof + use mosart_data, only: ctl, Tctl, Tunit, TRunoff, Tpara use mosart_timemanager, only: get_nstep, get_curr_date use mpi @@ -16,27 +16,29 @@ module mosart_budget_type type budget_type ! accumulated budget over run (not used for now) - real(r8), pointer :: accum_grc(:, :) ! Gridcell level budget accumulator per tracer over the run (m3) - real(r8), pointer :: accum_glob(:) ! Global budget accumulator (1e6 m3) + real(r8), pointer :: accum_grc(:, :) ! Gridcell level budget accumulator per tracer over the run (m3) + real(r8), pointer :: accum_glob(:) ! Global budget accumulator (1e6 m3) ! budget terms per gridcell - real(r8), pointer :: beg_vol_grc(:, :) ! volume begining of the timestep (m3) - real(r8), pointer :: end_vol_grc(:, :) ! volume end of the timestep (m3) - real(r8), pointer :: in_grc(:, :) ! budget in terms (m3) - real(r8), pointer :: out_grc(:, :) ! budget out terms (m3) - real(r8), pointer :: net_grc(:, :) ! net budget (dvolume + inputs - outputs) (m3) - real(r8), pointer :: lag_grc(:, :) ! euler erout lagged (m3) + real(r8), pointer :: beg_vol_grc(:, :) ! volume begining of the timestep (m3) + real(r8), pointer :: end_vol_grc(:, :) ! volume end of the timestep (m3) + real(r8), pointer :: in_grc(:, :) ! budget in terms (m3) + real(r8), pointer :: out_grc(:, :) ! budget out terms (m3) + real(r8), pointer :: net_grc(:, :) ! net budget (dvolume + inputs - outputs) (m3) + real(r8), pointer :: lag_grc(:, :) ! euler erout lagged (m3) + ! budget global terms - real(r8), pointer :: beg_vol_glob(:) ! volume begining of the timestep (1e6 m3) - real(r8), pointer :: end_vol_glob(:) ! volume end of the timestep (1e6 m3) - real(r8), pointer :: in_glob(:) ! budget in terms (1e6 m3) - real(r8), pointer :: out_glob(:) ! budget out terms (1e6 m3) - real(r8), pointer :: net_glob(:) ! net budget (dvolume + inputs - outputs) (1e6 m3) - real(r8), pointer :: lag_glob(:) ! euler erout lagged (1e6 m3) + real(r8), pointer :: beg_vol_glob(:) ! volume begining of the timestep (1e6 m3) + real(r8), pointer :: end_vol_glob(:) ! volume end of the timestep (1e6 m3) + real(r8), pointer :: in_glob(:) ! budget in terms (1e6 m3) + real(r8), pointer :: out_glob(:) ! budget out terms (1e6 m3) + real(r8), pointer :: net_glob(:) ! net budget (dvolume + inputs - outputs) (1e6 m3) + real(r8), pointer :: lag_glob(:) ! euler erout lagged (1e6 m3) + ! budget parameters - real(r8) :: tolerance = 1e-6_r8 ! budget absolute tolerance - real(r8) :: rel_tolerance = 1e-6_r8 ! budget relative tolerance - logical(r8), pointer :: do_budget(:) ! if budget should be checked (per tracer) + real(r8) :: tolerance = 1e-6_r8 ! budget absolute tolerance + real(r8) :: rel_tolerance = 1e-6_r8 ! budget relative tolerance + logical(r8), pointer :: do_budget(:) ! if budget should be checked (per tracer) contains procedure, public :: Init procedure, public :: set_budget @@ -46,18 +48,19 @@ module mosart_budget_type character(*), parameter :: u_FILE_u = & __FILE__ - !----------------------------------------------------------------------- + +!----------------------------------------------------------------------- contains +!----------------------------------------------------------------------- subroutine Init(this, begr, endr, ntracers) - ! USES: + ! Initialize budget type - ! ARGUMENTS: + ! Arguments class(budget_type) :: this integer, intent(in) :: begr, endr, ntracers - - ! LOCAL VARIABLES: + !------------------------------------------------- ! gridcell level: allocate (this%accum_grc(begr:endr, ntracers)) @@ -108,22 +111,30 @@ subroutine Init(this, begr, endr, ntracers) end subroutine Init + !----------------------------------------------------------------------- + subroutine set_budget(this, begr, endr, ntracers, dt) - !USES: - use mosart_data, only: ctl, Tctl, Tunit, TRunoff, Tpara - !ARGUMENTS: + ! Arguments class(budget_type) :: this integer, intent(in) :: begr, endr, ntracers real(r8), intent(in) :: dt - !LOCAL VARIABLES: - integer nr, nt !indecies + ! local variables + integer :: nr, nt !indices + integer :: nt_liq, nt_ice + !------------------------------------------------- + nt_liq = 1 + nt_ice = 2 do nr = begr, endr do nt = 1, ntracers this%beg_vol_grc(nr, nt) = ctl%volr(nr, nt) - this%in_grc(nr, nt) = (ctl%qsur(nr, nt) + ctl%qsub(nr, nt) + ctl%qgwl(nr, nt)) * dt + if (nt == nt_ice) then + this%in_grc(nr, nt) = (ctl%qsur(nr, nt) + ctl%qsub(nr, nt) + ctl%qgwl(nr, nt) + ctl%qglc_ice(nr)) * dt + else if (nt == nt_liq) then + this%in_grc(nr, nt) = (ctl%qsur(nr, nt) + ctl%qsub(nr, nt) + ctl%qgwl(nr, nt) + ctl%qglc_liq(nr)) * dt + end if ! this was for budget_terms(17) !if (nt==1) then ! this%in_grc(nr,nt)=this%in_grc(nr,nt) +ctl%qirrig(nr) @@ -131,53 +142,56 @@ subroutine set_budget(this, begr, endr, ntracers, dt) end do end do - this%end_vol_grc = 0.0_r8 - this%out_grc = 0.0_r8 - this%net_grc = 0.0_r8 - this%lag_grc = 0.0_r8 + this%end_vol_grc(:,:) = 0.0_r8 + this%out_grc(:,:) = 0.0_r8 + this%net_grc(:,:) = 0.0_r8 + this%lag_grc(:,:) = 0.0_r8 - this%beg_vol_glob = 0.0_r8 - this%end_vol_glob = 0.0_r8 - this%in_glob = 0.0_r8 - this%out_glob = 0.0_r8 - this%net_glob = 0.0_r8 - this%lag_glob = 0.0_r8 + this%beg_vol_glob(:) = 0.0_r8 + this%end_vol_glob(:) = 0.0_r8 + this%in_glob(:) = 0.0_r8 + this%out_glob(:) = 0.0_r8 + this%net_glob(:) = 0.0_r8 + this%lag_glob(:) = 0.0_r8 end subroutine set_budget + !----------------------------------------------------------------------- + subroutine check_budget(this, begr, endr, ntracers, dt) - !USES: - use mosart_data, only: ctl, Tctl, Tunit, TRunoff, Tpara - !ARGUMENTS: + + ! Arguments class(budget_type) :: this integer, intent(in) :: begr, endr, ntracers real(r8), intent(in) :: dt - !LOCAL VARIABLES: - integer nr, nt !indecies - integer yr,mon,day,ymd,tod !time vars - real(r8) :: tmp_in(6, ntracers) ! array to pass to mpi_sum - real(r8) :: tmp_glob(6, ntracers) ! array from mpi_sum - logical :: error_budget ! flag for an error + ! Local variables + integer :: nr, nt !indecies + integer :: nt_liq ! liquid index + integer :: yr,mon,day,ymd,tod !time vars + real(r8) :: tmp_in(6, ntracers) ! array to pass to mpi_sum + real(r8) :: tmp_glob(6, ntracers) ! array from mpi_sum + logical :: error_budget ! flag for an error real(r8) :: abserr, relerr + !------------------------------------------------- call get_curr_date(yr, mon, day, tod) ymd = yr*10000 + mon*100 + day tmp_in = 0.0_r8 tmp_glob = 0.0_r8 + nt_liq = 1 do nr = begr, endr do nt = 1, ntracers this%end_vol_grc(nr, nt) = ctl%volr(nr, nt) this%out_grc(nr, nt) = this%out_grc(nr, nt) + ctl%direct(nr, nt) - if (nt == 1) then + if (nt == nt_liq) then this%out_grc(nr, nt) = this%out_grc(nr, nt) + ctl%flood(nr) end if if (ctl%mask(nr) >= 2) then this%out_grc(nr, nt) = this%out_grc(nr, nt) + ctl%runoff(nr, nt) else - this%lag_grc(nr, nt) = this%lag_grc(nr, nt) - ctl%erout_prev(nr, nt) & - - ctl%flow(nr, nt) + this%lag_grc(nr, nt) = this%lag_grc(nr, nt) - ctl%erout_prev(nr, nt) - ctl%flow(nr, nt) end if this%out_grc(nr,nt) = this%out_grc(nr,nt) * dt this%lag_grc(nr,nt) = this%lag_grc(nr,nt) * dt @@ -215,11 +229,10 @@ subroutine check_budget(this, begr, endr, ntracers, dt) abserr = abs(this%net_glob(nt) - this%lag_glob(nt)) end if if (abs(this%net_glob(nt) + this%lag_glob(nt)) > 1e-6) then - if (abs(this%net_glob(nt) - this%lag_glob(nt)) & - /abs(this%net_glob(nt) + this%lag_glob(nt)) > this%rel_tolerance) then + if ( abs(this%net_glob(nt) - this%lag_glob(nt)) & + /abs(this%net_glob(nt) + this%lag_glob(nt)) > this%rel_tolerance) then error_budget = .true. - relerr = abs(this%net_glob(nt) - this%lag_glob(nt)) & - /abs(this%net_glob(nt) + this%lag_glob(nt)) + relerr = abs(this%net_glob(nt) - this%lag_glob(nt)) /abs(this%net_glob(nt) + this%lag_glob(nt)) end if end if if (mainproc) then diff --git a/src/riverroute/mosart_driver.F90 b/src/riverroute/mosart_driver.F90 index eacfe25..dde8d81 100644 --- a/src/riverroute/mosart_driver.F90 +++ b/src/riverroute/mosart_driver.F90 @@ -394,6 +394,7 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) ! ! Local variables integer :: i, j, n, nr, ns, nt, n2, nf ! indices + integer :: nt_ice, nt_liq logical :: budget_check ! if budget check needs to be performed real(r8) :: volr_init ! temporary storage to compute dvolrdt integer :: yr, mon, day, ymd, tod ! time information @@ -419,6 +420,9 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) rc = ESMF_SUCCESS + nt_liq = 1 + nt_ice = 2 + !----------------------------------------------------- ! Get date info !----------------------------------------------------- @@ -468,7 +472,7 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) endif - ! data for euler solver, in m3/s here + ! initialize data for euler solver, in m3/s here do nr = begr,endr do nt = 1,ntracers TRunoff%qsur(nr,nt) = ctl%qsur(nr,nt) @@ -484,7 +488,6 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) !----------------------------------- call t_startf('mosartr_irrig') - nt = 1 ctl%qirrig_actual = 0._r8 do nr = begr,endr @@ -493,10 +496,10 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) ! compare irrig_volume to main channel storage; ! add overage to subsurface runoff - if(irrig_volume > TRunoff%wr(nr,nt)) then - ctl%qsub(nr,nt) = ctl%qsub(nr,nt) + (TRunoff%wr(nr,nt) - irrig_volume) / coupling_period - TRunoff%qsub(nr,nt) = ctl%qsub(nr,nt) - irrig_volume = TRunoff%wr(nr,nt) + if(irrig_volume > TRunoff%wr(nr,nt_liq)) then + ctl%qsub(nr,nt_liq) = ctl%qsub(nr,nt_liq) + (TRunoff%wr(nr,nt_liq) - irrig_volume) / coupling_period + TRunoff%qsub(nr,nt_liq) = ctl%qsub(nr,nt_liq) + irrig_volume = TRunoff%wr(nr,nt_liq) endif ! actual irrigation rate [m3/s] @@ -505,7 +508,7 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) ctl%qirrig_actual(nr) = - irrig_volume / coupling_period ! remove irrigation from wr (main channel) - TRunoff%wr(nr,nt) = TRunoff%wr(nr,nt) - irrig_volume + TRunoff%wr(nr,nt_liq) = TRunoff%wr(nr,nt_liq) - irrig_volume enddo call t_stopf('mosartr_irrig') @@ -518,14 +521,13 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) !----------------------------------- call t_startf('mosartr_flood') - nt = 1 ctl%flood = 0._r8 do nr = begr,endr ! initialize ctl%flood to zero if (ctl%mask(nr) == 1) then - if (ctl%volr(nr,nt) > ctl%fthresh(nr)) then + if (ctl%volr(nr,nt_liq) > ctl%fthresh(nr)) then ! determine flux that is sent back to the land this is in m3/s - ctl%flood(nr) = (ctl%volr(nr,nt)-ctl%fthresh(nr)) / (delt_coupling) + ctl%flood(nr) = (ctl%volr(nr,nt_liq)-ctl%fthresh(nr)) / (delt_coupling) ! ctl%flood will be sent back to land - so must subtract this ! from the input runoff from land @@ -536,7 +538,7 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) ! 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) - ctl%flood(nr) + TRunoff%qsur(nr,nt_liq) = TRunoff%qsur(nr,nt_liq) - ctl%flood(nr) endif endif enddo @@ -565,24 +567,47 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return !----------------------------------------------------- - !--- all frozen runoff passed direct to outlet + !--- direct to outlet: all frozen runoff (from lnd and glc) !----------------------------------------------------- - nt = 2 src_direct(:,:) = 0._r8 dst_direct(:,:) = 0._r8 ! set euler_calc = false for frozen runoff - ! TODO: will be reworked after addition of multiple tracers + ! TODO: will be reworked after addition of multiple tracers Tunit%euler_calc(nt) = .false. cnt = 0 do nr = begr,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 + src_direct(nt,cnt) = TRunoff%qsur(nr,nt_ice) + TRunoff%qsub(nr,nt_ice) + TRunoff%qgwl(nr,nt_ice) + ctl%qglc_ice(nr) + TRunoff%qsur(nr,nt_ice) = 0._r8 + TRunoff%qsub(nr,nt_ice) = 0._r8 + TRunoff%qgwl(nr,nt_ice) = 0._r8 + enddo + + call ESMF_FieldSMM(Tunit%srcfield, Tunit%dstfield, Tunit%rh_direct, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! copy direct transfer water to output field + ctl%direct = 0._r8 + cnt = 0 + do nr = begr,endr + cnt = cnt + 1 + ctl%direct(nr,nt_ice) = ctl%direct(nr,nt_ice) + dst_direct(nt,cnt) + enddo + + !----------------------------------------------------- + !--- direct to outlet: all liquid runoff from glc + !----------------------------------------------------- + + src_direct(:,:) = 0._r8 + dst_direct(:,:) = 0._r8 + + cnt = 0 + do nr = begr,endr + cnt = cnt + 1 + src_direct(nt_liq,cnt) = ctl%qglc_liq(nr) enddo call ESMF_FieldSMM(Tunit%srcfield, Tunit%dstfield, Tunit%rh_direct, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) @@ -593,17 +618,16 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) cnt = 0 do nr = begr,endr cnt = cnt + 1 - ctl%direct(nr,nt) = ctl%direct(nr,nt) + dst_direct(nt,cnt) + ctl%direct(nr,nt_liq) = ctl%direct(nr,nt_liq) + dst_direct(nt_liq,cnt) enddo !----------------------------------------------------- - !--- direct to outlet qgwl + !--- 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 @@ -612,12 +636,12 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) do nr = begr,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 + src_direct(nt_liq,cnt) = TRunoff%qgwl(nr,nt_liq) + TRunoff%qgwl(nr,nt_liq) = 0._r8 else if (trim(qgwl_runoff_option) == 'negative') then - if(TRunoff%qgwl(nr,nt) < 0._r8) then - src_direct(nt,cnt) = TRunoff%qgwl(nr,nt) - TRunoff%qgwl(nr,nt) = 0._r8 + if(TRunoff%qgwl(nr,nt_liq) < 0._r8) then + src_direct(nt_liq,cnt) = TRunoff%qgwl(nr,nt_liq) + TRunoff%qgwl(nr,nt_liq) = 0._r8 endif endif enddo @@ -629,63 +653,59 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) cnt = 0 do nr = begr,endr cnt = cnt + 1 - ctl%direct(nr,nt) = ctl%direct(nr,nt) + dst_direct(nt,cnt) + ctl%direct(nr,nt_liq) = ctl%direct(nr,nt_liq) + dst_direct(nt_liq,cnt) enddo endif !----------------------------------------------------- - !--- direct in place qgwl + !--- direct in place qgwl, qgwl, qglc_liq and qflc_ice !----------------------------------------------------- if (trim(bypass_routing_option) == 'direct_in_place') then - - nt = 1 do nr = begr,endr - if (trim(qgwl_runoff_option) == 'all') then - ctl%direct(nr,nt) = TRunoff%qgwl(nr,nt) - TRunoff%qgwl(nr,nt) = 0._r8 + ctl%direct(nr,nt_liq) = TRunoff%qgwl(nr,nt_liq) + TRunoff%qgwl(nr,nt_liq) = 0._r8 else if (trim(qgwl_runoff_option) == 'negative') then - if(TRunoff%qgwl(nr,nt) < 0._r8) then - ctl%direct(nr,nt) = TRunoff%qgwl(nr,nt) - TRunoff%qgwl(nr,nt) = 0._r8 + if(TRunoff%qgwl(nr,nt_liq) < 0._r8) then + ctl%direct(nr,nt_liq) = TRunoff%qgwl(nr,nt_liq) + TRunoff%qgwl(nr,nt_liq) = 0._r8 endif else if (trim(qgwl_runoff_option) == 'threshold') then ! --- calculate volume of qgwl flux during timestep - qgwl_volume = TRunoff%qgwl(nr,nt) * ctl%area(nr) * coupling_period + qgwl_volume = TRunoff%qgwl(nr,nt_liq) * ctl%area(nr) * coupling_period river_volume_minimum = river_depth_minimum * ctl%area(nr) ! if qgwl is negative, and adding it to the main channel ! would bring main channel storage below a threshold, ! send qgwl directly to ocean - if (((qgwl_volume + TRunoff%wr(nr,nt)) < river_volume_minimum) .and. (TRunoff%qgwl(nr,nt) < 0._r8)) then - ctl%direct(nr,nt) = TRunoff%qgwl(nr,nt) - TRunoff%qgwl(nr,nt) = 0._r8 + if (((qgwl_volume + TRunoff%wr(nr,nt_liq)) < river_volume_minimum) .and. (TRunoff%qgwl(nr,nt_liq) < 0._r8)) then + ctl%direct(nr,nt_liq) = TRunoff%qgwl(nr,nt_liq) + TRunoff%qgwl(nr,nt_liq) = 0._r8 endif endif + ! Add glc->rof liquid going directly to outlet + src_direct(nt,cnt) = src_direct(nt,cnt) + ctl%qglc_liq(nr) enddo - endif !------------------------------------------------------- - !--- add other direct terms, e.g. inputs outside of - !--- mosart mask, negative qsur + !--- direct in place: add other direct terms, e.g. inputs outside of mosart mask, negative qsur !------------------------------------------------------- if (trim(bypass_routing_option) == 'direct_in_place') then do nt = 1,ntracers do nr = begr,endr - if (TRunoff%qsub(nr,nt) < 0._r8) then ctl%direct(nr,nt) = ctl%direct(nr,nt) + TRunoff%qsub(nr,nt) TRunoff%qsub(nr,nt) = 0._r8 endif - if (TRunoff%qsur(nr,nt) < 0._r8) then ctl%direct(nr,nt) = ctl%direct(nr,nt) + TRunoff%qsur(nr,nt) TRunoff%qsur(nr,nt) = 0._r8 endif - + ! Note Tunit%mask is set in Tunit%init and is obtained from reading in fdir + ! if fdir<0 then mask=0 (ocean), if fdir=0 then mask=2 (outlet) and if fdir>0 then mask=1 (land) if (Tunit%mask(nr) > 0) then ! mosart euler else @@ -698,11 +718,13 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) enddo endif - if (trim(bypass_routing_option) == 'direct_to_outlet') then + !------------------------------------------------------- + !--- direct to outlet: add other direct terms, e.g. inputs outside of mosart mask, negative qsur + !------------------------------------------------------- + if (trim(bypass_routing_option) == 'direct_to_outlet') then src_direct(:,:) = 0._r8 dst_direct(:,:) = 0._r8 - cnt = 0 do nr = begr,endr cnt = cnt + 1 @@ -721,15 +743,20 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) !---- water outside the basin --- !---- *** DO NOT TURN THIS ONE OFF, conservation will fail *** --- + + ! Note Tunit%mask is set in Tunit%init and is obtained from reading in fdir + ! if fdir<0 then mask=0 (ocean), if fdir=0 then mask=2 (outlet) and if fdir>0 then mask=1 (land) if (Tunit%mask(nr) > 0) then ! mosart euler else - src_direct(nt,cnt) = src_direct(nt,cnt) + TRunoff%qsub(nr,nt) + TRunoff%qsur(nr,nt) & - + TRunoff%qgwl(nr,nt) + ! NOTE: that when nt = nt_ice, the TRunoff terms + ! below have already been set to zero in the frozen + ! runoff calculation above - where frozen runoff is always set to the outlet + src_direct(nt,cnt) = src_direct(nt,cnt) + TRunoff%qsub(nr,nt) + TRunoff%qsur(nr,nt) + TRunoff%qgwl(nr,nt) TRunoff%qsub(nr,nt) = 0._r8 TRunoff%qsur(nr,nt) = 0._r8 TRunoff%qgwl(nr,nt) = 0._r8 - endif + end if enddo enddo @@ -818,7 +845,6 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) ctl%erlat_avg = ctl%erlat_avg / float(nsub) ! update states when subsycling completed - ! TODO: move of this to hist_set_flds ctl%runoff = 0._r8 ctl%runofflnd = spval ctl%runoffocn = spval @@ -847,7 +873,7 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) !----------------------------------- ! BUDGET !----------------------------------- - if (budget_check) then + if (budget_check) then call t_startf('mosartr_budgetcheck') call budget%check_budget(begr,endr,ntracers,delt_coupling) call t_stopf('mosartr_budgetcheck') diff --git a/src/riverroute/mosart_histfile.F90 b/src/riverroute/mosart_histfile.F90 index 4872b34..c0eaf23 100644 --- a/src/riverroute/mosart_histfile.F90 +++ b/src/riverroute/mosart_histfile.F90 @@ -644,16 +644,12 @@ subroutine htape_create (t, histrest) call ncd_putatt(lnfid, ncd_global, 'username' , trim(username)) call ncd_putatt(lnfid, ncd_global, 'version' , trim(version)) call ncd_putatt(lnfid, ncd_global, 'model_doi_url', trim(model_doi_url)) - write(6,*)'DEBUG: I am here7' call ncd_putatt(lnfid, ncd_global, 'case_title', trim(ctitle)) - write(6,*)'DEBUG: I am here8' call ncd_putatt(lnfid, ncd_global, 'case_id', trim(caseid)) - write(6,*)'DEBUG: I am here9' str = get_filename(frivinp) call ncd_putatt(lnfid, ncd_global, 'input_dataset', trim(str)) - write(6,*)'DEBUG: I am here10' ! ! add global attribute time_period_freq @@ -679,7 +675,6 @@ subroutine htape_create (t, histrest) 999 format(a,i0) call ncd_putatt(lnfid, ncd_global, 'time_period_freq', trim(time_period_freq)) - write(6,*)'DEBUG: I am here6' ! Define dimensions. ! Time is an unlimited dimension. Character string is treated as an array of characters. @@ -689,12 +684,10 @@ subroutine htape_create (t, histrest) call ncd_defdim(lnfid, 'lat' , ctl%nlat , dimid) call ncd_defdim(lnfid, 'allrof', ctl%numr , dimid) call ncd_defdim(lnfid, 'string_length', 8, strlen_dimid) - write(6,*)'DEBUG: I am here7' if ( .not. lhistrest )then call ncd_defdim(lnfid, 'hist_interval', 2, hist_interval_dimid) call ncd_defdim(lnfid, 'time', ncd_unlimited, time_dimid) - write(6,*)'DEBUG: I am here8' if (mainproc)then write(iulog,*) trim(subname),' : Successfully defined netcdf history file ',t end if diff --git a/src/riverroute/mosart_histflds.F90 b/src/riverroute/mosart_histflds.F90 index 31287df..e042f40 100644 --- a/src/riverroute/mosart_histflds.F90 +++ b/src/riverroute/mosart_histflds.F90 @@ -31,6 +31,8 @@ module mosart_histflds type(hist_pointer_type), allocatable :: h_qgwl(:) real(r8), pointer :: h_volr_mch(:) + real(r8), pointer :: h_qglc_liq(:) + real(r8), pointer :: h_qglc_ice(:) !------------------------------------------------------------------------ contains @@ -75,6 +77,8 @@ subroutine mosart_histflds_init(begr, endr, ntracers) end do allocate(h_volr_mch(begr:endr)) + allocate(h_qglc_liq(begr:endr)) + allocate(h_qglc_ice(begr:endr)) !------------------------------------------------------- ! Build master field list of all possible fields in a history file. @@ -138,6 +142,14 @@ subroutine mosart_histflds_init(begr, endr, ntracers) avgflag='A', long_name='Actual irrigation (if limited by river storage)', & ptr_rof=ctl%qirrig_actual, default='inactive') + call mosart_hist_addfld (fname='QGLC_LIQ', units='m3', & + avgflag='A', long_name='liquid runoff from glc input', & + ptr_rof=h_qglc_liq, default='inactive') + + call mosart_hist_addfld (fname='QGLC_ICE', units='m3', & + avgflag='A', long_name='ice runoff from glc input', & + ptr_rof=h_qglc_ice, default='inactive') + ! print masterlist of history fields call mosart_hist_printflds() @@ -169,6 +181,8 @@ subroutine mosart_histflds_set(ntracers) h_qgwl(nt)%data(:) = ctl%qgwl(:,nt) end do h_volr_mch(:) = Trunoff%wr(:,1) + h_qglc_liq(:) = ctl%qglc_liq(:) + h_qglc_ice(:) = ctl%qglc_ice(:) end subroutine mosart_histflds_set From 2a0f772a12b0a4cac79389f86c800625b801dc6a Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Thu, 30 May 2024 04:31:25 -0600 Subject: [PATCH 51/86] fixed ice discharge --- src/riverroute/mosart_driver.F90 | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/src/riverroute/mosart_driver.F90 b/src/riverroute/mosart_driver.F90 index dde8d81..9a5c153 100644 --- a/src/riverroute/mosart_driver.F90 +++ b/src/riverroute/mosart_driver.F90 @@ -394,7 +394,7 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) ! ! Local variables integer :: i, j, n, nr, ns, nt, n2, nf ! indices - integer :: nt_ice, nt_liq + integer :: nt_ice, nt_liq ! incices logical :: budget_check ! if budget check needs to be performed real(r8) :: volr_init ! temporary storage to compute dvolrdt integer :: yr, mon, day, ymd, tod ! time information @@ -566,6 +566,12 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) call ESMF_FieldGet(Tunit%dstfield, farrayPtr=dst_direct, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + !----------------------------------------------------- + !--- initialize ctl%direct + !----------------------------------------------------- + + ctl%direct = 0._r8 + !----------------------------------------------------- !--- direct to outlet: all frozen runoff (from lnd and glc) !----------------------------------------------------- @@ -580,7 +586,7 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) cnt = 0 do nr = begr,endr cnt = cnt + 1 - src_direct(nt,cnt) = TRunoff%qsur(nr,nt_ice) + TRunoff%qsub(nr,nt_ice) + TRunoff%qgwl(nr,nt_ice) + ctl%qglc_ice(nr) + src_direct(nt_ice,cnt) = TRunoff%qsur(nr,nt_ice) + TRunoff%qsub(nr,nt_ice) + TRunoff%qgwl(nr,nt_ice) + ctl%qglc_ice(nr) TRunoff%qsur(nr,nt_ice) = 0._r8 TRunoff%qsub(nr,nt_ice) = 0._r8 TRunoff%qgwl(nr,nt_ice) = 0._r8 @@ -590,11 +596,10 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return ! copy direct transfer water to output field - ctl%direct = 0._r8 cnt = 0 do nr = begr,endr cnt = cnt + 1 - ctl%direct(nr,nt_ice) = ctl%direct(nr,nt_ice) + dst_direct(nt,cnt) + ctl%direct(nr,nt_ice) = ctl%direct(nr,nt_ice) + dst_direct(nt_ice,cnt) enddo !----------------------------------------------------- @@ -614,7 +619,6 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return ! copy direct transfer water to output field - ctl%direct = 0._r8 cnt = 0 do nr = begr,endr cnt = cnt + 1 @@ -685,7 +689,7 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) endif endif ! Add glc->rof liquid going directly to outlet - src_direct(nt,cnt) = src_direct(nt,cnt) + ctl%qglc_liq(nr) + src_direct(nt_liq,cnt) = src_direct(nt_liq,cnt) + ctl%qglc_liq(nr) enddo endif From ffd51738a9eb09f0635fd07574e66c942592a2b4 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sun, 2 Jun 2024 10:25:20 -0600 Subject: [PATCH 52/86] separation of input glc runoff and output direct rof due to glc input --- src/cpl/nuopc/rof_import_export.F90 | 47 ++++++----------- src/riverroute/mosart_budget_type.F90 | 13 +++-- src/riverroute/mosart_control_type.F90 | 73 ++++++++++++++++++++------ src/riverroute/mosart_driver.F90 | 61 +++++++++++---------- src/riverroute/mosart_histflds.F90 | 36 +++++++++---- 5 files changed, 139 insertions(+), 91 deletions(-) diff --git a/src/cpl/nuopc/rof_import_export.F90 b/src/cpl/nuopc/rof_import_export.F90 index 1846f08..d31cb60 100644 --- a/src/cpl/nuopc/rof_import_export.F90 +++ b/src/cpl/nuopc/rof_import_export.F90 @@ -241,7 +241,7 @@ subroutine import_fields( gcomp, begr, endr, rc ) ! Local variables type(ESMF_State) :: importState integer :: n,nt - integer :: nliq, nfrz + integer :: nliq, nice character(len=*), parameter :: subname='(rof_import_export:import_fields)' !--------------------------------------------------------------------------- @@ -252,17 +252,8 @@ subroutine import_fields( gcomp, begr, endr, rc ) call NUOPC_ModelGet(gcomp, importState=importState, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! Set tracers - nliq = 0 - nfrz = 0 - do nt = 1,ctl%ntracers - if (trim(ctl%tracer_names(nt)) == 'LIQ') nliq = nt - if (trim(ctl%tracer_names(nt)) == 'ICE') nfrz = nt - enddo - if (nliq == 0 .or. nfrz == 0) then - write(iulog,*) trim(subname),': ERROR in tracers LIQ ICE ',nliq,nfrz,ctl%tracer_names(:) - call shr_sys_abort() - endif + nliq = ctl%nt_liq + nice = ctl%nt_ice ! determine output array and scale by unit convertsion ! NOTE: the call to state_getimport will convert from input kg/m2s to m3/s @@ -279,7 +270,7 @@ subroutine import_fields( gcomp, begr, endr, rc ) do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'Flrl_rofi', begr, endr, ctl%area, output=ctl%qsur(:,nfrz), & + call state_getimport(importState, 'Flrl_rofi', begr, endr, ctl%area, output=ctl%qsur(:,nice), & do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -287,8 +278,8 @@ subroutine import_fields( gcomp, begr, endr, rc ) do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ctl%qsub(begr:endr, nfrz) = 0.0_r8 - ctl%qgwl(begr:endr, nfrz) = 0.0_r8 + ctl%qsub(begr:endr, nice) = 0.0_r8 + ctl%qgwl(begr:endr, nice) = 0.0_r8 call state_getimport(importState, 'Fgrg_rofl', begr, endr, ctl%area, output=ctl%qglc_liq(:), & do_area_correction=.true., rc=rc) @@ -315,7 +306,7 @@ subroutine export_fields (gcomp, begr, endr, rc) ! Local variables type(ESMF_State) :: exportState integer :: n,nt - integer :: nliq, nfrz + integer :: nliq, nice real(r8) :: rofl(begr:endr) real(r8) :: rofi(begr:endr) real(r8) :: flood(begr:endr) @@ -335,16 +326,8 @@ subroutine export_fields (gcomp, begr, endr, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! Set tracers - nliq = 0 - nfrz = 0 - do nt = 1,ctl%ntracers - if (trim(ctl%tracer_names(nt)) == 'LIQ') nliq = nt - if (trim(ctl%tracer_names(nt)) == 'ICE') nfrz = nt - enddo - if (nliq == 0 .or. nfrz == 0) then - write(iulog,*) trim(subname),': ERROR in tracers LIQ ICE ',nliq,nfrz,ctl%tracer_names(:) - call shr_sys_abort() - endif + nliq = ctl%nt_liq + nice = ctl%nt_ice if (first_time) then if (mainproc) then @@ -361,23 +344,27 @@ subroutine export_fields (gcomp, begr, endr, rc) ! separate liquid and ice runoff do n = begr,endr rofl(n) = ctl%direct(n,nliq) / (ctl%area(n)*0.001_r8) - rofi(n) = ctl%direct(n,nfrz) / (ctl%area(n)*0.001_r8) + rofi(n) = ctl%direct(n,nice) / (ctl%area(n)*0.001_r8) if (ctl%mask(n) >= 2) then ! liquid and ice runoff are treated separately - this is what goes to the ocean rofl(n) = rofl(n) + ctl%runoff(n,nliq) / (ctl%area(n)*0.001_r8) - rofi(n) = rofi(n) + ctl%runoff(n,nfrz) / (ctl%area(n)*0.001_r8) + rofi(n) = rofi(n) + ctl%runoff(n,nice) / (ctl%area(n)*0.001_r8) end if end do else ! liquid and ice runoff added to liquid runoff, ice runoff is zero do n = begr,endr - rofl(n) = (ctl%direct(n,nfrz) + ctl%direct(n,nliq)) / (ctl%area(n)*0.001_r8) + rofl(n) = (ctl%direct(n,nice) + ctl%direct(n,nliq)) / (ctl%area(n)*0.001_r8) if (ctl%mask(n) >= 2) then - rofl(n) = rofl(n) + (ctl%runoff(n,nfrz) + ctl%runoff(n,nliq)) / (ctl%area(n)*0.001_r8) + rofl(n) = rofl(n) + (ctl%runoff(n,nice) + ctl%runoff(n,nliq)) / (ctl%area(n)*0.001_r8) endif rofi(n) = 0._r8 end do end if + do n = begr,endr + rofl(n) = rofl(n) + ctl%direct_glc(n,nliq) / (ctl%area(n)*0.001_r8) + rofi(n) = rofl(n) + ctl%direct_glc(n,nice) / (ctl%area(n)*0.001_r8) + end do ! Flooding back to land, sign convention is positive in land->rof direction ! so if water is sent from rof to land, the flux must be negative. diff --git a/src/riverroute/mosart_budget_type.F90 b/src/riverroute/mosart_budget_type.F90 index f25c21f..b15571f 100644 --- a/src/riverroute/mosart_budget_type.F90 +++ b/src/riverroute/mosart_budget_type.F90 @@ -125,8 +125,8 @@ subroutine set_budget(this, begr, endr, ntracers, dt) integer :: nt_liq, nt_ice !------------------------------------------------- - nt_liq = 1 - nt_ice = 2 + nt_liq = ctl%nt_liq + nt_ice = ctl%nt_ice do nr = begr, endr do nt = 1, ntracers this%beg_vol_grc(nr, nt) = ctl%volr(nr, nt) @@ -180,11 +180,11 @@ subroutine check_budget(this, begr, endr, ntracers, dt) tmp_in = 0.0_r8 tmp_glob = 0.0_r8 - nt_liq = 1 + nt_liq = ctl%nt_liq do nr = begr, endr do nt = 1, ntracers this%end_vol_grc(nr, nt) = ctl%volr(nr, nt) - this%out_grc(nr, nt) = this%out_grc(nr, nt) + ctl%direct(nr, nt) + this%out_grc(nr, nt) = this%out_grc(nr, nt) + ctl%direct(nr, nt) + ctl%direct_glc(nr, nt) if (nt == nt_liq) then this%out_grc(nr, nt) = this%out_grc(nr, nt) + ctl%flood(nr) end if @@ -195,9 +195,8 @@ subroutine check_budget(this, begr, endr, ntracers, dt) end if this%out_grc(nr,nt) = this%out_grc(nr,nt) * dt this%lag_grc(nr,nt) = this%lag_grc(nr,nt) * dt - this%net_grc(nr, nt) = this%end_vol_grc(nr, nt) - this%beg_vol_grc(nr, nt) & - - (this%in_grc(nr, nt) - this%out_grc(nr, nt)) - this%accum_grc(nr, nt) = this%accum_grc(nr, nt) + this%net_grc(nr, nt) + this%net_grc(nr,nt) = this%end_vol_grc(nr,nt) - this%beg_vol_grc(nr,nt) - (this%in_grc(nr,nt)-this%out_grc(nr,nt)) + this%accum_grc(nr,nt) = this%accum_grc(nr,nt) + this%net_grc(nr,nt) end do end do diff --git a/src/riverroute/mosart_control_type.F90 b/src/riverroute/mosart_control_type.F90 index ddb17fd..76d6452 100644 --- a/src/riverroute/mosart_control_type.F90 +++ b/src/riverroute/mosart_control_type.F90 @@ -1,17 +1,18 @@ module mosart_control_type - use shr_kind_mod, only : r8 => shr_kind_r8, CL => SHR_KIND_CL - use shr_sys_mod, only : shr_sys_abort - use shr_const_mod, only : shr_const_pi, shr_const_rearth - use shr_mpi_mod, only : shr_mpi_sum, shr_mpi_max - use mosart_io, only : ncd_io, ncd_pio_openfile, ncd_pio_closefile - use mosart_vars, only : mainproc, iam, npes, mpicom_rof, iulog, spval, re - use pio, only : file_desc_t, PIO_BCAST_ERROR, pio_seterrorhandling - use ESMF, only : ESMF_DistGrid, ESMF_Array, ESMF_RouteHandle, ESMF_SUCCESS, & - ESMF_DistGridCreate, ESMF_ArrayCreate, ESMF_ArrayHaloStore, & - ESMF_ArrayHalo, ESMF_ArrayGet - use perf_mod, only : t_startf, t_stopf - use nuopc_shr_methods , only : chkerr + use shr_kind_mod, only : r8 => shr_kind_r8, CL => SHR_KIND_CL, CS => SHR_KIND_CS + use shr_sys_mod, only : shr_sys_abort + use shr_const_mod, only : shr_const_pi, shr_const_rearth + use shr_string_mod, only : shr_string_listGetNum, shr_string_listGetName + use shr_mpi_mod, only : shr_mpi_sum, shr_mpi_max + use mosart_io, only : ncd_io, ncd_pio_openfile, ncd_pio_closefile + use mosart_vars, only : mainproc, iam, npes, mpicom_rof, iulog, spval, re + use pio, only : file_desc_t, PIO_BCAST_ERROR, pio_seterrorhandling + use ESMF, only : ESMF_DistGrid, ESMF_Array, ESMF_RouteHandle, ESMF_SUCCESS, & + ESMF_DistGridCreate, ESMF_ArrayCreate, ESMF_ArrayHaloStore, & + ESMF_ArrayHalo, ESMF_ArrayGet + use perf_mod, only : t_startf, t_stopf + use nuopc_shr_methods, only : chkerr implicit none private @@ -27,6 +28,8 @@ module mosart_control_type ! tracers integer :: ntracers = -999 ! number of tracers character(len=3), allocatable :: tracer_names(:)! tracer names + integer :: nt_liq ! index of liquid tracer in tracer_names + integer :: nt_ice ! index of ice tracer in tracer_names ! decomp info integer :: begr ! local start index @@ -56,8 +59,9 @@ module mosart_control_type ! outputs from MOSART real(r8), pointer :: flood(:) => null() ! flood water to coupler [m3/s] (lnd) real(r8), pointer :: runoff(:,:) => null() ! runoff (from outlet to reach) to coupler [m3/s] - real(r8), pointer :: direct(:,:) => null() ! direct flow to coupler [m3/s] + real(r8), pointer :: direct(:,:) => null() ! direct flow to outlet from land input [m3/s] real(r8), pointer :: qirrig_actual(:) => null() ! minimum of irrigation and available main channel storage [m3/s] + real(r8), pointer :: direct_glc(:,:) =>null() ! direct flow to outlet from glc input [m3/s] ! storage, runoff real(r8), pointer :: runofflnd(:,:) => null() ! runoff masked for land [m3/s] @@ -90,6 +94,7 @@ module mosart_control_type contains procedure, public :: Init + procedure, public :: init_tracer_names procedure, private :: init_decomp procedure, private :: test_halo procedure, public :: calc_gradient @@ -117,13 +122,49 @@ module mosart_control_type integer, public :: halo_w = 7 integer, public :: halo_nw = 8 + ! The following are set from + character(*), parameter :: u_FILE_u = & __FILE__ - !======================================================================== +!======================================================================== contains - !======================================================================== +!======================================================================== + + subroutine init_tracer_names(this, mosart_tracers) + + ! Arguments + class(control_type) :: this + character(len=CS) :: mosart_tracers ! colon delimited string of tracer names + + ! Local variables + integer :: nt + character(len=*),parameter :: subname = '(mosart_control_type: init_tracer_names)' + !----------------------------------------------------------------------- + ! Determine number of tracers and array of tracer names + this%ntracers = shr_string_listGetNum(mosart_tracers) + allocate(this%tracer_names(this%ntracers)) + do nt = 1,this%ntracers + call shr_string_listGetName(mosart_tracers, nt, this%tracer_names(nt)) + end do + + ! Set tracers + this%nt_liq = 0 + this%nt_ice = 0 + do nt = 1,this%ntracers + if (trim(this%tracer_names(nt)) == 'LIQ') this%nt_liq = nt + if (trim(this%tracer_names(nt)) == 'ICE') this%nt_ice = nt + enddo + if (this%nt_liq == 0 .or. this%nt_ice == 0) then + write(iulog,*) trim(subname),': ERROR in tracers LIQ ICE ',this%nt_liq,this%nt_ice,this%tracer_names(:) + call shr_sys_abort() + endif + + end subroutine init_tracer_names + + + !======================================================================== subroutine Init(this, locfn, decomp_option, use_halo_option, IDkey, rc) ! Arguments @@ -315,6 +356,7 @@ subroutine Init(this, locfn, decomp_option, use_halo_option, IDkey, rc) this%erlat_avg(begr:endr,ntracers), & ! this%effvel(ntracers), & + this%direct_glc(begr:endr,2), & stat=ier) if (ier /= 0) then write(iulog,*)'mosarart_control_type allocation error' @@ -343,6 +385,7 @@ subroutine Init(this, locfn, decomp_option, use_halo_option, IDkey, rc) this%erout_prev(:,:) = 0._r8 this%eroutup_avg(:,:) = 0._r8 this%erlat_avg(:,:) = 0._r8 + this%direct_glc(:,:) = 0._r8 this%effvel(:) = effvel0 ! downstream velocity (m/s) do nt = 1,ntracers diff --git a/src/riverroute/mosart_driver.F90 b/src/riverroute/mosart_driver.F90 index 9a5c153..18fccbf 100644 --- a/src/riverroute/mosart_driver.F90 +++ b/src/riverroute/mosart_driver.F90 @@ -8,7 +8,6 @@ module mosart_driver 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 shr_string_mod , only : shr_string_listGetNum, shr_string_listGetName use mosart_vars , only : re, spval, iulog, ice_runoff, & frivinp, nsrContinue, nsrBranch, nsrStartup, nsrest, & inst_index, inst_suffix, inst_name, decomp_option, & @@ -63,6 +62,8 @@ module mosart_driver character(len=CL) :: nlfilename_rof = 'mosart_in' character(len=CL) :: fnamer ! name of netcdf restart file + integer :: nt_liq, nt_ice + character(*), parameter :: u_FILE_u = & __FILE__ !----------------------------------------------------------------------- @@ -149,12 +150,10 @@ subroutine mosart_read_namelist() call mpi_bcast (mosart_euler_calc, CS, MPI_CHARACTER, 0, mpicom_rof, ier) call mpi_bcast (budget_frq,1,MPI_INTEGER,0,mpicom_rof,ier) - ! Determine number of tracers and array of tracer names - ctl%ntracers = shr_string_listGetNum(mosart_tracers) - allocate(ctl%tracer_names(ctl%ntracers)) - do i = 1,ctl%ntracers - call shr_string_listGetName(mosart_tracers, i, ctl%tracer_names(i)) - end do + ! Determine number of tracers and array of tracer names and initialize module variables + call ctl%init_tracer_names(mosart_tracers) + nt_liq = ctl%nt_liq + nt_ice = ctl%nt_ice runtyp(:) = 'missing' runtyp(nsrStartup + 1) = 'initial' @@ -394,7 +393,6 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) ! ! Local variables integer :: i, j, n, nr, ns, nt, n2, nf ! indices - integer :: nt_ice, nt_liq ! incices logical :: budget_check ! if budget check needs to be performed real(r8) :: volr_init ! temporary storage to compute dvolrdt integer :: yr, mon, day, ymd, tod ! time information @@ -420,9 +418,6 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) rc = ESMF_SUCCESS - nt_liq = 1 - nt_ice = 2 - !----------------------------------------------------- ! Get date info !----------------------------------------------------- @@ -570,26 +565,21 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) !--- initialize ctl%direct !----------------------------------------------------- - ctl%direct = 0._r8 + ctl%direct(:,:) = 0._r8 + ctl%direct_glc(:,:) = 0._r8 !----------------------------------------------------- - !--- direct to outlet: all frozen runoff (from lnd and glc) + !--- direct to outlet: all liquid and frozen runoff from glc !----------------------------------------------------- src_direct(:,:) = 0._r8 dst_direct(:,:) = 0._r8 - ! set euler_calc = false for frozen runoff - ! TODO: will be reworked after addition of multiple tracers - Tunit%euler_calc(nt) = .false. - cnt = 0 do nr = begr,endr cnt = cnt + 1 - src_direct(nt_ice,cnt) = TRunoff%qsur(nr,nt_ice) + TRunoff%qsub(nr,nt_ice) + TRunoff%qgwl(nr,nt_ice) + ctl%qglc_ice(nr) - TRunoff%qsur(nr,nt_ice) = 0._r8 - TRunoff%qsub(nr,nt_ice) = 0._r8 - TRunoff%qgwl(nr,nt_ice) = 0._r8 + src_direct(nt_liq,cnt) = ctl%qglc_liq(nr) + src_direct(nt_ice,cnt) = ctl%qglc_ice(nr) enddo call ESMF_FieldSMM(Tunit%srcfield, Tunit%dstfield, Tunit%rh_direct, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) @@ -599,11 +589,12 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) cnt = 0 do nr = begr,endr cnt = cnt + 1 - ctl%direct(nr,nt_ice) = ctl%direct(nr,nt_ice) + dst_direct(nt_ice,cnt) + ctl%direct_glc(nr,nt_liq) = ctl%direct_glc(nr,nt_liq) + dst_direct(nt_liq,cnt) + ctl%direct_glc(nr,nt_ice) = ctl%direct_glc(nr,nt_ice) + dst_direct(nt_ice,cnt) enddo !----------------------------------------------------- - !--- direct to outlet: all liquid runoff from glc + !--- direct to outlet: all frozen runoff from lnd !----------------------------------------------------- src_direct(:,:) = 0._r8 @@ -612,7 +603,7 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) cnt = 0 do nr = begr,endr cnt = cnt + 1 - src_direct(nt_liq,cnt) = ctl%qglc_liq(nr) + src_direct(nt_ice,cnt) = TRunoff%qsur(nr,nt_ice) + TRunoff%qsub(nr,nt_ice) + TRunoff%qgwl(nr,nt_ice) enddo call ESMF_FieldSMM(Tunit%srcfield, Tunit%dstfield, Tunit%rh_direct, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) @@ -622,9 +613,18 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) cnt = 0 do nr = begr,endr cnt = cnt + 1 - ctl%direct(nr,nt_liq) = ctl%direct(nr,nt_liq) + dst_direct(nt_liq,cnt) + ctl%direct(nr,nt_ice) = ctl%direct(nr,nt_ice) + dst_direct(nt_ice,cnt) enddo + ! set euler_calc = false for frozen runoff + ! TODO: will be reworked after addition of multiple tracers + Tunit%euler_calc(nt_ice) = .false. + + ! Set Trunoff%qsur, TRunoff%qsub and Trunoff%qgwl to zero for nt_ice + TRunoff%qsur(:,nt_ice) = 0._r8 + TRunoff%qsub(:,nt_ice) = 0._r8 + TRunoff%qgwl(:,nt_ice) = 0._r8 + !----------------------------------------------------- !--- direct to outlet: qgwl !----------------------------------------------------- @@ -662,7 +662,7 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) endif !----------------------------------------------------- - !--- direct in place qgwl, qgwl, qglc_liq and qflc_ice + !--- direct in place qgwl, qgwl !----------------------------------------------------- if (trim(bypass_routing_option) == 'direct_in_place') then @@ -688,8 +688,6 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) TRunoff%qgwl(nr,nt_liq) = 0._r8 endif endif - ! Add glc->rof liquid going directly to outlet - src_direct(nt_liq,cnt) = src_direct(nt_liq,cnt) + ctl%qglc_liq(nr) enddo endif @@ -872,6 +870,13 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) endif enddo enddo + + ! final update from glc input + do nr = begr,endr + ctl%runofftot(nr,nt_liq) = ctl%runoff(nr,nt_liq) + ctl%direct_glc(nr,nt_liq) + ctl%runofftot(nr,nt_ice) = ctl%runoff(nr,nt_ice) + ctl%direct_glc(nr,nt_ice) + end do + call t_stopf('mosartr_subcycling') !----------------------------------- diff --git a/src/riverroute/mosart_histflds.F90 b/src/riverroute/mosart_histflds.F90 index e042f40..18534f1 100644 --- a/src/riverroute/mosart_histflds.F90 +++ b/src/riverroute/mosart_histflds.F90 @@ -23,6 +23,7 @@ module mosart_histflds type(hist_pointer_type), allocatable :: h_runoffocn(:) type(hist_pointer_type), allocatable :: h_runofftot(:) type(hist_pointer_type), allocatable :: h_direct(:) + type(hist_pointer_type), allocatable :: h_direct_glc(:) type(hist_pointer_type), allocatable :: h_dvolrdtlnd(:) type(hist_pointer_type), allocatable :: h_dvolrdtocn(:) type(hist_pointer_type), allocatable :: h_volr(:) @@ -31,8 +32,8 @@ module mosart_histflds type(hist_pointer_type), allocatable :: h_qgwl(:) real(r8), pointer :: h_volr_mch(:) - real(r8), pointer :: h_qglc_liq(:) - real(r8), pointer :: h_qglc_ice(:) + real(r8), pointer :: h_qglc_liq_input(:) + real(r8), pointer :: h_qglc_ice_input(:) !------------------------------------------------------------------------ contains @@ -62,6 +63,7 @@ subroutine mosart_histflds_init(begr, endr, ntracers) allocate(h_qsur(ntracers)) allocate(h_qsub(ntracers)) allocate(h_qgwl(ntracers)) + allocate(h_direct_glc(2)) do nt = 1,ntracers allocate(h_runofflnd(nt)%data(begr:endr)) @@ -75,10 +77,12 @@ subroutine mosart_histflds_init(begr, endr, ntracers) allocate(h_qsub(nt)%data(begr:endr)) allocate(h_qgwl(nt)%data(begr:endr)) end do + allocate(h_direct_glc(ctl%nt_liq)%data(begr:endr)) + allocate(h_direct_glc(ctl%nt_ice)%data(begr:endr)) allocate(h_volr_mch(begr:endr)) - allocate(h_qglc_liq(begr:endr)) - allocate(h_qglc_ice(begr:endr)) + allocate(h_qglc_liq_input(begr:endr)) + allocate(h_qglc_ice_input(begr:endr)) !------------------------------------------------------- ! Build master field list of all possible fields in a history file. @@ -95,7 +99,7 @@ subroutine mosart_histflds_init(begr, endr, ntracers) call mosart_hist_addfld (fname='RIVER_DISCHARGE_TO_OCEAN'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & avgflag='A', long_name='MOSART river discharge into ocean: '//trim(ctl%tracer_names(nt)), & - ptr_rof=h_runoffocn(nt)%data, default='inactive') + ptr_rof=h_runoffocn(nt)%data, default='active') call mosart_hist_addfld (fname='TOTAL_DISCHARGE_TO_OCEAN'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & avgflag='A', long_name='MOSART total discharge into ocean: '//trim(ctl%tracer_names(nt)), & @@ -105,6 +109,10 @@ subroutine mosart_histflds_init(begr, endr, ntracers) avgflag='A', long_name='MOSART direct discharge into ocean: '//trim(ctl%tracer_names(nt)), & ptr_rof=h_direct(nt)%data, default='active') + call mosart_hist_addfld (fname='DIRECT_DISCHARGE_TO_OCEAN_GLC'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & + avgflag='A', long_name='MOSART direct discharge into ocean from glc: '//trim(ctl%tracer_names(nt)), & + ptr_rof=h_direct_glc(nt)%data, default='active') + call mosart_hist_addfld (fname='STORAGE'//'_'//trim(ctl%tracer_names(nt)), units='m3', & avgflag='A', long_name='MOSART storage: '//trim(ctl%tracer_names(nt)), & ptr_rof=h_volr(nt)%data, default='inactive') @@ -142,13 +150,13 @@ subroutine mosart_histflds_init(begr, endr, ntracers) avgflag='A', long_name='Actual irrigation (if limited by river storage)', & ptr_rof=ctl%qirrig_actual, default='inactive') - call mosart_hist_addfld (fname='QGLC_LIQ', units='m3', & + call mosart_hist_addfld (fname='QGLC_LIQ_INPUT', units='m3', & avgflag='A', long_name='liquid runoff from glc input', & - ptr_rof=h_qglc_liq, default='inactive') + ptr_rof=h_qglc_liq_input, default='active') - call mosart_hist_addfld (fname='QGLC_ICE', units='m3', & + call mosart_hist_addfld (fname='QGLC_ICE_INPUT', units='m3', & avgflag='A', long_name='ice runoff from glc input', & - ptr_rof=h_qglc_ice, default='inactive') + ptr_rof=h_qglc_ice_input, default='active') ! print masterlist of history fields call mosart_hist_printflds() @@ -168,6 +176,10 @@ subroutine mosart_histflds_set(ntracers) ! Local variables integer :: nt + integer :: nt_liq, nt_ice + + nt_liq = ctl%nt_liq + nt_ice = ctl%nt_ice do nt = 1,ntracers h_runofflnd(nt)%data(:) = ctl%runofflnd(:,nt) @@ -181,8 +193,10 @@ subroutine mosart_histflds_set(ntracers) h_qgwl(nt)%data(:) = ctl%qgwl(:,nt) end do h_volr_mch(:) = Trunoff%wr(:,1) - h_qglc_liq(:) = ctl%qglc_liq(:) - h_qglc_ice(:) = ctl%qglc_ice(:) + h_qglc_liq_input(:) = ctl%qglc_liq(:) + h_qglc_ice_input(:) = ctl%qglc_ice(:) + h_direct_glc(nt_liq)%data(:) = ctl%direct_glc(:,nt_liq) + h_direct_glc(nt_ice)%data(:) = ctl%direct_glc(:,nt_ice) end subroutine mosart_histflds_set From 881fb9d06aaee0af4b143db91ae982162447dab5 Mon Sep 17 00:00:00 2001 From: Samuel Levis Date: Wed, 5 Jun 2024 17:46:34 -0600 Subject: [PATCH 53/86] Fixed test category for betsy versus izumi in one test --- cime_config/testdefs/testlist_mosart.xml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cime_config/testdefs/testlist_mosart.xml b/cime_config/testdefs/testlist_mosart.xml index 8030578..9e79cbd 100644 --- a/cime_config/testdefs/testlist_mosart.xml +++ b/cime_config/testdefs/testlist_mosart.xml @@ -62,8 +62,8 @@ - - + + From 8fd94746591f5ff5abd1f751da2ff7067a7902a5 Mon Sep 17 00:00:00 2001 From: mvertens Date: Thu, 6 Jun 2024 04:38:05 -0600 Subject: [PATCH 54/86] fixed compilation problems with nag --- src/riverroute/mosart_control_type.F90 | 13 ++++++------- src/riverroute/mosart_driver.F90 | 3 +-- 2 files changed, 7 insertions(+), 9 deletions(-) diff --git a/src/riverroute/mosart_control_type.F90 b/src/riverroute/mosart_control_type.F90 index 9d98de3..1245545 100644 --- a/src/riverroute/mosart_control_type.F90 +++ b/src/riverroute/mosart_control_type.F90 @@ -1,9 +1,9 @@ module mosart_control_type - use shr_kind_mod, only : r8 => shr_kind_r8, CL => SHR_KIND_CL + use shr_kind_mod, only : r8 => shr_kind_r8 use shr_sys_mod, only : shr_sys_abort use shr_const_mod, only : shr_const_pi, shr_const_rearth - use shr_mpi_mod, only : shr_mpi_sum, shr_mpi_max + use shr_mpi_mod, only : shr_mpi_sum use mosart_io, only : ncd_io, ncd_pio_openfile, ncd_pio_closefile use mosart_vars, only : mainproc, iam, npes, mpicom_rof, iulog, spval, re use pio, only : file_desc_t, PIO_BCAST_ERROR, pio_seterrorhandling @@ -423,7 +423,6 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & integer, pointer :: halo_list(:) integer, pointer :: seqlist(:) integer, allocatable :: store_halo_index(:) - integer :: nglob character(len=*),parameter :: subname = '(mosart_control_type: init_decomp) ' !----------------------------------------------------------------------- @@ -1110,10 +1109,10 @@ subroutine calc_gradient(this, fld, fld_halo_array, dfld_dx, dfld_dy, rc) integer :: i, n, nr ! local indices real(r8) :: deg2rad real(r8) :: mean_dx, mean_dy, dlon, dlat - real(r8) :: ax_indices(4) ! x indices to add - real(r8) :: sx_indices(4) ! x indices to subtract - real(r8) :: ay_indices(4) ! y indices to add - real(r8) :: sy_indices(4) ! y indices to subtract + integer :: ax_indices(4) ! x indices to add + integer :: sx_indices(4) ! x indices to subtract + integer :: ay_indices(4) ! y indices to add + integer :: sy_indices(4) ! y indices to subtract real(r8) :: fld_surrounding(max_num_halo) real(r8) :: dx(max_num_halo) real(r8) :: dy(max_num_halo) diff --git a/src/riverroute/mosart_driver.F90 b/src/riverroute/mosart_driver.F90 index eacfe25..83fc1ee 100644 --- a/src/riverroute/mosart_driver.F90 +++ b/src/riverroute/mosart_driver.F90 @@ -6,7 +6,6 @@ module mosart_driver use shr_kind_mod , only : r8 => shr_kind_r8, CS => shr_kind_cs, CL => shr_kind_CL use shr_sys_mod , only : shr_sys_abort - use shr_mpi_mod , only : shr_mpi_sum, shr_mpi_max use shr_const_mod , only : SHR_CONST_PI, SHR_CONST_CDAY use shr_string_mod , only : shr_string_listGetNum, shr_string_listGetName use mosart_vars , only : re, spval, iulog, ice_runoff, & @@ -167,7 +166,7 @@ subroutine mosart_read_namelist() write(iulog,'(a,i8)') ' coupling_period = ',coupling_period write(iulog,'(a,i8)') ' delt_mosart = ',delt_mosart write(iulog,'(a)' ) ' decomp option = '//trim(decomp_option) - write(iulog,'(a,l)' ) ' use_halo_option = ',use_halo_option + write(iulog,'(a,l1)') ' use_halo_option = ',use_halo_option write(iulog,'(a)' ) ' bypass_routing option = '//trim(bypass_routing_option) write(iulog,'(a)' ) ' qgwl runoff option = '//trim(qgwl_runoff_option) write(iulog,'(a)' ) ' mosart tracers = '//trim(mosart_tracers) From 5ef52061f9668015430bf5cf9f204607e01a64a3 Mon Sep 17 00:00:00 2001 From: mvertens Date: Thu, 6 Jun 2024 04:48:47 -0600 Subject: [PATCH 55/86] addressed https://github.com/ESCOMP/MOSART/issues/93 --- src/riverroute/mosart_io.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/riverroute/mosart_io.F90 b/src/riverroute/mosart_io.F90 index 15ae9f9..98d6e77 100644 --- a/src/riverroute/mosart_io.F90 +++ b/src/riverroute/mosart_io.F90 @@ -200,8 +200,8 @@ subroutine ncd_pio_openfile(file, fname, mode) character(len=*),parameter :: subname='ncd_pio_openfile' ! subroutine name !----------------------------------------------------------------------- + call pio_seterrorhandling(file, PIO_BCAST_ERROR) ierr = pio_openfile(pio_subsystem, file, io_type, fname, mode) - if(ierr/= PIO_NOERR) then call shr_sys_abort(subname//'ERROR: Failed to open file') else if(pio_iotask_rank(pio_subsystem)==0 .and. mainproc) then @@ -247,8 +247,8 @@ subroutine ncd_pio_createfile(file, fname) if(io_type == PIO_IOTYPE_NETCDF .or. io_type == PIO_IOTYPE_PNETCDF) then iomode = ior(iomode, io_format) endif + call pio_seterrorhandling(file, PIO_BCAST_ERROR) ierr = pio_createfile(pio_subsystem, file, io_type, fname, iomode) - if(ierr/= PIO_NOERR) then call shr_sys_abort( subname//' ERROR: Failed to open file to write: '//trim(fname)) else if(pio_iotask_rank(pio_subsystem)==0 .and. mainproc) then From 38b64c84ffed689f1f99fe69bf4bd695dc6f7584 Mon Sep 17 00:00:00 2001 From: mvertens Date: Thu, 6 Jun 2024 04:57:21 -0600 Subject: [PATCH 56/86] updates to get build working with nag --- src/riverroute/mosart_control_type.F90 | 8 ++++---- src/riverroute/mosart_driver.F90 | 3 +-- src/riverroute/mosart_io.F90 | 4 ++-- 3 files changed, 7 insertions(+), 8 deletions(-) diff --git a/src/riverroute/mosart_control_type.F90 b/src/riverroute/mosart_control_type.F90 index 76d6452..ec98507 100644 --- a/src/riverroute/mosart_control_type.F90 +++ b/src/riverroute/mosart_control_type.F90 @@ -1159,10 +1159,10 @@ subroutine calc_gradient(this, fld, fld_halo_array, dfld_dx, dfld_dy, rc) integer :: i, n, nr ! local indices real(r8) :: deg2rad real(r8) :: mean_dx, mean_dy, dlon, dlat - real(r8) :: ax_indices(4) ! x indices to add - real(r8) :: sx_indices(4) ! x indices to subtract - real(r8) :: ay_indices(4) ! y indices to add - real(r8) :: sy_indices(4) ! y indices to subtract + integer :: ax_indices(4) ! x indices to add + integer :: sx_indices(4) ! x indices to subtract + integer :: ay_indices(4) ! y indices to add + integer :: sy_indices(4) ! y indices to subtract real(r8) :: fld_surrounding(max_num_halo) real(r8) :: dx(max_num_halo) real(r8) :: dy(max_num_halo) diff --git a/src/riverroute/mosart_driver.F90 b/src/riverroute/mosart_driver.F90 index 18fccbf..2ec8161 100644 --- a/src/riverroute/mosart_driver.F90 +++ b/src/riverroute/mosart_driver.F90 @@ -6,7 +6,6 @@ module mosart_driver use shr_kind_mod , only : r8 => shr_kind_r8, CS => shr_kind_cs, CL => shr_kind_CL use shr_sys_mod , only : shr_sys_abort - use shr_mpi_mod , only : shr_mpi_sum, shr_mpi_max use shr_const_mod , only : SHR_CONST_PI, SHR_CONST_CDAY use mosart_vars , only : re, spval, iulog, ice_runoff, & frivinp, nsrContinue, nsrBranch, nsrStartup, nsrest, & @@ -166,7 +165,7 @@ subroutine mosart_read_namelist() write(iulog,'(a,i8)') ' coupling_period = ',coupling_period write(iulog,'(a,i8)') ' delt_mosart = ',delt_mosart write(iulog,'(a)' ) ' decomp option = '//trim(decomp_option) - write(iulog,'(a,l)' ) ' use_halo_option = ',use_halo_option + write(iulog,'(a,l1)') ' use_halo_option = ',use_halo_option write(iulog,'(a)' ) ' bypass_routing option = '//trim(bypass_routing_option) write(iulog,'(a)' ) ' qgwl runoff option = '//trim(qgwl_runoff_option) write(iulog,'(a)' ) ' mosart tracers = '//trim(mosart_tracers) diff --git a/src/riverroute/mosart_io.F90 b/src/riverroute/mosart_io.F90 index 15ae9f9..98d6e77 100644 --- a/src/riverroute/mosart_io.F90 +++ b/src/riverroute/mosart_io.F90 @@ -200,8 +200,8 @@ subroutine ncd_pio_openfile(file, fname, mode) character(len=*),parameter :: subname='ncd_pio_openfile' ! subroutine name !----------------------------------------------------------------------- + call pio_seterrorhandling(file, PIO_BCAST_ERROR) ierr = pio_openfile(pio_subsystem, file, io_type, fname, mode) - if(ierr/= PIO_NOERR) then call shr_sys_abort(subname//'ERROR: Failed to open file') else if(pio_iotask_rank(pio_subsystem)==0 .and. mainproc) then @@ -247,8 +247,8 @@ subroutine ncd_pio_createfile(file, fname) if(io_type == PIO_IOTYPE_NETCDF .or. io_type == PIO_IOTYPE_PNETCDF) then iomode = ior(iomode, io_format) endif + call pio_seterrorhandling(file, PIO_BCAST_ERROR) ierr = pio_createfile(pio_subsystem, file, io_type, fname, iomode) - if(ierr/= PIO_NOERR) then call shr_sys_abort( subname//' ERROR: Failed to open file to write: '//trim(fname)) else if(pio_iotask_rank(pio_subsystem)==0 .and. mainproc) then From b8f3aefdd2c7b57e6b1fb157b098414810412b8d Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 3 Jun 2024 03:33:55 -0600 Subject: [PATCH 57/86] cleaned up glc direct claculation --- src/riverroute/mosart_driver.F90 | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/riverroute/mosart_driver.F90 b/src/riverroute/mosart_driver.F90 index 2ec8161..917a5ca 100644 --- a/src/riverroute/mosart_driver.F90 +++ b/src/riverroute/mosart_driver.F90 @@ -465,7 +465,6 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) call t_stopf('mosartr_budgetset') endif - ! initialize data for euler solver, in m3/s here do nr = begr,endr do nt = 1,ntracers @@ -565,7 +564,6 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) !----------------------------------------------------- ctl%direct(:,:) = 0._r8 - ctl%direct_glc(:,:) = 0._r8 !----------------------------------------------------- !--- direct to outlet: all liquid and frozen runoff from glc @@ -588,8 +586,8 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) cnt = 0 do nr = begr,endr cnt = cnt + 1 - ctl%direct_glc(nr,nt_liq) = ctl%direct_glc(nr,nt_liq) + dst_direct(nt_liq,cnt) - ctl%direct_glc(nr,nt_ice) = ctl%direct_glc(nr,nt_ice) + dst_direct(nt_ice,cnt) + ctl%direct_glc(nr,nt_liq) = dst_direct(nt_liq,cnt) + ctl%direct_glc(nr,nt_ice) = dst_direct(nt_ice,cnt) enddo !----------------------------------------------------- From d729df9db1f186360b78dcf1b15e8f9a143fd1aa Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 5 Jun 2024 22:47:00 -0600 Subject: [PATCH 58/86] new ability to set separate of fluxes to mediator as option --- cime_config/namelist_definition_mosart.xml | 16 ++++++++- src/cpl/nuopc/rof_import_export.F90 | 33 +++++++++++++++--- src/riverroute/mosart_driver.F90 | 39 ++++++++++++---------- src/riverroute/mosart_vars.F90 | 13 ++++---- 4 files changed, 72 insertions(+), 29 deletions(-) diff --git a/cime_config/namelist_definition_mosart.xml b/cime_config/namelist_definition_mosart.xml index a6ad704..24916b8 100644 --- a/cime_config/namelist_definition_mosart.xml +++ b/cime_config/namelist_definition_mosart.xml @@ -288,10 +288,24 @@ -24 - Frequency to perform budget check. Similar to nhtfrq, + Frequency to perform budget check. Similar to nhtfrq, positive means in time steps, 0=monthly, negative means hours (i.e. 24 means every 24 time-steps and -24 means every day + + logical + mosart + mosart_inparm + + .false. + + + Default: .false. + If .true., glc2ocn fluxes that are passed through mosart will be sent + as a separate fields to the mediator. + + + diff --git a/src/cpl/nuopc/rof_import_export.F90 b/src/cpl/nuopc/rof_import_export.F90 index d31cb60..00938a8 100644 --- a/src/cpl/nuopc/rof_import_export.F90 +++ b/src/cpl/nuopc/rof_import_export.F90 @@ -9,7 +9,7 @@ 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 mosart_vars , only : iulog, mainproc, mpicom_rof, ice_runoff + use mosart_vars , only : iulog, mainproc, mpicom_rof, ice_runoff, separate_glc2ocn_fluxes use mosart_data , only : ctl, TRunoff, TUnit use mosart_timemanager , only : get_nstep use nuopc_shr_methods , only : chkerr @@ -82,9 +82,14 @@ subroutine advertise_fields(gcomp, flds_scalar_name, rc) isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) read(cvalue,*) flds_r2l_stream_channel_depths + call fldlist_add(fldsFrRof_num, fldsFrRof, trim(flds_scalar_name)) call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofl') call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofi') + if (separate_glc2ocn_fluxes) then + call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofl_glc') + call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofi_glc') + end if call fldlist_add(fldsFrRof_num, fldsFrRof, 'Flrr_flood') call fldlist_add(fldsFrRof_num, fldsFrRof, 'Flrr_volr') call fldlist_add(fldsFrRof_num, fldsFrRof, 'Flrr_volrmch') @@ -309,6 +314,8 @@ subroutine export_fields (gcomp, begr, endr, rc) integer :: nliq, nice real(r8) :: rofl(begr:endr) real(r8) :: rofi(begr:endr) + real(r8) :: rofl_glc(begr:endr) + real(r8) :: rofi_glc(begr:endr) real(r8) :: flood(begr:endr) real(r8) :: volr(begr:endr) real(r8) :: volrmch(begr:endr) @@ -361,10 +368,18 @@ subroutine export_fields (gcomp, begr, endr, rc) rofi(n) = 0._r8 end do end if - do n = begr,endr - rofl(n) = rofl(n) + ctl%direct_glc(n,nliq) / (ctl%area(n)*0.001_r8) - rofi(n) = rofl(n) + ctl%direct_glc(n,nice) / (ctl%area(n)*0.001_r8) - end do + + if (separate_glc2ocn_fluxes) then + do n = begr,endr + rofl_glc(n) = ctl%direct_glc(n,nliq) / (ctl%area(n)*0.001_r8) + rofi_glc(n) = ctl%direct_glc(n,nice) / (ctl%area(n)*0.001_r8) + end do + else + do n = begr,endr + rofl(n) = rofl(n) + ctl%direct_glc(n,nliq) / (ctl%area(n)*0.001_r8) + rofi(n) = rofi(n) + ctl%direct_glc(n,nice) / (ctl%area(n)*0.001_r8) + 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. @@ -388,6 +403,14 @@ subroutine export_fields (gcomp, begr, endr, rc) call state_setexport(exportState, 'Forr_rofi', begr, endr, input=rofi, do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (separate_glc2ocn_fluxes) then + call state_setexport(exportState, 'Forr_rofl_glc', begr, endr, input=rofl_glc, do_area_correction=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call state_setexport(exportState, 'Forr_rofi_glc', begr, endr, input=rofi_glc, do_area_correction=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + call state_setexport(exportState, 'Flrr_flood', begr, endr, input=flood, do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return diff --git a/src/riverroute/mosart_driver.F90 b/src/riverroute/mosart_driver.F90 index 917a5ca..9bdcb9b 100644 --- a/src/riverroute/mosart_driver.F90 +++ b/src/riverroute/mosart_driver.F90 @@ -11,7 +11,8 @@ module mosart_driver frivinp, nsrContinue, nsrBranch, nsrStartup, nsrest, & inst_index, inst_suffix, inst_name, decomp_option, & bypass_routing_option, qgwl_runoff_option, barrier_timers, & - mainproc, npes, iam, mpicom_rof, budget_frq, isecspday + mainproc, npes, iam, mpicom_rof, budget_frq, isecspday, & + separate_glc2ocn_fluxes use mosart_data , only : ctl, Tctl, Tunit, TRunoff, Tpara use mosart_budget_type , only : budget_type use mosart_fileutils , only : getfil @@ -42,11 +43,11 @@ module mosart_driver public :: mosart_run ! River routing model ! mosart namelists - integer :: coupling_period ! mosart coupling period - integer :: delt_mosart ! mosart internal timestep (->nsub) - logical :: use_halo_option ! enable halo capability using ESMF - character(len=CS) :: mosart_tracers ! colon delimited string of tracer names - character(len=CS) :: mosart_euler_calc ! colon delimited string of logicals for using Euler algorithm + integer :: coupling_period ! mosart coupling period + integer :: delt_mosart ! mosart internal timestep (->nsub) + logical :: use_halo_option ! enable halo capability using ESMF + character(len=CS) :: mosart_tracers ! colon delimited string of tracer names + character(len=CS) :: mosart_euler_calc ! colon delimited string of logicals for using Euler algorithm ! subcycling integer :: nsub_save ! previous nsub @@ -91,7 +92,8 @@ subroutine mosart_read_namelist() namelist /mosart_inparm / frivinp, finidat, nrevsn, coupling_period, ice_runoff, & ndens, mfilt, nhtfrq, fincl1, fincl2, fincl3, fexcl1, fexcl2, fexcl3, & avgflag_pertape, decomp_option, bypass_routing_option, qgwl_runoff_option, & - use_halo_option, delt_mosart, mosart_tracers, mosart_euler_calc, budget_frq + use_halo_option, delt_mosart, mosart_tracers, mosart_euler_calc, budget_frq, & + separate_glc2ocn_fluxes ! Preset values ice_runoff = .true. @@ -105,6 +107,7 @@ subroutine mosart_read_namelist() use_halo_option = .false. mosart_tracers = 'LIQ:ICE' mosart_euler_calc = 'T:F' + separate_glc2ocn_fluxes = .false. nlfilename_rof = "mosart_in" // trim(inst_suffix) inquire (file = trim(nlfilename_rof), exist = lexist) @@ -148,6 +151,7 @@ subroutine mosart_read_namelist() call mpi_bcast (mosart_tracers, CS, MPI_CHARACTER, 0, mpicom_rof, ier) call mpi_bcast (mosart_euler_calc, CS, MPI_CHARACTER, 0, mpicom_rof, ier) call mpi_bcast (budget_frq,1,MPI_INTEGER,0,mpicom_rof,ier) + call mpi_bcast (separate_glc2ocn_fluxes, 1, MPI_LOGICAL, 0, mpicom_rof, ier) ! Determine number of tracers and array of tracer names and initialize module variables call ctl%init_tracer_names(mosart_tracers) @@ -161,17 +165,18 @@ subroutine mosart_read_namelist() if (mainproc) then write(iulog,*) 'define run:' - write(iulog,'(a)' ) ' run type = '//trim(runtyp(nsrest+1)) - write(iulog,'(a,i8)') ' coupling_period = ',coupling_period - write(iulog,'(a,i8)') ' delt_mosart = ',delt_mosart - write(iulog,'(a)' ) ' decomp option = '//trim(decomp_option) - write(iulog,'(a,l1)') ' use_halo_option = ',use_halo_option - write(iulog,'(a)' ) ' bypass_routing option = '//trim(bypass_routing_option) - write(iulog,'(a)' ) ' qgwl runoff option = '//trim(qgwl_runoff_option) - write(iulog,'(a)' ) ' mosart tracers = '//trim(mosart_tracers) - write(iulog,'(a)' ) ' mosart euler calc = '//trim(mosart_euler_calc) + write(iulog,'(a)' ) ' run type = '//trim(runtyp(nsrest+1)) + write(iulog,'(a,i8)') ' coupling_period = ',coupling_period + write(iulog,'(a,i8)') ' delt_mosart = ',delt_mosart + write(iulog,'(a)' ) ' decomp option = '//trim(decomp_option) + write(iulog,'(a,l1)') ' use_halo_option = ',use_halo_option + write(iulog,'(a)' ) ' bypass_routing option = '//trim(bypass_routing_option) + write(iulog,'(a)' ) ' qgwl runoff option = '//trim(qgwl_runoff_option) + write(iulog,'(a)' ) ' mosart tracers = '//trim(mosart_tracers) + write(iulog,'(a)' ) ' mosart euler calc = '//trim(mosart_euler_calc) + write(iulog,'(a,l1)') ' separate_glc2ocn_fluxes = ',separate_glc2ocn_fluxes if (nsrest == nsrStartup .and. finidat /= ' ') then - write(iulog,'(a)') ' mosart initial data = '//trim(finidat) + write(iulog,'(a)') ' mosart initial data = '//trim(finidat) end if endif diff --git a/src/riverroute/mosart_vars.F90 b/src/riverroute/mosart_vars.F90 index cc0cc48..efb40f0 100644 --- a/src/riverroute/mosart_vars.F90 +++ b/src/riverroute/mosart_vars.F90 @@ -31,12 +31,13 @@ module mosart_vars integer :: nsrest = iundef ! Type of run ! Namelist variables - character(len=CL) :: frivinp ! MOSART input data file name - logical :: ice_runoff ! true => runoff is split into liquid and ice, otherwise just liquid - character(len=CS) :: decomp_option ! decomp option - character(len=CS) :: bypass_routing_option ! bypass routing model method - character(len=CS) :: qgwl_runoff_option ! method for handling qgwl runoff - integer :: budget_frq = -24 ! budget check frequency + character(len=CL) :: frivinp ! MOSART input data file name + logical :: ice_runoff ! true => runoff is split into liquid and ice, otherwise just liquid + character(len=CS) :: decomp_option ! decomp option + character(len=CS) :: bypass_routing_option ! bypass routing model method + character(len=CS) :: qgwl_runoff_option ! method for handling qgwl runoff + integer :: budget_frq = -24 ! budget check frequency + logical :: separate_glc2cn_fluxes ! true => send fluxes from glc through mozart separately to mediator ! Metadata variables used in history and restart generation character(len=CL) :: caseid = ' ' ! case id From 377d6ca94fd9fb554dd8f032f6987c656c680892 Mon Sep 17 00:00:00 2001 From: mvertens Date: Thu, 6 Jun 2024 07:06:51 -0600 Subject: [PATCH 59/86] reverted changes in mosart_io.F90 since they caused the model to crash with a segmentation error --- src/riverroute/mosart_io.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/riverroute/mosart_io.F90 b/src/riverroute/mosart_io.F90 index 98d6e77..15ae9f9 100644 --- a/src/riverroute/mosart_io.F90 +++ b/src/riverroute/mosart_io.F90 @@ -200,8 +200,8 @@ subroutine ncd_pio_openfile(file, fname, mode) character(len=*),parameter :: subname='ncd_pio_openfile' ! subroutine name !----------------------------------------------------------------------- - call pio_seterrorhandling(file, PIO_BCAST_ERROR) ierr = pio_openfile(pio_subsystem, file, io_type, fname, mode) + if(ierr/= PIO_NOERR) then call shr_sys_abort(subname//'ERROR: Failed to open file') else if(pio_iotask_rank(pio_subsystem)==0 .and. mainproc) then @@ -247,8 +247,8 @@ subroutine ncd_pio_createfile(file, fname) if(io_type == PIO_IOTYPE_NETCDF .or. io_type == PIO_IOTYPE_PNETCDF) then iomode = ior(iomode, io_format) endif - call pio_seterrorhandling(file, PIO_BCAST_ERROR) ierr = pio_createfile(pio_subsystem, file, io_type, fname, iomode) + if(ierr/= PIO_NOERR) then call shr_sys_abort( subname//' ERROR: Failed to open file to write: '//trim(fname)) else if(pio_iotask_rank(pio_subsystem)==0 .and. mainproc) then From 410b04a6998dc9ca88b4143d58f8efa65e9535fd Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Thu, 6 Jun 2024 08:21:02 -0600 Subject: [PATCH 60/86] updates for pio error checking --- src/riverroute/mosart_io.F90 | 33 +++++++++++++++++++++------------ src/riverroute/mosart_vars.F90 | 2 +- 2 files changed, 22 insertions(+), 13 deletions(-) diff --git a/src/riverroute/mosart_io.F90 b/src/riverroute/mosart_io.F90 index 98d6e77..06945ea 100644 --- a/src/riverroute/mosart_io.F90 +++ b/src/riverroute/mosart_io.F90 @@ -196,17 +196,19 @@ subroutine ncd_pio_openfile(file, fname, mode) integer , intent(in) :: mode ! file mode ! Local variables + integer :: oldmethod integer :: ierr character(len=*),parameter :: subname='ncd_pio_openfile' ! subroutine name !----------------------------------------------------------------------- - call pio_seterrorhandling(file, PIO_BCAST_ERROR) + call pio_seterrorhandling(pio_subsystem, PIO_BCAST_ERROR, oldmethod) ierr = pio_openfile(pio_subsystem, file, io_type, fname, mode) if(ierr/= PIO_NOERR) then call shr_sys_abort(subname//'ERROR: Failed to open file') else if(pio_iotask_rank(pio_subsystem)==0 .and. mainproc) then write(iulog,*) 'Opened existing file ', trim(fname), file%fh end if + call pio_seterrorhandling(pio_subsystem, oldmethod) end subroutine ncd_pio_openfile @@ -237,6 +239,7 @@ subroutine ncd_pio_createfile(file, fname) character(len=*), intent(in) :: fname ! File name to create ! Local variables + integer :: oldmethod integer :: ierr integer :: iomode character(len=*),parameter :: subname='ncd_pio_createfile' ! subroutine name @@ -247,13 +250,14 @@ subroutine ncd_pio_createfile(file, fname) if(io_type == PIO_IOTYPE_NETCDF .or. io_type == PIO_IOTYPE_PNETCDF) then iomode = ior(iomode, io_format) endif - call pio_seterrorhandling(file, PIO_BCAST_ERROR) + call pio_seterrorhandling(pio_subsystem, PIO_BCAST_ERROR, oldmethod) ierr = pio_createfile(pio_subsystem, file, io_type, fname, iomode) if(ierr/= PIO_NOERR) then call shr_sys_abort( subname//' ERROR: Failed to open file to write: '//trim(fname)) else if(pio_iotask_rank(pio_subsystem)==0 .and. mainproc) then write(iulog,*) 'Opened file ', trim(fname), ' to write', file%fh end if + call pio_seterrorhandling(pio_subsystem, oldmethod) end subroutine ncd_pio_createfile @@ -272,6 +276,7 @@ subroutine check_var(ncid, varname, vardesc, readvar, print_err ) logical, optional, intent(in) :: print_err ! If should print about error ! Local variables + integer :: oldmethod integer :: ret ! return value logical :: log_err ! if should log error character(len=*),parameter :: subname='check_var' ! subroutine name @@ -284,14 +289,15 @@ subroutine check_var(ncid, varname, vardesc, readvar, print_err ) log_err = .true. end if readvar = .true. - call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR, oldmethod) ret = pio_inq_varid (ncid, varname, vardesc) if (ret /= PIO_NOERR) then readvar = .false. - if (mainproc .and. log_err) & - write(iulog,*) subname//': variable ',trim(varname),' is not on dataset' + if (mainproc .and. log_err) then + write(iulog,*) subname//': variable ',trim(varname),' is not on dataset' + end if end if - call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + call pio_seterrorhandling(ncid, oldmethod) end subroutine check_var @@ -355,11 +361,12 @@ subroutine ncd_inqdid(ncid,name,dimid,dimexist) logical,optional, intent(out):: dimexist ! if this dimension exists or not ! Local variables + integer :: oldmethod integer :: status !----------------------------------------------------------------------- if ( present(dimexist) )then - call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR, oldmethod) end if status = PIO_inq_dimid(ncid,name,dimid) if ( present(dimexist) )then @@ -368,7 +375,7 @@ subroutine ncd_inqdid(ncid,name,dimid,dimexist) else dimexist = .false. end if - call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + call pio_seterrorhandling(ncid, oldmethod) end if end subroutine ncd_inqdid @@ -430,6 +437,7 @@ subroutine ncd_inqfdims(ncid, isgrid2d, ni, nj, ns) integer , intent(out) :: nj integer , intent(out) :: ns ! Local variables + integer :: oldmethod integer :: dimid ! netCDF id integer :: ier ! error status character(len=CS) :: subname = 'surfrd_filedims' ! subroutine name @@ -438,7 +446,7 @@ subroutine ncd_inqfdims(ncid, isgrid2d, ni, nj, ns) ni = 0 nj = 0 - call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR, oldmethod) ier = pio_inq_dimid (ncid, 'lon', dimid) if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, ni) ier = pio_inq_dimid (ncid, 'lat', dimid) @@ -460,7 +468,7 @@ subroutine ncd_inqfdims(ncid, isgrid2d, ni, nj, ns) if (ier == PIO_NOERR) nj = 1 end if - call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + call pio_seterrorhandling(ncid, oldmethod) if (ni == 0 .or. nj == 0) then write(iulog,*) trim(subname),' ERROR: ni,nj = ',ni,nj,' cannot be zero ' @@ -492,13 +500,14 @@ subroutine ncd_inqvid(ncid,name,varid,vardesc,readvar) logical, optional, intent(out) :: readvar ! does variable exist ! Local variables + integer :: oldmethod integer :: ret ! return code character(len=*),parameter :: subname='ncd_inqvid' ! subroutine name !----------------------------------------------------------------------- if (present(readvar)) then readvar = .false. - call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + call pio_seterrorhandling(pio_subsystem, PIO_BCAST_ERROR, oldmethod) ret = pio_inq_varid(ncid,name,vardesc) if (ret /= PIO_NOERR) then if (mainproc) write(iulog,*) subname//': variable ',trim(name),' is not on dataset' @@ -506,7 +515,7 @@ subroutine ncd_inqvid(ncid,name,varid,vardesc,readvar) else readvar = .true. end if - call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + call pio_seterrorhandling(ncid, oldmethod) else ret = pio_inq_varid(ncid,name,vardesc) endif diff --git a/src/riverroute/mosart_vars.F90 b/src/riverroute/mosart_vars.F90 index efb40f0..114fa2e 100644 --- a/src/riverroute/mosart_vars.F90 +++ b/src/riverroute/mosart_vars.F90 @@ -37,7 +37,7 @@ module mosart_vars character(len=CS) :: bypass_routing_option ! bypass routing model method character(len=CS) :: qgwl_runoff_option ! method for handling qgwl runoff integer :: budget_frq = -24 ! budget check frequency - logical :: separate_glc2cn_fluxes ! true => send fluxes from glc through mozart separately to mediator + logical :: separate_glc2ocn_fluxes ! true => send fluxes from glc through mozart separately to mediator ! Metadata variables used in history and restart generation character(len=CL) :: caseid = ' ' ! case id From 3c7b9d188c120c72f0a1b981129db86ac824b395 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Thu, 6 Jun 2024 11:00:18 -0600 Subject: [PATCH 61/86] updates to fix pio error checking in mosart_io.F90 --- src/riverroute/mosart_io.F90 | 33 +++++++++++++++++++++------------ 1 file changed, 21 insertions(+), 12 deletions(-) diff --git a/src/riverroute/mosart_io.F90 b/src/riverroute/mosart_io.F90 index 15ae9f9..06945ea 100644 --- a/src/riverroute/mosart_io.F90 +++ b/src/riverroute/mosart_io.F90 @@ -196,17 +196,19 @@ subroutine ncd_pio_openfile(file, fname, mode) integer , intent(in) :: mode ! file mode ! Local variables + integer :: oldmethod integer :: ierr character(len=*),parameter :: subname='ncd_pio_openfile' ! subroutine name !----------------------------------------------------------------------- + call pio_seterrorhandling(pio_subsystem, PIO_BCAST_ERROR, oldmethod) ierr = pio_openfile(pio_subsystem, file, io_type, fname, mode) - if(ierr/= PIO_NOERR) then call shr_sys_abort(subname//'ERROR: Failed to open file') else if(pio_iotask_rank(pio_subsystem)==0 .and. mainproc) then write(iulog,*) 'Opened existing file ', trim(fname), file%fh end if + call pio_seterrorhandling(pio_subsystem, oldmethod) end subroutine ncd_pio_openfile @@ -237,6 +239,7 @@ subroutine ncd_pio_createfile(file, fname) character(len=*), intent(in) :: fname ! File name to create ! Local variables + integer :: oldmethod integer :: ierr integer :: iomode character(len=*),parameter :: subname='ncd_pio_createfile' ! subroutine name @@ -247,13 +250,14 @@ subroutine ncd_pio_createfile(file, fname) if(io_type == PIO_IOTYPE_NETCDF .or. io_type == PIO_IOTYPE_PNETCDF) then iomode = ior(iomode, io_format) endif + call pio_seterrorhandling(pio_subsystem, PIO_BCAST_ERROR, oldmethod) ierr = pio_createfile(pio_subsystem, file, io_type, fname, iomode) - if(ierr/= PIO_NOERR) then call shr_sys_abort( subname//' ERROR: Failed to open file to write: '//trim(fname)) else if(pio_iotask_rank(pio_subsystem)==0 .and. mainproc) then write(iulog,*) 'Opened file ', trim(fname), ' to write', file%fh end if + call pio_seterrorhandling(pio_subsystem, oldmethod) end subroutine ncd_pio_createfile @@ -272,6 +276,7 @@ subroutine check_var(ncid, varname, vardesc, readvar, print_err ) logical, optional, intent(in) :: print_err ! If should print about error ! Local variables + integer :: oldmethod integer :: ret ! return value logical :: log_err ! if should log error character(len=*),parameter :: subname='check_var' ! subroutine name @@ -284,14 +289,15 @@ subroutine check_var(ncid, varname, vardesc, readvar, print_err ) log_err = .true. end if readvar = .true. - call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR, oldmethod) ret = pio_inq_varid (ncid, varname, vardesc) if (ret /= PIO_NOERR) then readvar = .false. - if (mainproc .and. log_err) & - write(iulog,*) subname//': variable ',trim(varname),' is not on dataset' + if (mainproc .and. log_err) then + write(iulog,*) subname//': variable ',trim(varname),' is not on dataset' + end if end if - call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + call pio_seterrorhandling(ncid, oldmethod) end subroutine check_var @@ -355,11 +361,12 @@ subroutine ncd_inqdid(ncid,name,dimid,dimexist) logical,optional, intent(out):: dimexist ! if this dimension exists or not ! Local variables + integer :: oldmethod integer :: status !----------------------------------------------------------------------- if ( present(dimexist) )then - call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR, oldmethod) end if status = PIO_inq_dimid(ncid,name,dimid) if ( present(dimexist) )then @@ -368,7 +375,7 @@ subroutine ncd_inqdid(ncid,name,dimid,dimexist) else dimexist = .false. end if - call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + call pio_seterrorhandling(ncid, oldmethod) end if end subroutine ncd_inqdid @@ -430,6 +437,7 @@ subroutine ncd_inqfdims(ncid, isgrid2d, ni, nj, ns) integer , intent(out) :: nj integer , intent(out) :: ns ! Local variables + integer :: oldmethod integer :: dimid ! netCDF id integer :: ier ! error status character(len=CS) :: subname = 'surfrd_filedims' ! subroutine name @@ -438,7 +446,7 @@ subroutine ncd_inqfdims(ncid, isgrid2d, ni, nj, ns) ni = 0 nj = 0 - call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR, oldmethod) ier = pio_inq_dimid (ncid, 'lon', dimid) if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, ni) ier = pio_inq_dimid (ncid, 'lat', dimid) @@ -460,7 +468,7 @@ subroutine ncd_inqfdims(ncid, isgrid2d, ni, nj, ns) if (ier == PIO_NOERR) nj = 1 end if - call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + call pio_seterrorhandling(ncid, oldmethod) if (ni == 0 .or. nj == 0) then write(iulog,*) trim(subname),' ERROR: ni,nj = ',ni,nj,' cannot be zero ' @@ -492,13 +500,14 @@ subroutine ncd_inqvid(ncid,name,varid,vardesc,readvar) logical, optional, intent(out) :: readvar ! does variable exist ! Local variables + integer :: oldmethod integer :: ret ! return code character(len=*),parameter :: subname='ncd_inqvid' ! subroutine name !----------------------------------------------------------------------- if (present(readvar)) then readvar = .false. - call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + call pio_seterrorhandling(pio_subsystem, PIO_BCAST_ERROR, oldmethod) ret = pio_inq_varid(ncid,name,vardesc) if (ret /= PIO_NOERR) then if (mainproc) write(iulog,*) subname//': variable ',trim(name),' is not on dataset' @@ -506,7 +515,7 @@ subroutine ncd_inqvid(ncid,name,varid,vardesc,readvar) else readvar = .true. end if - call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + call pio_seterrorhandling(ncid, oldmethod) else ret = pio_inq_varid(ncid,name,vardesc) endif From 641414c296367895fe9cb2a0e51de925118f4a3c Mon Sep 17 00:00:00 2001 From: Samuel Levis Date: Thu, 6 Jun 2024 15:20:17 -0600 Subject: [PATCH 62/86] Update a user_nl_mosart comment --- cime_config/user_nl_mosart | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cime_config/user_nl_mosart b/cime_config/user_nl_mosart index e8f3087..e7c8865 100644 --- a/cime_config/user_nl_mosart +++ b/cime_config/user_nl_mosart @@ -1,7 +1,7 @@ !---------------------------------------------------------------------------------- ! Users should add all user specific namelist changes below in the form of ! namelist_var = new_namelist_value -! NOTE: namelist variable rtm_tstep CAN ONLY be changed by modifying the value +! NOTE: namelist variable delt_mosart (the time-step) CAN ONLY be changed by modifying the value ! of the xml variable ROF_NCPL in env_run.xml !---------------------------------------------------------------------------------- From 2695f36fc405d6741773f439724cfd5af3204ca8 Mon Sep 17 00:00:00 2001 From: Samuel Levis Date: Thu, 6 Jun 2024 15:41:03 -0600 Subject: [PATCH 63/86] Updated ChangeLog --- docs/ChangeLog | 48 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/docs/ChangeLog b/docs/ChangeLog index 670f9b2..de7e2da 100644 --- a/docs/ChangeLog +++ b/docs/ChangeLog @@ -1,3 +1,51 @@ +=============================================================== +Tag name: mosart1_1_01 +Originator(s): mvertens +Date: Jun 06, 2024 +One-line Summary: major mosart refactor including addition of new halo capability + +Removed all references to rtm + +files have been renamed and namelists no longer contain rtm in the name + +New modularity: + +introduced new modules with new derived types and methods +mosart_control_type.F90 +mosart_tctl_type.F90 +mosart_tparameter_type.F90 +mosart_tspatialunit_type.F90 +mosart_tstatusflux_type.F90 + +the new modules modularize a lot of the complexity and variables that were previously found in RunOffMod.F90 and permit decomposition initialization to be more flexible and transparent. + +New halo capability + +Ability to have halo regions and communication using ESMF. This is needed for computing derivatives in upcoming new additions to MOSART. +New halo namelist - use_halo_option. When this is set to true halos can be activated. See the test_halo subroutine in mosart_control_type.F90 module. +Verified that the results for the halos are bfb identical regardless of the number of processors that are used. +-To set the values for the exclusive region that will be used in halo operations - you need to access the pointer as is done in the test_halo routine in mosart_control_type.F90: + n = 0 + do nr = this%begr,this%endr + n = n + 1 + this%halo_arrayptr(n) = this%latc(nr)*10. + this%lonc(nr)/100. + end do + + call ESMF_ArrayHalo(this%haloArray, routehandle=this%haloHandle, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + +Issues addressed: +Fixes #93 "if (ierr /= PIO_NOERR)" will not be invoked unless PIO_BCAST_ERROR is explicitly set +Fixes #98 Change namelist items to remove "rtm" in the names of namelist variables +Fixes #97 Remove RTM in more of the MOSART code (filenames, subroutines, variables etc.) +Fixes #99 Add a new mosart_noresm testlist + +Testing: standard testing + izumi -- OK + cheyenne -- OK + +See https://github.com/ESCOMP/MOSART/pull/76 for more details + =============================================================== Tag name: mosart1_0_49 Originator(s): mvertens From c95417e6b12a8f5a25e0e47c7c388a0d0bf725ab Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Fri, 7 Jun 2024 05:59:42 -0600 Subject: [PATCH 64/86] addressed issue https://github.com/ESCOMP/MOSART/issues/95 --- src/riverroute/mosart_budget_type.F90 | 32 ++++++++++++++++----------- src/riverroute/mosart_timemanager.F90 | 2 +- 2 files changed, 20 insertions(+), 14 deletions(-) diff --git a/src/riverroute/mosart_budget_type.F90 b/src/riverroute/mosart_budget_type.F90 index b15571f..3df5c8a 100644 --- a/src/riverroute/mosart_budget_type.F90 +++ b/src/riverroute/mosart_budget_type.F90 @@ -9,7 +9,6 @@ module mosart_budget_type use mosart_vars, only: re, spval, barrier_timers, iulog, mainproc, npes, iam, mpicom_rof use mosart_data, only: ctl, Tctl, Tunit, TRunoff, Tpara use mosart_timemanager, only: get_nstep, get_curr_date - use mpi implicit none private @@ -46,6 +45,13 @@ module mosart_budget_type end type budget_type public :: budget_type + integer, parameter :: index_beg_vol_grc = 1 + integer, parameter :: index_end_vol_grc = 2 + integer, parameter :: index_in_grc = 3 + integer, parameter :: index_out_grc = 4 + integer, parameter :: index_net_grc = 5 + integer, parameter :: index_lag_grc = 6 + character(*), parameter :: u_FILE_u = & __FILE__ @@ -201,12 +207,12 @@ subroutine check_budget(this, begr, endr, ntracers, dt) end do do nt = 1, ntracers - tmp_in(1, nt) = sum(this%beg_vol_grc(:, nt)) - tmp_in(2, nt) = sum(this%end_vol_grc(:, nt)) - tmp_in(3, nt) = sum(this%in_grc(:, nt)) - tmp_in(4, nt) = sum(this%out_grc(:, nt)) - tmp_in(5, nt) = sum(this%net_grc(:, nt)) - tmp_in(6, nt) = sum(this%lag_grc(:, nt)) + tmp_in(index_beg_vol_grc, nt) = sum(this%beg_vol_grc(:, nt)) + tmp_in(index_end_vol_grc, nt) = sum(this%end_vol_grc(:, nt)) + tmp_in(index_in_grc, nt) = sum(this%in_grc(:, nt)) + tmp_in(index_out_grc, nt) = sum(this%out_grc(:, nt)) + tmp_in(index_net_grc, nt) = sum(this%net_grc(:, nt)) + tmp_in(index_lag_grc, nt) = sum(this%lag_grc(:, nt)) end do tmp_in = tmp_in*1e-6_r8 !convert to million m3 @@ -216,12 +222,12 @@ subroutine check_budget(this, begr, endr, ntracers, dt) error_budget = .false. abserr = 0.0_r8 relerr = 0.0_r8 - this%beg_vol_glob(nt) = tmp_glob(1, nt) - this%end_vol_glob(nt) = tmp_glob(2, nt) - this%in_glob(nt) = tmp_glob(3, nt) - this%out_glob(nt) = tmp_glob(4, nt) - this%net_glob(nt) = tmp_glob(5, nt) - this%lag_glob(nt) = tmp_glob(6, nt) + this%beg_vol_glob(nt) = tmp_glob(index_beg_vol_grc, nt) + this%end_vol_glob(nt) = tmp_glob(index_end_vol_grc, nt) + this%in_glob(nt) = tmp_glob(index_in_grc, nt) + this%out_glob(nt) = tmp_glob(index_out_grc, nt) + this%net_glob(nt) = tmp_glob(index_net_grc, nt) + this%lag_glob(nt) = tmp_glob(index_lag_grc, nt) if (this%do_budget(nt)) then if (abs(this%net_glob(nt) - this%lag_glob(nt)*dt) > this%tolerance) then error_budget = .true. diff --git a/src/riverroute/mosart_timemanager.F90 b/src/riverroute/mosart_timemanager.F90 index 1d35ae7..df53ba5 100644 --- a/src/riverroute/mosart_timemanager.F90 +++ b/src/riverroute/mosart_timemanager.F90 @@ -3,7 +3,7 @@ module mosart_timemanager use shr_kind_mod , only: r8 => shr_kind_r8, CS => shr_kind_CS use shr_sys_mod , only: shr_sys_abort use shr_string_mod , only: shr_string_toUpper - use mosart_vars , only: isecspday, iulog, nsrest, nsrContinue, mpicom_rof, mainproc + use mosart_vars , only: isecspday, iulog, nsrest, nsrContinue, mainproc use ESMF , only: ESMF_MAXSTR, ESMF_Calendar, ESMF_Clock, ESMF_Time, ESMF_TimeInterval, & ESMF_TimeIntervalSet, ESMF_TimeIntervalGet, ESMF_TimeSet, ESMF_TimeGet, & ESMF_ClockCreate, ESMF_ClockGet, ESMF_ClockAdvance, & From 9013f77683054005aa0a3912c8a98a8212a973e0 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Fri, 14 Jun 2024 09:52:29 -0600 Subject: [PATCH 65/86] various updates --- src/cpl/nuopc/rof_comp_nuopc.F90 | 8 ++--- src/cpl/nuopc/rof_import_export.F90 | 45 +++++++++++++----------- src/riverroute/mosart_control_type.F90 | 18 ++++++---- src/riverroute/mosart_physics.F90 | 48 +++++--------------------- src/riverroute/mosart_vars.F90 | 2 ++ 5 files changed, 52 insertions(+), 69 deletions(-) diff --git a/src/cpl/nuopc/rof_comp_nuopc.F90 b/src/cpl/nuopc/rof_comp_nuopc.F90 index bd222d6..29b75d4 100644 --- a/src/cpl/nuopc/rof_comp_nuopc.F90 +++ b/src/cpl/nuopc/rof_comp_nuopc.F90 @@ -25,14 +25,14 @@ module rof_comp_nuopc model_label_DataInitialize => label_DataInitialize, & model_label_SetRunClock => label_SetRunClock, & model_label_Finalize => label_Finalize, & - SetVM, NUOPC_ModelGet + NUOPC_ModelGet use shr_kind_mod , only : R8=>SHR_KIND_R8, CL=>SHR_KIND_CL, CS=>SHR_KIND_CS use shr_sys_mod , only : shr_sys_abort use shr_log_mod , only : shr_log_getlogunit, shr_log_setlogunit use shr_cal_mod , only : shr_cal_noleap, shr_cal_gregorian, shr_cal_ymd2date use mosart_vars , only : nsrStartup, nsrContinue, nsrBranch, & inst_index, inst_suffix, inst_name, & - mainproc, mpicom_rof, iam, npes, iulog, & + mainproc, mpicom_rof, iam, npes, iulog, vm, & nsrest, caseid, ctitle, version, hostname, username use mosart_data , only : ctl use mosart_driver , only : mosart_read_namelist, mosart_init1, mosart_init2, mosart_run @@ -49,7 +49,6 @@ module rof_comp_nuopc ! Module routines public :: SetServices - public :: SetVM private :: InitializeP0 private :: InitializeAdvertise private :: InitializeRealize @@ -159,7 +158,6 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) type(ESMF_Time) :: refTime ! Ref time type(ESMF_TimeInterval) :: timeStep ! Model timestep type(ESMF_CalKind_Flag) :: esmf_caltype ! esmf calendar type - type(ESMF_VM) :: vm ! esmf virtual machine integer :: ref_ymd ! reference date (YYYYMMDD) integer :: ref_tod ! reference time of day (sec) integer :: yy,mm,dd ! Temporaries for time query @@ -187,6 +185,8 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! generate local mpi comm !---------------------------------------------------------------------------- + ! Note vm is in mosart_vars.F90 and can be shared among components + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return diff --git a/src/cpl/nuopc/rof_import_export.F90 b/src/cpl/nuopc/rof_import_export.F90 index 00938a8..85650eb 100644 --- a/src/cpl/nuopc/rof_import_export.F90 +++ b/src/cpl/nuopc/rof_import_export.F90 @@ -9,7 +9,7 @@ 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 mosart_vars , only : iulog, mainproc, mpicom_rof, ice_runoff, separate_glc2ocn_fluxes + use mosart_vars , only : iulog, mainproc, ice_runoff, separate_glc2ocn_fluxes, vm use mosart_data , only : ctl, TRunoff, TUnit use mosart_timemanager , only : get_nstep use nuopc_shr_methods , only : chkerr @@ -131,8 +131,8 @@ subroutine realize_fields(gcomp, Emesh, flds_scalar_name, flds_scalar_num, rc) use ESMF , only : ESMF_GridComp, ESMF_StateGet use ESMF , only : ESMF_Mesh, ESMF_MeshGet use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_FieldRegridGetArea + use ESMF , only : ESMF_GridCompGet, ESMF_VMAllReduce, ESMF_REDUCE_MAX, ESMF_REDUCE_MIN use shr_const_mod , only : shr_const_rearth - use shr_mpi_mod , only : shr_mpi_min, shr_mpi_max ! input/output variables type(ESMF_GridComp) , intent(inout) :: gcomp @@ -151,14 +151,14 @@ subroutine realize_fields(gcomp, Emesh, flds_scalar_name, flds_scalar_num, rc) real(r8), allocatable :: model_areas(:) real(r8), pointer :: dataptr(:) real(r8) :: re = shr_const_rearth*0.001_r8 ! radius of earth (km) - real(r8) :: max_mod2med_areacor - real(r8) :: max_med2mod_areacor - real(r8) :: min_mod2med_areacor - real(r8) :: min_med2mod_areacor - real(r8) :: max_mod2med_areacor_glob - real(r8) :: max_med2mod_areacor_glob - real(r8) :: min_mod2med_areacor_glob - real(r8) :: min_med2mod_areacor_glob + real(r8) :: max_mod2med_areacor(1) + real(r8) :: max_med2mod_areacor(1) + real(r8) :: min_mod2med_areacor(1) + real(r8) :: min_med2mod_areacor(1) + real(r8) :: max_mod2med_areacor_glob(1) + real(r8) :: max_med2mod_areacor_glob(1) + real(r8) :: min_mod2med_areacor_glob(1) + real(r8) :: min_med2mod_areacor_glob(1) character(len=*), parameter :: subname='(rof_import_export:realize_fields)' !--------------------------------------------------------------------------- @@ -213,20 +213,25 @@ subroutine realize_fields(gcomp, Emesh, flds_scalar_name, flds_scalar_num, rc) deallocate(model_areas) deallocate(mesh_areas) - min_mod2med_areacor = minval(mod2med_areacor) - max_mod2med_areacor = maxval(mod2med_areacor) - min_med2mod_areacor = minval(med2mod_areacor) - max_med2mod_areacor = maxval(med2mod_areacor) - call shr_mpi_max(max_mod2med_areacor, max_mod2med_areacor_glob, mpicom_rof) - call shr_mpi_min(min_mod2med_areacor, min_mod2med_areacor_glob, mpicom_rof) - 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) + min_mod2med_areacor(1) = minval(mod2med_areacor) + max_mod2med_areacor(1) = maxval(mod2med_areacor) + min_med2mod_areacor(1) = minval(med2mod_areacor) + max_med2mod_areacor(1) = maxval(med2mod_areacor) + + call ESMF_VMAllReduce(vm, max_mod2med_areacor, max_mod2med_areacor_glob, 1, ESMF_REDUCE_MAX, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMAllReduce(vm, min_mod2med_areacor, min_mod2med_areacor_glob, 1, ESMF_REDUCE_MIN, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMAllReduce(vm, max_med2mod_areacor, max_med2mod_areacor_glob, 1, ESMF_REDUCE_MAX, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMAllReduce(vm, min_med2mod_areacor, min_med2mod_areacor_glob, 1, ESMF_REDUCE_MIN, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return 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' + min_mod2med_areacor_glob(1), max_mod2med_areacor_glob(1), 'MOSART' write(iulog,'(2A,2g23.15,A )') trim(subname),' : min_med2mod_areacor, max_med2mod_areacor ',& - min_med2mod_areacor_glob, max_med2mod_areacor_glob, 'MOSART' + min_med2mod_areacor_glob(1), max_med2mod_areacor_glob(1), 'MOSART' end if end subroutine realize_fields diff --git a/src/riverroute/mosart_control_type.F90 b/src/riverroute/mosart_control_type.F90 index 792751c..d5ebdf5 100644 --- a/src/riverroute/mosart_control_type.F90 +++ b/src/riverroute/mosart_control_type.F90 @@ -3,13 +3,14 @@ module mosart_control_type use shr_kind_mod, only : r8 => shr_kind_r8, CS => shr_kind_cs use shr_sys_mod, only : shr_sys_abort use shr_const_mod, only : shr_const_pi, shr_const_rearth + use shr_string_mod, only : shr_string_listGetNum, shr_string_listGetName use shr_mpi_mod, only : shr_mpi_sum use mosart_io, only : ncd_io, ncd_pio_openfile, ncd_pio_closefile - use mosart_vars, only : mainproc, iam, npes, mpicom_rof, iulog, spval, re + use mosart_vars, only : mainproc, iam, npes, mpicom_rof, iulog, spval, re, vm use pio, only : file_desc_t, PIO_BCAST_ERROR, pio_seterrorhandling use ESMF, only : ESMF_DistGrid, ESMF_Array, ESMF_RouteHandle, ESMF_SUCCESS, & ESMF_DistGridCreate, ESMF_ArrayCreate, ESMF_ArrayHaloStore, & - ESMF_ArrayHalo, ESMF_ArrayGet + ESMF_ArrayHalo, ESMF_ArrayGet, ESMF_VMAllReduce, ESMF_REDUCE_SUM use perf_mod, only : t_startf, t_stopf use nuopc_shr_methods, only : chkerr @@ -181,7 +182,8 @@ subroutine Init(this, locfn, decomp_option, use_halo_option, IDkey, rc) real(r8) :: rlatn(this%nlat) ! latitude of 1d north grid cell edge (deg) real(r8) :: rlonw(this%nlon) ! longitude of 1d west grid cell edge (deg) real(r8) :: rlone(this%nlon) ! longitude of 1d east grid cell edge (deg) - real(r8) :: larea ! tmp local sum of area + real(r8) :: larea(1) ! tmp local sum of area + real(r8) :: totarea(1) ! tmp total area real(r8) :: deg2rad ! pi/180 integer :: g, n, i, j, nr, nt ! iterators real(r8) :: edgen ! North edge of the direction file @@ -402,15 +404,19 @@ subroutine Init(this, locfn, decomp_option, use_halo_option, IDkey, rc) this%area(nr) = area_global(n) enddo - larea = 0.0_r8 + larea(1) = 0.0_r8 do nr = begr,endr - larea = larea + this%area(nr) + larea(1) = larea(1) + this%area(nr) end do if (minval(this%mask) < 1) then write(iulog,*) subname,'ERROR this mask lt 1 ',minval(this%mask),maxval(this%mask) call shr_sys_abort(subname//' ERROR this mask') endif - call shr_mpi_sum(larea, this%totarea, mpicom_rof, 'mosart totarea', all=.true.) + + call ESMF_VMAllReduce(vm, larea, totarea, 1, ESMF_REDUCE_SUM, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + this%totarea = totarea(1) + if (mainproc) then write(iulog,*) subname,' earth area ',4.0_r8*shr_const_pi*1.0e6_r8*re*re write(iulog,*) subname,' mosart area ',this%totarea diff --git a/src/riverroute/mosart_physics.F90 b/src/riverroute/mosart_physics.F90 index 4350f64..a03c61f 100644 --- a/src/riverroute/mosart_physics.F90 +++ b/src/riverroute/mosart_physics.F90 @@ -28,6 +28,15 @@ module mosart_physics public :: subnetworkrouting public :: mainchannelrouting + private :: Routing_KW + private :: CRVRMAN_nosqrt + private :: CREHT_nosqrt + private :: GRMR + private :: GRHT + private :: GRPT + private :: GRRR + private :: GRPR + real(r8), parameter :: TINYVALUE = 1.0e-14_r8 ! double precision variable has a significance of about 16 decimal digits real(r8), parameter :: SLOPE1def = 0.1_r8 ! here give it a small value in order to avoid the abrupt change of hydraulic radidus etc. real(r8) :: sinatanSLOPE1defr ! 1.0/sin(atan(slope1)) @@ -270,12 +279,6 @@ subroutine mainchannelRouting(nr, nt, theDeltaT) if(Tctl%RoutingMethod == 1) then call Routing_KW(nr, nt, theDeltaT) - else if(Tctl%RoutingMethod == 2) then - call Routing_MC(nr, nt, theDeltaT) - else if(Tctl%RoutingMethod == 3) then - call Routing_THREW(nr, nt, theDeltaT) - else if(Tctl%RoutingMethod == 4) then - call Routing_DW(nr, nt, theDeltaT) else call shr_sys_abort( "mosart: Please check the routing method! There are only 4 methods available." ) end if @@ -346,39 +349,6 @@ end subroutine Routing_KW !----------------------------------------------------------------------- - subroutine Routing_MC(nr, nt, theDeltaT) - ! Muskingum-Cunge routing method - - ! Arguments - integer, intent(in) :: nr, nt - real(r8), intent(in) :: theDeltaT - - end subroutine Routing_MC - - !----------------------------------------------------------------------- - - subroutine Routing_THREW(nr, nt, theDeltaT) - ! kinematic wave routing method from THREW model - - ! Arguments - integer, intent(in) :: nr, nt - real(r8), intent(in) :: theDeltaT - - end subroutine Routing_THREW - - !----------------------------------------------------------------------- - - subroutine Routing_DW(nr, nt, theDeltaT) - ! classic diffusion wave routing method - - ! Arguments - integer, intent(in) :: nr, nt - real(r8), intent(in) :: theDeltaT - - end subroutine Routing_DW - - !----------------------------------------------------------------------- - subroutine updateState_hillslope(nr,nt) ! update the state variables at hillslope diff --git a/src/riverroute/mosart_vars.F90 b/src/riverroute/mosart_vars.F90 index 114fa2e..101d5d7 100644 --- a/src/riverroute/mosart_vars.F90 +++ b/src/riverroute/mosart_vars.F90 @@ -3,6 +3,7 @@ module mosart_vars use shr_kind_mod , only : r8 => shr_kind_r8, CL => SHR_KIND_CL, CS => shr_kind_CS use shr_const_mod , only : SHR_CONST_CDAY,SHR_CONST_REARTH use shr_sys_mod , only : shr_sys_abort + use ESMF , only : ESMF_VM implicit none public @@ -13,6 +14,7 @@ module mosart_vars integer :: npes ! number of processors for mosart integer :: mpicom_rof ! communicator group for mosart logical :: barrier_timers = .false. ! barrier timers + type(ESMF_VM) :: vm ! ESMF VM ! Constants integer , parameter :: iundef = -9999999 From 0336d53f28ad54c08e566d55d2723a16157184d7 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Fri, 14 Jun 2024 14:35:30 -0600 Subject: [PATCH 66/86] more simplicification for glc input runoff --- src/cpl/nuopc/rof_import_export.F90 | 47 ++++++++++++++++++++++---- src/riverroute/mosart_control_type.F90 | 1 + src/riverroute/mosart_driver.F90 | 45 +++++++++++++----------- 3 files changed, 66 insertions(+), 27 deletions(-) diff --git a/src/cpl/nuopc/rof_import_export.F90 b/src/cpl/nuopc/rof_import_export.F90 index 85650eb..3731326 100644 --- a/src/cpl/nuopc/rof_import_export.F90 +++ b/src/cpl/nuopc/rof_import_export.F90 @@ -27,6 +27,7 @@ module rof_import_export private :: state_getimport private :: state_setexport private :: check_for_nans + private :: fldchk type fld_list_type character(len=128) :: stdname @@ -234,6 +235,12 @@ subroutine realize_fields(gcomp, Emesh, flds_scalar_name, flds_scalar_num, rc) min_med2mod_areacor_glob(1), max_med2mod_areacor_glob(1), 'MOSART' end if + if (fldchk(importState, 'Fgrg_rofl') .and. fldchk(importState, 'Fgrg_rofl')) then + ctl%rof_from_glc = .true. + else + ctl%rof_from_glc = .false. + end if + end subroutine realize_fields !=============================================================================== @@ -291,13 +298,18 @@ subroutine import_fields( gcomp, begr, endr, rc ) ctl%qsub(begr:endr, nice) = 0.0_r8 ctl%qgwl(begr:endr, nice) = 0.0_r8 - call state_getimport(importState, 'Fgrg_rofl', begr, endr, ctl%area, output=ctl%qglc_liq(:), & - do_area_correction=.true., rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call state_getimport(importState, 'Fgrg_rofi', begr, endr, ctl%area, output=ctl%qglc_ice(:), & - do_area_correction=.true., rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ctl%rof_from_glc) then + call state_getimport(importState, 'Fgrg_rofl', begr, endr, ctl%area, output=ctl%qglc_liq(:), & + do_area_correction=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport(importState, 'Fgrg_rofi', begr, endr, ctl%area, output=ctl%qglc_ice(:), & + do_area_correction=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + ctl%qglc_liq(:) = 0._r8 + ctl%qglc_ice(:) = 0._r8 + end if + write(6,*)'DEBUG: ctl%rof_from_glc = ',ctl%rof_from_glc end subroutine import_fields @@ -679,4 +691,25 @@ subroutine check_for_nans(array, fname, begg) end if end subroutine check_for_nans + !=============================================================================== + logical function fldchk(state, fldname) + ! ---------------------------------------------- + ! Determine if field with fldname is in the input state + ! ---------------------------------------------- + + ! input/output variables + type(ESMF_State), intent(in) :: state + character(len=*), intent(in) :: fldname + + ! local variables + type(ESMF_StateItem_Flag) :: itemFlag + ! ---------------------------------------------- + call ESMF_StateGet(state, trim(fldname), itemFlag) + if (itemflag /= ESMF_STATEITEM_NOTFOUND) then + fldchk = .true. + else + fldchk = .false. + endif + end function fldchk + end module rof_import_export diff --git a/src/riverroute/mosart_control_type.F90 b/src/riverroute/mosart_control_type.F90 index d5ebdf5..04b297c 100644 --- a/src/riverroute/mosart_control_type.F90 +++ b/src/riverroute/mosart_control_type.F90 @@ -30,6 +30,7 @@ module mosart_control_type character(len=3), allocatable :: tracer_names(:)! tracer names integer :: nt_liq ! index of liquid tracer in tracer_names integer :: nt_ice ! index of ice tracer in tracer_names + logical :: rof_from_glc ! if true, will receive liq and ice runoff from glc ! decomp info integer :: begr ! local start index diff --git a/src/riverroute/mosart_driver.F90 b/src/riverroute/mosart_driver.F90 index 9bdcb9b..b161bf6 100644 --- a/src/riverroute/mosart_driver.F90 +++ b/src/riverroute/mosart_driver.F90 @@ -574,26 +574,31 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) !--- direct to outlet: all liquid and frozen runoff from glc !----------------------------------------------------- - src_direct(:,:) = 0._r8 - dst_direct(:,:) = 0._r8 - - cnt = 0 - do nr = begr,endr - cnt = cnt + 1 - src_direct(nt_liq,cnt) = ctl%qglc_liq(nr) - src_direct(nt_ice,cnt) = ctl%qglc_ice(nr) - enddo - - call ESMF_FieldSMM(Tunit%srcfield, Tunit%dstfield, Tunit%rh_direct, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - ! copy direct transfer water to output field - cnt = 0 - do nr = begr,endr - cnt = cnt + 1 - ctl%direct_glc(nr,nt_liq) = dst_direct(nt_liq,cnt) - ctl%direct_glc(nr,nt_ice) = dst_direct(nt_ice,cnt) - enddo + if (ctl%rof_from_glc) then + src_direct(:,:) = 0._r8 + dst_direct(:,:) = 0._r8 + + cnt = 0 + do nr = begr,endr + cnt = cnt + 1 + src_direct(nt_liq,cnt) = ctl%qglc_liq(nr) + src_direct(nt_ice,cnt) = ctl%qglc_ice(nr) + enddo + + call ESMF_FieldSMM(Tunit%srcfield, Tunit%dstfield, Tunit%rh_direct, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! copy direct transfer water to output field + cnt = 0 + do nr = begr,endr + cnt = cnt + 1 + ctl%direct_glc(nr,nt_liq) = dst_direct(nt_liq,cnt) + ctl%direct_glc(nr,nt_ice) = dst_direct(nt_ice,cnt) + enddo + else + ctl%direct_glc(:,:) = 0._r8 + ctl%direct_glc(:,:) = 0._r8 + end if !----------------------------------------------------- !--- direct to outlet: all frozen runoff from lnd From 7c0f3fc7cfcb8cf02530e9b9fc12e8c9da7d819c Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sat, 15 Jun 2024 02:41:29 -0600 Subject: [PATCH 67/86] removed vm updates for now from rof_import_export.F90 --- src/cpl/nuopc/rof_import_export.F90 | 49 ++++++++++++++--------------- 1 file changed, 23 insertions(+), 26 deletions(-) diff --git a/src/cpl/nuopc/rof_import_export.F90 b/src/cpl/nuopc/rof_import_export.F90 index 3731326..dc682a4 100644 --- a/src/cpl/nuopc/rof_import_export.F90 +++ b/src/cpl/nuopc/rof_import_export.F90 @@ -9,7 +9,7 @@ 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 mosart_vars , only : iulog, mainproc, ice_runoff, separate_glc2ocn_fluxes, vm + use mosart_vars , only : iulog, mainproc, mpicom_rof, ice_runoff, separate_glc2ocn_fluxes use mosart_data , only : ctl, TRunoff, TUnit use mosart_timemanager , only : get_nstep use nuopc_shr_methods , only : chkerr @@ -132,8 +132,8 @@ subroutine realize_fields(gcomp, Emesh, flds_scalar_name, flds_scalar_num, rc) use ESMF , only : ESMF_GridComp, ESMF_StateGet use ESMF , only : ESMF_Mesh, ESMF_MeshGet use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_FieldRegridGetArea - use ESMF , only : ESMF_GridCompGet, ESMF_VMAllReduce, ESMF_REDUCE_MAX, ESMF_REDUCE_MIN use shr_const_mod , only : shr_const_rearth + use shr_mpi_mod , only : shr_mpi_min, shr_mpi_max ! input/output variables type(ESMF_GridComp) , intent(inout) :: gcomp @@ -152,14 +152,14 @@ subroutine realize_fields(gcomp, Emesh, flds_scalar_name, flds_scalar_num, rc) real(r8), allocatable :: model_areas(:) real(r8), pointer :: dataptr(:) real(r8) :: re = shr_const_rearth*0.001_r8 ! radius of earth (km) - real(r8) :: max_mod2med_areacor(1) - real(r8) :: max_med2mod_areacor(1) - real(r8) :: min_mod2med_areacor(1) - real(r8) :: min_med2mod_areacor(1) - real(r8) :: max_mod2med_areacor_glob(1) - real(r8) :: max_med2mod_areacor_glob(1) - real(r8) :: min_mod2med_areacor_glob(1) - real(r8) :: min_med2mod_areacor_glob(1) + real(r8) :: max_mod2med_areacor + real(r8) :: max_med2mod_areacor + real(r8) :: min_mod2med_areacor + real(r8) :: min_med2mod_areacor + real(r8) :: max_mod2med_areacor_glob + real(r8) :: max_med2mod_areacor_glob + real(r8) :: min_mod2med_areacor_glob + real(r8) :: min_med2mod_areacor_glob character(len=*), parameter :: subname='(rof_import_export:realize_fields)' !--------------------------------------------------------------------------- @@ -214,25 +214,20 @@ subroutine realize_fields(gcomp, Emesh, flds_scalar_name, flds_scalar_num, rc) deallocate(model_areas) deallocate(mesh_areas) - min_mod2med_areacor(1) = minval(mod2med_areacor) - max_mod2med_areacor(1) = maxval(mod2med_areacor) - min_med2mod_areacor(1) = minval(med2mod_areacor) - max_med2mod_areacor(1) = maxval(med2mod_areacor) - - call ESMF_VMAllReduce(vm, max_mod2med_areacor, max_mod2med_areacor_glob, 1, ESMF_REDUCE_MAX, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_VMAllReduce(vm, min_mod2med_areacor, min_mod2med_areacor_glob, 1, ESMF_REDUCE_MIN, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_VMAllReduce(vm, max_med2mod_areacor, max_med2mod_areacor_glob, 1, ESMF_REDUCE_MAX, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_VMAllReduce(vm, min_med2mod_areacor, min_med2mod_areacor_glob, 1, ESMF_REDUCE_MIN, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + min_mod2med_areacor = minval(mod2med_areacor) + max_mod2med_areacor = maxval(mod2med_areacor) + min_med2mod_areacor = minval(med2mod_areacor) + max_med2mod_areacor = maxval(med2mod_areacor) + call shr_mpi_max(max_mod2med_areacor, max_mod2med_areacor_glob, mpicom_rof) + call shr_mpi_min(min_mod2med_areacor, min_mod2med_areacor_glob, mpicom_rof) + 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 (mainproc) then write(iulog,'(2A,2g23.15,A )') trim(subname),' : min_mod2med_areacor, max_mod2med_areacor ',& - min_mod2med_areacor_glob(1), max_mod2med_areacor_glob(1), 'MOSART' + min_mod2med_areacor_glob, max_mod2med_areacor_glob, 'MOSART' write(iulog,'(2A,2g23.15,A )') trim(subname),' : min_med2mod_areacor, max_med2mod_areacor ',& - min_med2mod_areacor_glob(1), max_med2mod_areacor_glob(1), 'MOSART' + min_med2mod_areacor_glob, max_med2mod_areacor_glob, 'MOSART' end if if (fldchk(importState, 'Fgrg_rofl') .and. fldchk(importState, 'Fgrg_rofl')) then @@ -240,6 +235,9 @@ subroutine realize_fields(gcomp, Emesh, flds_scalar_name, flds_scalar_num, rc) else ctl%rof_from_glc = .false. end if + if (mainproc) then + write(iulog,'(A,l1)') trim(subname) //' rof from glc is ',ctl%rof_from_glc + end if end subroutine realize_fields @@ -309,7 +307,6 @@ subroutine import_fields( gcomp, begr, endr, rc ) ctl%qglc_liq(:) = 0._r8 ctl%qglc_ice(:) = 0._r8 end if - write(6,*)'DEBUG: ctl%rof_from_glc = ',ctl%rof_from_glc end subroutine import_fields From 4a80be551254cd98adbc71cda58e9832f66c3dee Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sat, 15 Jun 2024 03:30:09 -0600 Subject: [PATCH 68/86] fixed mosart history for total runoff --- src/riverroute/mosart_driver.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/riverroute/mosart_driver.F90 b/src/riverroute/mosart_driver.F90 index b161bf6..1a370b6 100644 --- a/src/riverroute/mosart_driver.F90 +++ b/src/riverroute/mosart_driver.F90 @@ -880,8 +880,8 @@ subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) ! final update from glc input do nr = begr,endr - ctl%runofftot(nr,nt_liq) = ctl%runoff(nr,nt_liq) + ctl%direct_glc(nr,nt_liq) - ctl%runofftot(nr,nt_ice) = ctl%runoff(nr,nt_ice) + ctl%direct_glc(nr,nt_ice) + ctl%runofftot(nr,nt_liq) = ctl%runofftot(nr,nt_liq) + ctl%direct_glc(nr,nt_liq) + ctl%runofftot(nr,nt_ice) = ctl%runofftot(nr,nt_ice) + ctl%direct_glc(nr,nt_ice) end do call t_stopf('mosartr_subcycling') From e6fd7706b998f629c3360877f2fe0e7b2e9e7ccb Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 18 Jun 2024 03:45:28 -0600 Subject: [PATCH 69/86] made separate_glc2ocn_fluxes be true by default --- cime_config/namelist_definition_mosart.xml | 4 ++-- src/riverroute/mosart_driver.F90 | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/cime_config/namelist_definition_mosart.xml b/cime_config/namelist_definition_mosart.xml index 24916b8..adf10b2 100644 --- a/cime_config/namelist_definition_mosart.xml +++ b/cime_config/namelist_definition_mosart.xml @@ -299,10 +299,10 @@ mosart mosart_inparm - .false. + .true. - Default: .false. + Default: .true. If .true., glc2ocn fluxes that are passed through mosart will be sent as a separate fields to the mediator. diff --git a/src/riverroute/mosart_driver.F90 b/src/riverroute/mosart_driver.F90 index 1a370b6..bc14c52 100644 --- a/src/riverroute/mosart_driver.F90 +++ b/src/riverroute/mosart_driver.F90 @@ -107,7 +107,7 @@ subroutine mosart_read_namelist() use_halo_option = .false. mosart_tracers = 'LIQ:ICE' mosart_euler_calc = 'T:F' - separate_glc2ocn_fluxes = .false. + separate_glc2ocn_fluxes = .true. nlfilename_rof = "mosart_in" // trim(inst_suffix) inquire (file = trim(nlfilename_rof), exist = lexist) From 68995dd5ea90303ebcd0fa1ef5743326520479b8 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Thu, 20 Jun 2024 03:02:32 -0600 Subject: [PATCH 70/86] removed namelist variable separate_glc2ocn_fluxes - mosart will only send glc fluxes separately to the mediator --- cime_config/namelist_definition_mosart.xml | 14 --------- src/cpl/nuopc/rof_import_export.F90 | 33 ++++++++-------------- src/riverroute/mosart_driver.F90 | 9 ++---- src/riverroute/mosart_physics.F90 | 2 +- src/riverroute/mosart_tctl_type.F90 | 2 +- src/riverroute/mosart_vars.F90 | 1 - 6 files changed, 15 insertions(+), 46 deletions(-) diff --git a/cime_config/namelist_definition_mosart.xml b/cime_config/namelist_definition_mosart.xml index adf10b2..86f5224 100644 --- a/cime_config/namelist_definition_mosart.xml +++ b/cime_config/namelist_definition_mosart.xml @@ -294,18 +294,4 @@ - - logical - mosart - mosart_inparm - - .true. - - - Default: .true. - If .true., glc2ocn fluxes that are passed through mosart will be sent - as a separate fields to the mediator. - - - diff --git a/src/cpl/nuopc/rof_import_export.F90 b/src/cpl/nuopc/rof_import_export.F90 index dc682a4..80cc7c7 100644 --- a/src/cpl/nuopc/rof_import_export.F90 +++ b/src/cpl/nuopc/rof_import_export.F90 @@ -9,7 +9,7 @@ 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 mosart_vars , only : iulog, mainproc, mpicom_rof, ice_runoff, separate_glc2ocn_fluxes + use mosart_vars , only : iulog, mainproc, mpicom_rof, ice_runoff use mosart_data , only : ctl, TRunoff, TUnit use mosart_timemanager , only : get_nstep use nuopc_shr_methods , only : chkerr @@ -87,10 +87,8 @@ subroutine advertise_fields(gcomp, flds_scalar_name, rc) call fldlist_add(fldsFrRof_num, fldsFrRof, trim(flds_scalar_name)) call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofl') call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofi') - if (separate_glc2ocn_fluxes) then - call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofl_glc') - call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofi_glc') - end if + call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofl_glc') + call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofi_glc') call fldlist_add(fldsFrRof_num, fldsFrRof, 'Flrr_flood') call fldlist_add(fldsFrRof_num, fldsFrRof, 'Flrr_volr') call fldlist_add(fldsFrRof_num, fldsFrRof, 'Flrr_volrmch') @@ -383,17 +381,10 @@ subroutine export_fields (gcomp, begr, endr, rc) end do end if - if (separate_glc2ocn_fluxes) then - do n = begr,endr - rofl_glc(n) = ctl%direct_glc(n,nliq) / (ctl%area(n)*0.001_r8) - rofi_glc(n) = ctl%direct_glc(n,nice) / (ctl%area(n)*0.001_r8) - end do - else - do n = begr,endr - rofl(n) = rofl(n) + ctl%direct_glc(n,nliq) / (ctl%area(n)*0.001_r8) - rofi(n) = rofi(n) + ctl%direct_glc(n,nice) / (ctl%area(n)*0.001_r8) - end do - end if + do n = begr,endr + rofl_glc(n) = ctl%direct_glc(n,nliq) / (ctl%area(n)*0.001_r8) + rofi_glc(n) = ctl%direct_glc(n,nice) / (ctl%area(n)*0.001_r8) + end do ! Flooding back to land, sign convention is positive in land->rof direction ! so if water is sent from rof to land, the flux must be negative. @@ -417,13 +408,11 @@ subroutine export_fields (gcomp, begr, endr, rc) call state_setexport(exportState, 'Forr_rofi', begr, endr, input=rofi, do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (separate_glc2ocn_fluxes) then - call state_setexport(exportState, 'Forr_rofl_glc', begr, endr, input=rofl_glc, do_area_correction=.true., rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_setexport(exportState, 'Forr_rofl_glc', begr, endr, input=rofl_glc, do_area_correction=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_setexport(exportState, 'Forr_rofi_glc', begr, endr, input=rofi_glc, do_area_correction=.true., rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if + call state_setexport(exportState, 'Forr_rofi_glc', begr, endr, input=rofi_glc, do_area_correction=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call state_setexport(exportState, 'Flrr_flood', begr, endr, input=flood, do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return diff --git a/src/riverroute/mosart_driver.F90 b/src/riverroute/mosart_driver.F90 index bc14c52..652bf98 100644 --- a/src/riverroute/mosart_driver.F90 +++ b/src/riverroute/mosart_driver.F90 @@ -11,8 +11,7 @@ module mosart_driver frivinp, nsrContinue, nsrBranch, nsrStartup, nsrest, & inst_index, inst_suffix, inst_name, decomp_option, & bypass_routing_option, qgwl_runoff_option, barrier_timers, & - mainproc, npes, iam, mpicom_rof, budget_frq, isecspday, & - separate_glc2ocn_fluxes + mainproc, npes, iam, mpicom_rof, budget_frq, isecspday use mosart_data , only : ctl, Tctl, Tunit, TRunoff, Tpara use mosart_budget_type , only : budget_type use mosart_fileutils , only : getfil @@ -92,8 +91,7 @@ subroutine mosart_read_namelist() namelist /mosart_inparm / frivinp, finidat, nrevsn, coupling_period, ice_runoff, & ndens, mfilt, nhtfrq, fincl1, fincl2, fincl3, fexcl1, fexcl2, fexcl3, & avgflag_pertape, decomp_option, bypass_routing_option, qgwl_runoff_option, & - use_halo_option, delt_mosart, mosart_tracers, mosart_euler_calc, budget_frq, & - separate_glc2ocn_fluxes + use_halo_option, delt_mosart, mosart_tracers, mosart_euler_calc, budget_frq ! Preset values ice_runoff = .true. @@ -107,7 +105,6 @@ subroutine mosart_read_namelist() use_halo_option = .false. mosart_tracers = 'LIQ:ICE' mosart_euler_calc = 'T:F' - separate_glc2ocn_fluxes = .true. nlfilename_rof = "mosart_in" // trim(inst_suffix) inquire (file = trim(nlfilename_rof), exist = lexist) @@ -151,7 +148,6 @@ subroutine mosart_read_namelist() call mpi_bcast (mosart_tracers, CS, MPI_CHARACTER, 0, mpicom_rof, ier) call mpi_bcast (mosart_euler_calc, CS, MPI_CHARACTER, 0, mpicom_rof, ier) call mpi_bcast (budget_frq,1,MPI_INTEGER,0,mpicom_rof,ier) - call mpi_bcast (separate_glc2ocn_fluxes, 1, MPI_LOGICAL, 0, mpicom_rof, ier) ! Determine number of tracers and array of tracer names and initialize module variables call ctl%init_tracer_names(mosart_tracers) @@ -174,7 +170,6 @@ subroutine mosart_read_namelist() write(iulog,'(a)' ) ' qgwl runoff option = '//trim(qgwl_runoff_option) write(iulog,'(a)' ) ' mosart tracers = '//trim(mosart_tracers) write(iulog,'(a)' ) ' mosart euler calc = '//trim(mosart_euler_calc) - write(iulog,'(a,l1)') ' separate_glc2ocn_fluxes = ',separate_glc2ocn_fluxes if (nsrest == nsrStartup .and. finidat /= ' ') then write(iulog,'(a)') ' mosart initial data = '//trim(finidat) end if diff --git a/src/riverroute/mosart_physics.F90 b/src/riverroute/mosart_physics.F90 index a03c61f..3700d42 100644 --- a/src/riverroute/mosart_physics.F90 +++ b/src/riverroute/mosart_physics.F90 @@ -280,7 +280,7 @@ subroutine mainchannelRouting(nr, nt, theDeltaT) if(Tctl%RoutingMethod == 1) then call Routing_KW(nr, nt, theDeltaT) else - call shr_sys_abort( "mosart: Please check the routing method! There are only 4 methods available." ) + call shr_sys_abort( "mosart: Please check the routing method! There is only 1 method currently available." ) end if end subroutine mainchannelRouting diff --git a/src/riverroute/mosart_tctl_type.F90 b/src/riverroute/mosart_tctl_type.F90 index ce35168..3571086 100644 --- a/src/riverroute/mosart_tctl_type.F90 +++ b/src/riverroute/mosart_tctl_type.F90 @@ -10,7 +10,7 @@ module mosart_tctl_type integer :: DLevelH2R ! The base number of channel routing sub-time-steps within one hillslope routing step. ! Usually channel routing requires small time steps than hillslope routing. integer :: DLevelR ! The number of channel routing sub-time-steps at a higher level within one channel routing step at a lower level. - integer :: RoutingMethod ! Flag for routing methods. 1 --> variable storage method from SWAT model; 2 --> Muskingum method? + integer :: RoutingMethod ! Flag for routing methods. 1 --> variable storage method from SWAT model contains procedure :: Init end type Tctl_type diff --git a/src/riverroute/mosart_vars.F90 b/src/riverroute/mosart_vars.F90 index 101d5d7..6712c4d 100644 --- a/src/riverroute/mosart_vars.F90 +++ b/src/riverroute/mosart_vars.F90 @@ -39,7 +39,6 @@ module mosart_vars character(len=CS) :: bypass_routing_option ! bypass routing model method character(len=CS) :: qgwl_runoff_option ! method for handling qgwl runoff integer :: budget_frq = -24 ! budget check frequency - logical :: separate_glc2ocn_fluxes ! true => send fluxes from glc through mozart separately to mediator ! Metadata variables used in history and restart generation character(len=CL) :: caseid = ' ' ! case id From 01f40dcf589d4e6c5932c76128e3d42faea91e9f Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Thu, 20 Jun 2024 03:10:41 -0600 Subject: [PATCH 71/86] updates for issues raised in PR review --- src/riverroute/mosart_control_type.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/riverroute/mosart_control_type.F90 b/src/riverroute/mosart_control_type.F90 index 04b297c..672613f 100644 --- a/src/riverroute/mosart_control_type.F90 +++ b/src/riverroute/mosart_control_type.F90 @@ -134,6 +134,9 @@ module mosart_control_type subroutine init_tracer_names(this, mosart_tracers) + ! This sets the indices for liquid and ice runoff. In the future additional tracers + ! will be enabled so this is a starting point. + ! Arguments class(control_type) :: this character(len=CS) :: mosart_tracers ! colon delimited string of tracer names From ca0acc0336365456bec653c4c233abb57d9bc62d Mon Sep 17 00:00:00 2001 From: Samuel Levis Date: Fri, 21 Jun 2024 16:27:38 -0600 Subject: [PATCH 72/86] Add I1850...G (ie cism) test to the mosart test-suite --- cime_config/testdefs/testlist_mosart.xml | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/cime_config/testdefs/testlist_mosart.xml b/cime_config/testdefs/testlist_mosart.xml index 9e79cbd..168d47b 100644 --- a/cime_config/testdefs/testlist_mosart.xml +++ b/cime_config/testdefs/testlist_mosart.xml @@ -21,6 +21,15 @@ + + + + + + + + + From 19966c36fa79622d81d841033e223d5644363616 Mon Sep 17 00:00:00 2001 From: Samuel Levis Date: Fri, 21 Jun 2024 17:11:59 -0600 Subject: [PATCH 73/86] Updated ChangeLog --- docs/ChangeLog | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/docs/ChangeLog b/docs/ChangeLog index de7e2da..444d6d9 100644 --- a/docs/ChangeLog +++ b/docs/ChangeLog @@ -1,3 +1,26 @@ +=============================================================== +Tag name: mosart1_1_02 +Originator(s): mvertens +Date: Jun 21, 2024 +One-line Summary: cism runoff will be now routed to ocn via mosart + +Enables CISM runoff to be routed to the ocean via mosart. + +All runoff from CISM will be routed directly to the outlet points +New fields will be advertised in the mosart cap +call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofl_glc') +call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofi_glc') + +Issues addressed: +Fixes #92 +Fixes #102 + +Testing: standard testing + izumi -- OK + cheyenne -- OK + +See https://github.com/ESCOMP/MOSART/pull/94 for more details + =============================================================== Tag name: mosart1_1_01 Originator(s): mvertens From 7b8b9e545c097f628e20db0836dea070001266cd Mon Sep 17 00:00:00 2001 From: Samuel Levis Date: Fri, 18 Oct 2024 16:50:05 -0600 Subject: [PATCH 74/86] time now equals the middle of the time_bounds --- src/riverroute/mosart_histfile.F90 | 56 ++++++++++++++++++++++-------- 1 file changed, 41 insertions(+), 15 deletions(-) diff --git a/src/riverroute/mosart_histfile.F90 b/src/riverroute/mosart_histfile.F90 index c0eaf23..f1afce2 100644 --- a/src/riverroute/mosart_histfile.F90 +++ b/src/riverroute/mosart_histfile.F90 @@ -445,6 +445,7 @@ subroutine htape_addfld (t, f, avgflag) integer :: n ! field index on defined tape integer :: begr ! per-proc beginning land runoff index integer :: endr ! per-proc ending land runoff index + character(len=1) :: avgflag_temp ! local copy of hist_avgflag_pertape(t) character(len=*),parameter :: subname = 'htape_addfld' !------------------------------------------------------- @@ -479,6 +480,13 @@ subroutine htape_addfld (t, f, avgflag) call shr_sys_abort() end select + ! Override this field's avgflag if the namelist has set this tape to + ! - instantaneous + avgflag_temp = hist_avgflag_pertape(t) + if (avgflag_temp == 'I') then + tape(t)%hlist(n)%avgflag = avgflag_temp + end if + end subroutine htape_addfld !----------------------------------------------------------------------- @@ -593,7 +601,6 @@ subroutine htape_create (t, histrest) character(len=CL) :: name ! name of attribute character(len=CL) :: units ! units of attribute character(len=CL) :: str ! global attribute string - character(len= 1) :: avgflag ! time averaging flag character(len=*),parameter :: subname = 'htape_create' !----------------------------------------------------- @@ -719,6 +726,7 @@ subroutine htape_timeconst(t, mode) integer :: dtime ! timestep size integer :: yr,mon,day,nbsec ! year,month,day,seconds components of a date integer :: hours,minutes,secs ! hours,minutes,seconds of hh:mm:ss + character(len= 12) :: step_or_bounds ! string used in long_name of several time variables character(len= 10) :: basedate ! base date (yyyymmdd) character(len= 8) :: basesec ! base seconds character(len= 8) :: cdate ! system date @@ -754,8 +762,18 @@ subroutine htape_timeconst(t, mode) dim1id(1) = time_dimid str = 'days since ' // basedate // " " // basesec - call ncd_defvar(nfid(t), 'time', tape(t)%ncprec, 1, dim1id, varid, & - long_name='time',units=str) + if (tape(t)%hlist(1)%avgflag /= 'I') then ! NOT instantaneous fields tape + step_or_bounds = 'time_bounds' + long_name = 'time at exact middle of ' // step_or_bounds + call ncd_defvar(nfid(t), 'time', tape(t)%ncprec, 1, dim1id, varid, & + long_name=long_name, units=str) + call ncd_putatt(nfid(t), varid, 'bounds', 'time_bounds') + else ! instantaneous fields tape + step_or_bounds = 'time step' + long_name = 'time at end of ' // step_or_bounds + call ncd_defvar(nfid(t), 'time', tape(t)%ncprec, 1, dim1id, varid, & + long_name=long_name, units=str) + end if cal = get_calendar() if ( trim(cal) == NO_LEAP_C )then caldesc = "noleap" @@ -763,23 +781,28 @@ subroutine htape_timeconst(t, mode) caldesc = "gregorian" end if call ncd_putatt(nfid(t), varid, 'calendar', caldesc) - call ncd_putatt(nfid(t), varid, 'bounds', 'time_bounds') dim1id(1) = time_dimid + long_name = 'current date (YYYYMMDD) at end of ' // step_or_bounds call ncd_defvar(nfid(t) , 'mcdate', ncd_int, 1, dim1id , varid, & - long_name = 'current date (YYYYMMDD)') + long_name = long_name) + long_name = 'current seconds of current date at end of ' // step_or_bounds call ncd_defvar(nfid(t) , 'mcsec' , ncd_int, 1, dim1id , varid, & - long_name = 'current seconds of current date', units='s') + long_name = long_name, units='s') + long_name = 'current day (from base day) at end of ' // step_or_bounds call ncd_defvar(nfid(t) , 'mdcur' , ncd_int, 1, dim1id , varid, & - long_name = 'current day (from base day)') + long_name = long_name) + long_name = 'current seconds of current day at end of ' // step_or_bounds call ncd_defvar(nfid(t) , 'mscur' , ncd_int, 1, dim1id , varid, & - long_name = 'current seconds of current day') + long_name = long_name) call ncd_defvar(nfid(t) , 'nstep' , ncd_int, 1, dim1id , varid, & long_name = 'time step') dim2id(1) = hist_interval_dimid; dim2id(2) = time_dimid - call ncd_defvar(nfid(t), 'time_bounds', ncd_double, 2, dim2id, varid, & - long_name = 'history time interval endpoints') + if (tape(t)%hlist(1)%avgflag /= 'I') then ! NOT instantaneous fields tape + call ncd_defvar(nfid(t), 'time_bounds', ncd_double, 2, dim2id, varid, & + long_name = 'history time interval endpoints') + end if dim2id(1) = strlen_dimid; dim2id(2) = time_dimid call ncd_defvar(nfid(t), 'date_written', ncd_char, 2, dim2id, varid) @@ -811,13 +834,16 @@ subroutine htape_timeconst(t, mode) call ncd_io('mscur' , mscur , 'write', nfid(t), nt=tape(t)%ntimes) call ncd_io('nstep' , nstep , 'write', nfid(t), nt=tape(t)%ntimes) - time = mdcur + mscur/secspday + timedata(1) = tape(t)%begtime ! beginning time + timedata(2) = mdcur + mscur / secspday ! end time + if (tape(t)%hlist(1)%avgflag /= 'I') then ! NOT instantaneous fields tape + time = (timedata(1) + timedata(2)) * 0.5_r8 + call ncd_io('time_bounds', timedata, 'write', nfid(t), nt=tape(t)%ntimes) + else + time = timedata(2) + end if call ncd_io('time' , time , 'write', nfid(t), nt=tape(t)%ntimes) - timedata(1) = tape(t)%begtime - timedata(2) = time - call ncd_io('time_bounds', timedata, 'write', nfid(t), nt=tape(t)%ntimes) - call ncd_getdatetime (cdate, ctime) call ncd_io('date_written', cdate, 'write', nfid(t), nt=tape(t)%ntimes) From e9adf70e8e65d29f26fd70a3bbda13dae3617444 Mon Sep 17 00:00:00 2001 From: Samuel Levis Date: Tue, 22 Oct 2024 17:54:43 -0600 Subject: [PATCH 75/86] Correct coding error --- src/riverroute/mosart_histfile.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/riverroute/mosart_histfile.F90 b/src/riverroute/mosart_histfile.F90 index f1afce2..ad4f15c 100644 --- a/src/riverroute/mosart_histfile.F90 +++ b/src/riverroute/mosart_histfile.F90 @@ -445,7 +445,7 @@ subroutine htape_addfld (t, f, avgflag) integer :: n ! field index on defined tape integer :: begr ! per-proc beginning land runoff index integer :: endr ! per-proc ending land runoff index - character(len=1) :: avgflag_temp ! local copy of hist_avgflag_pertape(t) + character(len=1) :: avgflag_temp ! local copy of avgflag_pertape(t) character(len=*),parameter :: subname = 'htape_addfld' !------------------------------------------------------- @@ -482,7 +482,7 @@ subroutine htape_addfld (t, f, avgflag) ! Override this field's avgflag if the namelist has set this tape to ! - instantaneous - avgflag_temp = hist_avgflag_pertape(t) + avgflag_temp = avgflag_pertape(t) if (avgflag_temp == 'I') then tape(t)%hlist(n)%avgflag = avgflag_temp end if From 495e8c3c4bba43a4cd8537a50b95b6c67fad95f8 Mon Sep 17 00:00:00 2001 From: Samuel Levis Date: Wed, 23 Oct 2024 14:33:06 -0600 Subject: [PATCH 76/86] Override tape's avgflag with 'I' if nhtfrq == 1 --- src/riverroute/mosart_histfile.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/riverroute/mosart_histfile.F90 b/src/riverroute/mosart_histfile.F90 index ad4f15c..7e1b266 100644 --- a/src/riverroute/mosart_histfile.F90 +++ b/src/riverroute/mosart_histfile.F90 @@ -480,6 +480,10 @@ subroutine htape_addfld (t, f, avgflag) call shr_sys_abort() end select + ! Override this tape's avgflag if nhtfrq == 1 + if (tape(t)%nhtfrq == 1) then ! output is instantaneous + avgflag_pertape(t) = 'I' + end if ! Override this field's avgflag if the namelist has set this tape to ! - instantaneous avgflag_temp = avgflag_pertape(t) From 212f459d728e08cfbed7bf0402e6864799b60a9e Mon Sep 17 00:00:00 2001 From: Erik Kluzek Date: Wed, 30 Oct 2024 18:14:43 -0600 Subject: [PATCH 77/86] Fix conflicts from the merge in the testlist Adds more tests on izumi as well as some gnu and one nvhpc test. --- cime_config/testdefs/testlist_mosart.xml | 66 ++++-------------------- 1 file changed, 11 insertions(+), 55 deletions(-) diff --git a/cime_config/testdefs/testlist_mosart.xml b/cime_config/testdefs/testlist_mosart.xml index b274535..8a1b899 100644 --- a/cime_config/testdefs/testlist_mosart.xml +++ b/cime_config/testdefs/testlist_mosart.xml @@ -1,29 +1,16 @@ - + -<<<<<<< HEAD - - - - - -||||||| abd2bc4 - - -======= + ->>>>>>> mosart1.1.02 + + -<<<<<<< HEAD - -||||||| abd2bc4 - -======= @@ -44,7 +31,6 @@ ->>>>>>> mosart1.1.02 @@ -69,15 +55,9 @@ -<<<<<<< HEAD - - -||||||| abd2bc4 - -======= + ->>>>>>> mosart1.1.02 @@ -96,16 +76,10 @@ -<<<<<<< HEAD - - - -||||||| abd2bc4 - - -======= + + + ->>>>>>> mosart1.1.02 @@ -127,15 +101,9 @@ -<<<<<<< HEAD - - -||||||| abd2bc4 - -======= ->>>>>>> mosart1.1.02 + @@ -144,15 +112,9 @@ -<<<<<<< HEAD - - -||||||| abd2bc4 - -======= ->>>>>>> mosart1.1.02 + @@ -161,15 +123,9 @@ -<<<<<<< HEAD - - -||||||| abd2bc4 - -======= ->>>>>>> mosart1.1.02 + From fb41a046f96c91772e0c1a401a353604454dce9a Mon Sep 17 00:00:00 2001 From: Erik Kluzek Date: Wed, 30 Oct 2024 18:19:20 -0600 Subject: [PATCH 78/86] Fix compset to point to MOSART and add a comment that it isn't functional yet. Would be good for testing though. This resolves #61 --- cime_config/config_compsets.xml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/cime_config/config_compsets.xml b/cime_config/config_compsets.xml index 2e0d1e2..bcdb077 100644 --- a/cime_config/config_compsets.xml +++ b/cime_config/config_compsets.xml @@ -37,8 +37,9 @@ + R2000MOSART - 2000_SATM_DLND%LCPL_SICE_SOCN_MIZUROUTE_SGLC_SWAV + 2000_SATM_DLND%LCPL_SICE_SOCN_MOSART_SGLC_SWAV From c1f476cd0e508edbb0cb680fcf8ab4129af9b7e8 Mon Sep 17 00:00:00 2001 From: Erik Kluzek Date: Wed, 30 Oct 2024 18:34:52 -0600 Subject: [PATCH 79/86] Change Clm51 test to Clm60 This fixes #91 --- cime_config/testdefs/testlist_mosart.xml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cime_config/testdefs/testlist_mosart.xml b/cime_config/testdefs/testlist_mosart.xml index 8a1b899..98a610c 100644 --- a/cime_config/testdefs/testlist_mosart.xml +++ b/cime_config/testdefs/testlist_mosart.xml @@ -64,14 +64,14 @@ - + - + From 891a45d45c28ada9ea8d23b0095ed6667d878306 Mon Sep 17 00:00:00 2001 From: Samuel Levis Date: Thu, 31 Oct 2024 12:29:14 -0600 Subject: [PATCH 80/86] Change mosart tests to all be Clm60 --- cime_config/testdefs/testlist_mosart.xml | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/cime_config/testdefs/testlist_mosart.xml b/cime_config/testdefs/testlist_mosart.xml index 98a610c..c572a91 100644 --- a/cime_config/testdefs/testlist_mosart.xml +++ b/cime_config/testdefs/testlist_mosart.xml @@ -1,7 +1,7 @@ - + @@ -14,7 +14,7 @@ - + @@ -24,7 +24,7 @@ - + @@ -33,7 +33,7 @@ - + @@ -43,7 +43,7 @@ - + @@ -53,7 +53,7 @@ - + @@ -74,7 +74,7 @@ - + @@ -89,7 +89,7 @@ - + @@ -99,7 +99,7 @@ - + @@ -110,7 +110,7 @@ - + @@ -121,7 +121,7 @@ - + @@ -132,7 +132,7 @@ - + From 77494596d594df6c5843747944abf1612c8d5494 Mon Sep 17 00:00:00 2001 From: Samuel Levis Date: Thu, 31 Oct 2024 12:33:04 -0600 Subject: [PATCH 81/86] Rm 2 fldlist_add lines needed only for rof_from_glc, which is obsolete --- src/cpl/nuopc/rof_import_export.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/cpl/nuopc/rof_import_export.F90 b/src/cpl/nuopc/rof_import_export.F90 index 80cc7c7..d5fd022 100644 --- a/src/cpl/nuopc/rof_import_export.F90 +++ b/src/cpl/nuopc/rof_import_export.F90 @@ -113,8 +113,6 @@ subroutine advertise_fields(gcomp, flds_scalar_name, rc) call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_rofsub') call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_rofi') call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_irrig') - call fldlist_add(fldsToRof_num, fldsToRof, 'Fgrg_rofl') ! liq runoff from glc - call fldlist_add(fldsToRof_num, fldsToRof, 'Fgrg_rofi') ! ice runoff from glc do n = 1,fldsToRof_num call NUOPC_Advertise(importState, standardName=fldsToRof(n)%stdname, & From 17c55722219c625cf3bf2dc9a69149309972cc72 Mon Sep 17 00:00:00 2001 From: Samuel Levis Date: Thu, 31 Oct 2024 12:37:37 -0600 Subject: [PATCH 82/86] Reduce logging noise from mosart's decomp info --- src/riverroute/mosart_control_type.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/riverroute/mosart_control_type.F90 b/src/riverroute/mosart_control_type.F90 index 672613f..095d1f1 100644 --- a/src/riverroute/mosart_control_type.F90 +++ b/src/riverroute/mosart_control_type.F90 @@ -990,10 +990,12 @@ subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & endif pid = max(pid,0) pid = min(pid,npes-1) +#ifndef NDEBUG if (iam == pid) then write(iulog,'(2a,i9,a,i9,a,i9,a,i9)')' mosart decomp info',& ' proc = ',iam,' begr = ',begr,' endr = ',endr,' numr = ',lnumr endif +#endif call mpi_barrier(mpicom_rof,ier) enddo From 3fa79c4ae3f8b50a433d0a9aab9690843a791a71 Mon Sep 17 00:00:00 2001 From: Samuel Levis Date: Thu, 31 Oct 2024 13:08:24 -0600 Subject: [PATCH 83/86] Fix typo --- cime_config/testdefs/testlist_mosart.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cime_config/testdefs/testlist_mosart.xml b/cime_config/testdefs/testlist_mosart.xml index c572a91..4974b78 100644 --- a/cime_config/testdefs/testlist_mosart.xml +++ b/cime_config/testdefs/testlist_mosart.xml @@ -1,4 +1,4 @@ - + From 3af251485b1847fd005845aa1a4126f105390a29 Mon Sep 17 00:00:00 2001 From: Samuel Levis Date: Thu, 31 Oct 2024 13:36:09 -0600 Subject: [PATCH 84/86] Partly back out 891a45d due to ERROR: Invalid compset name --- cime_config/testdefs/testlist_mosart.xml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/cime_config/testdefs/testlist_mosart.xml b/cime_config/testdefs/testlist_mosart.xml index 4974b78..f43e080 100644 --- a/cime_config/testdefs/testlist_mosart.xml +++ b/cime_config/testdefs/testlist_mosart.xml @@ -14,7 +14,7 @@ - + @@ -33,7 +33,7 @@ - + @@ -53,7 +53,7 @@ - + From 692d1839489d6979c1a241e0f638189186405cfc Mon Sep 17 00:00:00 2001 From: Samuel Levis Date: Thu, 31 Oct 2024 15:33:10 -0600 Subject: [PATCH 85/86] Revert 7749459 and add if statement as proposed by Erik K --- src/cpl/nuopc/rof_import_export.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/cpl/nuopc/rof_import_export.F90 b/src/cpl/nuopc/rof_import_export.F90 index d5fd022..08dbc60 100644 --- a/src/cpl/nuopc/rof_import_export.F90 +++ b/src/cpl/nuopc/rof_import_export.F90 @@ -113,6 +113,10 @@ subroutine advertise_fields(gcomp, flds_scalar_name, rc) call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_rofsub') call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_rofi') call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_irrig') + if ( ctl%rof_from_glc ) then + call fldlist_add(fldsToRof_num, fldsToRof, 'Fgrg_rofl') ! liq runoff from glc + call fldlist_add(fldsToRof_num, fldsToRof, 'Fgrg_rofi') ! ice runoff from glc + end if do n = 1,fldsToRof_num call NUOPC_Advertise(importState, standardName=fldsToRof(n)%stdname, & From e49b68400c6578a6dc3073ef150ee236d60ff7e9 Mon Sep 17 00:00:00 2001 From: Samuel Levis Date: Thu, 31 Oct 2024 16:42:17 -0600 Subject: [PATCH 86/86] Update mosart testlist --- cime_config/testdefs/testlist_mosart.xml | 26 ++++++++---------------- 1 file changed, 8 insertions(+), 18 deletions(-) diff --git a/cime_config/testdefs/testlist_mosart.xml b/cime_config/testdefs/testlist_mosart.xml index f43e080..ce171cf 100644 --- a/cime_config/testdefs/testlist_mosart.xml +++ b/cime_config/testdefs/testlist_mosart.xml @@ -14,16 +14,6 @@ - - - - - - - - - - @@ -33,7 +23,7 @@ - + @@ -43,7 +33,7 @@ - + @@ -53,7 +43,7 @@ - + @@ -64,7 +54,7 @@ - + @@ -74,7 +64,7 @@ - + @@ -89,7 +79,7 @@ - + @@ -99,7 +89,7 @@ - + @@ -110,7 +100,7 @@ - +