diff --git a/cime_config/buildlib b/cime_config/buildlib index c8670e0a..459106d2 100755 --- a/cime_config/buildlib +++ b/cime_config/buildlib @@ -56,7 +56,7 @@ def _main_func(): complib = os.path.join(libroot,"librof.a") makefile = os.path.join(casetools, "Makefile") - cmd = "{} complib -j {} MODEL=mizuRoute COMPLIB={} -f {} {}" \ + cmd = "{} complib -j {} COMP_NAME=mizuRoute COMPLIB={} -f {} {}" \ .format(gmake, gmake_j, complib, makefile, get_standard_makefile_args(case)) rc, out, err = run_cmd(cmd) diff --git a/cime_config/buildnml b/cime_config/buildnml index 5af5cdd6..1b09150e 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -14,7 +14,8 @@ import os, sys CIMEROOT = os.environ.get("CIMEROOT") if CIMEROOT is None: raise SystemExit("ERROR: must set CIMEROOT environment variable") -sys.path.append(os.path.join(CIMEROOT, "scripts", "Tools")) +_LIBDIR = os.path.join(CIMEROOT, "CIME", "Tools") +sys.path.append(_LIBDIR) # Path for mizuRoute/route/settings for both a mizuRoute standalone checkout as well as a CESM checkout sys.path.append(os.path.join(CIMEROOT, "..", "route", "settings")) sys.path.append(os.path.join(CIMEROOT, "..", "components", "mizuRoute", "route", "settings")) @@ -22,6 +23,7 @@ sys.path.append(os.path.join(CIMEROOT, "..", "components", "mizuRoute", "route", from standard_script_setup import * from CIME.case import Case from CIME.nmlgen import NamelistGenerator +from CIME.XML.files import Files from CIME.utils import expect, safe_copy from CIME.buildnml import create_namelist_infile, parse_input from mizuRoute_control import mizuRoute_control @@ -30,7 +32,7 @@ logger = logging.getLogger(__name__) # pylint: disable=too-many-arguments,too-many-locals,too-many-branches,too-many-statements #################################################################################### -def _create_control_files(case, caseroot, srcroot, confdir, inst_string, infile, nmlgen, ctl, data_list_path): +def _create_control_files(case, caseroot, srcroot, confdir, inst_string, infile, nmlgen, ctl): #################################################################################### """Write out the input configuration file for mizuRoute @@ -124,7 +126,7 @@ def _create_control_files(case, caseroot, srcroot, confdir, inst_string, infile, varname_downSegId = "Tosegment" varname_pfafCode = "pfaf" elif ( config['rof_grid'] == "USGS_GFmz" ): - fname_ntopOld = "ntopo_USGS-GFmz_Conus_cdf5_c20201008.nc" + fname_ntopOld = "ntopo_USGS-GFmz_Conus_cdf5_c20230602.nc" varname_area = "Basin_Area" varname_length = "Length" varname_slope = "Slope" @@ -180,7 +182,7 @@ def _create_control_files(case, caseroot, srcroot, confdir, inst_string, infile, #---------------------------------------------------- # Initialize namelist defaults #---------------------------------------------------- - nmlgen.init_defaults(infile, config) + nmlgen.init_defaults(infile, config, skip_default_for_groups="data_files",) #---------------------------------------------------- # Check for incompatible options. @@ -202,6 +204,7 @@ def _create_control_files(case, caseroot, srcroot, confdir, inst_string, infile, ctl.set( "input_dir", rundir+"/" ) ctl.set( "ancil_dir", ancil_dir ) ctl.set( "fname_ntopOld", fname_ntopOld ) + nmlgen.set_value( "fname_ntopold", value=os.path.join( ancil_dir, fname_ntopOld ) ) ctl.set( "dt_qsim", str(dt_qsim) ) ctl.set( "dname_sseg", dname_sseg ) ctl.set( "dname_nhru", dname_nhru ) @@ -239,6 +242,8 @@ def _create_control_files(case, caseroot, srcroot, confdir, inst_string, infile, fname_state_in = "empty" ctl.set( "fname_state_in", fname_state_in ) + if fname_state_in is not "empty": + nmlgen.set_value( "fname_state_in", value=os.path.join( ancil_dir, fname_ntopOld ) ) # Read in the user control file for the case and change settings to it file_src = "user_nl_mizuroute_control" @@ -257,17 +262,18 @@ def _create_control_files(case, caseroot, srcroot, confdir, inst_string, infile, #---------------------------------------------------- control_file = os.path.join(confdir, "mizuRoute.control") nml_file = os.path.join(confdir, "mizuRoute_in") - write_nml_in_file(case, nmlgen, confdir, nml_file) + write_nml_in_file(case, nmlgen, confdir, nml_file ) ctl.write( control_file ) ############################################################################### def write_nml_in_file(case, nmlgen, confdir, nml_file): ############################################################################### - data_list_path = os.path.join(case.get_case_root(), "Buildconf", "rof.input_data_list") + data_list_path = os.path.join(case.get_case_root(), "Buildconf", "mizuroute.input_data_list") if os.path.exists(data_list_path): os.remove(data_list_path) + namelist_file = os.path.join(confdir, nml_file) - nmlgen.write_output_file(namelist_file, data_list_path ) + nmlgen.write_output_file(namelist_file, data_list_path=data_list_path, groups=["HSLOPE", "IRF_UH", "KWT"]) ############################################################################### def buildnml(case, caseroot, compname): @@ -294,13 +300,6 @@ def buildnml(case, caseroot, compname): ctl = mizuRoute_control() ctl.read( sampleFile ) - #---------------------------------------------------- - # Clear out old data. - #---------------------------------------------------- - data_list_path = os.path.join(case.get_case_root(), "Buildconf", "mizuRoute.input_data_list") - if os.path.exists(data_list_path): - os.remove(data_list_path) - #---------------------------------------------------- # Do some checking #---------------------------------------------------- @@ -322,12 +321,15 @@ def buildnml(case, caseroot, compname): create_namelist_infile(case, user_nl_file, infile) control_infile = [infile] + # NOTE: User definition *replaces* existing definition. + files = Files(comp_interface="nuopc") + # Create the namelist generator object - independent of instance - definition_files = [srcroot + "/cime_config/namelist_definition_mizuRoute.xml"] - nmlgen = NamelistGenerator(case, definition_files) + definition_files = [os.path.join( srcroot, "cime_config/namelist_definition_mizuRoute.xml") ] + nmlgen = NamelistGenerator(case, definition_files, files=files) # create control files - _create_control_files(case, caseroot, srcroot, confdir, inst_string, control_infile, nmlgen, ctl, data_list_path) + _create_control_files(case, caseroot, srcroot, confdir, inst_string, control_infile, nmlgen, ctl) # copy control files to rundir if os.path.isdir(rundir): @@ -343,7 +345,7 @@ def buildnml(case, caseroot, compname): def _main_func(): caseroot = parse_input(sys.argv) - with Case(caseroot) as case: + with Case(case_root=caseroot) as case: buildnml(case, caseroot, "mizuRoute") if __name__ == "__main__": diff --git a/cime_config/config_archive.xml b/cime_config/config_archive.xml index 39974b3d..67fef674 100644 --- a/cime_config/config_archive.xml +++ b/cime_config/config_archive.xml @@ -2,7 +2,8 @@ r h.*\.nc$ - unset + h_gauge.*\.nc$ + history_file rpointer.rof ./$CASE.mizuroute.r.$DATENAME.nc diff --git a/cime_config/namelist_definition_mizuRoute.xml b/cime_config/namelist_definition_mizuRoute.xml index d93cfcfe..25b4bd46 100644 --- a/cime_config/namelist_definition_mizuRoute.xml +++ b/cime_config/namelist_definition_mizuRoute.xml @@ -122,4 +122,27 @@ + + + + + char + datasets + abs + data_files + + River network description file + + + + + char + datasets + abs + data_files + + Initial conditions file + + + diff --git a/cime_config/test/env_case.xml b/cime_config/test/env_case.xml index 352ed964..df4f4419 100644 --- a/cime_config/test/env_case.xml +++ b/cime_config/test/env_case.xml @@ -13,8 +13,8 @@ char file containing specification of component specific definitions and values(for documentation only - DO NOT EDIT) - $CIMEROOT/config/xml_schemas/entry_id.xsd - $CIMEROOT/config/xml_schemas/entry_id_version3.xsd + $CIMEROOT/CIME/data/config/xml_schemas/entry_id.xsd + $CIMEROOT/CIME/data/config/xml_schemas/entry_id_version3.xsd @@ -22,10 +22,10 @@ Component set long name (for documentation only - DO NOT EDIT) - + char Root directory of the case river runoff model component - $CIMEROOT/config/xml_schemas/config_compsets.xsd + $CIMEROOT/CIME/data/config/xml_schemas/config_compsets.xsd @@ -34,11 +34,20 @@ Name of river component - + char full pathname of source root directory + + char + Machine name + + + char + Machines directory location + + char case name diff --git a/cime_config/test/env_run.xml b/cime_config/test/env_run.xml index 04ca7e8e..5cc1ee51 100644 --- a/cime_config/test/env_run.xml +++ b/cime_config/test/env_run.xml @@ -11,7 +11,7 @@ Sample env_run.xml file that allows buildnml to be run for testing in this direc --> - + diff --git a/cime_config/test/runbuildnml b/cime_config/test/runbuildnml index cc72df55..f5d4542a 100755 --- a/cime_config/test/runbuildnml +++ b/cime_config/test/runbuildnml @@ -1,9 +1,12 @@ #!/bin/bash -cd ../../cime >& /dev/null +# Run the buildnmal for mizuRoute, assing it's under a CTSM or CESM checkout +cd ../../../../cime >& /dev/null if [ $? != 0 ]; then - cd ../../../../cime + echo "cime directory does not exist where expected" + exit -1 fi export CIMEROOT=`pwd` +echo "CIMEROOT = $CIMEROOT" cd - cp ../user_nl_* . @@ -22,6 +25,8 @@ if [ $? != 0 ] ; then else echo "Cat the results...." cat Buildconf/mizurouteconf/mizuRoute* + echo "input_data_list..." + cat Buildconf/mizuroute.input_data_list fi rm -rf user_* run/* Buildconf/mizurouteconf/* Buildconf/* CaseDocs echo "Successfully ran test" diff --git a/cime_config/testdefs/ExpectedTestFails.xml b/cime_config/testdefs/ExpectedTestFails.xml index 63e21961..49abf98a 100644 --- a/cime_config/testdefs/ExpectedTestFails.xml +++ b/cime_config/testdefs/ExpectedTestFails.xml @@ -48,14 +48,42 @@ #390 - + + FAIL + #390 + + + + + FAIL + #390 + + + FAIL + #390 + + + + + FAIL + #390 + FAIL - #388 + #390 + + FAIL - #388 + #390 + + + + + FAIL + #390 diff --git a/cime_config/testdefs/testlist_mizuRoute.xml b/cime_config/testdefs/testlist_mizuRoute.xml index a0f0fc00..e3f0da5a 100644 --- a/cime_config/testdefs/testlist_mizuRoute.xml +++ b/cime_config/testdefs/testlist_mizuRoute.xml @@ -3,20 +3,20 @@ - + - + - + - + @@ -96,7 +96,9 @@ + @@ -113,7 +115,26 @@ - + + + + + + + + + + + + + + + + + + + + @@ -122,7 +143,7 @@ - + @@ -133,7 +154,7 @@ - + @@ -155,15 +176,11 @@ - + - - - - @@ -189,11 +206,10 @@ - + - @@ -212,30 +228,36 @@ - + - - + - - + + + + + + + + + diff --git a/route/build/cpl/RtmMod.F90 b/route/build/cpl/RtmMod.F90 index 99f98bdb..17922664 100644 --- a/route/build/cpl/RtmMod.F90 +++ b/route/build/cpl/RtmMod.F90 @@ -337,7 +337,7 @@ SUBROUTINE get_hru_area(NETOPO_in, RPARAM_in, offset, verbose) do iHru = 1, nCatch ix = NETOPO_in(iRch)%HRUIX(iHru) if (present(offset)) ix = ix+offset - write(iulog, '(a,x,5(g20.12))') & + write(iulog, '(a,1x,5(g20.12))') & 'reachID, hruID, basinArea [m2], weight[-], hruArea [m2]=', & NETOPO_in(iRch)%REACHID, NETOPO_in(iRch)%HRUID(iHru), RPARAM_in(iRch)%BASAREA, & NETOPO_in(iRch)%HRUWGT(iHru), rtmCTL%area(ix) diff --git a/route/build/cpl/RtmTimeManager.F90 b/route/build/cpl/RtmTimeManager.F90 index 2d4d3a6d..513e8e02 100644 --- a/route/build/cpl/RtmTimeManager.F90 +++ b/route/build/cpl/RtmTimeManager.F90 @@ -1,6 +1,5 @@ MODULE RtmTimeManager - USE ESMF USE shr_kind_mod, ONLY: r8 => shr_kind_r8 USE shr_sys_mod , ONLY: shr_sys_abort, shr_sys_flush USE public_var , ONLY: iulog @@ -20,14 +19,12 @@ MODULE RtmTimeManager !-------------------------------------------------------------------------- ! Input from CESM driver - integer, save :: nelapse = integerMissing, & ! number of timesteps (or days if negative) to extend a run - start_ymd = integerMissing, & ! starting date for run in yearmmdd format + integer :: start_ymd = integerMissing, & ! starting date for run in yearmmdd format start_tod = 0, & ! starting time of day for run in seconds stop_ymd = integerMissing, & ! stopping date for run in yearmmdd format stop_tod = 0, & ! stopping time of day for run in seconds ref_ymd = integerMissing, & ! reference date for time coordinate in yearmmdd format ref_tod = 0 ! reference time of day for time coordinate in seconds - logical, save :: tm_first_restart_step = .false. ! true for first step of a restart or branch run CONTAINS @@ -71,7 +68,10 @@ SUBROUTINE init_time(ierr, message) case('hours','hour','hr','h'); sec2tunit=3600._r8 case('days','day','d'); sec2tunit=86400._r8 case default - ierr=20; message=trim(message)//'= '//trim(time_units)//': must be seconds, minutes, hours or days.'; return + ierr=20 + message=trim(message)//'= '//trim(time_units)// & + ': must be seconds, minutes, hours or days.' + return end select ! obtain reference, simulation start and end datetimes @@ -92,7 +92,11 @@ SUBROUTINE init_time(ierr, message) timeVar(2) = timeVar(1) + dt ! check that the dates are aligned - if(endDatetime < begDatetime) then; ierr=20; message=trim(message)//'simulation end is before simulation start'; return; endif + if(endDatetime < begDatetime) then + ierr=20 + message=trim(message)//'simulation end is before simulation start' + return + endif ! initialize model time at first time step (1) and previous time step (0) iTime = 1 @@ -103,7 +107,8 @@ SUBROUTINE init_time(ierr, message) if (masterproc .and. debug) then write(iulog,*) 'simStart datetime = ', trim(simStart) write(iulog,*) 'simEnd datetime = ', trim(simEnd) - write(iulog,*) 'reference datetime = ', refDatetime%year(), refDatetime%month(), refDatetime%day(), refDatetime%hour(), refDatetime%minute(), refDatetime%sec() + write(iulog,*) 'reference datetime = ', refDatetime%year(), refDatetime%month(), refDatetime%day(), & + refDatetime%hour(), refDatetime%minute(), refDatetime%sec() write(iulog,*) 'dt [sec] = ', dt write(iulog,*) 'nTime = ', nTime write(iulog,*) 'iTime = ', iTime @@ -117,6 +122,7 @@ END SUBROUTINE init_time ! Public subroutine: SUBROUTINE shr_timeStr(esmfTime, timeStr) + USE ESMF , ONLY: ESMF_Time, ESMF_TimeGet implicit none ! Arguments @@ -129,9 +135,8 @@ SUBROUTINE shr_timeStr(esmfTime, timeStr) call ESMF_TimeGet(esmfTime , yy=yy, mm=mm, dd=dd, h=hr, m=mn, s=sec, rc=rc ) - write(timeStr,'(i4.4,a,i2.2,a,i2.2,a,i2.2,a,i2.2,a,i2.2)'), yy,'-',mm,'-',dd,' ',hr,':',mn,':',sec + write(timeStr,'(i4.4,a1,i2.2,a1,i2.2,a1,i2.2,a1,i2.2,a1,i2.2)') yy,'-',mm,'-',dd,' ',hr,':',mn,':',sec END SUBROUTINE shr_timeStr - END MODULE RtmTimeManager diff --git a/route/build/cpl/nuopc/rof_comp_nuopc.F90 b/route/build/cpl/nuopc/rof_comp_nuopc.F90 index 9d7a3cad..3b761e69 100644 --- a/route/build/cpl/nuopc/rof_comp_nuopc.F90 +++ b/route/build/cpl/nuopc/rof_comp_nuopc.F90 @@ -447,11 +447,8 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call shr_cal_ymd2date(yy,mm,dd,start_ymd) - if (trim(starttype) == trim('continue') ) then - call shr_timeStr( currTime, simStart ) - else - call shr_timeStr( startTime, simStart ) - endif + ! Always have simulation start at current time + call shr_timeStr( currTime, simStart ) call ESMF_TimeGet( stopTime, yy=yy, mm=mm, dd=dd, s=stop_tod, rc=rc ) if (ChkErr(rc,__LINE__,u_FILE_u)) return diff --git a/route/build/src/accum_runoff.f90 b/route/build/src/accum_runoff.f90 index 2310f976..f0d3336d 100644 --- a/route/build/src/accum_runoff.f90 +++ b/route/build/src/accum_runoff.f90 @@ -80,7 +80,7 @@ SUBROUTINE accum_inst_runoff(this, & ! "accum_runoff_rchr" object to bo ! check if(segIndex == ixDesire)then write(iulog,'(2a)') new_line('a'),'** Check upstream discharge accumulation **' - write(iulog,'(a,x,I10,x,I10)') ' Reach index & ID =', segIndex, NETOPO_in(segIndex)%REACHID + write(iulog,'(a,1x,I10,1x,I10)') ' Reach index & ID =', segIndex, NETOPO_in(segIndex)%REACHID if (nUps>0) then write(fmt1,'(A,I5,A)') '(A,1X',nUps,'(1X,I10))' write(fmt2,'(A,I5,A)') '(A,1X',nUps,'(1X,F20.7))' @@ -89,8 +89,8 @@ SUBROUTINE accum_inst_runoff(this, & ! "accum_runoff_rchr" object to bo write(iulog,fmt2) ' prflux =', (RCHFLX_out(iens,NETOPO_in(segIndex)%UREACHI(iUps))%ROUTE(idxSUM)%REACH_Q, iUps=1,nUps) end if write(iulog,'(a)') ' * local area discharge (RCHFLX_out%BASIN_QR(1)) and final discharge (RCHFLX_out%ROUTE(idxSUM)%REACH_Q) [m3/s] :' - write(iulog,'(a,x,G15.4)') ' RCHFLX_out%BASIN_QR(1) =', RCHFLX_out(iEns,segIndex)%BASIN_QR(1) - write(iulog,'(a,x,G15.4)') ' RCHFLX_out%ROUTE(idxSUM)%REACH_Q =', RCHFLX_out(iens,segIndex)%ROUTE(idxSUM)%REACH_Q + write(iulog,'(a,1x,G15.4)') ' RCHFLX_out%BASIN_QR(1) =', RCHFLX_out(iEns,segIndex)%BASIN_QR(1) + write(iulog,'(a,1x,G15.4)') ' RCHFLX_out%ROUTE(idxSUM)%REACH_Q =', RCHFLX_out(iens,segIndex)%ROUTE(idxSUM)%REACH_Q endif END SUBROUTINE accum_inst_runoff diff --git a/route/build/src/ascii_utils.f90 b/route/build/src/ascii_utils.f90 index d7c86512..8e0a509f 100644 --- a/route/build/src/ascii_utils.f90 +++ b/route/build/src/ascii_utils.f90 @@ -204,8 +204,9 @@ SUBROUTINE get_vlines(unt,vlines,err,message) vlines(current%ix) = current%chardat previous=>current; current=>current%next deallocate(previous) + nullify(previous) end do - if(associated(list)) nullify(list) + nullify(list) END SUBROUTINE get_vlines ! ********************************************************************************************** diff --git a/route/build/src/base_route.f90 b/route/build/src/base_route.f90 index aab4092e..409285b4 100644 --- a/route/build/src/base_route.f90 +++ b/route/build/src/base_route.f90 @@ -10,12 +10,6 @@ MODULE base_route public:: base_route_rch ! base (abstract) reach routing method class (to be extended to specific) public:: routeContainer ! a holder of instantiated reach routing method object - ! --- routing method container - ! This container (holder) include instantiated reach routing method - type :: routeContainer - class(base_route_rch), allocatable :: rch_route - end type - ! --- base (abstract or template) reach routing method type, abstract :: base_route_rch @@ -23,6 +17,13 @@ MODULE base_route procedure(sub_route_rch), deferred :: route end type + ! --- routing method container + ! This container (holder) include instantiated reach routing method + type :: routeContainer + class(base_route_rch), allocatable :: rch_route + end type + + ABSTRACT INTERFACE SUBROUTINE sub_route_rch(this, & ! object to bound the procedure diff --git a/route/build/src/dfw_route.f90 b/route/build/src/dfw_route.f90 index a7134257..b50b9ad5 100644 --- a/route/build/src/dfw_route.f90 +++ b/route/build/src/dfw_route.f90 @@ -90,10 +90,11 @@ SUBROUTINE dfw_rch(this, & ! dfw_route_rch object to bound this proced if (nUps>0) then do iUps = 1,nUps iRch_ups = NETOPO_in(segIndex)%UREACHI(iUps) ! index of upstream of segIndex-th reach - write(iulog,'(A,X,I12,X,G15.4)') ' UREACHK, uprflux=',NETOPO_in(segIndex)%UREACHK(iUps),RCHFLX_out(iens, iRch_ups)%ROUTE(idxDW)%REACH_Q + write(iulog,'(A,1X,I12,1X,G15.4)') ' UREACHK, uprflux=',NETOPO_in(segIndex)%UREACHK(iUps), & + RCHFLX_out(iens, iRch_ups)%ROUTE(idxDW)%REACH_Q enddo end if - write(iulog,'(A,X,G15.4)') ' RCHFLX_out(iEns,segIndex)%BASIN_QR(1)=',RCHFLX_out(iEns,segIndex)%BASIN_QR(1) + write(iulog,'(A,1X,G15.4)') ' RCHFLX_out(iEns,segIndex)%BASIN_QR(1)=',RCHFLX_out(iEns,segIndex)%BASIN_QR(1) endif ! solve diffusive wave equation @@ -108,16 +109,17 @@ SUBROUTINE dfw_rch(this, & ! dfw_route_rch object to bound this proced verbose, & ! input: reach index to be examined ierr, cmessage) ! output: error control if(ierr/=0)then - write(message, '(A,X,I12,X,A)') trim(message)//'/segment=', NETOPO_in(segIndex)%REACHID, '/'//trim(cmessage) + write(message, '(A,1X,I12,1X,A)') trim(message)//'/segment=', NETOPO_in(segIndex)%REACHID, '/'//trim(cmessage) return endif if(verbose)then - write(iulog,'(A,X,G15.4)') ' RCHFLX_out(iens,segIndex)%REACH_Q=', RCHFLX_out(iens,segIndex)%ROUTE(idxDW)%REACH_Q + write(iulog,'(A,1X,G15.4)') ' RCHFLX_out(iens,segIndex)%REACH_Q=', RCHFLX_out(iens,segIndex)%ROUTE(idxDW)%REACH_Q endif if (RCHFLX_out(iens,segIndex)%ROUTE(idxDW)%REACH_VOL(1) < 0) then - write(iulog,'(A,X,G12.5,X,A,X,I9)') ' ---- NEGATIVE VOLUME = ', RCHFLX_out(iens,segIndex)%ROUTE(idxDW)%REACH_VOL(1), 'at ', NETOPO_in(segIndex)%REACHID + write(iulog,'(A,1X,G12.5,1X,A,1X,I9)') ' ---- NEGATIVE VOLUME = ', RCHFLX_out(iens,segIndex)%ROUTE(idxDW)%REACH_VOL(1), & + 'at ', NETOPO_in(segIndex)%REACHID end if call comp_reach_wb(NETOPO_in(segIndex)%REACHID, idxDW, q_upstream, RCHFLX_out(iens,segIndex), verbose, lakeFlag=.false.) @@ -252,17 +254,17 @@ SUBROUTINE diffusive_wave(rch_param, & ! input: river parameter data structu dx = rch_param%RLENGTH/(Nx-1) ! one extra sub-segment beyond outlet if (verbose) then - write(iulog,'(A,X,G12.5)') ' length [m] =',rch_param%RLENGTH - write(iulog,'(A,X,G12.5)') ' slope [-] =',rch_param%R_SLOPE - write(iulog,'(A,X,G12.5)') ' channel width [m] =',rch_param%R_WIDTH - write(iulog,'(A,X,G12.5)') ' manning coef [-] =',rch_param%R_MAN_N + write(iulog,'(A,1X,G12.5)') ' length [m] =',rch_param%RLENGTH + write(iulog,'(A,1X,G12.5)') ' slope [-] =',rch_param%R_SLOPE + write(iulog,'(A,1X,G12.5)') ' channel width [m] =',rch_param%R_WIDTH + write(iulog,'(A,1X,G12.5)') ' manning coef [-] =',rch_param%R_MAN_N end if ! time-step adjustment so Courant number is less than 1 dTsub = dt/ntSub if (verbose) then - write(iulog,'(A,X,I3,A,X,G12.5)') ' No. sub timestep=',nTsub,' sub time-step [sec]=',dTsub + write(iulog,'(A,1X,I3,A,1X,G12.5)') ' No. sub timestep=',nTsub,' sub time-step [sec]=',dTsub end if allocate(Qlocal(1:nMolecule%DW_ROUTE, 0:1), stat=ierr, errmsg=cmessage) @@ -355,7 +357,7 @@ SUBROUTINE diffusive_wave(rch_param, & ! input: river parameter data structu if (verbose) then write(fmt1,'(A,I5,A)') '(A,1X',nMolecule%DW_ROUTE,'(1X,G15.4))' - write(iulog,'(A,X,G12.5)') ' rflux%REACH_Q= ', rflux%ROUTE(idxDW)%REACH_Q + write(iulog,'(A,1X,G12.5)') ' rflux%REACH_Q= ', rflux%ROUTE(idxDW)%REACH_Q write(iulog,fmt1) ' Qprev(1:nMolecule)= ', Qprev(1:nMolecule%DW_ROUTE) write(iulog,'(A,5(1X,G12.5))') ' Qbar, Abar, Vbar, ck, dk= ',Qbar, Abar, Vbar, ck, dk write(iulog,'(A,2(1X,G12.5))') ' Cd, Ca= ', Cd, Ca diff --git a/route/build/src/domain_decomposition.f90 b/route/build/src/domain_decomposition.f90 index beef8f6f..93b39a2f 100644 --- a/route/build/src/domain_decomposition.f90 +++ b/route/build/src/domain_decomposition.f90 @@ -112,11 +112,11 @@ SUBROUTINE print_screen() associate (segIndexSub => domains_mpi(ix)%segIndex, nSubSeg => size(domains_mpi(ix)%segIndex)) do iSeg = 1,size(segIndexSub) if (downIndex(segIndexSub(iSeg)) > 0) then - write(iulog, "(I9,x,I12,x,I9,x,I12,x,I5,x,I3)") segIndexSub(iSeg),segId(segIndexSub(iSeg)), & + write(iulog, "(I9,1x,I12,1x,I9,1x,I12,1x,I5,1x,I3)") segIndexSub(iSeg),segId(segIndexSub(iSeg)), & downIndex(segIndexSub(iSeg)),segId(downIndex(segIndexSub(iSeg))), & ix, domains_mpi(ix)%idNode else - write(iulog, "(I9,x,I12,x,I9,x,I12,x,I5,x,I3)") segIndexSub(iSeg),segId(segIndexSub(iSeg)), & + write(iulog, "(I9,1x,I12,1x,I9,1x,I12,1x,I5,1x,I3)") segIndexSub(iSeg),segId(segIndexSub(iSeg)), & downIndex(segIndexSub(iSeg)),-999, & ix, domains_mpi(ix)%idNode endif diff --git a/route/build/src/globalData.f90 b/route/build/src/globalData.f90 index 805b9e01..ad8c839a 100644 --- a/route/build/src/globalData.f90 +++ b/route/build/src/globalData.f90 @@ -119,9 +119,9 @@ MODULE globalData integer(i4b), public :: nEns=1 ! number of ensemble integer(i4b), public :: maxtdh ! maximum unit-hydrograph future time steps type(cMolecule), public :: nMolecule ! number of computational molecule (used for KW, MC, DW) - character(300), public :: hfileout=charMissing ! history output file name - character(300), public :: hfileout_gage=charMissing ! gage-only history output file name - character(300), public :: rfileout=charMissing ! restart output file name + character(FileStrLen), public :: hfileout=charMissing ! history output file name + character(FileStrLen), public :: hfileout_gage=charMissing ! gage-only history output file name + character(FileStrLen), public :: rfileout=charMissing ! restart output file name logical(lgt), public :: initHvars=.false. ! status of history variable data initialization logical(lgt), public :: isColdStart=.true. ! initial river state - cold start (T) or from restart file (F) diff --git a/route/build/src/histVars_data.f90 b/route/build/src/histVars_data.f90 index 94416c6d..c0deda0a 100644 --- a/route/build/src/histVars_data.f90 +++ b/route/build/src/histVars_data.f90 @@ -198,7 +198,7 @@ SUBROUTINE aggregate(this, & ! inout: case(muskingumCunge); idxMethod=idxMC case(diffusiveWave); idxMethod=idxDW case default - write(message,'(2A,X,G0,X,A)') trim(message), 'routing method index:',routeMethods(iRoute), 'must be 0-5' + write(message,'(2A,1X,G0,1X,A)') trim(message), 'routing method index:',routeMethods(iRoute), 'must be 0-5' ierr=81; return end select @@ -438,7 +438,7 @@ SUBROUTINE read_restart(this, restart_name, ierr, message) ixFlow=ixRFLX%DWroutedRunoff ixVol=ixRFLX%DWvolume case default - write(message,'(2A,X,G0,X,A)') trim(message), 'routing method index:',routeMethods(ixRoute), 'must be 0-5' + write(message,'(2A,1X,G0,1X,A)') trim(message), 'routing method index:',routeMethods(ixRoute), 'must be 0-5' ierr=81; return end select diff --git a/route/build/src/historyFile.f90 b/route/build/src/historyFile.f90 index 3e8e7cc5..414bc8e2 100644 --- a/route/build/src/historyFile.f90 +++ b/route/build/src/historyFile.f90 @@ -30,7 +30,7 @@ MODULE historyFile type :: histFile private - character(300) :: fname ! netCDF name + character(FileStrLen) :: fname ! netCDF name integer(i4b) :: iTime=0 ! time step in output netCDF logical(lgt) :: fileStatus=.false. ! flag to indicate history output netcdf is open logical(lgt) :: gageOutput=.false. ! flag to indicate this is at-gage-only output (== output subset of reaches) @@ -77,6 +77,7 @@ FUNCTION constructor(fname, pioSys, gageOutput) RESULT(instHistFile) type(iosystem_desc_t), optional, intent(in) :: pioSys instHistFile%fname = fname + instHistFile%fileStatus = .false. if (present(gageOutput)) then instHistFile%gageOutput = gageOutput @@ -321,7 +322,7 @@ SUBROUTINE closeNC(this) implicit none class(histFile), intent(inout) :: this - if (this%fileStatus) then + if (this%fileOpen() ) then call closeFile(this%pioFileDesc, this%fileStatus) endif END SUBROUTINE closeNC @@ -350,7 +351,7 @@ SUBROUTINE cleanup_hru(this) implicit none class(histFile), intent(inout) :: this - call freeDecomp(this%pioFileDesc, this%ioDescHruFlux) + call freeDecomp(this%pioSys, this%ioDescHruFlux) END SUBROUTINE cleanup_hru @@ -361,7 +362,7 @@ SUBROUTINE cleanup_rch(this) implicit none class(histFile), intent(inout) :: this - call freeDecomp(this%pioFileDesc, this%ioDescRchFlux) + call freeDecomp(this%pioSys, this%ioDescRchFlux) END SUBROUTINE cleanup_rch diff --git a/route/build/src/init_model_data.f90 b/route/build/src/init_model_data.f90 index 311c3f9f..f5b57017 100644 --- a/route/build/src/init_model_data.f90 +++ b/route/build/src/init_model_data.f90 @@ -576,8 +576,6 @@ SUBROUTINE init_ntopo(nHRU_out, nRch_out, ! --> users can modify the hard-coded parameter "maxUpstreamFile" if desired if(tot_upstream > maxUpstreamFile) tot_upstream=0 - call system('rm -f '//trim(ancil_dir)//trim(fname_ntopNew)) - call writeData(& ! input trim(ancil_dir)//trim(fname_ntopNew), & ! input: file name diff --git a/route/build/src/irf_route.f90 b/route/build/src/irf_route.f90 index d649bfd3..3d4f8b33 100644 --- a/route/build/src/irf_route.f90 +++ b/route/build/src/irf_route.f90 @@ -138,20 +138,23 @@ SUBROUTINE irf_rch(this, & ! irf_route_rch object to bound this procedur ntdh = size(NETOPO_in(segIndex)%UH) write(fmt1,'(A,I5,A)') '(A, 1X',ntdh,'(1X,F20.7))' write(*,'(2a)') new_line('a'),'** Check Impulse Response Function routing **' - write(*,'(a,x,I10,x,I10)') ' Reach index & ID =', segIndex, NETOPO_in(segIndex)%REACHID - write(*,fmt1) ' Unit-Hydrograph =', (NETOPO_in(segIndex)%UH(itdh), itdh=1,ntdh) - write(*,'(a)') ' * total discharge from upstream(q_upstream) [m3/s], local area discharge [m3/s], and Final discharge [m3/s]:' - write(*,'(a,x,F15.7)') ' q_upstream =', q_upstream - write(*,'(a,x,F15.7)') ' RCHFLX_out%BASIN_QR(1) =', RCHFLX_out(iens,segIndex)%BASIN_QR(1) - write(*,'(a,x,F15.7)') ' RCHFLX_out%REACH_Q =', RCHFLX_out(iens,segIndex)%ROUTE(idxIRF)%REACH_Q + write(*,'(a,1x,I10,1x,I10)')' Reach index & ID =', segIndex, NETOPO_in(segIndex)%REACHID + write(*,fmt1) ' Unit-Hydrograph =', (NETOPO_in(segIndex)%UH(itdh), itdh=1,ntdh) + write(*,'(a)') ' * total discharge from upstream(q_upstream) [m3/s], local area discharge [m3/s]' // & + ', and Final discharge [m3/s]:' + write(*,'(a,1x,F15.7)') ' q_upstream =', q_upstream + write(*,'(a,1x,F15.7)') ' RCHFLX_out%BASIN_QR(1) =', RCHFLX_out(iens,segIndex)%BASIN_QR(1) + write(*,'(a,1x,F15.7)') ' RCHFLX_out%REACH_Q =', RCHFLX_out(iens,segIndex)%ROUTE(idxIRF)%REACH_Q endif if (RCHFLX_out(iens,segIndex)%ROUTE(idxIRF)%REACH_VOL(1) < 0) then - write(iulog,'(A,X,G12.5,X,A,X,I9)') ' ---- NEGATIVE VOLUME [m3]= ', RCHFLX_out(iens,segIndex)%ROUTE(idxIRF)%REACH_VOL(1), 'at ', NETOPO_in(segIndex)%REACHID + write(iulog,'(A,1X,G12.5,1X,A,1X,I9)') ' ---- NEGATIVE VOLUME [m3]= ', RCHFLX_out(iens,segIndex)%ROUTE(idxIRF)%REACH_VOL(1), & + 'at ', NETOPO_in(segIndex)%REACHID ! RCHFLX_out(iens,segIndex)%ROUTE(idxIRF)%REACH_VOL(1) = 0._dp end if if (RCHFLX_out(iens,segIndex)%ROUTE(idxIRF)%REACH_Q < 0) then - write(iulog,'(A,X,G12.5,X,A,X,I9)') ' ---- NEGATIVE FLOW [m3/s] = ', RCHFLX_out(iens,segIndex)%ROUTE(idxIRF)%REACH_Q, 'at ', NETOPO_in(segIndex)%REACHID + write(iulog,'(A,1X,G12.5,1X,A,1X,I9)') ' ---- NEGATIVE FLOW [m3/s] = ', RCHFLX_out(iens,segIndex)%ROUTE(idxIRF)%REACH_Q, & + 'at ', NETOPO_in(segIndex)%REACHID ! RCHFLX_out(iens,segIndex)%ROUTE(idxIRF)%REACH_Q = 0._dp end if diff --git a/route/build/src/kwe_route.f90 b/route/build/src/kwe_route.f90 index 3c2d6b02..e0c3d96b 100644 --- a/route/build/src/kwe_route.f90 +++ b/route/build/src/kwe_route.f90 @@ -91,10 +91,11 @@ SUBROUTINE kw_rch(this, & ! kwe_route_rch object to bound this procedu if (nUps>0) then do iUps = 1,nUps iRch_ups = NETOPO_in(segIndex)%UREACHI(iUps) ! index of upstream of segIndex-th reach - write(iulog,'(A,X,I12,X,G12.5)') ' UREACHK, uprflux=',NETOPO_in(segIndex)%UREACHK(iUps),RCHFLX_out(iens, iRch_ups)%ROUTE(idxKW)%REACH_Q + write(iulog,'(A,1X,I12,1X,G12.5)') ' UREACHK, uprflux=',NETOPO_in(segIndex)%UREACHK(iUps), & + RCHFLX_out(iens, iRch_ups)%ROUTE(idxKW)%REACH_Q enddo end if - write(iulog,'(A,X,G15.4)') ' RCHFLX_out(iEns,segIndex)%BASIN_QR(1)=',RCHFLX_out(iEns,segIndex)%BASIN_QR(1) + write(iulog,'(A,1X,G15.4)') ' RCHFLX_out(iEns,segIndex)%BASIN_QR(1)=',RCHFLX_out(iEns,segIndex)%BASIN_QR(1) endif ! perform river network KW routing @@ -109,15 +110,16 @@ SUBROUTINE kw_rch(this, & ! kwe_route_rch object to bound this procedu verbose, & ! input: reach index to be examined ierr, cmessage) ! output: error control if(ierr/=0)then - write(message, '(A,X,I12,X,A)') trim(message)//'/segment=', NETOPO_in(segIndex)%REACHID, '/'//trim(cmessage); return + write(message, '(A,1X,I12,1X,A)') trim(message)//'/segment=', NETOPO_in(segIndex)%REACHID, '/'//trim(cmessage); return endif if(verbose)then - write(iulog,'(A,X,G15.4)') ' RCHFLX_out(iens,segIndex)%REACH_Q=', RCHFLX_out(iens,segIndex)%ROUTE(idxKW)%REACH_Q + write(iulog,'(A,1X,G15.4)') ' RCHFLX_out(iens,segIndex)%REACH_Q=', RCHFLX_out(iens,segIndex)%ROUTE(idxKW)%REACH_Q endif if (RCHFLX_out(iens,segIndex)%ROUTE(idxKW)%REACH_VOL(1) < 0) then - write(iulog,'(A,X,G12.5,X,A,X,I9)') ' ---- NEGATIVE VOLUME = ', RCHFLX_out(iens,segIndex)%ROUTE(idxKW)%REACH_VOL(1), 'at ', NETOPO_in(segIndex)%REACHID + write(iulog,'(A,1X,G12.5,1X,A,1X,I9)') ' ---- NEGATIVE VOLUME = ', RCHFLX_out(iens,segIndex)%ROUTE(idxKW)%REACH_VOL(1), & + 'at ', NETOPO_in(segIndex)%REACHID end if call comp_reach_wb(NETOPO_in(segIndex)%REACHID, idxKW, q_upstream, RCHFLX_out(iens,segIndex), verbose, lakeFlag=.false.) @@ -216,12 +218,12 @@ SUBROUTINE kinematic_wave(rch_param, & ! input: river parameter data structu Q(1,0) = QupMod if (verbose) then - write(iulog,'(A,X,G12.5)') ' length [m] =',rch_param%RLENGTH - write(iulog,'(A,X,G12.5)') ' slope [-] =',rch_param%R_SLOPE - write(iulog,'(A,X,G12.5)') ' channel width [m] =',rch_param%R_WIDTH - write(iulog,'(A,X,G12.5)') ' manning coef. [-] =',rch_param%R_MAN_N - write(iulog,'(A)') ' Initial 3 point discharge [m3/s]: ' - write(iulog,'(3(A,X,G12.5))') ' Q(0,0)=',Q(0,0),' Q(0,1)=',Q(0,1),' Q(1,0)=',Q(1,0) + write(iulog,'(A,1X,G12.5)') ' length [m] =',rch_param%RLENGTH + write(iulog,'(A,1X,G12.5)') ' slope [-] =',rch_param%R_SLOPE + write(iulog,'(A,1X,G12.5)') ' channel width [m] =',rch_param%R_WIDTH + write(iulog,'(A,1X,G12.5)') ' manning coef. [-] =',rch_param%R_MAN_N + write(iulog,'(A)') ' Initial 3 point discharge [m3/s]: ' + write(iulog,'(3(A,1X,G12.5))') ' Q(0,0)=',Q(0,0),' Q(0,1)=',Q(0,1),' Q(1,0)=',Q(1,0) end if ! ---------- @@ -282,7 +284,7 @@ SUBROUTINE kinematic_wave(rch_param, & ! input: river parameter data structu rflux%ROUTE(idxKW)%REACH_Q = Q(1,1)+rflux%BASIN_QR(1) if (verbose) then - write(iulog,'(1(A,X,G15.4))') ' Q(1,1)=',Q(1,1) + write(iulog,'(1(A,1X,G15.4))') ' Q(1,1)=',Q(1,1) end if ! Q abstraction diff --git a/route/build/src/kwt_route.f90 b/route/build/src/kwt_route.f90 index e9edd77b..0589b8c1 100644 --- a/route/build/src/kwt_route.f90 +++ b/route/build/src/kwt_route.f90 @@ -138,11 +138,11 @@ SUBROUTINE kwt_rch(this, & ! kwt_route_rch object to bound this procedur if(segIndex==ixDesire) then write(iulog,'(2a)') new_line('a'),'** Check kinematic wave tracking routing **' - write(iulog,"(a,x,I10,x,I10)") ' Reach index & ID =', segIndex, NETOPO_in(segIndex)%REACHID - write(iulog,"(a,x,F20.7,1x,F20.7)") ' time step(T0,T1) =', T0, T1 - write(iulog,'(a,x,F15.7)') ' RPARAM_in%R_SLOPE =', RPARAM_in(segIndex)%R_SLOPE - write(iulog,'(a,x,F15.7)') ' RPARAM_in%R_MAN_N =', RPARAM_in(segIndex)%R_MAN_N - write(iulog,'(a,x,F15.7)') ' RPARAM_in%R_WIDTH =', RPARAM_in(segIndex)%R_WIDTH + write(iulog,"(a,1x,I10,1x,I10)") ' Reach index & ID =', segIndex, NETOPO_in(segIndex)%REACHID + write(iulog,"(a,1x,F20.7,1x,F20.7)") ' time step(T0,T1) =', T0, T1 + write(iulog,'(a,1x,F15.7)') ' RPARAM_in%R_SLOPE =', RPARAM_in(segIndex)%R_SLOPE + write(iulog,'(a,1x,F15.7)') ' RPARAM_in%R_MAN_N =', RPARAM_in(segIndex)%R_MAN_N + write(iulog,'(a,1x,F15.7)') ' RPARAM_in%R_WIDTH =', RPARAM_in(segIndex)%R_WIDTH end if ! ---------------------------------------------------------------------------------------- @@ -175,7 +175,10 @@ SUBROUTINE kwt_rch(this, & ! kwt_route_rch object to bound this procedur if(ierr/=0)then; message=trim(message)//'problem deallocating space for RCHSTA_out'; return; endif endif allocate(RCHSTA_out(IENS,segIndex)%LKW_ROUTE%KWAVE(0:0),STAT=ierr) - if(ierr/=0)then; message=trim(message)//'problem allocating space for RCHSTA_out(IENS,segIndex)%LKW_ROUTE%KWAVE(1)'; return; endif + if(ierr/=0)then + message=trim(message)//'problem allocating space for RCHSTA_out(IENS,segIndex)%LKW_ROUTE%KWAVE(1)' + return + endif RCHSTA_out(IENS,segIndex)%LKW_ROUTE%KWAVE(0)%QF=-9999 RCHSTA_out(IENS,segIndex)%LKW_ROUTE%KWAVE(0)%TI=-9999 RCHSTA_out(IENS,segIndex)%LKW_ROUTE%KWAVE(0)%TR=-9999 @@ -184,7 +187,7 @@ SUBROUTINE kwt_rch(this, & ! kwt_route_rch object to bound this procedur if(segIndex==ixDesire) then write(iulog,'(a)') ' * Final discharge (RCHFLX_out(IENS,segIndex)%REACH_Q) [m3/s]:' - write(iulog,'(x,G15.4)') RCHFLX_out(IENS,segIndex)%ROUTE(idxKWT)%REACH_Q + write(iulog,'(1x,G15.4)') RCHFLX_out(IENS,segIndex)%ROUTE(idxKWT)%REACH_Q end if return ! no upstream reaches (routing for sub-basins done using time-delay histogram) endif @@ -413,9 +416,9 @@ SUBROUTINE extract_from_rch(iens, jrch, & ! input: ensemble and rea call interp_rch(TENTRY(0:NR-1),Q_jrch_abs(0:NR-1), TP, Qavg, ierr,cmessage) Qabs = Qavg(1)*RPARAM_in(JRCH)%R_WIDTH write(*,'(a)') ' * Target abstraction (Qtake) [m3/s], Available discharge (totQ) [m3/s], Actual abstraction (Qabs) [m3/s] ' - write(*,'(a,x,G15.4)') ' Qtake =', Qtake - write(*,'(a,x,G15.4)') ' totQ =', totQ - write(*,'(a,x,G15.4)') ' Qabs =', Qabs + write(*,'(a,1x,G15.4)') ' Qtake =', Qtake + write(*,'(a,1x,G15.4)') ' totQ =', totQ + write(*,'(a,1x,G15.4)') ' Qabs =', Qabs end if ! modify wave speed at modified wave discharge and re-compute exit time @@ -559,9 +562,9 @@ subroutine getusq_rch(IENS,JRCH,LAKEFLAG,T0,T1,ixDesire, & ! input if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif if (JRCH == ixDesire) then write(fmt1,'(A,I5,A)') '(A,1X',ND,'(1X,G15.4))' - write(*,'(a)') ' * After qexmul_rch: # of routed wave from upstreams (ND) and wave discharge (QD) [m2/s]:' - write(*,'(A,x,I5)') ' ND=', ND - write(*,fmt1) ' QD=', (QD(iw), iw=1,ND) + write(*,'(a)') ' * After qexmul_rch: # of routed wave from upstreams (ND) and wave discharge (QD) [m2/s]:' + write(*,'(A,1x,I5)') ' ND=', ND + write(*,fmt1) ' QD=', (QD(iw), iw=1,ND) end if end if @@ -738,7 +741,8 @@ SUBROUTINE qexmul_rch(IENS,JRCH,T0,T1,ixDesire, & ! input TD(1) = T1 if(JRCH == ixDesire) then - write(iulog,'(A,x,I8,x,I8)') ' * Special case - This reach has one headwater upstream: IR, NETOPO_in(IR)%REACHID = ', IR, NETOPO_in(IR)%REACHID + write(iulog,'(A,1x,I8,1x,I8)') ' * Special case - This reach has one headwater upstream: IR, NETOPO_in(IR)%REACHID = ', & + IR, NETOPO_in(IR)%REACHID end if return @@ -1277,10 +1281,10 @@ SUBROUTINE kinwav_rch(JRCH,T_START,T_END,ixDesire, & ! input: loca if(jRch==ixDesire) then write(fmt1,'(A,I5,A)') '(A,1X',NN,'(1X,G15.4))' - write(iulog,'(a)') ' * Wave discharge (q1) [m2/s] and wave celertiy (wc) [m/s]:' - write(iulog,'(a,x,I3)') ' Number of wave =', NN - write(iulog,fmt1) ' q1=', (q1(iw), iw=1,NN) - write(iulog,fmt1) ' wc=', (wc(iw), iw=1,NN) + write(iulog,'(a)') ' * Wave discharge (q1) [m2/s] and wave celertiy (wc) [m/s]:' + write(iulog,'(a,1x,I3)') ' Number of wave =', NN + write(iulog,fmt1) ' q1=', (q1(iw), iw=1,NN) + write(iulog,fmt1) ' wc=', (wc(iw), iw=1,NN) end if ! handle breaking waves @@ -1337,9 +1341,9 @@ SUBROUTINE kinwav_rch(JRCH,T_START,T_END,ixDesire, & ! input: loca ! check if(jRch==ixDesire) then write(fmt1,'(A,I5,A)') '(A,1X',NN,'(1X,G15.4))' - write(iulog,'(a)') ' * After wave merge: wave celertiy (wc) [m/s]:' - write(iulog,'(a,x,I3)') ' Number of wave =', NN - write(iulog,fmt1) ' wc=', (wc(iw), iw=1,NN) + write(iulog,'(a)') ' * After wave merge: wave celertiy (wc) [m/s]:' + write(iulog,'(a,1x,I3)') ' Number of wave =', NN + write(iulog,fmt1) ' wc=', (wc(iw), iw=1,NN) end if ICOUNT=0 diff --git a/route/build/src/mc_route.f90 b/route/build/src/mc_route.f90 index 42ff3d19..03b6c632 100644 --- a/route/build/src/mc_route.f90 +++ b/route/build/src/mc_route.f90 @@ -90,10 +90,11 @@ SUBROUTINE mc_rch(this, & ! mc_route_rch object to bound this procedur if (nUps>0) then do iUps = 1,nUps iRch_ups = NETOPO_in(segIndex)%UREACHI(iUps) ! index of upstream of segIndex-th reach - write(iulog,'(A,X,I12,X,G12.5)') ' UREACHK, uprflux=',NETOPO_in(segIndex)%UREACHK(iUps),RCHFLX_out(iens, iRch_ups)%ROUTE(idxMC)%REACH_Q + write(iulog,'(A,1X,I12,1X,G12.5)') ' UREACHK, uprflux=',NETOPO_in(segIndex)%UREACHK(iUps), & + RCHFLX_out(iens, iRch_ups)%ROUTE(idxMC)%REACH_Q enddo end if - write(iulog,'(A,X,G12.5)') ' RCHFLX_out(iEns,segIndex)%BASIN_QR(1)=',RCHFLX_out(iEns,segIndex)%BASIN_QR(1) + write(iulog,'(A,1X,G12.5)') ' RCHFLX_out(iEns,segIndex)%BASIN_QR(1)=',RCHFLX_out(iEns,segIndex)%BASIN_QR(1) endif ! solve muskingum-cunge alogorithm @@ -108,15 +109,16 @@ SUBROUTINE mc_rch(this, & ! mc_route_rch object to bound this procedur verbose, & ! input: reach index to be examined ierr, cmessage) ! output: error control if(ierr/=0)then - write(message, '(A,X,I10,X,A)') trim(message)//'/segment=', NETOPO_in(segIndex)%REACHID, '/'//trim(cmessage); return + write(message, '(A,1X,I10,1X,A)') trim(message)//'/segment=', NETOPO_in(segIndex)%REACHID, '/'//trim(cmessage); return endif if(verbose)then - write(iulog,'(A,X,G12.5)') ' RCHFLX_out(iens,segIndex)%REACH_Q=', RCHFLX_out(iens,segIndex)%ROUTE(idxMC)%REACH_Q + write(iulog,'(A,1X,G12.5)') ' RCHFLX_out(iens,segIndex)%REACH_Q=', RCHFLX_out(iens,segIndex)%ROUTE(idxMC)%REACH_Q endif if (RCHFLX_out(iens,segIndex)%ROUTE(idxMC)%REACH_VOL(1) < 0) then - write(iulog,'(A,X,G12.5,X,A,X,I9)') ' ---- NEGATIVE VOLUME = ', RCHFLX_out(iens,segIndex)%ROUTE(idxMC)%REACH_VOL(1), 'at ', NETOPO_in(segIndex)%REACHID + write(iulog,'(A,1X,G12.5,1X,A,1X,I9)') ' ---- NEGATIVE VOLUME = ', RCHFLX_out(iens,segIndex)%ROUTE(idxMC)%REACH_VOL(1), & + 'at ', NETOPO_in(segIndex)%REACHID end if call comp_reach_wb(NETOPO_in(segIndex)%REACHID, idxMC, q_upstream, RCHFLX_out(iens,segIndex), verbose, lakeFlag=.false.) @@ -150,6 +152,10 @@ SUBROUTINE muskingum_cunge(rch_param, & ! input: river parameter data struct ! (time:0:1, loc:0:1) 0-previous time step/inlet, 1-current time step/outlet. ! Q or A(1,2,3,4): 1: (t=0,x=0), 2: (t=0,x=1), 3: (t=1,x=0), 4: (t=1,x=1) + ! -- EBK 06/26/2023 -- comment out isnan check, doesn't seem to be needed + ! Use of shr_infnan_isnan will require changes to the standalone build, and + ! this version is required to work on all compilers. + !use shr_infnan_mod, only : isnan => shr_infnan_isnan implicit none ! Argument variables type(RCHPRP), intent(in) :: rch_param ! River reach parameter @@ -217,12 +223,12 @@ SUBROUTINE muskingum_cunge(rch_param, & ! input: river parameter data struct Q(1,0) = QupMod if (verbose) then - write(iulog,'(A,X,G12.5)') ' length [m] =',rch_param%RLENGTH - write(iulog,'(A,X,G12.5)') ' slope [-] =',rch_param%R_SLOPE - write(iulog,'(A,X,G12.5)') ' channel width [m] =',rch_param%R_WIDTH - write(iulog,'(A,X,G12.5)') ' manning coef [-] =',rch_param%R_MAN_N - write(iulog,'(A)') ' Initial 3 point discharge [m3/s]: ' - write(iulog,'(3(A,X,G12.5))') ' Qin(t-1) Q(0,0)=',Q(0,0),' Qin(t) Q(1,0)=',Q(1,0),' Qout(t-1) Q(0,1)=',Q(0,1) + write(iulog,'(A,1X,G12.5)') ' length [m] =',rch_param%RLENGTH + write(iulog,'(A,1X,G12.5)') ' slope [-] =',rch_param%R_SLOPE + write(iulog,'(A,1X,G12.5)') ' channel width [m] =',rch_param%R_WIDTH + write(iulog,'(A,1X,G12.5)') ' manning coef [-] =',rch_param%R_MAN_N + write(iulog,'(A)') ' Initial 3 point discharge [m3/s]: ' + write(iulog,'(3(A,1X,G12.5))') ' Qin(t-1) Q(0,0)=',Q(0,0),' Qin(t) Q(1,0)=',Q(1,0),' Qout(t-1) Q(0,1)=',Q(0,1) end if ! first, using 3-point average in computational molecule, check Cournat number is less than 1, otherwise subcycle within one time step @@ -240,7 +246,7 @@ SUBROUTINE muskingum_cunge(rch_param, & ! input: river parameter data struct dTsub = dt/ntSub end if if (verbose) then - write(iulog,'(A,X,I3,A,X,G12.5)') ' No. sub timestep=',nTsub,' sub time-step [sec]=',dTsub + write(iulog,'(A,1X,I3,A,1X,G12.5)') ' No. sub timestep=',nTsub,' sub time-step [sec]=',dTsub end if allocate(QoutLocal(0:ntSub), QinLocal(0:ntSub), stat=ierr, errmsg=cmessage) @@ -269,12 +275,13 @@ SUBROUTINE muskingum_cunge(rch_param, & ! input: river parameter data struct QoutLocal(ix) = C0* QinLocal(ix)+ C1* QinLocal(ix-1)+ C2* QoutLocal(ix-1) QoutLocal(ix) = max(0.0, QoutLocal(ix)) - if (isnan(QoutLocal(ix))) then - ierr=10; message=trim(message)//'QoutLocal is Nan; activate vodose for this segment for diagnosis';return - end if + ! -- EBK 06/26/2023 -- comment out isnan check, doesn't seem to be needed. + !if (isnan(QoutLocal(ix))) then + ! ierr=10; message=trim(message)//'QoutLocal is Nan; activate vodose for this segment for diagnosis';return + !end if if (verbose) then - write(iulog,'(A,I3,X,A,G12.5,X,A,G12.5)') ' sub time-step= ',ix,'Courant number= ',Cn, 'Q= ',QoutLocal(ix) + write(iulog,'(A,I3,1X,A,G12.5,1X,A,G12.5)') ' sub time-step= ',ix,'Courant number= ',Cn, 'Q= ',QoutLocal(ix) end if end do @@ -318,7 +325,7 @@ SUBROUTINE muskingum_cunge(rch_param, & ! input: river parameter data struct end if if (verbose) then - write(iulog,'(A,X,G12.5)') ' Qout(t)=',Q(1,1) + write(iulog,'(A,1X,G12.5)') ' Qout(t)=',Q(1,1) endif ! save inflow (index 1) and outflow (index 2) at current time step diff --git a/route/build/src/mpi_process.f90 b/route/build/src/mpi_process.f90 index fa4af147..8a453c13 100644 --- a/route/build/src/mpi_process.f90 +++ b/route/build/src/mpi_process.f90 @@ -2883,6 +2883,8 @@ SUBROUTINE pass_global_data(comm, ierr, message) ! output: error control integer(i4b), intent(out) :: ierr character(len=strLen), intent(out) :: message ! error message + integer(i4b) :: receivemax ! Receive buffer for MAX over all tasks + ierr=0; message='pass_global_data/' ! send scalars @@ -2892,7 +2894,8 @@ SUBROUTINE pass_global_data(comm, ierr, message) ! output: error control call MPI_BCAST(calendar, strLen, MPI_CHARACTER, root, comm, ierr) call MPI_BCAST(time_units,strLen, MPI_CHARACTER, root, comm, ierr) - CALL MPI_ALLREDUCE(maxtdh, maxtdh, 1, MPI_INTEGER, MPI_MAX, comm, ierr) + CALL MPI_ALLREDUCE(maxtdh, receivemax, 1, MPI_INTEGER, MPI_MAX, comm, ierr) + maxtdh = receivemax END SUBROUTINE pass_global_data diff --git a/route/build/src/mpi_utils.f90 b/route/build/src/mpi_utils.f90 index 1d9b7289..99ff2cdd 100644 --- a/route/build/src/mpi_utils.f90 +++ b/route/build/src/mpi_utils.f90 @@ -975,7 +975,7 @@ SUBROUTINE shr_mpi_abort(message, ierr, comm) integer(i4b) :: jerr write(iulog,*) trim(subName),trim(message) - call flush(6) + flush(iulog) if (present(comm)) then call MPI_ABORT(comm, ierr, jerr) @@ -1009,11 +1009,11 @@ SUBROUTINE mpi_handle_err(ierr,pid) if(errLen>strLen)errMsg='errorMessageLengthTooLong' ! include process ID - write(*,'(a,1x,i4)') 'FATAL ERROR (MPI): '//trim(errMsg)//' for process ID ', pid + write(iulog,'(a,1x,i4)') 'FATAL ERROR (MPI): '//trim(errMsg)//' for process ID ', pid ! finalize MPI call MPI_FINALIZE(jerr) - call flush(6) + flush(iulog) stop endif diff --git a/route/build/src/nr_utils.f90 b/route/build/src/nr_utils.f90 index 9f854736..203c4ab8 100644 --- a/route/build/src/nr_utils.f90 +++ b/route/build/src/nr_utils.f90 @@ -108,7 +108,7 @@ SUBROUTINE indexx(arr,index) jstack=jstack-2 else k=(l+r)/2 - call swap(index(k),index(l+1)) + if ( k /= l+1 ) call swap(index(k),index(l+1)) call icomp_xchg(index(l),index(r)) call icomp_xchg(index(l+1),index(r)) call icomp_xchg(index(l),index(l+1)) @@ -126,7 +126,7 @@ SUBROUTINE indexx(arr,index) if (arr(index(j)) <= a) exit end do if (j < i) exit - call swap(index(i),index(j)) + if ( i /= j ) call swap(index(i),index(j)) end do index(l+1)=index(j) index(j)=indext @@ -423,7 +423,7 @@ FUNCTION match_index(array1, array2, ierr, message) RESULT(index1) do ix=1,size(array2) if(index1(ix) == integerMissing) cycle if(array2(ix) /= array1( index1(ix) ) )then - write(iulog,'(a,2(x,I10,x,I15))') 'ERROR Mapping: ix, ID(ix), index(ix), masterID(index(ix))=', ix, array2(ix), index1(ix), array1(index1(ix)) + write(iulog,'(a,2(1x,I10,1x,I15))') 'ERROR Mapping: ix, ID(ix), index(ix), masterID(index(ix))=', ix, array2(ix), index1(ix), array1(index1(ix)) message=trim(message)//'unable to find the match' ierr=20; return endif diff --git a/route/build/src/nrtype.f90 b/route/build/src/nrtype.f90 index 370f46b3..dc89c539 100644 --- a/route/build/src/nrtype.f90 +++ b/route/build/src/nrtype.f90 @@ -11,4 +11,5 @@ MODULE nrtype integer, parameter :: LGT = KIND(.true.) ! common variables integer(i4b),parameter :: strLen=256 ! string length + integer(i4b),parameter :: FileStrLen=300 ! File string length END MODULE nrtype diff --git a/route/build/src/pio_utils.f90 b/route/build/src/pio_utils.f90 index 062122bb..e4deac4f 100644 --- a/route/build/src/pio_utils.f90 +++ b/route/build/src/pio_utils.f90 @@ -3,6 +3,7 @@ MODULE pio_utils USE mpi USE nrtype USE pio + USE public_var, only : iulog implicit none @@ -52,6 +53,7 @@ MODULE pio_utils END INTERFACE INTERFACE write_netcdf + module procedure write_char0D module procedure write_array1D module procedure write_array2D END INTERFACE @@ -324,12 +326,22 @@ SUBROUTINE openFile(pioIoSystem, pioFileDesc, fname, netcdf_type, mode, fileOpen ! local variable integer(i4b) :: iotype ! netcdf type ID character(len=strLen) :: cmessage ! error message from subroutine + logical(lgt) :: lexist ! IF file exists or not ierr=0; message='openFile/' iotype = iotype_id(netcdf_type, ierr, cmessage) if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + inquire(file=trim(fname), exist=lexist) + write(iulog,*) ' opening file: ', trim(fname) + flush(iulog) + if ( .not. lexist )then + ierr = 10 + message=trim(message)//'file does NOT exist'//trim(fname) + return + end if + ierr = pio_openfile(pioIoSystem, pioFileDesc, iotype, trim(fname), mode) if(ierr/=pio_noerr)then; message=trim(message)//'Could not open netCDF'; return; endif @@ -354,16 +366,16 @@ SUBROUTINE closeFile(pioFileDesc, fileOpen) END SUBROUTINE closeFile !----------------------------------------------------------------------- - SUBROUTINE freeDecomp(pioFileDesc, iodesc) + SUBROUTINE freeDecomp(pioIOsystem, iodesc) ! !DESCRIPTION: ! Free decomposition ! implicit none ! ARGUMENTS: - type(file_desc_t), intent(inout) :: pioFileDesc ! PIO file handle to close + type(iosystem_desc_t),intent(inout) :: pioIOsystem ! type(io_desc_t), intent(inout) :: iodesc - call pio_freedecomp(pioFileDesc, ioDesc) + call pio_freedecomp(pioIOsystem, ioDesc) END SUBROUTINE freeDecomp @@ -649,13 +661,59 @@ SUBROUTINE write_scalar_netcdf(pioFileDesc, & ierr = pio_put_var(pioFileDesc, pioVarId, [scalar]) type is (real(dp)) ierr = pio_put_var(pioFileDesc, pioVarId, [scalar]) - type is (character(len=*)) - ierr = pio_put_var(pioFileDesc, pioVarId, [scalar]) end select if(ierr/=pio_noerr)then; message=trim(message)//'cannot write data'; return; endif END SUBROUTINE write_scalar_netcdf + ! --------------------------------------------------------------- + ! write global character vector into 1D variable + SUBROUTINE write_char0D(pioFileDesc, & + vname, & ! input: variable name + string, & ! input: variable data + iStart, & ! input: start index + ierr, message) ! output: error control + implicit none + ! Argument variables: + type(file_desc_t), intent(inout) :: pioFileDesc ! pio file handle + character(len=*), intent(in) :: vname ! variable name + character(len=*), intent(in) :: string ! variable data + integer(i4b), intent(in) :: iStart ! start index + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message ! error message + ! local variables + type(var_desc_t) :: pioVarId + integer(i4b) :: m ! Index + integer(i4b) :: var_id + integer(i4b) :: start(2) + integer(i4b) :: icount(2) + character(len=1) :: tmpString(FileStrLen) ! temp for manipulating output string + + ierr=0; message='write_char0D/' + + if ( len(string) > size(tmpString) )then + ierr = 1 + message=trim(message)//'ERROR: length of string being written is larger than tmpString' + return + end if + ierr = pio_inq_varid(pioFileDesc, trim(vname), pioVarId) + if(ierr/=0)then; message=trim(message)//'ERROR: getting variable id'; return; endif + + + do m = 1,len(string) + tmpString(m:m) = string(m:m) + end do + start(1) = iStart + start(2) = 1 + icount(1) = len(string) + icount(2) = 1 + var_id = pioVarId%varid + ierr = pio_put_var(pioFileDesc, var_id, start, icount, ival=tmpString) + if(ierr/=pio_noerr)then; message=trim(message)//'cannot write data'; return; endif + + END SUBROUTINE write_char0D + + ! --------------------------------------------------------------- ! write global integer vector into 1D variable SUBROUTINE write_array1D(pioFileDesc, & diff --git a/route/build/src/popMetadat.f90 b/route/build/src/popMetadat.f90 index ba4f6531..afc1a85a 100644 --- a/route/build/src/popMetadat.f90 +++ b/route/build/src/popMetadat.f90 @@ -104,6 +104,8 @@ subroutine popMetadat(err,message) meta_stateDims(ixStateDims%mol_dw ) = dim_info('mol_dw', integerMissing, integerMissing) ! dw finite difference computing nodes meta_stateDims(ixStateDims%tdh_irf ) = dim_info('tdh_irf', integerMissing, integerMissing) ! future time steps for irf routing meta_stateDims(ixStateDims%tdh ) = dim_info('tdh', integerMissing, integerMissing) ! future time steps for bsasin irf routing + meta_stateDims(ixStateDims%nchars ) = dim_info('nchars', integerMissing, FileStrLen) ! number of characters for strings + meta_stateDims(ixStateDims%hist_fil) = dim_info('hist_fil',integerMissing, integerMissing) ! number of history files on restart file meta_qDims(ixQdims%time ) = dim_info('time', integerMissing, integerMissing) ! time meta_qDims(ixQdims%tbound ) = dim_info('tbound', integerMissing, 2) ! time bound (always 2 - start and end) diff --git a/route/build/src/read_control.f90 b/route/build/src/read_control.f90 index 8b13c68e..8608d59e 100644 --- a/route/build/src/read_control.f90 +++ b/route/build/src/read_control.f90 @@ -101,7 +101,7 @@ SUBROUTINE read_control(ctl_fname, err, message) cName = adjustl(cLines(iLine)(ibeg_name:iend_name)) cData = adjustl(cLines(iLine)(iend_name+1:iend_data-1)) if (masterproc) then - write(iulog,'(x,a,a,a)') trim(cName), ' --> ', trim(cData) + write(iulog,'(1x,a,a,a)') trim(cName), ' --> ', trim(cData) endif if (index(cData, achar(9)) > 0) then diff --git a/route/build/src/var_lookup.f90 b/route/build/src/var_lookup.f90 index e2fbec32..62944a5e 100644 --- a/route/build/src/var_lookup.f90 +++ b/route/build/src/var_lookup.f90 @@ -5,6 +5,8 @@ MODULE var_lookup USE public_var, ONLY: integerMissing ! missing value for integers implicit none private + ! + INTRINSIC :: storage_size ! local variables integer(i4b),parameter :: ixVal=1 ! an example integer integer(i4b),parameter :: iLength=storage_size(ixVal) ! size of the example integer @@ -44,6 +46,8 @@ MODULE var_lookup integer(i4b) :: mol_dw = integerMissing ! 9. kw finite difference computational molecule integer(i4b) :: tdh_irf = integerMissing ! 10. irf routed future channel flow in a segment integer(i4b) :: tdh = integerMissing ! 11. uh routed future overland flow + integer(i4b) :: nchars = integerMissing ! 12. number of characters + integer(i4b) :: hist_fil = integerMissing ! 13. history filenames endtype iLook_stateDims ! For river discharge variables type, public :: iLook_qDims @@ -261,7 +265,7 @@ MODULE var_lookup type(iLook_struct) ,public,parameter :: ixStruct = iLook_struct ( 1, 2, 3, 4, 5) type(iLook_dims) ,public,parameter :: ixDims = iLook_dims ( 1, 2, 3, 4, 5, 6, 7) type(iLook_stateDims),public,parameter :: ixStateDims = iLook_stateDims( 1, 2, 3, 4, 5, 6, 7, 8, 9,10, & - 11) + 11, 12, 13) type(iLook_qDims) ,public,parameter :: ixQdims = iLook_qDims ( 1, 2, 3, 4, 5) type(iLook_HRU) ,public,parameter :: ixHRU = iLook_HRU ( 1) type(iLook_HRU2SEG) ,public,parameter :: ixHRU2SEG = iLook_HRU2SEG ( 1, 2, 3, 4) diff --git a/route/build/src/write_restart_pio.f90 b/route/build/src/write_restart_pio.f90 index 8cf8fb70..3c2a609a 100644 --- a/route/build/src/write_restart_pio.f90 +++ b/route/build/src/write_restart_pio.f90 @@ -216,7 +216,7 @@ SUBROUTINE restart_fname(fname, timeStamp, ierr, message) ! local variables type(datetime) :: restartTimeStamp ! datetime corresponding to file name time stamp integer(i4b) :: sec_in_day ! second within day - character(len=50),parameter :: fmtYMDHMS = '(2a,I0.4,a,I0.2,a,I0.2,x,I0.2,a,I0.2,a,I0.2)' + character(len=50),parameter :: fmtYMDHMS = '(2a,I0.4,a,I0.2,a,I0.2,1x,I0.2,a,I0.2,a,I0.2)' character(len=50),parameter :: fmtYMDS='(a,I0.4,a,I0.2,a,I0.2,a,I0.5,a)' ierr=0; message='restart_fname/' @@ -274,14 +274,16 @@ SUBROUTINE define_state_nc(fname, & ! input: filename integer(i4b), allocatable :: compdof_rch(:) ! integer(i4b), allocatable :: compdof_hru(:) ! integer(i4b) :: jDim ! loop index for dimension - integer(i4b) :: ixDim_common(4) ! custom dimension ID array + integer(i4b) :: ixDim_common(6) ! custom dimension ID array character(len=strLen) :: cmessage ! error message of downwind routine ierr=0; message='define_state_nc/' - associate(dim_seg => meta_stateDims(ixStateDims%seg)%dimId, & - dim_ens => meta_stateDims(ixStateDims%ens)%dimId, & - dim_tbound => meta_stateDims(ixStateDims%tbound)%dimId) + associate(dim_seg => meta_stateDims(ixStateDims%seg)%dimId, & + dim_ens => meta_stateDims(ixStateDims%ens)%dimId, & + dim_tbound => meta_stateDims(ixStateDims%tbound)%dimId, & + dim_nchars => meta_stateDims(ixStateDims%nchars)%dimId, & + dim_hist_fil => meta_stateDims(ixStateDims%hist_fil)%dimId) ! ---------------------------------- ! Create file @@ -290,7 +292,7 @@ SUBROUTINE define_state_nc(fname, & ! input: filename if(ierr/=0)then; message=trim(cmessage)//'cannot create state netCDF'; return; endif ! For common dimension/variables - seg id, time, time-bound ----------- - ixDim_common = [ixStateDims%seg, ixStateDims%hru, ixStateDims%ens, ixStateDims%tbound] + ixDim_common = [ixStateDims%seg, ixStateDims%hru, ixStateDims%ens, ixStateDims%tbound, ixStateDims%nchars, ixStateDims%hist_fil] ! ---------------------------------- ! Define dimensions @@ -326,6 +328,9 @@ SUBROUTINE define_state_nc(fname, & ! input: filename call def_var(pioFileDescState, 'time_bound', ncd_float, ierr, cmessage, pioDimId=[dim_tbound], vdesc='time bound at last time step', vunit='sec') if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + call def_var(pioFileDescState, 'history_file', ncd_char, ierr, cmessage, pioDimId=[dim_nchars, dim_hist_fil], vdesc='history files that need to be read with this restart file', vunit='-') + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + end associate ! previous-time step hru inflow into reach @@ -492,7 +497,7 @@ SUBROUTINE define_state_nc(fname, & ! input: filename SUBROUTINE set_dim_len(ixDim, ierr, message1) ! populate state netCDF dimension size - USE public_var, ONLY: MAXQPAR + USE public_var, ONLY: MAXQPAR, outputAtGage USE globalData, ONLY: nMolecule USE globalData, ONLY: maxtdh ! maximum unit-hydrogrph future time USE globalData, ONLY: FRAC_FUTURE ! To get size of q future for basin IRF @@ -517,6 +522,12 @@ SUBROUTINE set_dim_len(ixDim, ierr, message1) case(ixStateDims%mol_mc); meta_stateDims(ixStateDims%mol_mc)%dimLength = nMolecule%MC_ROUTE case(ixStateDims%mol_dw); meta_stateDims(ixStateDims%mol_dw)%dimLength = nMolecule%DW_ROUTE case(ixStateDims%wave); meta_stateDims(ixStateDims%wave)%dimLength = MAXQPAR + case(ixStateDims%hist_fil) + if (outputAtGage) then + meta_stateDims(ixStateDims%hist_fil)%dimLength = 2 + else + meta_stateDims(ixStateDims%hist_fil)%dimLength = 1 + end if case default; ierr=20; message1=trim(message1)//'unable to identify dimension variable index'; return end select @@ -841,6 +852,7 @@ SUBROUTINE write_state_nc(fname, & ! Input: state netcdf name USE public_var, ONLY: kinematicWave USE public_var, ONLY: muskingumCunge USE public_var, ONLY: diffusiveWave + USE public_var, ONLY: outputAtGage USE globalData, ONLY: onRoute ! logical to indicate which routing method(s) is on USE globalData, ONLY: RCHFLX_trib ! tributary reach fluxes (ensembles, reaches) USE globalData, ONLY: NETOPO_main ! mainstem reach topology @@ -850,6 +862,8 @@ SUBROUTINE write_state_nc(fname, & ! Input: state netcdf name USE globalData, ONLY: nRch_mainstem ! number of mainstem reaches USE globalData, ONLY: nTribOutlet ! USE globalData, ONLY: reachID ! reach ID in network + USE globalData, ONLY: hfileOut ! Output history file + USE globalData, ONLY: hfileOut_gage ! Output history file for gaguges USE globalData, ONLY: nNodes ! number of MPI tasks USE globalData, ONLY: nRch ! number of reaches in network USE globalData, ONLY: TSEC ! beginning/ending of simulation time step [sec] @@ -923,6 +937,15 @@ SUBROUTINE write_state_nc(fname, & ! Input: state netcdf name call write_netcdf(pioFileDescState, 'time_bound', TSEC, [1], [2], ierr, cmessage) if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + call write_netcdf(pioFileDescState, 'history_file', hfileOut, & + iStart=1, ierr=ierr, message=cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + if ( outputAtGage )then + call write_netcdf(pioFileDescState, 'history_file', hfileOut_gage, & + iStart=2, ierr=ierr, message=cmessage) + end if + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + call write_basinQ_state(ierr, cmessage) if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif @@ -959,37 +982,37 @@ SUBROUTINE write_state_nc(fname, & ! Input: state netcdf name call write_history_state(ierr, cmessage) if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + ! close netCDF + call closeFile(pioFileDescState, restartOpen) + ! clean decomposition data - call freeDecomp(pioFileDescState, iodesc_rch_double) - call freeDecomp(pioFileDescState, iodesc_rch_int) - call freeDecomp(pioFileDescState, iodesc_hist_rch_double) + call freeDecomp(pioSystem, iodesc_rch_double) + call freeDecomp(pioSystem, iodesc_rch_int) + call freeDecomp(pioSystem, iodesc_hist_rch_double) if (meta_hflx(ixHFLX%basRunoff)%varFile) then - call freeDecomp(pioFileDescState, iodesc_hist_hru_double) + call freeDecomp(pioSystem, iodesc_hist_hru_double) end if if (doesBasinRoute==1) then - call freeDecomp(pioFileDescState, iodesc_irf_bas_double) + call freeDecomp(pioSystem, iodesc_irf_bas_double) end if if (onRoute(impulseResponseFunc))then - call freeDecomp(pioFileDescState, iodesc_irf_double) - call freeDecomp(pioFileDescState, iodesc_vol_double) + call freeDecomp(pioSystem, iodesc_irf_double) + call freeDecomp(pioSystem, iodesc_vol_double) end if if (onRoute(kinematicWaveTracking)) then - call freeDecomp(pioFileDescState, iodesc_wave_int) - call freeDecomp(pioFileDescState, iodesc_wave_double) + call freeDecomp(pioSystem, iodesc_wave_int) + call freeDecomp(pioSystem, iodesc_wave_double) end if if (onRoute(kinematicWave)) then - call freeDecomp(pioFileDescState, iodesc_mesh_kw_double) + call freeDecomp(pioSystem, iodesc_mesh_kw_double) end if if (onRoute(muskingumCunge)) then - call freeDecomp(pioFileDescState, iodesc_mesh_mc_double) + call freeDecomp(pioSystem, iodesc_mesh_mc_double) end if if (onRoute(diffusiveWave)) then - call freeDecomp(pioFileDescState, iodesc_mesh_dw_double) + call freeDecomp(pioSystem, iodesc_mesh_dw_double) end if - ! close netCDF - call closeFile(pioFileDescState, restartOpen) - CONTAINS SUBROUTINE write_basinQ_state(ierr, message1) diff --git a/route/build/src/write_simoutput_pio.f90 b/route/build/src/write_simoutput_pio.f90 index 86dc7fa8..62a25941 100644 --- a/route/build/src/write_simoutput_pio.f90 +++ b/route/build/src/write_simoutput_pio.f90 @@ -107,10 +107,6 @@ SUBROUTINE main_new_file(ierr, message) end if - ! update history files - call io_rpfile('w', ierr, cmessage) - if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - END SUBROUTINE main_new_file ! ********************************************************************* @@ -128,7 +124,8 @@ logical(lgt) FUNCTION newFileAlarm(inDatetime, alarmFrequency, ierr, message) ierr=0; message='new_file_alarm/' if (masterproc) then - write(iulog,'(a,I4,4(x,I4))') new_line('a'), inDatetime(1)%year(), inDatetime(1)%month(), inDatetime(1)%day(), inDatetime(1)%hour(), inDatetime(1)%minute() + write(iulog,'(a,I4,4(1x,I4))') new_line('a'), inDatetime(1)%year(), inDatetime(1)%month(), & + inDatetime(1)%day(), inDatetime(1)%hour(), inDatetime(1)%minute() endif ! check need for the new file @@ -479,12 +476,12 @@ END SUBROUTINE get_hfilename SUBROUTINE close_all() implicit none if (hist_all_network%fileOpen()) then - call hist_all_network%cleanup() call hist_all_network%closeNC() + call hist_all_network%cleanup() end if if (hist_gage%fileOpen()) then - call hist_gage%cleanup() call hist_gage%closeNC() + call hist_gage%cleanup() end if END SUBROUTINE diff --git a/route/build/src/write_streamSeg.f90 b/route/build/src/write_streamSeg.f90 index 0eae9097..8325036b 100644 --- a/route/build/src/write_streamSeg.f90 +++ b/route/build/src/write_streamSeg.f90 @@ -180,7 +180,8 @@ subroutine createFile(fname, dimCheck, ierr,message) ! ---------- create file ---------------------------------------------------------------------------------------- ! create file - ierr = nf90_create(trim(fname), NF90_64BIT_OFFSET, ncid) + ! Clobber an existing file if it exists, and output in 64Bit offset format + ierr = nf90_create(trim(fname), IOR(NF90_CLOBBER, NF90_64BIT_OFFSET), ncid) if(ierr/=0)then; message=trim(message)//trim(nf90_strerror(ierr)); return; endif ! ---------- define dimensions ---------------------------------------------------------------------------------- diff --git a/route/settings/SAMPLE-coupled.control b/route/settings/SAMPLE-coupled.control index 2a753bcd..968fab67 100644 --- a/route/settings/SAMPLE-coupled.control +++ b/route/settings/SAMPLE-coupled.control @@ -21,6 +21,7 @@ monthly ! time frequency used for temporal aggregation of output variables - numeric or daily, monthyly, or yearly 86400 ! coupling time interval of the forcing [sec] F ! logical; T-> append output in existing history files. F-> write output in new history file + F ! debug verbosity level; T -> extra log output. F-> normal log output ! **************************************************************************************************************************** ! DEFINE DIRECTORIES ! --------------------------