From 173dc50462a2bf93231828b1b9a4afe926885762 Mon Sep 17 00:00:00 2001 From: mjreno Date: Tue, 26 Sep 2023 15:43:06 -0400 Subject: [PATCH] feat(idm): update CHD to source static and dynamic list input from the input context (#1366) * align mempath initialization in NumericalPackage and DiscretizationBase * add helper routine to set FILEIN filename when 0 or 1 files are expected * add MemoryManager CharacterStringType checkin routine * CHD and bound package updates to support sourcing static and dynamic list input * run build_makefiles.py * BoundaryPackageExt cleanup --------- Co-authored-by: mjreno --- doc/mf6io/mf6ivar/dfn/gwf-chd.dfn | 15 + make/makefile | 82 +- msvs/mf6core.vfproj | 2 + src/Exchange/GwfGwtExchange.f90 | 4 +- src/Model/GroundWaterFlow/gwf3.f90 | 17 +- src/Model/GroundWaterFlow/gwf3chd8.f90 | 117 +-- src/Model/GroundWaterFlow/gwf3chd8idm.f90 | 433 ++++++++++ src/Model/GroundWaterFlow/gwf3dis8.f90 | 13 +- src/Model/GroundWaterFlow/gwf3disu8.f90 | 13 +- src/Model/GroundWaterFlow/gwf3disv8.f90 | 13 +- src/Model/GroundWaterFlow/gwf3npf8.f90 | 35 +- src/Model/GroundWaterTransport/gwt1dsp1.f90 | 8 +- .../ModelUtilities/BoundaryPackageExt.f90 | 767 ++++++++++++++++++ .../ModelUtilities/DiscretizationBase.f90 | 17 +- src/Model/NumericalPackage.f90 | 20 +- src/Utilities/Idm/IdmLoad.f90 | 51 ++ .../Idm/selector/IdmGwfDfnSelector.f90 | 36 +- src/Utilities/Memory/MemoryManager.f90 | 47 +- src/Utilities/PackageBudget.f90 | 15 +- src/meson.build | 2 + utils/idmloader/scripts/dfn2f90.py | 4 + 21 files changed, 1531 insertions(+), 180 deletions(-) create mode 100644 src/Model/GroundWaterFlow/gwf3chd8idm.f90 create mode 100644 src/Model/ModelUtilities/BoundaryPackageExt.f90 diff --git a/doc/mf6io/mf6ivar/dfn/gwf-chd.dfn b/doc/mf6io/mf6ivar/dfn/gwf-chd.dfn index 543433c1b3c..8c12234ac97 100644 --- a/doc/mf6io/mf6ivar/dfn/gwf-chd.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwf-chd.dfn @@ -1,5 +1,6 @@ # --------------------- gwf chd options --------------------- # flopy multi-package +# modflow6 aux-sfac-param head block options name auxiliary @@ -35,6 +36,7 @@ reader urword optional true longname print input to listing file description REPLACE print_input {'{#1}': 'constant-head'} +mf6internal iprpak block options name print_flows @@ -43,6 +45,7 @@ reader urword optional true longname print CHD flows to listing file description REPLACE print_flows {'{#1}': 'constant-head'} +mf6internal iprflow block options name save_flows @@ -51,6 +54,7 @@ reader urword optional true longname save CHD flows to budget file description REPLACE save_flows {'{#1}': 'constant-head'} +mf6internal ipakcb block options name ts_filerecord @@ -127,6 +131,15 @@ optional false longname obs6 input filename description REPLACE obs6_filename {'{#1}': 'constant-head'} +# dev options +block options +name dev_no_newton +type keyword +reader urword +optional true +longname turn off Newton for unconfined cells +description turn off Newton for unconfined cells +mf6internal inewton # --------------------- gwf chd dimensions --------------------- @@ -161,6 +174,7 @@ shape (maxbound) reader urword longname description +mf6internal spd block period name cellid @@ -194,6 +208,7 @@ optional true time_series true longname auxiliary variables description REPLACE aux {'{#1}': 'constant head'} +mf6internal auxvar block period name boundname diff --git a/make/makefile b/make/makefile index f82c2725180..2b0b60d316e 100644 --- a/make/makefile +++ b/make/makefile @@ -95,8 +95,21 @@ $(OBJDIR)/MemoryList.o \ $(OBJDIR)/TimeSeriesRecord.o \ $(OBJDIR)/BlockParser.o \ $(OBJDIR)/MemoryManager.o \ +$(OBJDIR)/InputDefinition.o \ $(OBJDIR)/TimeSeries.o \ $(OBJDIR)/ats.o \ +$(OBJDIR)/simnamidm.o \ +$(OBJDIR)/gwt1idm.o \ +$(OBJDIR)/gwt1dsp1idm.o \ +$(OBJDIR)/gwt1disv1idm.o \ +$(OBJDIR)/gwt1disu1idm.o \ +$(OBJDIR)/gwt1dis1idm.o \ +$(OBJDIR)/gwf3npf8idm.o \ +$(OBJDIR)/gwf3idm.o \ +$(OBJDIR)/gwf3disv8idm.o \ +$(OBJDIR)/gwf3disu8idm.o \ +$(OBJDIR)/gwf3dis8idm.o \ +$(OBJDIR)/gwf3chd8idm.o \ $(OBJDIR)/TimeSeriesLink.o \ $(OBJDIR)/TimeSeriesFileList.o \ $(OBJDIR)/tdis.o \ @@ -105,65 +118,62 @@ $(OBJDIR)/VectorBase.o \ $(OBJDIR)/Sparse.o \ $(OBJDIR)/DisvGeom.o \ $(OBJDIR)/ArrayReaders.o \ +$(OBJDIR)/IdmSimDfnSelector.o \ +$(OBJDIR)/IdmGwtDfnSelector.o \ +$(OBJDIR)/IdmGwfDfnSelector.o \ $(OBJDIR)/TimeSeriesManager.o \ $(OBJDIR)/SmoothingFunctions.o \ +$(OBJDIR)/MemoryManagerExt.o \ $(OBJDIR)/MatrixBase.o \ $(OBJDIR)/ListReader.o \ $(OBJDIR)/Connections.o \ -$(OBJDIR)/InputDefinition.o \ +$(OBJDIR)/IdmDfnSelector.o \ $(OBJDIR)/TimeArray.o \ +$(OBJDIR)/ArrayReaderBase.o \ $(OBJDIR)/ObsOutput.o \ $(OBJDIR)/DiscretizationBase.o \ -$(OBJDIR)/simnamidm.o \ -$(OBJDIR)/gwt1idm.o \ -$(OBJDIR)/gwt1dsp1idm.o \ -$(OBJDIR)/gwt1disv1idm.o \ -$(OBJDIR)/gwt1disu1idm.o \ -$(OBJDIR)/gwt1dis1idm.o \ -$(OBJDIR)/gwf3npf8idm.o \ -$(OBJDIR)/gwf3idm.o \ -$(OBJDIR)/gwf3disv8idm.o \ -$(OBJDIR)/gwf3disu8idm.o \ -$(OBJDIR)/gwf3dis8idm.o \ +$(OBJDIR)/STLVecInt.o \ +$(OBJDIR)/ModflowInput.o \ $(OBJDIR)/TimeArraySeries.o \ +$(OBJDIR)/Integer2dReader.o \ $(OBJDIR)/ObsOutputList.o \ $(OBJDIR)/Observe.o \ -$(OBJDIR)/IdmSimDfnSelector.o \ -$(OBJDIR)/IdmGwtDfnSelector.o \ -$(OBJDIR)/IdmGwfDfnSelector.o \ +$(OBJDIR)/StructVector.o \ +$(OBJDIR)/IdmLogger.o \ +$(OBJDIR)/DefinitionSelect.o \ +$(OBJDIR)/InputLoadType.o \ $(OBJDIR)/TimeArraySeriesLink.o \ +$(OBJDIR)/Integer1dReader.o \ +$(OBJDIR)/Double2dReader.o \ +$(OBJDIR)/Double1dReader.o \ $(OBJDIR)/ObsUtility.o \ $(OBJDIR)/ObsContainer.o \ $(OBJDIR)/BudgetFileReader.o \ -$(OBJDIR)/IdmDfnSelector.o \ -$(OBJDIR)/ArrayReaderBase.o \ +$(OBJDIR)/StructArray.o \ +$(OBJDIR)/BoundInputContext.o \ +$(OBJDIR)/AsciiInputLoadType.o \ $(OBJDIR)/TimeArraySeriesManager.o \ +$(OBJDIR)/SourceCommon.o \ +$(OBJDIR)/LayeredArrayReader.o \ $(OBJDIR)/PackageMover.o \ $(OBJDIR)/Obs3.o \ $(OBJDIR)/NumericalPackage.o \ $(OBJDIR)/Budget.o \ $(OBJDIR)/BudgetTerm.o \ +$(OBJDIR)/StressListInput.o \ +$(OBJDIR)/StressGridInput.o \ +$(OBJDIR)/LoadMf6File.o \ $(OBJDIR)/sort.o \ $(OBJDIR)/SfrCrossSectionUtils.o \ -$(OBJDIR)/STLVecInt.o \ -$(OBJDIR)/ModflowInput.o \ -$(OBJDIR)/MemoryManagerExt.o \ -$(OBJDIR)/Integer2dReader.o \ $(OBJDIR)/VirtualBase.o \ $(OBJDIR)/BoundaryPackage.o \ $(OBJDIR)/BaseModel.o \ $(OBJDIR)/PackageBudget.o \ $(OBJDIR)/HeadFileReader.o \ $(OBJDIR)/BudgetObject.o \ +$(OBJDIR)/IdmMf6File.o \ $(OBJDIR)/SfrCrossSectionManager.o \ $(OBJDIR)/dag_module.o \ -$(OBJDIR)/StructVector.o \ -$(OBJDIR)/IdmLogger.o \ -$(OBJDIR)/DefinitionSelect.o \ -$(OBJDIR)/InputLoadType.o \ -$(OBJDIR)/Integer1dReader.o \ -$(OBJDIR)/Double2dReader.o \ -$(OBJDIR)/Double1dReader.o \ $(OBJDIR)/VirtualDataLists.o \ $(OBJDIR)/VirtualDataContainer.o \ $(OBJDIR)/SimStages.o \ @@ -172,6 +182,8 @@ $(OBJDIR)/FlowModelInterface.o \ $(OBJDIR)/PrintSaveManager.o \ $(OBJDIR)/Xt3dAlgorithm.o \ $(OBJDIR)/gwf3tvbase8.o \ +$(OBJDIR)/SourceLoad.o \ +$(OBJDIR)/ModelPackageInputs.o \ $(OBJDIR)/gwf3sfr8.o \ $(OBJDIR)/gwf3riv8.o \ $(OBJDIR)/gwf3maw8.o \ @@ -181,11 +193,6 @@ $(OBJDIR)/GwfVscInputData.o \ $(OBJDIR)/gwf3ghb8.o \ $(OBJDIR)/gwf3drn8.o \ $(OBJDIR)/IndexMap.o \ -$(OBJDIR)/StructArray.o \ -$(OBJDIR)/BoundInputContext.o \ -$(OBJDIR)/AsciiInputLoadType.o \ -$(OBJDIR)/SourceCommon.o \ -$(OBJDIR)/LayeredArrayReader.o \ $(OBJDIR)/VirtualModel.o \ $(OBJDIR)/BaseExchange.o \ $(OBJDIR)/UzfCellGroup.o \ @@ -194,13 +201,11 @@ $(OBJDIR)/OutputControlData.o \ $(OBJDIR)/gwf3ic8.o \ $(OBJDIR)/Xt3dInterface.o \ $(OBJDIR)/gwf3tvk8.o \ +$(OBJDIR)/IdmLoad.o \ $(OBJDIR)/gwf3vsc8.o \ $(OBJDIR)/GwfNpfOptions.o \ $(OBJDIR)/InterfaceMap.o \ $(OBJDIR)/SeqVector.o \ -$(OBJDIR)/StressListInput.o \ -$(OBJDIR)/StressGridInput.o \ -$(OBJDIR)/LoadMf6File.o \ $(OBJDIR)/CellWithNbrs.o \ $(OBJDIR)/NumericalExchange.o \ $(OBJDIR)/gwf3uzf8.o \ @@ -218,18 +223,17 @@ $(OBJDIR)/Mover.o \ $(OBJDIR)/GwfMvrPeriodData.o \ $(OBJDIR)/ims8misc.o \ $(OBJDIR)/GwfBuyInputData.o \ +$(OBJDIR)/BoundaryPackageExt.o \ $(OBJDIR)/VirtualSolution.o \ $(OBJDIR)/SparseMatrix.o \ $(OBJDIR)/LinearSolverBase.o \ $(OBJDIR)/ims8reordering.o \ -$(OBJDIR)/IdmMf6File.o \ $(OBJDIR)/VirtualExchange.o \ $(OBJDIR)/gwf3disu8.o \ $(OBJDIR)/GridSorting.o \ $(OBJDIR)/DisConnExchange.o \ $(OBJDIR)/CsrUtils.o \ $(OBJDIR)/tsp1.o \ -$(OBJDIR)/ModelPackageInputs.o \ $(OBJDIR)/gwt1uzt1.o \ $(OBJDIR)/gwt1ssm1.o \ $(OBJDIR)/gwt1src1.o \ @@ -261,7 +265,6 @@ $(OBJDIR)/gwf3chd8.o \ $(OBJDIR)/RouterBase.o \ $(OBJDIR)/ImsLinearSolver.o \ $(OBJDIR)/ims8base.o \ -$(OBJDIR)/SourceLoad.o \ $(OBJDIR)/GridConnection.o \ $(OBJDIR)/DistributedVariable.o \ $(OBJDIR)/gwt1.o \ @@ -270,7 +273,6 @@ $(OBJDIR)/SerialRouter.o \ $(OBJDIR)/Timer.o \ $(OBJDIR)/LinearSolverFactory.o \ $(OBJDIR)/ims8linear.o \ -$(OBJDIR)/IdmLoad.o \ $(OBJDIR)/BaseSolution.o \ $(OBJDIR)/ExplicitModel.o \ $(OBJDIR)/SpatialModelConnection.o \ diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index 8270d990e13..275da841c99 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -122,6 +122,7 @@ + @@ -179,6 +180,7 @@ + diff --git a/src/Exchange/GwfGwtExchange.f90 b/src/Exchange/GwfGwtExchange.f90 index 986b84fd990..fe462a9c87a 100644 --- a/src/Exchange/GwfGwtExchange.f90 +++ b/src/Exchange/GwfGwtExchange.f90 @@ -551,7 +551,7 @@ subroutine gwfbnd2gwtfmi(this) packobj => GetBndFromList(gwfmodel%bndlist, ip) call gwtmodel%fmi%gwfpackages(iterm)%set_pointers( & 'SIMVALS', & - packobj%memoryPath) + packobj%memoryPath, packobj%input_mempath) iterm = iterm + 1 ! ! -- If a mover is active for this package, then establish a separate @@ -561,7 +561,7 @@ subroutine gwfbnd2gwtfmi(this) if (imover /= 0) then call gwtmodel%fmi%gwfpackages(iterm)%set_pointers( & 'SIMTOMVR', & - packobj%memoryPath) + packobj%memoryPath, packobj%input_mempath) iterm = iterm + 1 end if end do diff --git a/src/Model/GroundWaterFlow/gwf3.f90 b/src/Model/GroundWaterFlow/gwf3.f90 index 9a8057246be..cb25f0b16c6 100644 --- a/src/Model/GroundWaterFlow/gwf3.f90 +++ b/src/Model/GroundWaterFlow/gwf3.f90 @@ -1254,8 +1254,8 @@ end subroutine allocate_scalars !! (2) add a pointer to the package !! !< - subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & - iout) + subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, mempath, & + inunit, iout) ! -- modules use ConstantsModule, only: LINELENGTH use SimModule, only: store_error @@ -1278,6 +1278,7 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & integer(I4B), intent(in) :: ipakid integer(I4B), intent(in) :: ipaknum character(len=*), intent(in) :: pakname + character(len=*), intent(in) :: mempath integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout ! -- local @@ -1289,7 +1290,8 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & ! -- This part creates the package object select case (filtyp) case ('CHD6') - call chd_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + call chd_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + pakname, mempath) case ('WEL6') call wel_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) case ('DRN6') @@ -1432,8 +1434,8 @@ subroutine create_bndpkgs(this, bndpkgs, pkgtypes, pkgnames, & bndptype = pkgtype end if ! - call this%package_create(pkgtype, ipakid, ipaknum, pkgname, inunit, & - this%iout) + call this%package_create(pkgtype, ipakid, ipaknum, pkgname, mempath, & + inunit, this%iout) ipakid = ipakid + 1 ipaknum = ipaknum + 1 end do @@ -1541,8 +1543,9 @@ subroutine create_packages(this) this%inoc = inunit case ('OBS6') this%inobs = inunit - case ('WEL6', 'DRN6', 'RIV6', 'GHB6', 'RCH6', 'EVT6', & - 'API6', 'CHD6', 'MAW6', 'SFR6', 'LAK6', 'UZF6') + case ('WEL6', 'DRN6', 'RIV6', 'GHB6', 'RCH6', & + 'EVT6', 'API6', 'CHD6', 'MAW6', 'SFR6', & + 'LAK6', 'UZF6') call expandarray(bndpkgs) bndpkgs(size(bndpkgs)) = n case default diff --git a/src/Model/GroundWaterFlow/gwf3chd8.f90 b/src/Model/GroundWaterFlow/gwf3chd8.f90 index 5b55207e1cc..c3f79bc9129 100644 --- a/src/Model/GroundWaterFlow/gwf3chd8.f90 +++ b/src/Model/GroundWaterFlow/gwf3chd8.f90 @@ -3,9 +3,12 @@ module ChdModule use KindModule, only: DP, I4B use ConstantsModule, only: DZERO, DONE, NAMEDBOUNDFLAG, LENFTYPE, & LINELENGTH, LENPACKAGENAME + use SimVariablesModule, only: errmsg + use SimModule, only: count_errors, store_error, store_error_filename use MemoryHelperModule, only: create_mem_path use ObsModule, only: DefaultObsIdProcessor use BndModule, only: BndType + use BndExtModule, only: BndExtType use ObserveModule, only: ObserveType use TimeSeriesLinkModule, only: TimeSeriesLinkType, & GetTimeSeriesLinkFromList @@ -19,7 +22,8 @@ module ChdModule character(len=LENFTYPE) :: ftype = 'CHD' character(len=LENPACKAGENAME) :: text = ' CHD' ! - type, extends(BndType) :: ChdType + type, extends(BndExtType) :: ChdType + real(DP), dimension(:), pointer, contiguous :: head => null() !< constant head array real(DP), dimension(:), pointer, contiguous :: ratechdin => null() !simulated flows into constant head (excluding other chds) real(DP), dimension(:), pointer, contiguous :: ratechdout => null() !simulated flows out of constant head (excluding to other chds) contains @@ -32,16 +36,16 @@ module ChdModule procedure :: bnd_da => chd_da procedure :: allocate_arrays => chd_allocate_arrays procedure :: define_listlabel + procedure :: bound_value => chd_bound_value ! -- methods for observations procedure, public :: bnd_obs_supported => chd_obs_supported procedure, public :: bnd_df_obs => chd_df_obs - ! -- method for time series - procedure, public :: bnd_rp_ts => chd_rp_ts end type ChdType contains - subroutine chd_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) + subroutine chd_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & + mempath) ! ****************************************************************************** ! chd_create -- Create a New Constant Head Package ! Subroutine: (1) create new-style package @@ -58,6 +62,7 @@ subroutine chd_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) integer(I4B), intent(in) :: iout character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname + character(len=*), intent(in) :: mempath ! -- local type(ChdType), pointer :: chdobj ! ------------------------------------------------------------------------------ @@ -67,11 +72,11 @@ subroutine chd_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) packobj => chdobj ! ! -- create name and memory path - call packobj%set_names(ibcnum, namemodel, pakname, ftype) + call packobj%set_names(ibcnum, namemodel, pakname, ftype, mempath) packobj%text = text ! ! -- allocate scalars - call packobj%allocate_scalars() + call chdobj%allocate_scalars() ! ! -- initialize package call packobj%pack_initialize() @@ -91,13 +96,13 @@ end subroutine chd_create subroutine chd_allocate_arrays(this, nodelist, auxvar) ! ****************************************************************************** -! allocate_scalars -- allocate arrays +! chd_allocate_arrays -- allocate arrays ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use MemoryManagerModule, only: mem_allocate + use MemoryManagerModule, only: mem_allocate, mem_setptr, mem_checkin ! -- dummy class(ChdType) :: this integer(I4B), dimension(:), pointer, contiguous, optional :: nodelist @@ -107,7 +112,7 @@ subroutine chd_allocate_arrays(this, nodelist, auxvar) ! ------------------------------------------------------------------------------ ! ! -- call standard BndType allocate scalars - call this%BndType%allocate_arrays() + call this%BndExtType%allocate_arrays(nodelist, auxvar) ! ! -- allocate ratechdex call mem_allocate(this%ratechdin, this%maxbound, 'RATECHDIN', this%memoryPath) @@ -118,6 +123,13 @@ subroutine chd_allocate_arrays(this, nodelist, auxvar) this%ratechdout(i) = DZERO end do ! + ! -- set constant head array input context pointer + call mem_setptr(this%head, 'HEAD', this%input_mempath) + ! + ! -- checkin constant head array input context pointer + call mem_checkin(this%head, 'HEAD', this%memoryPath, & + 'HEAD', this%input_mempath) + ! ! -- return return end subroutine chd_allocate_arrays @@ -129,23 +141,23 @@ subroutine chd_rp(this) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - use SimModule, only: store_error + use TdisModule, only: kper ! -- dummy class(ChdType), intent(inout) :: this ! -- local - character(len=LINELENGTH) :: errmsg character(len=30) :: nodestr integer(I4B) :: i, node, ibd, ierr ! ------------------------------------------------------------------------------ + if (this%iper /= kper) return ! ! -- Reset previous CHDs to active cell do i = 1, this%nbound node = this%nodelist(i) this%ibound(node) = this%ibcnum end do - ! + !! ! -- Call the parent class read and prepare - call this%BndType%bnd_rp() + call this%BndExtType%bnd_rp() ! ! -- Set ibound to -(ibcnum + 1) for constant head cells ierr = 0 @@ -165,7 +177,12 @@ subroutine chd_rp(this) ! ! -- Stop if errors detected if (ierr > 0) then - call this%parser%StoreErrorUnit() + call store_error_filename(this%input_fname) + end if + ! + ! -- Write the list to iout if requested + if (this%iprpak /= 0) then + call this%write_list() end if ! ! -- return @@ -187,14 +204,15 @@ subroutine chd_ad(this) real(DP) :: hb ! -- formats ! ------------------------------------------------------------------------------ - ! - ! -- Advance the time series - call this%TsManager%ad() ! ! -- Process each entry in the specified-head cell list do i = 1, this%nbound node = this%nodelist(i) - hb = this%bound(1, i) + if (this%iauxmultcol > 0) then + hb = this%head(i) * this%auxvar(this%iauxmultcol, i) + else + hb = this%head(i) + end if this%xnew(node) = hb this%xold(node) = this%xnew(node) end do @@ -216,12 +234,9 @@ subroutine chd_ck(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error, count_errors ! -- dummy class(ChdType), intent(inout) :: this ! -- local - character(len=LINELENGTH) :: errmsg character(len=30) :: nodestr integer(I4B) :: i integer(I4B) :: node @@ -237,16 +252,16 @@ subroutine chd_ck(this) node = this%nodelist(i) bt = this%dis%bot(node) ! -- accumulate errors - if (this%bound(1, i) < bt .and. this%icelltype(node) /= 0) then + if (this%head(i) < bt .and. this%icelltype(node) /= 0) then call this%dis%noder_to_string(node, nodestr) - write (errmsg, fmt=fmtchderr) i, this%bound(1, i), bt, trim(nodestr) + write (errmsg, fmt=fmtchderr) i, this%head(i), bt, trim(nodestr) call store_error(errmsg) end if end do ! !write summary of chd package error messages if (count_errors() > 0) then - call this%parser%StoreErrorUnit() + call store_error_filename(this%input_fname) end if ! ! -- return @@ -375,11 +390,12 @@ subroutine chd_da(this) ! ------------------------------------------------------------------------------ ! ! -- Deallocate parent package - call this%BndType%bnd_da() + call this%BndExtType%bnd_da() ! ! -- arrays call mem_deallocate(this%ratechdin) call mem_deallocate(this%ratechdout) + call mem_deallocate(this%head, 'HEAD', this%memoryPath) ! ! -- return return @@ -455,31 +471,34 @@ subroutine chd_df_obs(this) return end subroutine chd_df_obs - ! -- Procedure related to time series - - subroutine chd_rp_ts(this) - ! -- Assign tsLink%Text appropriately for - ! all time series in use by package. - ! In CHD package variable HEAD - ! can be controlled by time series. - ! -- dummy - class(ChdType), intent(inout) :: this - ! -- local - integer(I4B) :: i, nlinks - type(TimeSeriesLinkType), pointer :: tslink => null() - ! - nlinks = this%TsManager%boundtslinks%Count() - do i = 1, nlinks - tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) - if (associated(tslink)) then - select case (tslink%JCol) - case (1) - tslink%Text = 'HEAD' - end select - end if - end do + !> @ brief Return a bound value + !! + !! Return a bound value associated with an ncolbnd index + !! and row. + !! + !< + function chd_bound_value(this, col, row) result(bndval) + ! -- modules + use ConstantsModule, only: DZERO + ! -- dummy variables + class(ChdType), intent(inout) :: this !< BndType object + integer(I4B), intent(in) :: col + integer(I4B), intent(in) :: row + ! -- result + real(DP) :: bndval ! + select case (col) + case (1) + bndval = this%head(row) + case default + errmsg = 'Programming error. CHD bound value requested column '& + &'outside range of ncolbnd (1).' + call store_error(errmsg) + call store_error_filename(this%input_fname) + end select + ! + ! -- return return - end subroutine chd_rp_ts + end function chd_bound_value end module ChdModule diff --git a/src/Model/GroundWaterFlow/gwf3chd8idm.f90 b/src/Model/GroundWaterFlow/gwf3chd8idm.f90 new file mode 100644 index 00000000000..788b84b4c41 --- /dev/null +++ b/src/Model/GroundWaterFlow/gwf3chd8idm.f90 @@ -0,0 +1,433 @@ +! ** Do Not Modify! MODFLOW 6 system generated file. ** +module GwfChdInputModule + use ConstantsModule, only: LENVARNAME + use InputDefinitionModule, only: InputParamDefinitionType, & + InputBlockDefinitionType + private + public gwf_chd_param_definitions + public gwf_chd_aggregate_definitions + public gwf_chd_block_definitions + public GwfChdParamFoundType + public gwf_chd_multi_package + public gwf_chd_aux_sfac_param + + type GwfChdParamFoundType + logical :: auxiliary = .false. + logical :: auxmultname = .false. + logical :: boundnames = .false. + logical :: iprpak = .false. + logical :: iprflow = .false. + logical :: ipakcb = .false. + logical :: ts_filerecord = .false. + logical :: ts6 = .false. + logical :: filein = .false. + logical :: ts6_filename = .false. + logical :: obs_filerecord = .false. + logical :: obs6 = .false. + logical :: obs6_filename = .false. + logical :: inewton = .false. + logical :: maxbound = .false. + logical :: cellid = .false. + logical :: head = .false. + logical :: auxvar = .false. + logical :: boundname = .false. + end type GwfChdParamFoundType + + logical :: gwf_chd_multi_package = .true. + + character(len=LENVARNAME) :: gwf_chd_aux_sfac_param = 'HEAD' + + type(InputParamDefinitionType), parameter :: & + gwfchd_auxiliary = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'CHD', & ! subcomponent + 'OPTIONS', & ! block + 'AUXILIARY', & ! tag name + 'AUXILIARY', & ! fortran variable + 'STRING', & ! type + 'NAUX', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false., & ! layered + .false. & ! timeseries + ) + + type(InputParamDefinitionType), parameter :: & + gwfchd_auxmultname = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'CHD', & ! subcomponent + 'OPTIONS', & ! block + 'AUXMULTNAME', & ! tag name + 'AUXMULTNAME', & ! fortran variable + 'STRING', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false., & ! layered + .false. & ! timeseries + ) + + type(InputParamDefinitionType), parameter :: & + gwfchd_boundnames = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'CHD', & ! subcomponent + 'OPTIONS', & ! block + 'BOUNDNAMES', & ! tag name + 'BOUNDNAMES', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false., & ! layered + .false. & ! timeseries + ) + + type(InputParamDefinitionType), parameter :: & + gwfchd_iprpak = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'CHD', & ! subcomponent + 'OPTIONS', & ! block + 'PRINT_INPUT', & ! tag name + 'IPRPAK', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false., & ! layered + .false. & ! timeseries + ) + + type(InputParamDefinitionType), parameter :: & + gwfchd_iprflow = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'CHD', & ! subcomponent + 'OPTIONS', & ! block + 'PRINT_FLOWS', & ! tag name + 'IPRFLOW', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false., & ! layered + .false. & ! timeseries + ) + + type(InputParamDefinitionType), parameter :: & + gwfchd_ipakcb = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'CHD', & ! subcomponent + 'OPTIONS', & ! block + 'SAVE_FLOWS', & ! tag name + 'IPAKCB', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false., & ! layered + .false. & ! timeseries + ) + + type(InputParamDefinitionType), parameter :: & + gwfchd_ts_filerecord = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'CHD', & ! subcomponent + 'OPTIONS', & ! block + 'TS_FILERECORD', & ! tag name + 'TS_FILERECORD', & ! fortran variable + 'RECORD TS6 FILEIN TS6_FILENAME', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false., & ! layered + .false. & ! timeseries + ) + + type(InputParamDefinitionType), parameter :: & + gwfchd_ts6 = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'CHD', & ! subcomponent + 'OPTIONS', & ! block + 'TS6', & ! tag name + 'TS6', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false., & ! layered + .false. & ! timeseries + ) + + type(InputParamDefinitionType), parameter :: & + gwfchd_filein = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'CHD', & ! subcomponent + 'OPTIONS', & ! block + 'FILEIN', & ! tag name + 'FILEIN', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false., & ! layered + .false. & ! timeseries + ) + + type(InputParamDefinitionType), parameter :: & + gwfchd_ts6_filename = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'CHD', & ! subcomponent + 'OPTIONS', & ! block + 'TS6_FILENAME', & ! tag name + 'TS6_FILENAME', & ! fortran variable + 'STRING', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .true., & ! preserve case + .false., & ! layered + .false. & ! timeseries + ) + + type(InputParamDefinitionType), parameter :: & + gwfchd_obs_filerecord = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'CHD', & ! subcomponent + 'OPTIONS', & ! block + 'OBS_FILERECORD', & ! tag name + 'OBS_FILERECORD', & ! fortran variable + 'RECORD OBS6 FILEIN OBS6_FILENAME', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false., & ! layered + .false. & ! timeseries + ) + + type(InputParamDefinitionType), parameter :: & + gwfchd_obs6 = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'CHD', & ! subcomponent + 'OPTIONS', & ! block + 'OBS6', & ! tag name + 'OBS6', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false., & ! layered + .false. & ! timeseries + ) + + type(InputParamDefinitionType), parameter :: & + gwfchd_obs6_filename = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'CHD', & ! subcomponent + 'OPTIONS', & ! block + 'OBS6_FILENAME', & ! tag name + 'OBS6_FILENAME', & ! fortran variable + 'STRING', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .true., & ! preserve case + .false., & ! layered + .false. & ! timeseries + ) + + type(InputParamDefinitionType), parameter :: & + gwfchd_inewton = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'CHD', & ! subcomponent + 'OPTIONS', & ! block + 'DEV_NO_NEWTON', & ! tag name + 'INEWTON', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false., & ! layered + .false. & ! timeseries + ) + + type(InputParamDefinitionType), parameter :: & + gwfchd_maxbound = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'CHD', & ! subcomponent + 'DIMENSIONS', & ! block + 'MAXBOUND', & ! tag name + 'MAXBOUND', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false., & ! layered + .false. & ! timeseries + ) + + type(InputParamDefinitionType), parameter :: & + gwfchd_cellid = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'CHD', & ! subcomponent + 'PERIOD', & ! block + 'CELLID', & ! tag name + 'CELLID', & ! fortran variable + 'INTEGER1D', & ! type + 'NCELLDIM', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false., & ! layered + .false. & ! timeseries + ) + + type(InputParamDefinitionType), parameter :: & + gwfchd_head = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'CHD', & ! subcomponent + 'PERIOD', & ! block + 'HEAD', & ! tag name + 'HEAD', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false., & ! layered + .true. & ! timeseries + ) + + type(InputParamDefinitionType), parameter :: & + gwfchd_auxvar = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'CHD', & ! subcomponent + 'PERIOD', & ! block + 'AUX', & ! tag name + 'AUXVAR', & ! fortran variable + 'DOUBLE1D', & ! type + 'NAUX', & ! shape + .false., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false., & ! layered + .true. & ! timeseries + ) + + type(InputParamDefinitionType), parameter :: & + gwfchd_boundname = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'CHD', & ! subcomponent + 'PERIOD', & ! block + 'BOUNDNAME', & ! tag name + 'BOUNDNAME', & ! fortran variable + 'STRING', & ! type + '', & ! shape + .false., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false., & ! layered + .false. & ! timeseries + ) + + type(InputParamDefinitionType), parameter :: & + gwf_chd_param_definitions(*) = & + [ & + gwfchd_auxiliary, & + gwfchd_auxmultname, & + gwfchd_boundnames, & + gwfchd_iprpak, & + gwfchd_iprflow, & + gwfchd_ipakcb, & + gwfchd_ts_filerecord, & + gwfchd_ts6, & + gwfchd_filein, & + gwfchd_ts6_filename, & + gwfchd_obs_filerecord, & + gwfchd_obs6, & + gwfchd_obs6_filename, & + gwfchd_inewton, & + gwfchd_maxbound, & + gwfchd_cellid, & + gwfchd_head, & + gwfchd_auxvar, & + gwfchd_boundname & + ] + + type(InputParamDefinitionType), parameter :: & + gwfchd_spd = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'CHD', & ! subcomponent + 'PERIOD', & ! block + 'STRESS_PERIOD_DATA', & ! tag name + 'SPD', & ! fortran variable + 'RECARRAY CELLID HEAD AUX BOUNDNAME', & ! type + 'MAXBOUND', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false., & ! layered + .false. & ! timeseries + ) + + type(InputParamDefinitionType), parameter :: & + gwf_chd_aggregate_definitions(*) = & + [ & + gwfchd_spd & + ] + + type(InputBlockDefinitionType), parameter :: & + gwf_chd_block_definitions(*) = & + [ & + InputBlockDefinitionType( & + 'OPTIONS', & ! blockname + .false., & ! required + .false., & ! aggregate + .false. & ! block_variable + ), & + InputBlockDefinitionType( & + 'DIMENSIONS', & ! blockname + .true., & ! required + .false., & ! aggregate + .false. & ! block_variable + ), & + InputBlockDefinitionType( & + 'PERIOD', & ! blockname + .true., & ! required + .true., & ! aggregate + .true. & ! block_variable + ) & + ] + +end module GwfChdInputModule diff --git a/src/Model/GroundWaterFlow/gwf3dis8.f90 b/src/Model/GroundWaterFlow/gwf3dis8.f90 index 0d3e1d334c7..1380a9503b5 100644 --- a/src/Model/GroundWaterFlow/gwf3dis8.f90 +++ b/src/Model/GroundWaterFlow/gwf3dis8.f90 @@ -84,22 +84,16 @@ subroutine dis_cr(dis, name_model, input_mempath, inunit, iout) integer(I4B), intent(in) :: iout ! -- locals type(GwfDisType), pointer :: disnew - logical(LGP) :: found_fname character(len=*), parameter :: fmtheader = & "(1X, /1X, 'DIS -- STRUCTURED GRID DISCRETIZATION PACKAGE,', & &' VERSION 2 : 3/27/2014 - INPUT READ FROM MEMPATH: ', A, /)" ! ------------------------------------------------------------------------------ allocate (disnew) dis => disnew - call disnew%allocate_scalars(name_model) - dis%input_mempath = input_mempath + call disnew%allocate_scalars(name_model, input_mempath) dis%inunit = inunit dis%iout = iout ! - ! -- set name of input file - call mem_set_value(dis%input_fname, 'INPUT_FNAME', dis%input_mempath, & - found_fname) - ! ! -- If dis enabled if (inunit > 0) then ! @@ -872,7 +866,7 @@ function get_nodenumber_idx3(this, k, i, j, icheck) & return end function get_nodenumber_idx3 - subroutine allocate_scalars(this, name_model) + subroutine allocate_scalars(this, name_model, input_mempath) ! ****************************************************************************** ! allocate_scalars -- Allocate and initialize scalars ! ****************************************************************************** @@ -883,10 +877,11 @@ subroutine allocate_scalars(this, name_model) ! -- dummy class(GwfDisType) :: this character(len=*), intent(in) :: name_model + character(len=*), intent(in) :: input_mempath ! ------------------------------------------------------------------------------ ! ! -- Allocate parent scalars - call this%DisBaseType%allocate_scalars(name_model) + call this%DisBaseType%allocate_scalars(name_model, input_mempath) ! ! -- Allocate call mem_allocate(this%nlay, 'NLAY', this%memoryPath) diff --git a/src/Model/GroundWaterFlow/gwf3disu8.f90 b/src/Model/GroundWaterFlow/gwf3disu8.f90 index 404ea357340..d33bf55eb2a 100644 --- a/src/Model/GroundWaterFlow/gwf3disu8.f90 +++ b/src/Model/GroundWaterFlow/gwf3disu8.f90 @@ -100,7 +100,6 @@ subroutine disu_cr(dis, name_model, input_mempath, inunit, iout) integer(I4B), intent(in) :: iout ! -- local type(GwfDisuType), pointer :: disnew - logical(LGP) :: found_fname character(len=*), parameter :: fmtheader = & "(1X, /1X, 'DISU -- UNSTRUCTURED GRID DISCRETIZATION PACKAGE,', & &' VERSION 2 : 3/27/2014 - INPUT READ FROM MEMPATH: ', A, //)" @@ -111,15 +110,10 @@ subroutine disu_cr(dis, name_model, input_mempath, inunit, iout) dis => disnew ! ! -- Allocate scalars and assign data - call dis%allocate_scalars(name_model) - dis%input_mempath = input_mempath + call dis%allocate_scalars(name_model, input_mempath) dis%inunit = inunit dis%iout = iout ! - ! -- set name of input file - call mem_set_value(dis%input_fname, 'INPUT_FNAME', dis%input_mempath, & - found_fname) - ! ! -- If disu is enabled if (inunit > 0) then ! @@ -1311,7 +1305,7 @@ subroutine get_dis_type(this, dis_type) end subroutine get_dis_type - subroutine allocate_scalars(this, name_model) + subroutine allocate_scalars(this, name_model, input_mempath) ! ****************************************************************************** ! allocate_scalars -- Allocate and initialize scalar variables in this class ! ****************************************************************************** @@ -1323,11 +1317,12 @@ subroutine allocate_scalars(this, name_model) ! -- dummy class(GwfDisuType) :: this character(len=*), intent(in) :: name_model + character(len=*), intent(in) :: input_mempath ! -- local ! ------------------------------------------------------------------------------ ! ! -- Allocate parent scalars - call this%DisBaseType%allocate_scalars(name_model) + call this%DisBaseType%allocate_scalars(name_model, input_mempath) ! ! -- Allocate variables for DISU call mem_allocate(this%njausr, 'NJAUSR', this%memoryPath) diff --git a/src/Model/GroundWaterFlow/gwf3disv8.f90 b/src/Model/GroundWaterFlow/gwf3disv8.f90 index 25b1d7d1758..06d07c8d78f 100644 --- a/src/Model/GroundWaterFlow/gwf3disv8.f90 +++ b/src/Model/GroundWaterFlow/gwf3disv8.f90 @@ -88,22 +88,16 @@ subroutine disv_cr(dis, name_model, input_mempath, inunit, iout) integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout type(GwfDisvType), pointer :: disnew - logical(LGP) :: found_fname character(len=*), parameter :: fmtheader = & "(1X, /1X, 'DISV -- VERTEX GRID DISCRETIZATION PACKAGE,', & &' VERSION 1 : 12/23/2015 - INPUT READ FROM MEMPATH: ', A, //)" ! ------------------------------------------------------------------------------ allocate (disnew) dis => disnew - call disnew%allocate_scalars(name_model) - dis%input_mempath = input_mempath + call disnew%allocate_scalars(name_model, input_mempath) dis%inunit = inunit dis%iout = iout ! - ! -- set name of input file - call mem_set_value(dis%input_fname, 'INPUT_FNAME', dis%input_mempath, & - found_fname) - ! ! -- If disv enabled if (inunit > 0) then ! @@ -1240,7 +1234,7 @@ subroutine get_dis_type(this, dis_type) end subroutine get_dis_type - subroutine allocate_scalars(this, name_model) + subroutine allocate_scalars(this, name_model, input_mempath) ! ****************************************************************************** ! allocate_scalars -- Allocate and initialize scalars ! ****************************************************************************** @@ -1252,10 +1246,11 @@ subroutine allocate_scalars(this, name_model) ! -- dummy class(GwfDisvType) :: this character(len=*), intent(in) :: name_model + character(len=*), intent(in) :: input_mempath ! ------------------------------------------------------------------------------ ! ! -- Allocate parent scalars - call this%DisBaseType%allocate_scalars(name_model) + call this%DisBaseType%allocate_scalars(name_model, input_mempath) ! ! -- Allocate call mem_allocate(this%nlay, 'NLAY', this%memoryPath) diff --git a/src/Model/GroundWaterFlow/gwf3npf8.f90 b/src/Model/GroundWaterFlow/gwf3npf8.f90 index 56358e2e9b2..8aad85144af 100644 --- a/src/Model/GroundWaterFlow/gwf3npf8.f90 +++ b/src/Model/GroundWaterFlow/gwf3npf8.f90 @@ -166,7 +166,6 @@ subroutine npf_cr(npfobj, name_model, input_mempath, inunit, iout) integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout ! -- locals - logical(LGP) :: found_fname ! -- formats character(len=*), parameter :: fmtheader = & "(1x, /1x, 'NPF -- NODE PROPERTY FLOW PACKAGE, VERSION 1, 3/30/2015', & @@ -177,20 +176,15 @@ subroutine npf_cr(npfobj, name_model, input_mempath, inunit, iout) allocate (npfobj) ! ! -- create name and memory path - call npfobj%set_names(1, name_model, 'NPF', 'NPF') + call npfobj%set_names(1, name_model, 'NPF', 'NPF', input_mempath) ! ! -- Allocate scalars call npfobj%allocate_scalars() ! ! -- Set variables - npfobj%input_mempath = input_mempath npfobj%inunit = inunit npfobj%iout = iout ! - ! -- set name of input file - call mem_set_value(npfobj%input_fname, 'INPUT_FNAME', npfobj%input_mempath, & - found_fname) - ! ! -- check if npf is enabled if (inunit > 0) then ! @@ -1481,16 +1475,14 @@ subroutine source_options(this) use MemoryManagerExtModule, only: mem_set_value use CharacterStringModule, only: CharacterStringType use GwfNpfInputModule, only: GwfNpfParamFoundType + use IdmLoadModule, only: filein_fname ! -- dummy class(GwfNpftype) :: this ! -- locals character(len=LENVARNAME), dimension(3) :: cellavg_method = & &[character(len=LENVARNAME) :: 'LOGARITHMIC', 'AMT-LMK', 'AMT-HMK'] type(GwfNpfParamFoundType) :: found - type(CharacterStringType), dimension(:), pointer, & - contiguous :: tvk6_fnames character(len=LINELENGTH) :: tvk6_filename - integer(I4B) :: tvk6_isize, n ! ------------------------------------------------------------------------------ ! ! -- update defaults with idm sourced values @@ -1542,24 +1534,11 @@ subroutine source_options(this) this%iasym = 0 end if ! - call get_isize('TVK6_FILENAME', this%input_mempath, tvk6_isize) - ! - if (tvk6_isize > 0) then - ! - if (tvk6_isize /= 1) then - errmsg = 'Multiple TVK6 keywords detected in OPTIONS block.'// & - ' Only one TVK6 entry allowed.' - call store_error(errmsg) - call store_error_filename(this%input_fname) - end if - ! - call mem_setptr(tvk6_fnames, 'TVK6_FILENAME', this%input_mempath) - ! - do n = 1, tvk6_isize - tvk6_filename = tvk6_fnames(n) - call openfile(this%intvk, this%iout, tvk6_filename, 'TVK') - call tvk_cr(this%tvk, this%name_model, this%intvk, this%iout) - end do + ! -- enforce 0 or 1 TVK6_FILENAME entries in option block + if (filein_fname(tvk6_filename, 'TVK6_FILENAME', this%input_mempath, & + this%input_fname)) then + call openfile(this%intvk, this%iout, tvk6_filename, 'TVK') + call tvk_cr(this%tvk, this%name_model, this%intvk, this%iout) end if ! ! -- log options diff --git a/src/Model/GroundWaterTransport/gwt1dsp1.f90 b/src/Model/GroundWaterTransport/gwt1dsp1.f90 index 50881f867c7..acf48a88052 100644 --- a/src/Model/GroundWaterTransport/gwt1dsp1.f90 +++ b/src/Model/GroundWaterTransport/gwt1dsp1.f90 @@ -90,7 +90,6 @@ subroutine dsp_cr(dspobj, name_model, input_mempath, inunit, iout, fmi) integer(I4B), intent(in) :: iout type(GwtFmiType), intent(in), target :: fmi ! -- locals - logical(LGP) :: found_fname ! -- formats character(len=*), parameter :: fmtdsp = & "(1x,/1x,'DSP-- DISPERSION PACKAGE, VERSION 1, 1/24/2018', & @@ -101,21 +100,16 @@ subroutine dsp_cr(dspobj, name_model, input_mempath, inunit, iout, fmi) allocate (dspobj) ! ! -- create name and memory path - call dspobj%set_names(1, name_model, 'DSP', 'DSP') + call dspobj%set_names(1, name_model, 'DSP', 'DSP', input_mempath) ! ! -- Allocate scalars call dspobj%allocate_scalars() ! ! -- Set variables - dspobj%input_mempath = input_mempath dspobj%inunit = inunit dspobj%iout = iout dspobj%fmi => fmi ! - ! -- set name of input file - call mem_set_value(dspobj%input_fname, 'INPUT_FNAME', dspobj%input_mempath, & - found_fname) - ! if (dspobj%inunit > 0) then ! ! -- Print a message identifying the dispersion package. diff --git a/src/Model/ModelUtilities/BoundaryPackageExt.f90 b/src/Model/ModelUtilities/BoundaryPackageExt.f90 new file mode 100644 index 00000000000..4451669250d --- /dev/null +++ b/src/Model/ModelUtilities/BoundaryPackageExt.f90 @@ -0,0 +1,767 @@ +!> @brief This module contains the extended boundary package +!! +!! This module contains the extended boundary type that itself +!! should be extended by model boundary packages that have been +!! updated to source static and dynamic input data from the +!! input context. +!! +!< +module BndExtModule + + use KindModule, only: DP, LGP, I4B + use ConstantsModule, only: LENMEMPATH, LENBOUNDNAME, LENAUXNAME, LINELENGTH + use ObsModule, only: obs_cr + use SimVariablesModule, only: errmsg + use SimModule, only: store_error, count_errors, store_error_filename + use BndModule, only: BndType + + implicit none + + private + public :: BndExtType + + !> @ brief BndExtType + !! + !! Generic extended boundary package type. This derived type can be + !! overriden to define concrete boundary package types that source + !! all input from the input context. + !< + type, extends(BndType) :: BndExtType + ! -- characters + ! -- scalars + integer(I4B), pointer :: iper + ! -- arrays + integer(I4B), dimension(:, :), pointer, contiguous :: cellid => null() + contains + procedure :: bnd_df => bndext_df + procedure :: bnd_rp => bndext_rp + procedure :: bnd_da => bndext_da + procedure :: allocate_scalars => bndext_allocate_scalars + procedure :: allocate_arrays => bndext_allocate_arrays + procedure :: source_options + procedure :: source_dimensions + procedure :: log_options + procedure :: nodelist_update + procedure :: check_cellid + procedure :: write_list + procedure :: bound_value + end type BndExtType + +contains + + !> @ brief Define boundary package options and dimensions + !! + !! Define base boundary package options and dimensions for + !! a model boundary package. + !! + !< + subroutine bndext_df(this, neq, dis) + ! -- modules + use BaseDisModule, only: DisBaseType + use TimeArraySeriesManagerModule, only: TimeArraySeriesManagerType, & + tasmanager_cr + use TimeSeriesManagerModule, only: TimeSeriesManagerType, tsmanager_cr + ! -- dummy variables + class(BndExtType), intent(inout) :: this !< BndExtType object + integer(I4B), intent(inout) :: neq !< number of equations + class(DisBaseType), pointer :: dis !< discretization object + ! + ! -- set pointer to dis object for the model + this%dis => dis + ! + ! -- Create time series managers + ! -- Not in use by this type but BndType uses and deallocates + call tsmanager_cr(this%TsManager, this%iout) + call tasmanager_cr(this%TasManager, dis, this%name_model, this%iout) + ! + ! -- create obs package + call obs_cr(this%obs, this%inobspkg) + ! + ! -- Write information to model list file + write (this%iout, 1) this%filtyp, trim(adjustl(this%text)), this%input_mempath +1 format(1X, /1X, a, ' -- ', a, ' PACKAGE, VERSION 8, 2/22/2014', & + ' INPUT READ FROM MEMPATH: ', a) + ! + ! -- source options + call this%source_options() + ! + ! -- Define time series managers + call this%tsmanager%tsmanager_df() + call this%tasmanager%tasmanager_df() + ! + ! -- source dimensions + call this%source_dimensions() + ! + ! -- update package moffset for packages that add rows + if (this%npakeq > 0) then + this%ioffset = neq - this%dis%nodes + end if + ! + ! -- update neq + neq = neq + this%npakeq + ! + ! -- Store information needed for observations + if (this%bnd_obs_supported()) then + call this%obs%obs_df(this%iout, this%packName, this%filtyp, this%dis) + call this%bnd_df_obs() + end if + ! + ! -- return + return + end subroutine bndext_df + + subroutine bndext_rp(this) + ! -- modules + use TdisModule, only: kper + use MemoryManagerModule, only: mem_deallocate, mem_reallocate + use MemoryManagerExtModule, only: mem_set_value + ! -- dummy variables + class(BndExtType), intent(inout) :: this !< BndExtType object + ! -- local variables + logical(LGP) :: found + integer(I4B) :: n + ! + if (this%iper /= kper) return + ! + ! -- copy nbound from input context + call mem_set_value(this%nbound, 'NBOUND', this%input_mempath, & + found) + ! + ! -- convert cellids to node numbers + call this%nodelist_update() + ! + ! -- update boundname string list + if (this%inamedbound /= 0) then + do n = 1, size(this%boundname_cst) + this%boundname(n) = this%boundname_cst(n) + end do + end if + ! + ! -- return + return + end subroutine bndext_rp + + !> @ brief Deallocate package memory + !< + subroutine bndext_da(this) + ! -- modules + use MemoryManagerModule, only: mem_deallocate, mem_setptr + ! -- dummy variables + class(BndExtType) :: this !< BndExtType object + ! + ! -- deallocate checkin paths + call mem_deallocate(this%cellid, 'CELLID', this%memoryPath) + call mem_deallocate(this%boundname_cst, 'BOUNDNAME_IDM', this%memoryPath) + call mem_deallocate(this%auxvar, 'AUXVAR_IDM', this%memoryPath) + ! + ! -- reassign pointers for base class _da + call mem_setptr(this%boundname_cst, 'BOUNDNAME_CST', this%memoryPath) + call mem_setptr(this%auxvar, 'AUXVAR', this%memoryPath) + ! + ! -- scalars + nullify (this%iper) + ! + ! -- deallocate + call this%BndType%bnd_da() + ! + ! -- return + return + end subroutine bndext_da + + !> @ brief Allocate package scalars + !! + !! Allocate and initialize base boundary package scalars. This method + !! only needs to be overridden if additional scalars are defined + !! for a specific package. + !! + !< + subroutine bndext_allocate_scalars(this) + ! -- modules + use MemoryManagerModule, only: mem_setptr + use MemoryManagerExtModule, only: mem_set_value + use MemoryHelperModule, only: create_mem_path + use SimVariablesModule, only: idm_context + ! -- dummy variables + class(BndExtType) :: this !< BndExtType object + ! -- local variables + character(len=LENMEMPATH) :: input_mempath + ! + ! -- set memory path + input_mempath = create_mem_path(this%name_model, this%packName, idm_context) + ! + ! -- allocate base BndType scalars + call this%BndType%allocate_scalars() + ! + ! -- set pointers to period input data scalars + call mem_setptr(this%iper, 'IPER', input_mempath) + ! + ! -- return + return + end subroutine bndext_allocate_scalars + + !> @ brief Allocate package arrays + !! + !! Allocate and initialize base boundary package arrays. This method + !! only needs to be overridden if additional arrays are defined + !! for a specific package. + !! + !< + subroutine bndext_allocate_arrays(this, nodelist, auxvar) + ! -- modules + use MemoryManagerModule, only: mem_deallocate, mem_setptr, mem_checkin + ! -- dummy variables + class(BndExtType) :: this !< BndExtType object + ! -- local variables + integer(I4B), dimension(:), pointer, contiguous, optional :: nodelist !< package nodelist + real(DP), dimension(:, :), pointer, contiguous, optional :: auxvar !< package aux variable array + ! + ! -- allocate base BndType arrays + call this%BndType%allocate_arrays(nodelist, auxvar) + ! + ! -- set input context pointers + call mem_setptr(this%cellid, 'CELLID', this%input_mempath) + call mem_setptr(this%boundname_cst, 'BOUNDNAME', this%input_mempath) + ! + ! -- checkin input context pointers + call mem_checkin(this%cellid, 'CELLID', this%memoryPath, & + 'CELLID', this%input_mempath) + call mem_checkin(this%boundname_cst, LENBOUNDNAME, 'BOUNDNAME_IDM', & + this%memoryPath, 'BOUNDNAME', this%input_mempath) + ! + if (present(auxvar)) then + ! no-op + else + ! -- set auxvar input context pointer + call mem_setptr(this%auxvar, 'AUXVAR', this%input_mempath) + ! + ! -- checkin auxvar input context pointer + call mem_checkin(this%auxvar, 'AUXVAR_IDM', this%memoryPath, & + 'AUXVAR', this%input_mempath) + end if + ! + ! -- return + return + end subroutine bndext_allocate_arrays + + !> @ brief Source package options from input context + !< + subroutine source_options(this) + ! -- modules + use MemoryManagerModule, only: mem_reallocate, mem_setptr !, get_isize + use MemoryManagerExtModule, only: mem_set_value + use InputOutputModule, only: GetUnit, openfile + use CharacterStringModule, only: CharacterStringType + use IdmLoadModule, only: filein_fname + use IdmGwfDfnSelectorModule, only: GwfParamFoundType + ! -- dummy variables + class(BndExtType), intent(inout) :: this !< BndExtType object + ! -- local variables + character(len=LENAUXNAME) :: sfacauxname + integer(I4B) :: n + type(GwfParamFoundType) :: found + logical :: found_naux + ! + ! -- update defaults with idm sourced values + call mem_set_value(this%naux, 'NAUX', this%input_mempath, found_naux) + call mem_set_value(this%ipakcb, 'IPAKCB', this%input_mempath, found%ipakcb) + call mem_set_value(this%iprpak, 'IPRPAK', this%input_mempath, found%iprpak) + call mem_set_value(this%iprflow, 'IPRFLOW', this%input_mempath, found%iprflow) + call mem_set_value(this%inamedbound, 'BOUNDNAMES', this%input_mempath, & + found%boundnames) + call mem_set_value(sfacauxname, 'AUXMULTNAME', this%input_mempath, & + found%auxmultname) + call mem_set_value(this%inewton, 'INEWTON', this%input_mempath, found%inewton) + ! + ! -- log found options + call this%log_options(found, sfacauxname) + ! + ! -- reallocate aux arrays if aux variables provided + if (found_naux .and. this%naux > 0) then + call mem_reallocate(this%auxname, LENAUXNAME, this%naux, & + 'AUXNAME', this%memoryPath) + call mem_reallocate(this%auxname_cst, LENAUXNAME, this%naux, & + 'AUXNAME_CST', this%memoryPath) + call mem_set_value(this%auxname_cst, 'AUXILIARY', this%input_mempath, & + found%auxiliary) + ! + do n = 1, this%naux + this%auxname(n) = this%auxname_cst(n) + end do + end if + ! + ! -- save flows option active + if (found%ipakcb) this%ipakcb = -1 + ! + ! -- auxmultname provided + if (found%auxmultname) this%iauxmultcol = -1 + ! + ! + ! -- enforce 0 or 1 OBS6_FILENAME entries in option block + if (filein_fname(this%obs%inputFilename, 'OBS6_FILENAME', & + this%input_mempath, this%input_fname)) then + this%obs%active = .true. + this%obs%inUnitObs = GetUnit() + call openfile(this%obs%inUnitObs, this%iout, this%obs%inputFilename, 'OBS') + end if + ! + ! -- no newton specified + if (found%inewton) this%inewton = 0 + ! + ! -- AUXMULTNAME was specified, so find column of auxvar that will be multiplier + if (this%iauxmultcol < 0) then + ! + ! -- Error if no aux variable specified + if (this%naux == 0) then + write (errmsg, '(a,2(1x,a))') & + 'AUXMULTNAME was specified as', trim(adjustl(sfacauxname)), & + 'but no AUX variables specified.' + call store_error(errmsg) + end if + ! + ! -- Assign mult column + this%iauxmultcol = 0 + do n = 1, this%naux + if (sfacauxname == this%auxname(n)) then + this%iauxmultcol = n + exit + end if + end do + ! + ! -- Error if aux variable cannot be found + if (this%iauxmultcol == 0) then + write (errmsg, '(a,2(1x,a))') & + 'AUXMULTNAME was specified as', trim(adjustl(sfacauxname)), & + 'but no AUX variable found with this name.' + call store_error(errmsg) + end if + end if + ! + ! -- terminate if errors were detected + if (count_errors() > 0) then + call store_error_filename(this%input_fname) + end if + ! + ! -- return + return + end subroutine source_options + + !> @ brief Log package options + !< + subroutine log_options(this, found, sfacauxname) + ! -- modules + use IdmGwfDfnSelectorModule, only: GwfParamFoundType + ! -- dummy variables + class(BndExtType), intent(inout) :: this !< BndExtType object + type(GwfParamFoundType), intent(in) :: found + character(len=*), intent(in) :: sfacauxname + ! -- local variables + ! -- format + character(len=*), parameter :: fmtflow = & + &"(4x, 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL')" + character(len=*), parameter :: fmttas = & + &"(4x, 'TIME-ARRAY SERIES DATA WILL BE READ FROM FILE: ', a)" + character(len=*), parameter :: fmtts = & + &"(4x, 'TIME-SERIES DATA WILL BE READ FROM FILE: ', a)" + character(len=*), parameter :: fmtnme = & + &"(a, i0, a)" + ! + ! -- log found options + write (this%iout, '(/1x,a)') 'PROCESSING '//trim(adjustl(this%text)) & + //' OPTIONS' + ! + if (found%ipakcb) then + write (this%iout, fmtflow) + end if + ! + if (found%iprpak) then + write (this%iout, '(4x,a)') & + 'LISTS OF '//trim(adjustl(this%text))//' CELLS WILL BE PRINTED.' + end if + ! + if (found%iprflow) then + write (this%iout, '(4x,a)') trim(adjustl(this%text))// & + ' FLOWS WILL BE PRINTED TO LISTING FILE.' + end if + ! + if (found%boundnames) then + write (this%iout, '(4x,a)') trim(adjustl(this%text))// & + ' BOUNDARIES HAVE NAMES IN LAST COLUMN.' + end if + ! + if (found%auxmultname) then + write (this%iout, '(4x,a,a)') & + 'AUXILIARY MULTIPLIER NAME: ', sfacauxname + end if + ! + if (found%inewton) then + write (this%iout, '(4x,a)') & + 'NEWTON-RAPHSON method disabled for unconfined cells' + end if + ! + ! -- close logging block + write (this%iout, '(1x,a)') & + 'END OF '//trim(adjustl(this%text))//' OPTIONS' + ! + ! -- return + return + end subroutine log_options + + !> @ brief Source package dimensions from input context + !< + subroutine source_dimensions(this) + use MemoryManagerExtModule, only: mem_set_value + use IdmGwfDfnSelectorModule, only: GwfParamFoundType + ! -- dummy variables + class(BndExtType), intent(inout) :: this !< BndExtType object + ! -- local variables + type(GwfParamFoundType) :: found + ! + ! -- open dimensions logging block + write (this%iout, '(/1x,a)') 'PROCESSING '//trim(adjustl(this%text))// & + ' DIMENSIONS' + ! + ! -- update defaults with idm sourced values + call mem_set_value(this%maxbound, 'MAXBOUND', this%input_mempath, & + found%maxbound) + ! + write (this%iout, '(4x,a,i7)') 'MAXBOUND = ', this%maxbound + ! + ! -- close logging block + write (this%iout, '(1x,a)') & + 'END OF '//trim(adjustl(this%text))//' DIMENSIONS' + ! + ! -- verify dimensions were set + if (this%maxbound <= 0) then + write (errmsg, '(a)') 'MAXBOUND must be an integer greater than zero.' + call store_error(errmsg) + call store_error_filename(this%input_fname) + end if + ! + ! -- Call define_listlabel to construct the list label that is written + ! when PRINT_INPUT option is used. + call this%define_listlabel() + ! + ! -- return + return + end subroutine source_dimensions + + !> @ brief Update package nodelist + !! + !! Convert period updated cellids to node numbers. + !! + !< + subroutine nodelist_update(this) + ! -- modules + use SimVariablesModule, only: errmsg + use InputOutputModule, only: get_node + ! -- dummy + class(BndExtType) :: this !< BndExtType object + ! -- local + integer(I4B), dimension(:), pointer :: cellid + integer(I4B) :: n, nodeu, noder + character(len=LINELENGTH) :: nodestr + ! + ! -- update nodelist + do n = 1, this%nbound + ! + ! -- set cellid + cellid => this%cellid(:, n) + ! + ! -- ensure cellid is valid, store an error otherwise + call this%check_cellid(n, cellid, this%dis%mshape, this%dis%ndim) + ! + ! -- Determine user node number + if (this%dis%ndim == 1) then + nodeu = cellid(1) + elseif (this%dis%ndim == 2) then + nodeu = get_node(cellid(1), 1, cellid(2), & + this%dis%mshape(1), 1, & + this%dis%mshape(2)) + else + nodeu = get_node(cellid(1), cellid(2), cellid(3), & + this%dis%mshape(1), & + this%dis%mshape(2), & + this%dis%mshape(3)) + end if + ! + ! -- update the nodelist + if (this%dis%nodes < this%dis%nodesuser) then + ! -- convert user to reduced node numbers + noder = this%dis%get_nodenumber(nodeu, 0) + if (noder <= 0) then + call this%dis%nodeu_to_string(nodeu, nodestr) + write (errmsg, *) & + ' Cell is outside active grid domain: '// & + trim(adjustl(nodestr)) + call store_error(errmsg) + end if + this%nodelist(n) = noder + else + this%nodelist(n) = nodeu + end if + end do + ! + ! -- exit if errors were found + if (count_errors() > 0) then + write (errmsg, *) count_errors(), ' errors encountered.' + call store_error(errmsg) + call store_error_filename(this%input_fname) + end if + ! + ! -- return + return + end subroutine nodelist_update + + !> @ brief Check for valid cellid + !< + subroutine check_cellid(this, ii, cellid, mshape, ndim) + ! -- modules + use SimVariablesModule, only: errmsg + use InputOutputModule, only: get_node + ! -- dummy + class(BndExtType) :: this !< BndExtType object + ! -- local + integer(I4B), intent(in) :: ii + integer(I4B), dimension(:), intent(in) :: cellid !< cellid + integer(I4B), dimension(:), intent(in) :: mshape !< model shape + integer(I4B), intent(in) :: ndim !< size of mshape + character(len=20) :: cellstr, mshstr + character(len=*), parameter :: fmterr = & + "('List entry ',i0,' contains cellid ',a,' but this cellid is invalid & + &for model with shape ', a)" + character(len=*), parameter :: fmtndim1 = & + "('(',i0,')')" + character(len=*), parameter :: fmtndim2 = & + "('(',i0,',',i0,')')" + character(len=*), parameter :: fmtndim3 = & + "('(',i0,',',i0,',',i0,')')" + select case (ndim) + case (1) + ! + if (cellid(1) < 1 .or. cellid(1) > mshape(1)) then + write (cellstr, fmtndim1) cellid(1) + write (mshstr, fmtndim1) mshape(1) + write (errmsg, fmterr) ii, trim(adjustl(cellstr)), trim(adjustl(mshstr)) + call store_error(errmsg) + end if + ! + case (2) + ! + if (cellid(1) < 1 .or. cellid(1) > mshape(1) .or. & + cellid(2) < 1 .or. cellid(2) > mshape(2)) then + write (cellstr, fmtndim2) cellid(1), cellid(2) + write (mshstr, fmtndim2) mshape(1), mshape(2) + write (errmsg, fmterr) ii, trim(adjustl(cellstr)), trim(adjustl(mshstr)) + call store_error(errmsg) + end if + ! + case (3) + ! + if (cellid(1) < 1 .or. cellid(1) > mshape(1) .or. & + cellid(2) < 1 .or. cellid(2) > mshape(2) .or. & + cellid(3) < 1 .or. cellid(3) > mshape(3)) then + write (cellstr, fmtndim3) cellid(1), cellid(2), cellid(3) + write (mshstr, fmtndim3) mshape(1), mshape(2), mshape(3) + write (errmsg, fmterr) ii, trim(adjustl(cellstr)), trim(adjustl(mshstr)) + call store_error(errmsg) + end if + ! + case default + end select + ! + ! -- return + return + end subroutine check_cellid + + !> @ brief Log package list input + !! + !! Log period list based input. This routine requires a package specific + !! bound_value() routine to report accurate bound values. + !! + !< + subroutine write_list(this) + ! -- modules + use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, & + TABLEFT, TABCENTER, DZERO + use InputOutputModule, only: ulstlb, get_ijk + use TableModule, only: TableType, table_cr + ! -- dummy + class(BndExtType) :: this !< BndExtType object + ! -- local + character(len=10) :: cpos + character(len=LINELENGTH) :: tag + character(len=LINELENGTH), allocatable, dimension(:) :: words + integer(I4B) :: ntabrows + integer(I4B) :: ntabcols + integer(I4B) :: ipos + integer(I4B) :: ii, jj, i, j, k, nod + integer(I4B) :: ldim + integer(I4B) :: naux + type(TableType), pointer :: inputtab => null() + ! -- formats + character(len=LINELENGTH) :: fmtlstbn +! ------------------------------------------------------------------------------ + ! + ! -- Determine sizes + ldim = this%ncolbnd + naux = size(this%auxvar, 1) + ! + ! -- dimension table + ntabrows = this%nbound + ! + ! -- start building format statement to parse this%label, which + ! contains the column headers (except for boundname and auxnames) + ipos = index(this%listlabel, 'NO.') + if (ipos /= 0) then + write (cpos, '(i10)') ipos + 3 + fmtlstbn = '(a'//trim(adjustl(cpos)) + else + fmtlstbn = '(a7' + end if + ! -- sequence number, layer, row, and column. + if (size(this%dis%mshape) == 3) then + ntabcols = 4 + fmtlstbn = trim(fmtlstbn)//',a7,a7,a7' + ! + ! -- sequence number, layer, and cell2d. + else if (size(this%dis%mshape) == 2) then + ntabcols = 3 + fmtlstbn = trim(fmtlstbn)//',a7,a7' + ! + ! -- sequence number and node. + else + ntabcols = 2 + fmtlstbn = trim(fmtlstbn)//',a7' + end if + ! + ! -- Add fields for non-optional real values + ntabcols = ntabcols + ldim + do i = 1, ldim + fmtlstbn = trim(fmtlstbn)//',a16' + end do + ! + ! -- Add field for boundary name + if (this%inamedbound == 1) then + ntabcols = ntabcols + 1 + fmtlstbn = trim(fmtlstbn)//',a16' + end if + ! + ! -- Add fields for auxiliary variables + ntabcols = ntabcols + naux + do i = 1, naux + fmtlstbn = trim(fmtlstbn)//',a16' + end do + fmtlstbn = trim(fmtlstbn)//')' + ! + ! -- allocate words + allocate (words(ntabcols)) + ! + ! -- parse this%listlabel into words + read (this%listlabel, fmtlstbn) (words(i), i=1, ntabcols) + ! + ! -- initialize the input table object + call table_cr(inputtab, ' ', ' ') + call inputtab%table_df(ntabrows, ntabcols, this%iout) + ! + ! -- add the columns + ipos = 1 + call inputtab%initialize_column(words(ipos), 10, alignment=TABCENTER) + ! + ! -- discretization + do i = 1, size(this%dis%mshape) + ipos = ipos + 1 + call inputtab%initialize_column(words(ipos), 7, alignment=TABCENTER) + end do + ! + ! -- non-optional variables + do i = 1, ldim + ipos = ipos + 1 + call inputtab%initialize_column(words(ipos), 16, alignment=TABCENTER) + end do + ! + ! -- boundname + if (this%inamedbound == 1) then + ipos = ipos + 1 + tag = 'BOUNDNAME' + call inputtab%initialize_column(tag, LENBOUNDNAME, alignment=TABLEFT) + end if + ! + ! -- aux variables + do i = 1, naux + call inputtab%initialize_column(this%auxname(i), 16, alignment=TABCENTER) + end do + ! + ! -- Write the table + do ii = 1, this%nbound + call inputtab%add_term(ii) + ! + ! -- discretization + if (size(this%dis%mshape) == 3) then + nod = this%nodelist(ii) + call get_ijk(nod, this%dis%mshape(2), this%dis%mshape(3), & + this%dis%mshape(1), i, j, k) + call inputtab%add_term(k) + call inputtab%add_term(i) + call inputtab%add_term(j) + else if (size(this%dis%mshape) == 2) then + nod = this%nodelist(ii) + call get_ijk(nod, 1, this%dis%mshape(2), this%dis%mshape(1), i, j, k) + call inputtab%add_term(k) + call inputtab%add_term(j) + else + nod = this%nodelist(ii) + call inputtab%add_term(nod) + end if + ! + ! -- non-optional variables + do jj = 1, ldim + call inputtab%add_term(this%bound_value(jj, ii)) + end do + ! + ! -- boundname + if (this%inamedbound == 1) then + call inputtab%add_term(this%boundname(ii)) + end if + ! + ! -- aux variables + do jj = 1, naux + call inputtab%add_term(this%auxvar(jj, ii)) + end do + end do + ! + ! -- deallocate the local variables + call inputtab%table_da() + deallocate (inputtab) + nullify (inputtab) + deallocate (words) + ! + ! -- return + return + end subroutine write_list + + !> @ brief Return a bound value + !! + !! Return a bound value associated with an ncolbnd index + !! and row. This function should be overridden in the + !! derived package class. + !! + !< + function bound_value(this, col, row) result(bndval) + ! -- modules + use ConstantsModule, only: DNODATA + ! -- dummy variables + class(BndExtType), intent(inout) :: this !< BndExtType object + integer(I4B), intent(in) :: col + integer(I4B), intent(in) :: row + ! -- result + real(DP) :: bndval + ! + ! -- override this return value by redefining this + ! routine in the derived package. + bndval = DNODATA + ! + ! -- return + return + end function bound_value + +end module BndExtModule diff --git a/src/Model/ModelUtilities/DiscretizationBase.f90 b/src/Model/ModelUtilities/DiscretizationBase.f90 index 03c807dc1fd..ab19fd6afe5 100644 --- a/src/Model/ModelUtilities/DiscretizationBase.f90 +++ b/src/Model/ModelUtilities/DiscretizationBase.f90 @@ -1,6 +1,6 @@ module BaseDisModule - use KindModule, only: DP, I4B + use KindModule, only: DP, I4B, LGP use ConstantsModule, only: LENMODELNAME, LENAUXNAME, LINELENGTH, & DZERO, LENMEMPATH, DPIO180 use SmoothingModule, only: sQuadraticSaturation @@ -24,8 +24,8 @@ module BaseDisModule type :: DisBaseType character(len=LENMEMPATH) :: memoryPath !< path for memory allocation + character(len=LENMEMPATH) :: input_mempath = '' !< input context mempath character(len=LENMODELNAME), pointer :: name_model => null() !< name of the model - character(len=LENMEMPATH), pointer :: input_mempath => null() !< input context mempath character(len=LINELENGTH), pointer :: input_fname => null() !< input file name integer(I4B), pointer :: inunit => null() !< unit number for input file integer(I4B), pointer :: iout => null() !< unit number for output file @@ -262,7 +262,6 @@ subroutine dis_da(this) ! ! -- Strings deallocate (this%name_model) - deallocate (this%input_mempath) deallocate (this%input_fname) ! ! -- Scalars @@ -553,7 +552,7 @@ subroutine get_dis_type(this, dis_type) end subroutine get_dis_type - subroutine allocate_scalars(this, name_model) + subroutine allocate_scalars(this, name_model, input_mempath) ! ****************************************************************************** ! allocate_scalars -- Allocate and initialize scalar variables in this class ! ****************************************************************************** @@ -562,9 +561,12 @@ subroutine allocate_scalars(this, name_model) ! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate + use MemoryManagerExtModule, only: mem_set_value ! -- dummy class(DisBaseType) :: this character(len=*), intent(in) :: name_model + character(len=*), intent(in) :: input_mempath + logical(LGP) :: found ! -- local ! ------------------------------------------------------------------------------ ! @@ -573,7 +575,6 @@ subroutine allocate_scalars(this, name_model) ! ! -- Allocate allocate (this%name_model) - allocate (this%input_mempath) allocate (this%input_fname) ! call mem_allocate(this%inunit, 'INUNIT', this%memoryPath) @@ -592,7 +593,7 @@ subroutine allocate_scalars(this, name_model) ! ! -- Initialize this%name_model = name_model - this%input_mempath = '' + this%input_mempath = input_mempath this%input_fname = '' this%inunit = 0 this%iout = 0 @@ -608,6 +609,10 @@ subroutine allocate_scalars(this, name_model) this%njas = 0 this%lenuni = 0 ! + ! -- update input filename + call mem_set_value(this%input_fname, 'INPUT_FNAME', & + this%input_mempath, found) + ! ! -- Return return end subroutine allocate_scalars diff --git a/src/Model/NumericalPackage.f90 b/src/Model/NumericalPackage.f90 index 114256a4778..1d9e66decf0 100644 --- a/src/Model/NumericalPackage.f90 +++ b/src/Model/NumericalPackage.f90 @@ -6,7 +6,7 @@ !< module NumericalPackageModule ! -- modules - use KindModule, only: DP, I4B + use KindModule, only: DP, I4B, LGP use ConstantsModule, only: LENPACKAGENAME, LENMODELNAME, & LENMEMPATH, LENFTYPE, LINELENGTH, & LENVARNAME @@ -28,7 +28,7 @@ module NumericalPackageModule character(len=LENMEMPATH) :: memoryPath = '' !< the location in the memory manager where the variables are stored character(len=LENMEMPATH) :: memoryPathModel = '' !< the location in the memory manager where the variables !! of the parent model are stored - character(len=LENMEMPATH), pointer :: input_mempath => null() !< input context mempath + character(len=LENMEMPATH) :: input_mempath = '' !< input context mempath character(len=LINELENGTH), pointer :: input_fname => null() !< input file name character(len=LENFTYPE) :: filtyp = '' !< file type (CHD, DRN, RIV, etc.) character(len=LENFTYPE), pointer :: package_type => null() !< package type (same as filtyp) stored in memory manager @@ -66,17 +66,19 @@ module NumericalPackageModule !! is used by the memory manager when variables are allocated. !! !< - subroutine set_names(this, ibcnum, name_model, pakname, ftype) + subroutine set_names(this, ibcnum, name_model, pakname, ftype, input_mempath) ! -- dummy variables class(NumericalPackageType), intent(inout) :: this !< NumericalPackageType object integer(I4B), intent(in) :: ibcnum !< unique package number character(len=*), intent(in) :: name_model !< name of the model character(len=*), intent(in) :: pakname !< name of the package character(len=*), intent(in) :: ftype !< package type + character(len=*), optional, intent(in) :: input_mempath !< input_mempath ! ! -- set names this%filtyp = ftype this%name_model = name_model + if (present(input_mempath)) this%input_mempath = input_mempath if (pakname == '') then write (this%packName, '(a, i0)') trim(ftype)//'-', ibcnum else @@ -106,6 +108,7 @@ end subroutine set_names subroutine allocate_scalars(this) ! -- modules use MemoryManagerModule, only: mem_allocate, mem_setptr + use MemoryManagerExtModule, only: mem_set_value ! -- dummy variables class(NumericalPackageType) :: this !< NumericalPackageType object ! -- local variables @@ -113,10 +116,9 @@ subroutine allocate_scalars(this) integer(I4B), pointer :: imodelprpak => null() integer(I4B), pointer :: imodelprflow => null() integer(I4B), pointer :: imodelpakcb => null() + logical(LGP) :: found ! ! -- allocate scalars - call mem_allocate(this%input_mempath, LENMEMPATH, 'INPUT_MEMPATH', & - this%memoryPath) call mem_allocate(this%input_fname, LINELENGTH, 'INPUT_FNAME', & this%memoryPath) call mem_allocate(this%package_type, LENFTYPE, 'PACKAGE_TYPE', & @@ -140,7 +142,6 @@ subroutine allocate_scalars(this) call mem_setptr(imodelpakcb, 'IPAKCB', this%memoryPathModel) ! ! -- initialize - this%input_mempath = '' this%input_fname = '' this%package_type = this%filtyp this%id = 0 @@ -160,6 +161,12 @@ subroutine allocate_scalars(this) imodelprflow => null() imodelpakcb => null() ! + ! -- update input filename + if (this%input_mempath /= '') then + call mem_set_value(this%input_fname, 'INPUT_FNAME', & + this%input_mempath, found) + end if + ! ! -- return return end subroutine allocate_scalars @@ -176,7 +183,6 @@ subroutine da(this) class(NumericalPackageType) :: this !< NumericalPackageType object ! ! -- deallocate - call mem_deallocate(this%input_mempath, 'INPUT_MEMPATH', this%memoryPath) call mem_deallocate(this%input_fname, 'INPUT_FNAME', this%memoryPath) call mem_deallocate(this%package_type, 'PACKAGE_TYPE', this%memoryPath) call mem_deallocate(this%id) diff --git a/src/Utilities/Idm/IdmLoad.f90 b/src/Utilities/Idm/IdmLoad.f90 index 63690c9863b..fe6d5b263e6 100644 --- a/src/Utilities/Idm/IdmLoad.f90 +++ b/src/Utilities/Idm/IdmLoad.f90 @@ -21,6 +21,7 @@ module IdmLoadModule private public :: simnam_load public :: load_models + public :: filein_fname public :: idm_df public :: idm_rp public :: idm_ad @@ -30,6 +31,56 @@ module IdmLoadModule contains + !> @brief enforce and set a single input filename provided via FILEIN keyword + !! + !! Set a FILEIN filename provided via an OPTIONS block. + !! Only use this function if a maximum of one FILEIN file name + !! string is expected. + !! + !! Return true if single FILEIN file name found and set, return + !! false if FILEIN tag not found. + !! + !< + function filein_fname(filename, tagname, input_mempath, input_fname) & + result(found) + use SimModule, only: store_error, store_error_filename + use MemoryManagerModule, only: mem_setptr, get_isize + use CharacterStringModule, only: CharacterStringType + character(len=*), intent(inout) :: filename + character(len=*), intent(in) :: tagname + character(len=*), intent(in) :: input_mempath + character(len=*), intent(in) :: input_fname + logical(LGP) :: found + type(CharacterStringType), dimension(:), pointer, & + contiguous :: fnames + integer(I4B) :: isize + ! + ! -- initialize + found = .false. + filename = '' + ! + call get_isize(tagname, input_mempath, isize) + ! + if (isize > 0) then + ! + if (isize /= 1) then + errmsg = 'Multiple FILEIN keywords detected for tag "'//trim(tagname)// & + '" in OPTIONS block. Only one entry allowed.' + call store_error(errmsg) + call store_error_filename(input_fname) + end if + ! + call mem_setptr(fnames, tagname, input_mempath) + ! + filename = fnames(1) + found = .true. + ! + end if + ! + ! -- return + return + end function filein_fname + !> @brief advance package dynamic data for period steps !< subroutine idm_df() diff --git a/src/Utilities/Idm/selector/IdmGwfDfnSelector.f90 b/src/Utilities/Idm/selector/IdmGwfDfnSelector.f90 index 5d79675b9e8..bb58e47e741 100644 --- a/src/Utilities/Idm/selector/IdmGwfDfnSelector.f90 +++ b/src/Utilities/Idm/selector/IdmGwfDfnSelector.f90 @@ -5,6 +5,7 @@ module IdmGwfDfnSelectorModule use SimModule, only: store_error use InputDefinitionModule, only: InputParamDefinitionType, & InputBlockDefinitionType + use GwfChdInputModule use GwfDisInputModule use GwfDisuInputModule use GwfDisvInputModule @@ -22,6 +23,25 @@ module IdmGwfDfnSelectorModule public :: gwf_idm_integrated type GwfParamFoundType + logical :: auxiliary = .false. + logical :: auxmultname = .false. + logical :: boundnames = .false. + logical :: iprpak = .false. + logical :: iprflow = .false. + logical :: ipakcb = .false. + logical :: ts_filerecord = .false. + logical :: ts6 = .false. + logical :: filein = .false. + logical :: ts6_filename = .false. + logical :: obs_filerecord = .false. + logical :: obs6 = .false. + logical :: obs6_filename = .false. + logical :: inewton = .false. + logical :: maxbound = .false. + logical :: cellid = .false. + logical :: head = .false. + logical :: auxvar = .false. + logical :: boundname = .false. logical :: length_units = .false. logical :: nogrb = .false. logical :: xorigin = .false. @@ -56,8 +76,6 @@ module IdmGwfDfnSelectorModule logical :: ncvert = .false. logical :: icvert = .false. logical :: ncpl = .false. - logical :: ipakcb = .false. - logical :: iprflow = .false. logical :: cellavg = .false. logical :: ithickstrt = .false. logical :: cvoptions = .false. @@ -78,9 +96,7 @@ module IdmGwfDfnSelectorModule logical :: ik33overk = .false. logical :: tvk_filerecord = .false. logical :: tvk6 = .false. - logical :: filein = .false. logical :: tvk6_filename = .false. - logical :: inewton = .false. logical :: iusgnrhc = .false. logical :: inwtupw = .false. logical :: satmin = .false. @@ -124,6 +140,8 @@ function gwf_param_definitions(subcomponent) result(input_definition) type(InputParamDefinitionType), dimension(:), pointer :: input_definition nullify (input_definition) select case (subcomponent) + case ('CHD') + call set_param_pointer(input_definition, gwf_chd_param_definitions) case ('DIS') call set_param_pointer(input_definition, gwf_dis_param_definitions) case ('DISU') @@ -144,6 +162,8 @@ function gwf_aggregate_definitions(subcomponent) result(input_definition) type(InputParamDefinitionType), dimension(:), pointer :: input_definition nullify (input_definition) select case (subcomponent) + case ('CHD') + call set_param_pointer(input_definition, gwf_chd_aggregate_definitions) case ('DIS') call set_param_pointer(input_definition, gwf_dis_aggregate_definitions) case ('DISU') @@ -164,6 +184,8 @@ function gwf_block_definitions(subcomponent) result(input_definition) type(InputBlockDefinitionType), dimension(:), pointer :: input_definition nullify (input_definition) select case (subcomponent) + case ('CHD') + call set_block_pointer(input_definition, gwf_chd_block_definitions) case ('DIS') call set_block_pointer(input_definition, gwf_dis_block_definitions) case ('DISU') @@ -183,6 +205,8 @@ function gwf_idm_multi_package(subcomponent) result(multi_package) character(len=*), intent(in) :: subcomponent logical :: multi_package select case (subcomponent) + case ('CHD') + multi_package = gwf_chd_multi_package case ('DIS') multi_package = gwf_dis_multi_package case ('DISU') @@ -205,6 +229,8 @@ function gwf_idm_sfac_param(subcomponent) result(sfac_param) character(len=*), intent(in) :: subcomponent character(len=LENVARNAME) :: sfac_param select case (subcomponent) + case ('CHD') + sfac_param = gwf_chd_aux_sfac_param case ('DIS') sfac_param = gwf_dis_aux_sfac_param case ('DISU') @@ -228,6 +254,8 @@ function gwf_idm_integrated(subcomponent) result(integrated) logical :: integrated integrated = .false. select case (subcomponent) + case ('CHD') + integrated = .true. case ('DIS') integrated = .true. case ('DISU') diff --git a/src/Utilities/Memory/MemoryManager.f90 b/src/Utilities/Memory/MemoryManager.f90 index 0961dfc8533..7e617a3e478 100644 --- a/src/Utilities/Memory/MemoryManager.f90 +++ b/src/Utilities/Memory/MemoryManager.f90 @@ -69,7 +69,8 @@ module MemoryManagerModule checkin_int1d, & checkin_int2d, & checkin_dbl1d, & - checkin_dbl2d + checkin_dbl2d, & + checkin_charstr1d end interface mem_checkin interface mem_reallocate @@ -1126,6 +1127,50 @@ subroutine checkin_dbl2d(adbl2d, name, mem_path, name2, mem_path2) return end subroutine checkin_dbl2d + !> @brief Check in an existing 1d CharacterStringType array with a new address (name + path) + !< + subroutine checkin_charstr1d(acharstr1d, ilen, name, mem_path, name2, mem_path2) + type(CharacterStringType), dimension(:), & + pointer, contiguous, intent(inout) :: acharstr1d !< the existing array + integer(I4B), intent(in) :: ilen + character(len=*), intent(in) :: name !< new variable name + character(len=*), intent(in) :: mem_path !< new path where variable is stored + character(len=*), intent(in) :: name2 !< existing variable name + character(len=*), intent(in) :: mem_path2 !< existing path where variable is stored + ! --local + type(MemoryType), pointer :: mt + integer(I4B) :: isize + ! -- code + ! + ! -- check variable name length + call mem_check_length(name, LENVARNAME, "variable") + ! + ! -- set isize + isize = size(acharstr1d) + ! + ! -- allocate memory type + allocate (mt) + ! + ! -- set memory type + mt%acharstr1d => acharstr1d + mt%element_size = ilen + mt%isize = isize + mt%name = name + mt%path = mem_path + write (mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, isize + ! + ! -- set master information + mt%master = .false. + mt%mastername = name2 + mt%masterPath = mem_path2 + ! + ! -- add memory type to the memory list + call memorylist%add(mt) + ! + ! -- return + return + end subroutine checkin_charstr1d + !> @brief Reallocate a 1-dimensional defined length string array !< subroutine reallocate_str1d(astr, ilen, nrow, name, mem_path) diff --git a/src/Utilities/PackageBudget.f90 b/src/Utilities/PackageBudget.f90 index 93f1f5b2c6b..c6485cd904b 100644 --- a/src/Utilities/PackageBudget.f90 +++ b/src/Utilities/PackageBudget.f90 @@ -119,10 +119,20 @@ end subroutine set_auxname !! GWF Package members stored in BndType. !! !< - subroutine set_pointers(this, flowvarname, mem_path_target) + subroutine set_pointers(this, flowvarname, mem_path_target, input_mempath) + use ConstantsModule, only: LENVARNAME class(PackageBudgetType) :: this !< PackageBudgetType object character(len=*), intent(in) :: flowvarname !< name of variable storing flow (SIMVALS, SIMTOMVR) character(len=*), intent(in) :: mem_path_target !< path where target variable is stored + character(len=*), intent(in) :: input_mempath + character(len=LENVARNAME) :: auxvarname + ! + ! -- set memory manager aux varname + if (input_mempath /= '') then + auxvarname = 'AUXVAR_IDM' + else + auxvarname = 'AUXVAR' + end if ! ! -- Reassign pointers to variables in the flow model call mem_reassignptr(this%nbound, 'NBOUND', this%memoryPath, & @@ -132,7 +142,8 @@ subroutine set_pointers(this, flowvarname, mem_path_target) call mem_reassignptr(this%flow, 'FLOW', this%memoryPath, & flowvarname, mem_path_target) call mem_reassignptr(this%auxvar, 'AUXVAR', this%memoryPath, & - 'AUXVAR', mem_path_target) + auxvarname, mem_path_target) + ! return end subroutine set_pointers diff --git a/src/meson.build b/src/meson.build index 232e58c7bcc..dd170a1ae59 100644 --- a/src/meson.build +++ b/src/meson.build @@ -50,6 +50,7 @@ modflow_sources = files( 'Model' / 'GroundWaterFlow' / 'gwf3api8.f90', 'Model' / 'GroundWaterFlow' / 'gwf3buy8.f90', 'Model' / 'GroundWaterFlow' / 'gwf3chd8.f90', + 'Model' / 'GroundWaterFlow' / 'gwf3chd8idm.f90', 'Model' / 'GroundWaterFlow' / 'gwf3csub8.f90', 'Model' / 'GroundWaterFlow' / 'gwf3dis8.f90', 'Model' / 'GroundWaterFlow' / 'gwf3dis8idm.f90', @@ -104,6 +105,7 @@ modflow_sources = files( 'Model' / 'GroundWaterTransport' / 'gwt1ssm1.f90', 'Model' / 'GroundWaterTransport' / 'gwt1uzt1.f90', 'Model' / 'ModelUtilities' / 'BoundaryPackage.f90', + 'Model' / 'ModelUtilities' / 'BoundaryPackageExt.f90', 'Model' / 'ModelUtilities' / 'Connections.f90', 'Model' / 'ModelUtilities' / 'DiscretizationBase.f90', 'Model' / 'ModelUtilities' / 'DisvGeom.f90', diff --git a/utils/idmloader/scripts/dfn2f90.py b/utils/idmloader/scripts/dfn2f90.py index 3e8e063e04e..9799280b03e 100644 --- a/utils/idmloader/scripts/dfn2f90.py +++ b/utils/idmloader/scripts/dfn2f90.py @@ -968,6 +968,10 @@ def _write_master_component(self, fh=None): dfns = [ # ** Add a new dfn parameter set to MODFLOW 6 by adding a new entry to this list ** # [relative path of input dnf, relative path of output f90 definition file] + [ + Path("../../../doc/mf6io/mf6ivar/dfn", "gwf-chd.dfn"), + Path("../../../src/Model/GroundWaterFlow", "gwf3chd8idm.f90"), + ], [ Path("../../../doc/mf6io/mf6ivar/dfn", "gwf-dis.dfn"), Path("../../../src/Model/GroundWaterFlow", "gwf3dis8idm.f90"),