diff --git a/make/makefile b/make/makefile index d7d5d3cef71..97c4928de57 100644 --- a/make/makefile +++ b/make/makefile @@ -1,41 +1,41 @@ -# makefile created by pymake (version 1.2.7) for the 'mf6' executable. +# makefile created by pymake (version 1.2.9.dev0) for the 'mf6' executable. include ./makedefaults # Define the source file directories SOURCEDIR1=../src -SOURCEDIR2=../src/Distributed -SOURCEDIR3=../src/Exchange +SOURCEDIR2=../src/Exchange +SOURCEDIR3=../src/Timing SOURCEDIR4=../src/Model SOURCEDIR5=../src/Model/Connection -SOURCEDIR6=../src/Model/Geometry -SOURCEDIR7=../src/Model/GroundWaterEnergy -SOURCEDIR8=../src/Model/GroundWaterFlow -SOURCEDIR9=../src/Model/GroundWaterTransport -SOURCEDIR10=../src/Model/ModelUtilities -SOURCEDIR11=../src/Model/TransportModel +SOURCEDIR6=../src/Model/ModelUtilities +SOURCEDIR7=../src/Model/GroundWaterFlow +SOURCEDIR8=../src/Model/Geometry +SOURCEDIR9=../src/Model/TransportModel +SOURCEDIR10=../src/Model/GroundWaterTransport +SOURCEDIR11=../src/Model/GroundWaterEnergy SOURCEDIR12=../src/Solution SOURCEDIR13=../src/Solution/LinearMethods SOURCEDIR14=../src/Solution/PETSc -SOURCEDIR15=../src/Timing +SOURCEDIR15=../src/Distributed SOURCEDIR16=../src/Utilities -SOURCEDIR17=../src/Utilities/ArrayRead +SOURCEDIR17=../src/Utilities/TimeSeries SOURCEDIR18=../src/Utilities/Idm -SOURCEDIR19=../src/Utilities/Idm/mf6blockfile -SOURCEDIR20=../src/Utilities/Idm/selector -SOURCEDIR21=../src/Utilities/Libraries -SOURCEDIR22=../src/Utilities/Libraries/blas -SOURCEDIR23=../src/Utilities/Libraries/daglib -SOURCEDIR24=../src/Utilities/Libraries/rcm -SOURCEDIR25=../src/Utilities/Libraries/sparsekit -SOURCEDIR26=../src/Utilities/Libraries/sparskit2 -SOURCEDIR27=../src/Utilities/Matrix -SOURCEDIR28=../src/Utilities/Memory -SOURCEDIR29=../src/Utilities/Observation -SOURCEDIR30=../src/Utilities/OutputControl -SOURCEDIR31=../src/Utilities/TimeSeries -SOURCEDIR32=../src/Utilities/Vector +SOURCEDIR19=../src/Utilities/Idm/selector +SOURCEDIR20=../src/Utilities/Idm/mf6blockfile +SOURCEDIR21=../src/Utilities/ArrayRead +SOURCEDIR22=../src/Utilities/Memory +SOURCEDIR23=../src/Utilities/Matrix +SOURCEDIR24=../src/Utilities/Vector +SOURCEDIR25=../src/Utilities/Observation +SOURCEDIR26=../src/Utilities/OutputControl +SOURCEDIR27=../src/Utilities/Libraries +SOURCEDIR28=../src/Utilities/Libraries/rcm +SOURCEDIR29=../src/Utilities/Libraries/sparskit2 +SOURCEDIR30=../src/Utilities/Libraries/sparsekit +SOURCEDIR31=../src/Utilities/Libraries/blas +SOURCEDIR32=../src/Utilities/Libraries/daglib VPATH = \ ${SOURCEDIR1} \ @@ -207,6 +207,7 @@ $(OBJDIR)/GwfVscInputData.o \ $(OBJDIR)/gwf3ghb8.o \ $(OBJDIR)/gwf3drn8.o \ $(OBJDIR)/IndexMap.o \ +$(OBJDIR)/ArrayReaderBase.o \ $(OBJDIR)/VirtualModel.o \ $(OBJDIR)/BaseExchange.o \ $(OBJDIR)/tsp1fmi1.o \ @@ -224,7 +225,7 @@ $(OBJDIR)/InterfaceMap.o \ $(OBJDIR)/SeqVector.o \ $(OBJDIR)/ImsLinearSettings.o \ $(OBJDIR)/ConvergenceSummary.o \ -$(OBJDIR)/ArrayReaderBase.o \ +$(OBJDIR)/Integer2dReader.o \ $(OBJDIR)/CellWithNbrs.o \ $(OBJDIR)/NumericalExchange.o \ $(OBJDIR)/tsp1ssm1.o \ @@ -251,9 +252,13 @@ $(OBJDIR)/VirtualSolution.o \ $(OBJDIR)/SparseMatrix.o \ $(OBJDIR)/LinearSolverBase.o \ $(OBJDIR)/ims8reordering.o \ +$(OBJDIR)/StructVector.o \ $(OBJDIR)/ModflowInput.o \ $(OBJDIR)/IdmLogger.o \ -$(OBJDIR)/Integer2dReader.o \ +$(OBJDIR)/DefinitionSelect.o \ +$(OBJDIR)/Integer1dReader.o \ +$(OBJDIR)/Double2dReader.o \ +$(OBJDIR)/Double1dReader.o \ $(OBJDIR)/VirtualExchange.o \ $(OBJDIR)/GridSorting.o \ $(OBJDIR)/DisConnExchange.o \ @@ -291,12 +296,9 @@ $(OBJDIR)/gwe1cnd1.o \ $(OBJDIR)/RouterBase.o \ $(OBJDIR)/ImsLinearSolver.o \ $(OBJDIR)/ims8base.o \ -$(OBJDIR)/StructVector.o \ -$(OBJDIR)/DefinitionSelect.o \ +$(OBJDIR)/StructArray.o \ +$(OBJDIR)/LayeredArrayReader.o \ $(OBJDIR)/InputLoadType.o \ -$(OBJDIR)/Integer1dReader.o \ -$(OBJDIR)/Double2dReader.o \ -$(OBJDIR)/Double1dReader.o \ $(OBJDIR)/GridConnection.o \ $(OBJDIR)/DistributedVariable.o \ $(OBJDIR)/gwt1.o \ @@ -308,10 +310,10 @@ $(OBJDIR)/Timer.o \ $(OBJDIR)/LinearSolverFactory.o \ $(OBJDIR)/ims8linear.o \ $(OBJDIR)/BaseSolution.o \ -$(OBJDIR)/StructArray.o \ +$(OBJDIR)/LoadMf6File.o \ +$(OBJDIR)/DynamicParamFilter.o \ $(OBJDIR)/BoundInputContext.o \ $(OBJDIR)/AsciiInputLoadType.o \ -$(OBJDIR)/LayeredArrayReader.o \ $(OBJDIR)/ExplicitModel.o \ $(OBJDIR)/SpatialModelConnection.o \ $(OBJDIR)/GwtInterfaceModel.o \ @@ -323,9 +325,8 @@ $(OBJDIR)/GweGweExchange.o \ $(OBJDIR)/RouterFactory.o \ $(OBJDIR)/NumericalSolution.o \ $(OBJDIR)/MappedMemory.o \ -$(OBJDIR)/StressListInput.o \ -$(OBJDIR)/StressGridInput.o \ -$(OBJDIR)/LoadMf6File.o \ +$(OBJDIR)/Mf6FileListInput.o \ +$(OBJDIR)/Mf6FileGridInput.o \ $(OBJDIR)/ExplicitSolution.o \ $(OBJDIR)/GwtGwtConnection.o \ $(OBJDIR)/GwfGwfConnection.o \ diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index b9cbf1a7366..e0ddcbb959d 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -328,8 +328,8 @@ - - + + @@ -341,6 +341,7 @@ + diff --git a/src/Exchange/gwegweidm.f90 b/src/Exchange/gwegweidm.f90 index 588078857a2..21ccdf031f1 100644 --- a/src/Exchange/gwegweidm.f90 +++ b/src/Exchange/gwegweidm.f90 @@ -9,6 +9,8 @@ module ExgGwegweInputModule public exg_gwegwe_block_definitions public ExgGwegweParamFoundType public exg_gwegwe_multi_package + public exg_gwegwe_advanced_package + public exg_gwegwe_subpackages type ExgGwegweParamFoundType logical :: gwfmodelname1 = .false. @@ -41,6 +43,13 @@ module ExgGwegweInputModule end type ExgGwegweParamFoundType logical :: exg_gwegwe_multi_package = .true. + logical :: exg_gwegwe_advanced_package = .false. + + character(len=16), parameter :: & + exg_gwegwe_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & exggwegwe_gwfmodelname1 = InputParamDefinitionType & @@ -563,19 +572,22 @@ module ExgGwegweInputModule 'OPTIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'DIMENSIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'EXCHANGEDATA', & ! blockname .true., & ! required .true., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/src/Exchange/gwfgweidm.f90 b/src/Exchange/gwfgweidm.f90 index bc69319b14c..12c647b3990 100644 --- a/src/Exchange/gwfgweidm.f90 +++ b/src/Exchange/gwfgweidm.f90 @@ -9,11 +9,20 @@ module ExgGwfgweInputModule public exg_gwfgwe_block_definitions public ExgGwfgweParamFoundType public exg_gwfgwe_multi_package + public exg_gwfgwe_advanced_package + public exg_gwfgwe_subpackages type ExgGwfgweParamFoundType end type ExgGwfgweParamFoundType logical :: exg_gwfgwe_multi_package = .false. + logical :: exg_gwfgwe_advanced_package = .false. + + character(len=16), parameter :: & + exg_gwfgwe_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & exg_gwfgwe_param_definitions(*) = & diff --git a/src/Exchange/gwfgwfidm.f90 b/src/Exchange/gwfgwfidm.f90 index 888f6422cb1..277e5ba0351 100644 --- a/src/Exchange/gwfgwfidm.f90 +++ b/src/Exchange/gwfgwfidm.f90 @@ -9,6 +9,8 @@ module ExgGwfgwfInputModule public exg_gwfgwf_block_definitions public ExgGwfgwfParamFoundType public exg_gwfgwf_multi_package + public exg_gwfgwf_advanced_package + public exg_gwfgwf_subpackages type ExgGwfgwfParamFoundType logical :: auxiliary = .false. @@ -45,6 +47,13 @@ module ExgGwfgwfInputModule end type ExgGwfgwfParamFoundType logical :: exg_gwfgwf_multi_package = .true. + logical :: exg_gwfgwf_advanced_package = .false. + + character(len=16), parameter :: & + exg_gwfgwf_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & exggwfgwf_auxiliary = InputParamDefinitionType & @@ -639,19 +648,22 @@ module ExgGwfgwfInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'DIMENSIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'EXCHANGEDATA', & ! blockname .true., & ! required .true., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/src/Exchange/gwfgwtidm.f90 b/src/Exchange/gwfgwtidm.f90 index 30374514be3..c7e4fc9b491 100644 --- a/src/Exchange/gwfgwtidm.f90 +++ b/src/Exchange/gwfgwtidm.f90 @@ -9,11 +9,20 @@ module ExgGwfgwtInputModule public exg_gwfgwt_block_definitions public ExgGwfgwtParamFoundType public exg_gwfgwt_multi_package + public exg_gwfgwt_advanced_package + public exg_gwfgwt_subpackages type ExgGwfgwtParamFoundType end type ExgGwfgwtParamFoundType logical :: exg_gwfgwt_multi_package = .false. + logical :: exg_gwfgwt_advanced_package = .false. + + character(len=16), parameter :: & + exg_gwfgwt_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & exg_gwfgwt_param_definitions(*) = & diff --git a/src/Exchange/gwtgwtidm.f90 b/src/Exchange/gwtgwtidm.f90 index dba0074ce73..ecd8fc887a1 100644 --- a/src/Exchange/gwtgwtidm.f90 +++ b/src/Exchange/gwtgwtidm.f90 @@ -9,6 +9,8 @@ module ExgGwtgwtInputModule public exg_gwtgwt_block_definitions public ExgGwtgwtParamFoundType public exg_gwtgwt_multi_package + public exg_gwtgwt_advanced_package + public exg_gwtgwt_subpackages type ExgGwtgwtParamFoundType logical :: gwfmodelname1 = .false. @@ -41,6 +43,13 @@ module ExgGwtgwtInputModule end type ExgGwtgwtParamFoundType logical :: exg_gwtgwt_multi_package = .true. + logical :: exg_gwtgwt_advanced_package = .false. + + character(len=16), parameter :: & + exg_gwtgwt_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & exggwtgwt_gwfmodelname1 = InputParamDefinitionType & @@ -563,19 +572,22 @@ module ExgGwtgwtInputModule 'OPTIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'DIMENSIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'EXCHANGEDATA', & ! blockname .true., & ! required .true., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterEnergy/gwe1cnd1.f90 b/src/Model/GroundWaterEnergy/gwe1cnd1.f90 index f3a1646ef55..59c1e25314d 100644 --- a/src/Model/GroundWaterEnergy/gwe1cnd1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1cnd1.f90 @@ -669,11 +669,13 @@ subroutine source_griddata(this) call mem_reassignptr(this%atv, 'ATV', trim(this%memoryPath), & 'ATH2', trim(this%memoryPath)) else - call mem_reallocate(this%alh, 0, 'ALH', trim(this%memoryPath)) - call mem_reallocate(this%alv, 0, 'ALV', trim(this%memoryPath)) - call mem_reallocate(this%ath1, 0, 'ATH1', trim(this%memoryPath)) - call mem_reallocate(this%ath2, 0, 'ATH2', trim(this%memoryPath)) - call mem_reallocate(this%atv, 0, 'ATV', trim(this%memoryPath)) + call mem_reallocate(this%alh, 0, 'ALH', trim(this%memoryPath), copy=.FALSE.) + call mem_reallocate(this%alv, 0, 'ALV', trim(this%memoryPath), copy=.FALSE.) + call mem_reallocate(this%ath1, 0, 'ATH1', trim(this%memoryPath), & + copy=.FALSE.) + call mem_reallocate(this%ath2, 0, 'ATH2', trim(this%memoryPath), & + copy=.FALSE.) + call mem_reallocate(this%atv, 0, 'ATV', trim(this%memoryPath), copy=.FALSE.) end if ! ! -- log griddata diff --git a/src/Model/GroundWaterEnergy/gwe1cnd1idm.f90 b/src/Model/GroundWaterEnergy/gwe1cnd1idm.f90 index 9757a46bcc1..4e9b04cc61a 100644 --- a/src/Model/GroundWaterEnergy/gwe1cnd1idm.f90 +++ b/src/Model/GroundWaterEnergy/gwe1cnd1idm.f90 @@ -9,6 +9,8 @@ module GweCndInputModule public gwe_cnd_block_definitions public GweCndParamFoundType public gwe_cnd_multi_package + public gwe_cnd_advanced_package + public gwe_cnd_subpackages type GweCndParamFoundType logical :: xt3d_off = .false. @@ -23,6 +25,13 @@ module GweCndInputModule end type GweCndParamFoundType logical :: gwe_cnd_multi_package = .false. + logical :: gwe_cnd_advanced_package = .false. + + character(len=16), parameter :: & + gwe_cnd_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwecnd_xt3d_off = InputParamDefinitionType & @@ -218,13 +227,15 @@ module GweCndInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'GRIDDATA', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterEnergy/gwe1ctp1idm.f90 b/src/Model/GroundWaterEnergy/gwe1ctp1idm.f90 index 3b2ca0a2889..a6e0e01244c 100644 --- a/src/Model/GroundWaterEnergy/gwe1ctp1idm.f90 +++ b/src/Model/GroundWaterEnergy/gwe1ctp1idm.f90 @@ -9,6 +9,8 @@ module GweCtpInputModule public gwe_ctp_block_definitions public GweCtpParamFoundType public gwe_ctp_multi_package + public gwe_ctp_advanced_package + public gwe_ctp_subpackages type GweCtpParamFoundType logical :: auxiliary = .false. @@ -32,6 +34,13 @@ module GweCtpInputModule end type GweCtpParamFoundType logical :: gwe_ctp_multi_package = .true. + logical :: gwe_ctp_advanced_package = .false. + + character(len=16), parameter :: & + gwe_ctp_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwectp_auxiliary = InputParamDefinitionType & @@ -392,19 +401,22 @@ module GweCtpInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'DIMENSIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'PERIOD', & ! blockname .true., & ! required .true., & ! aggregate - .true. & ! block_variable + .true., & ! block_variable + .true. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterEnergy/gwe1dis1idm.f90 b/src/Model/GroundWaterEnergy/gwe1dis1idm.f90 index cda16809731..f9650b8ab98 100644 --- a/src/Model/GroundWaterEnergy/gwe1dis1idm.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dis1idm.f90 @@ -9,6 +9,8 @@ module GweDisInputModule public gwe_dis_block_definitions public GweDisParamFoundType public gwe_dis_multi_package + public gwe_dis_advanced_package + public gwe_dis_subpackages type GweDisParamFoundType logical :: length_units = .false. @@ -27,6 +29,13 @@ module GweDisInputModule end type GweDisParamFoundType logical :: gwe_dis_multi_package = .false. + logical :: gwe_dis_advanced_package = .false. + + character(len=16), parameter :: & + gwe_dis_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwedis_length_units = InputParamDefinitionType & @@ -294,19 +303,22 @@ module GweDisInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'DIMENSIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'GRIDDATA', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterEnergy/gwe1disu1idm.f90 b/src/Model/GroundWaterEnergy/gwe1disu1idm.f90 index 4e61f3935b2..010c824ed1a 100644 --- a/src/Model/GroundWaterEnergy/gwe1disu1idm.f90 +++ b/src/Model/GroundWaterEnergy/gwe1disu1idm.f90 @@ -9,6 +9,8 @@ module GweDisuInputModule public gwe_disu_block_definitions public GweDisuParamFoundType public gwe_disu_multi_package + public gwe_disu_advanced_package + public gwe_disu_subpackages type GweDisuParamFoundType logical :: length_units = .false. @@ -41,6 +43,13 @@ module GweDisuInputModule end type GweDisuParamFoundType logical :: gwe_disu_multi_package = .false. + logical :: gwe_disu_advanced_package = .false. + + character(len=16), parameter :: & + gwe_disu_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwedisu_length_units = InputParamDefinitionType & @@ -581,37 +590,43 @@ module GweDisuInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'DIMENSIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'GRIDDATA', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'CONNECTIONDATA', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'VERTICES', & ! blockname .true., & ! required .true., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'CELL2D', & ! blockname .true., & ! required .true., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterEnergy/gwe1disv1idm.f90 b/src/Model/GroundWaterEnergy/gwe1disv1idm.f90 index e109482271f..43f10be6c82 100644 --- a/src/Model/GroundWaterEnergy/gwe1disv1idm.f90 +++ b/src/Model/GroundWaterEnergy/gwe1disv1idm.f90 @@ -9,6 +9,8 @@ module GweDisvInputModule public gwe_disv_block_definitions public GweDisvParamFoundType public gwe_disv_multi_package + public gwe_disv_advanced_package + public gwe_disv_subpackages type GweDisvParamFoundType logical :: length_units = .false. @@ -33,6 +35,13 @@ module GweDisvInputModule end type GweDisvParamFoundType logical :: gwe_disv_multi_package = .false. + logical :: gwe_disv_advanced_package = .false. + + character(len=16), parameter :: & + gwe_disv_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwedisv_length_units = InputParamDefinitionType & @@ -429,31 +438,36 @@ module GweDisvInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'DIMENSIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'GRIDDATA', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'VERTICES', & ! blockname .true., & ! required .true., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'CELL2D', & ! blockname .true., & ! required .true., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterEnergy/gwe1ic1idm.f90 b/src/Model/GroundWaterEnergy/gwe1ic1idm.f90 index 95dd79e256d..c33f1df14f2 100644 --- a/src/Model/GroundWaterEnergy/gwe1ic1idm.f90 +++ b/src/Model/GroundWaterEnergy/gwe1ic1idm.f90 @@ -9,12 +9,21 @@ module GweIcInputModule public gwe_ic_block_definitions public GweIcParamFoundType public gwe_ic_multi_package + public gwe_ic_advanced_package + public gwe_ic_subpackages type GweIcParamFoundType logical :: strt = .false. end type GweIcParamFoundType logical :: gwe_ic_multi_package = .false. + logical :: gwe_ic_advanced_package = .false. + + character(len=16), parameter :: & + gwe_ic_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gweic_strt = InputParamDefinitionType & @@ -66,13 +75,15 @@ module GweIcInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'GRIDDATA', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterEnergy/gwe1idm.f90 b/src/Model/GroundWaterEnergy/gwe1idm.f90 index 14d85843018..77b9e731928 100644 --- a/src/Model/GroundWaterEnergy/gwe1idm.f90 +++ b/src/Model/GroundWaterEnergy/gwe1idm.f90 @@ -9,6 +9,8 @@ module GweNamInputModule public gwe_nam_block_definitions public GweNamParamFoundType public gwe_nam_multi_package + public gwe_nam_advanced_package + public gwe_nam_subpackages type GweNamParamFoundType logical :: list = .false. @@ -21,6 +23,13 @@ module GweNamInputModule end type GweNamParamFoundType logical :: gwe_nam_multi_package = .false. + logical :: gwe_nam_advanced_package = .false. + + character(len=16), parameter :: & + gwe_nam_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwenam_list = InputParamDefinitionType & @@ -183,13 +192,15 @@ module GweNamInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'PACKAGES', & ! blockname .true., & ! required .true., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterFlow/gwf3chd8idm.f90 b/src/Model/GroundWaterFlow/gwf3chd8idm.f90 index 78f5c565e44..39074014f55 100644 --- a/src/Model/GroundWaterFlow/gwf3chd8idm.f90 +++ b/src/Model/GroundWaterFlow/gwf3chd8idm.f90 @@ -9,6 +9,8 @@ module GwfChdInputModule public gwf_chd_block_definitions public GwfChdParamFoundType public gwf_chd_multi_package + public gwf_chd_advanced_package + public gwf_chd_subpackages type GwfChdParamFoundType logical :: auxiliary = .false. @@ -33,6 +35,13 @@ module GwfChdInputModule end type GwfChdParamFoundType logical :: gwf_chd_multi_package = .true. + logical :: gwf_chd_advanced_package = .false. + + character(len=16), parameter :: & + gwf_chd_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwfchd_auxiliary = InputParamDefinitionType & @@ -411,19 +420,22 @@ module GwfChdInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'DIMENSIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'PERIOD', & ! blockname .true., & ! required .true., & ! aggregate - .true. & ! block_variable + .true., & ! block_variable + .true. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterFlow/gwf3dis8idm.f90 b/src/Model/GroundWaterFlow/gwf3dis8idm.f90 index 35a4db3f326..7b201edb992 100644 --- a/src/Model/GroundWaterFlow/gwf3dis8idm.f90 +++ b/src/Model/GroundWaterFlow/gwf3dis8idm.f90 @@ -9,6 +9,8 @@ module GwfDisInputModule public gwf_dis_block_definitions public GwfDisParamFoundType public gwf_dis_multi_package + public gwf_dis_advanced_package + public gwf_dis_subpackages type GwfDisParamFoundType logical :: length_units = .false. @@ -27,6 +29,13 @@ module GwfDisInputModule end type GwfDisParamFoundType logical :: gwf_dis_multi_package = .false. + logical :: gwf_dis_advanced_package = .false. + + character(len=16), parameter :: & + gwf_dis_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwfdis_length_units = InputParamDefinitionType & @@ -294,19 +303,22 @@ module GwfDisInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'DIMENSIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'GRIDDATA', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterFlow/gwf3disu8.f90 b/src/Model/GroundWaterFlow/gwf3disu8.f90 index e5ee2aaac74..21903aac8a1 100644 --- a/src/Model/GroundWaterFlow/gwf3disu8.f90 +++ b/src/Model/GroundWaterFlow/gwf3disu8.f90 @@ -255,8 +255,8 @@ subroutine grid_finalize(this) this%yc(noder) = this%cellxy(2, node) end do else - call mem_reallocate(this%xc, 0, 'XC', this%memoryPath) - call mem_reallocate(this%yc, 0, 'YC', this%memoryPath) + call mem_reallocate(this%xc, 0, 'XC', this%memoryPath, copy=.FALSE.) + call mem_reallocate(this%yc, 0, 'YC', this%memoryPath, copy=.FALSE.) end if ! ! -- create and fill the connections object diff --git a/src/Model/GroundWaterFlow/gwf3disu8idm.f90 b/src/Model/GroundWaterFlow/gwf3disu8idm.f90 index 7f09d38be19..6b24ef7b644 100644 --- a/src/Model/GroundWaterFlow/gwf3disu8idm.f90 +++ b/src/Model/GroundWaterFlow/gwf3disu8idm.f90 @@ -9,6 +9,8 @@ module GwfDisuInputModule public gwf_disu_block_definitions public GwfDisuParamFoundType public gwf_disu_multi_package + public gwf_disu_advanced_package + public gwf_disu_subpackages type GwfDisuParamFoundType logical :: length_units = .false. @@ -41,6 +43,13 @@ module GwfDisuInputModule end type GwfDisuParamFoundType logical :: gwf_disu_multi_package = .false. + logical :: gwf_disu_advanced_package = .false. + + character(len=16), parameter :: & + gwf_disu_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwfdisu_length_units = InputParamDefinitionType & @@ -581,37 +590,43 @@ module GwfDisuInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'DIMENSIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'GRIDDATA', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'CONNECTIONDATA', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'VERTICES', & ! blockname .false., & ! required .true., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'CELL2D', & ! blockname .false., & ! required .true., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterFlow/gwf3disv8idm.f90 b/src/Model/GroundWaterFlow/gwf3disv8idm.f90 index 657d138186f..313bbba99a7 100644 --- a/src/Model/GroundWaterFlow/gwf3disv8idm.f90 +++ b/src/Model/GroundWaterFlow/gwf3disv8idm.f90 @@ -9,6 +9,8 @@ module GwfDisvInputModule public gwf_disv_block_definitions public GwfDisvParamFoundType public gwf_disv_multi_package + public gwf_disv_advanced_package + public gwf_disv_subpackages type GwfDisvParamFoundType logical :: length_units = .false. @@ -33,6 +35,13 @@ module GwfDisvInputModule end type GwfDisvParamFoundType logical :: gwf_disv_multi_package = .false. + logical :: gwf_disv_advanced_package = .false. + + character(len=16), parameter :: & + gwf_disv_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwfdisv_length_units = InputParamDefinitionType & @@ -429,31 +438,36 @@ module GwfDisvInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'DIMENSIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'GRIDDATA', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'VERTICES', & ! blockname .true., & ! required .true., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'CELL2D', & ! blockname .true., & ! required .true., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterFlow/gwf3drn8idm.f90 b/src/Model/GroundWaterFlow/gwf3drn8idm.f90 index ddd87932b4c..dbcf436f26f 100644 --- a/src/Model/GroundWaterFlow/gwf3drn8idm.f90 +++ b/src/Model/GroundWaterFlow/gwf3drn8idm.f90 @@ -9,6 +9,8 @@ module GwfDrnInputModule public gwf_drn_block_definitions public GwfDrnParamFoundType public gwf_drn_multi_package + public gwf_drn_advanced_package + public gwf_drn_subpackages type GwfDrnParamFoundType logical :: auxiliary = .false. @@ -36,6 +38,13 @@ module GwfDrnInputModule end type GwfDrnParamFoundType logical :: gwf_drn_multi_package = .true. + logical :: gwf_drn_advanced_package = .false. + + character(len=16), parameter :: & + gwf_drn_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwfdrn_auxiliary = InputParamDefinitionType & @@ -468,19 +477,22 @@ module GwfDrnInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'DIMENSIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'PERIOD', & ! blockname .true., & ! required .true., & ! aggregate - .true. & ! block_variable + .true., & ! block_variable + .true. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterFlow/gwf3evt8idm.f90 b/src/Model/GroundWaterFlow/gwf3evt8idm.f90 index 9ed6fe5ba12..a43206dae0d 100644 --- a/src/Model/GroundWaterFlow/gwf3evt8idm.f90 +++ b/src/Model/GroundWaterFlow/gwf3evt8idm.f90 @@ -9,6 +9,8 @@ module GwfEvtInputModule public gwf_evt_block_definitions public GwfEvtParamFoundType public gwf_evt_multi_package + public gwf_evt_advanced_package + public gwf_evt_subpackages type GwfEvtParamFoundType logical :: fixed_cell = .false. @@ -40,6 +42,13 @@ module GwfEvtInputModule end type GwfEvtParamFoundType logical :: gwf_evt_multi_package = .true. + logical :: gwf_evt_advanced_package = .false. + + character(len=16), parameter :: & + gwf_evt_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwfevt_fixed_cell = InputParamDefinitionType & @@ -544,19 +553,22 @@ module GwfEvtInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'DIMENSIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'PERIOD', & ! blockname .true., & ! required .true., & ! aggregate - .true. & ! block_variable + .true., & ! block_variable + .true. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterFlow/gwf3evta8idm.f90 b/src/Model/GroundWaterFlow/gwf3evta8idm.f90 index a5f9a6ea56d..688873bfdba 100644 --- a/src/Model/GroundWaterFlow/gwf3evta8idm.f90 +++ b/src/Model/GroundWaterFlow/gwf3evta8idm.f90 @@ -9,6 +9,8 @@ module GwfEvtaInputModule public gwf_evta_block_definitions public GwfEvtaParamFoundType public gwf_evta_multi_package + public gwf_evta_advanced_package + public gwf_evta_subpackages type GwfEvtaParamFoundType logical :: readasarrays = .false. @@ -33,6 +35,13 @@ module GwfEvtaInputModule end type GwfEvtaParamFoundType logical :: gwf_evta_multi_package = .true. + logical :: gwf_evta_advanced_package = .false. + + character(len=16), parameter :: & + gwf_evta_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwfevta_readasarrays = InputParamDefinitionType & @@ -408,13 +417,15 @@ module GwfEvtaInputModule 'OPTIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'PERIOD', & ! blockname .true., & ! required .false., & ! aggregate - .true. & ! block_variable + .true., & ! block_variable + .true. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterFlow/gwf3ghb8idm.f90 b/src/Model/GroundWaterFlow/gwf3ghb8idm.f90 index 2774d26c883..919669ea68f 100644 --- a/src/Model/GroundWaterFlow/gwf3ghb8idm.f90 +++ b/src/Model/GroundWaterFlow/gwf3ghb8idm.f90 @@ -9,6 +9,8 @@ module GwfGhbInputModule public gwf_ghb_block_definitions public GwfGhbParamFoundType public gwf_ghb_multi_package + public gwf_ghb_advanced_package + public gwf_ghb_subpackages type GwfGhbParamFoundType logical :: auxiliary = .false. @@ -34,6 +36,13 @@ module GwfGhbInputModule end type GwfGhbParamFoundType logical :: gwf_ghb_multi_package = .true. + logical :: gwf_ghb_advanced_package = .false. + + character(len=16), parameter :: & + gwf_ghb_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwfghb_auxiliary = InputParamDefinitionType & @@ -430,19 +439,22 @@ module GwfGhbInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'DIMENSIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'PERIOD', & ! blockname .true., & ! required .true., & ! aggregate - .true. & ! block_variable + .true., & ! block_variable + .true. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterFlow/gwf3ic8idm.f90 b/src/Model/GroundWaterFlow/gwf3ic8idm.f90 index f943a35dc98..ce2b411dd63 100644 --- a/src/Model/GroundWaterFlow/gwf3ic8idm.f90 +++ b/src/Model/GroundWaterFlow/gwf3ic8idm.f90 @@ -9,12 +9,21 @@ module GwfIcInputModule public gwf_ic_block_definitions public GwfIcParamFoundType public gwf_ic_multi_package + public gwf_ic_advanced_package + public gwf_ic_subpackages type GwfIcParamFoundType logical :: strt = .false. end type GwfIcParamFoundType logical :: gwf_ic_multi_package = .false. + logical :: gwf_ic_advanced_package = .false. + + character(len=16), parameter :: & + gwf_ic_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwfic_strt = InputParamDefinitionType & @@ -66,13 +75,15 @@ module GwfIcInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'GRIDDATA', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterFlow/gwf3idm.f90 b/src/Model/GroundWaterFlow/gwf3idm.f90 index 8b8acf82eeb..7395efd31e3 100644 --- a/src/Model/GroundWaterFlow/gwf3idm.f90 +++ b/src/Model/GroundWaterFlow/gwf3idm.f90 @@ -9,6 +9,8 @@ module GwfNamInputModule public gwf_nam_block_definitions public GwfNamParamFoundType public gwf_nam_multi_package + public gwf_nam_advanced_package + public gwf_nam_subpackages type GwfNamParamFoundType logical :: list = .false. @@ -24,6 +26,13 @@ module GwfNamInputModule end type GwfNamParamFoundType logical :: gwf_nam_multi_package = .false. + logical :: gwf_nam_advanced_package = .false. + + character(len=16), parameter :: & + gwf_nam_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwfnam_list = InputParamDefinitionType & @@ -240,13 +249,15 @@ module GwfNamInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'PACKAGES', & ! blockname .true., & ! required .true., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterFlow/gwf3npf8.f90 b/src/Model/GroundWaterFlow/gwf3npf8.f90 index e02a183b87c..452661f2da6 100644 --- a/src/Model/GroundWaterFlow/gwf3npf8.f90 +++ b/src/Model/GroundWaterFlow/gwf3npf8.f90 @@ -1696,13 +1696,17 @@ subroutine source_griddata(this) call mem_set_value(this%k22, 'K', this%input_mempath, map, afound(2)) end if if (.not. found%wetdry) call mem_reallocate(this%wetdry, 1, 'WETDRY', & - trim(this%memoryPath)) + trim(this%memoryPath), & + copy=.FALSE.) if (.not. found%angle1 .and. this%ixt3d == 0) & - call mem_reallocate(this%angle1, 0, 'ANGLE1', trim(this%memoryPath)) + call mem_reallocate(this%angle1, 0, 'ANGLE1', trim(this%memoryPath), & + copy=.FALSE.) if (.not. found%angle2 .and. this%ixt3d == 0) & - call mem_reallocate(this%angle2, 0, 'ANGLE2', trim(this%memoryPath)) + call mem_reallocate(this%angle2, 0, 'ANGLE2', trim(this%memoryPath), & + copy=.FALSE.) if (.not. found%angle3 .and. this%ixt3d == 0) & - call mem_reallocate(this%angle3, 0, 'ANGLE3', trim(this%memoryPath)) + call mem_reallocate(this%angle3, 0, 'ANGLE3', trim(this%memoryPath), & + copy=.FALSE.) ! ! -- log griddata if (this%iout > 0) then diff --git a/src/Model/GroundWaterFlow/gwf3npf8idm.f90 b/src/Model/GroundWaterFlow/gwf3npf8idm.f90 index b4e7f4e7ac2..2e728489c71 100644 --- a/src/Model/GroundWaterFlow/gwf3npf8idm.f90 +++ b/src/Model/GroundWaterFlow/gwf3npf8idm.f90 @@ -9,6 +9,8 @@ module GwfNpfInputModule public gwf_npf_block_definitions public GwfNpfParamFoundType public gwf_npf_multi_package + public gwf_npf_advanced_package + public gwf_npf_subpackages type GwfNpfParamFoundType logical :: ipakcb = .false. @@ -51,6 +53,13 @@ module GwfNpfInputModule end type GwfNpfParamFoundType logical :: gwf_npf_multi_package = .false. + logical :: gwf_npf_advanced_package = .false. + + character(len=16), parameter :: & + gwf_npf_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwfnpf_ipakcb = InputParamDefinitionType & @@ -750,13 +759,15 @@ module GwfNpfInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'GRIDDATA', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterFlow/gwf3rch8idm.f90 b/src/Model/GroundWaterFlow/gwf3rch8idm.f90 index a39fff2acda..88deaead850 100644 --- a/src/Model/GroundWaterFlow/gwf3rch8idm.f90 +++ b/src/Model/GroundWaterFlow/gwf3rch8idm.f90 @@ -9,6 +9,8 @@ module GwfRchInputModule public gwf_rch_block_definitions public GwfRchParamFoundType public gwf_rch_multi_package + public gwf_rch_advanced_package + public gwf_rch_subpackages type GwfRchParamFoundType logical :: fixed_cell = .false. @@ -33,6 +35,13 @@ module GwfRchInputModule end type GwfRchParamFoundType logical :: gwf_rch_multi_package = .true. + logical :: gwf_rch_advanced_package = .false. + + character(len=16), parameter :: & + gwf_rch_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwfrch_fixed_cell = InputParamDefinitionType & @@ -411,19 +420,22 @@ module GwfRchInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'DIMENSIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'PERIOD', & ! blockname .true., & ! required .true., & ! aggregate - .true. & ! block_variable + .true., & ! block_variable + .true. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterFlow/gwf3rcha8idm.f90 b/src/Model/GroundWaterFlow/gwf3rcha8idm.f90 index d692d12ee29..c4723e896b2 100644 --- a/src/Model/GroundWaterFlow/gwf3rcha8idm.f90 +++ b/src/Model/GroundWaterFlow/gwf3rcha8idm.f90 @@ -9,6 +9,8 @@ module GwfRchaInputModule public gwf_rcha_block_definitions public GwfRchaParamFoundType public gwf_rcha_multi_package + public gwf_rcha_advanced_package + public gwf_rcha_subpackages type GwfRchaParamFoundType logical :: readasarrays = .false. @@ -31,6 +33,13 @@ module GwfRchaInputModule end type GwfRchaParamFoundType logical :: gwf_rcha_multi_package = .true. + logical :: gwf_rcha_advanced_package = .false. + + character(len=16), parameter :: & + gwf_rcha_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwfrcha_readasarrays = InputParamDefinitionType & @@ -370,13 +379,15 @@ module GwfRchaInputModule 'OPTIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'PERIOD', & ! blockname .true., & ! required .false., & ! aggregate - .true. & ! block_variable + .true., & ! block_variable + .true. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterFlow/gwf3riv8idm.f90 b/src/Model/GroundWaterFlow/gwf3riv8idm.f90 index b32255ad30f..50ae09b0523 100644 --- a/src/Model/GroundWaterFlow/gwf3riv8idm.f90 +++ b/src/Model/GroundWaterFlow/gwf3riv8idm.f90 @@ -9,6 +9,8 @@ module GwfRivInputModule public gwf_riv_block_definitions public GwfRivParamFoundType public gwf_riv_multi_package + public gwf_riv_advanced_package + public gwf_riv_subpackages type GwfRivParamFoundType logical :: auxiliary = .false. @@ -35,6 +37,13 @@ module GwfRivInputModule end type GwfRivParamFoundType logical :: gwf_riv_multi_package = .true. + logical :: gwf_riv_advanced_package = .false. + + character(len=16), parameter :: & + gwf_riv_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwfriv_auxiliary = InputParamDefinitionType & @@ -449,19 +458,22 @@ module GwfRivInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'DIMENSIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'PERIOD', & ! blockname .true., & ! required .true., & ! aggregate - .true. & ! block_variable + .true., & ! block_variable + .true. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterFlow/gwf3wel8idm.f90 b/src/Model/GroundWaterFlow/gwf3wel8idm.f90 index 5b3b6b68d2f..f816ad8a55e 100644 --- a/src/Model/GroundWaterFlow/gwf3wel8idm.f90 +++ b/src/Model/GroundWaterFlow/gwf3wel8idm.f90 @@ -9,6 +9,8 @@ module GwfWelInputModule public gwf_wel_block_definitions public GwfWelParamFoundType public gwf_wel_multi_package + public gwf_wel_advanced_package + public gwf_wel_subpackages type GwfWelParamFoundType logical :: auxiliary = .false. @@ -38,6 +40,13 @@ module GwfWelInputModule end type GwfWelParamFoundType logical :: gwf_wel_multi_package = .true. + logical :: gwf_wel_advanced_package = .false. + + character(len=16), parameter :: & + gwf_wel_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwfwel_auxiliary = InputParamDefinitionType & @@ -506,19 +515,22 @@ module GwfWelInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'DIMENSIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'PERIOD', & ! blockname .true., & ! required .true., & ! aggregate - .true. & ! block_variable + .true., & ! block_variable + .true. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterTransport/gwt1cnc1idm.f90 b/src/Model/GroundWaterTransport/gwt1cnc1idm.f90 index 2edbab4bfe5..8ec114c9aa9 100644 --- a/src/Model/GroundWaterTransport/gwt1cnc1idm.f90 +++ b/src/Model/GroundWaterTransport/gwt1cnc1idm.f90 @@ -9,6 +9,8 @@ module GwtCncInputModule public gwt_cnc_block_definitions public GwtCncParamFoundType public gwt_cnc_multi_package + public gwt_cnc_advanced_package + public gwt_cnc_subpackages type GwtCncParamFoundType logical :: auxiliary = .false. @@ -32,6 +34,13 @@ module GwtCncInputModule end type GwtCncParamFoundType logical :: gwt_cnc_multi_package = .true. + logical :: gwt_cnc_advanced_package = .false. + + character(len=16), parameter :: & + gwt_cnc_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwtcnc_auxiliary = InputParamDefinitionType & @@ -392,19 +401,22 @@ module GwtCncInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'DIMENSIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'PERIOD', & ! blockname .true., & ! required .true., & ! aggregate - .true. & ! block_variable + .true., & ! block_variable + .true. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterTransport/gwt1dis1idm.f90 b/src/Model/GroundWaterTransport/gwt1dis1idm.f90 index 9a0330c9461..e6da1a7de96 100644 --- a/src/Model/GroundWaterTransport/gwt1dis1idm.f90 +++ b/src/Model/GroundWaterTransport/gwt1dis1idm.f90 @@ -9,6 +9,8 @@ module GwtDisInputModule public gwt_dis_block_definitions public GwtDisParamFoundType public gwt_dis_multi_package + public gwt_dis_advanced_package + public gwt_dis_subpackages type GwtDisParamFoundType logical :: length_units = .false. @@ -27,6 +29,13 @@ module GwtDisInputModule end type GwtDisParamFoundType logical :: gwt_dis_multi_package = .false. + logical :: gwt_dis_advanced_package = .false. + + character(len=16), parameter :: & + gwt_dis_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwtdis_length_units = InputParamDefinitionType & @@ -294,19 +303,22 @@ module GwtDisInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'DIMENSIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'GRIDDATA', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterTransport/gwt1disu1idm.f90 b/src/Model/GroundWaterTransport/gwt1disu1idm.f90 index 9b552f60f11..0ca43cc7afe 100644 --- a/src/Model/GroundWaterTransport/gwt1disu1idm.f90 +++ b/src/Model/GroundWaterTransport/gwt1disu1idm.f90 @@ -9,6 +9,8 @@ module GwtDisuInputModule public gwt_disu_block_definitions public GwtDisuParamFoundType public gwt_disu_multi_package + public gwt_disu_advanced_package + public gwt_disu_subpackages type GwtDisuParamFoundType logical :: length_units = .false. @@ -41,6 +43,13 @@ module GwtDisuInputModule end type GwtDisuParamFoundType logical :: gwt_disu_multi_package = .false. + logical :: gwt_disu_advanced_package = .false. + + character(len=16), parameter :: & + gwt_disu_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwtdisu_length_units = InputParamDefinitionType & @@ -581,37 +590,43 @@ module GwtDisuInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'DIMENSIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'GRIDDATA', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'CONNECTIONDATA', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'VERTICES', & ! blockname .false., & ! required .true., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'CELL2D', & ! blockname .false., & ! required .true., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterTransport/gwt1disv1idm.f90 b/src/Model/GroundWaterTransport/gwt1disv1idm.f90 index 615cc025374..eecbf57dd65 100644 --- a/src/Model/GroundWaterTransport/gwt1disv1idm.f90 +++ b/src/Model/GroundWaterTransport/gwt1disv1idm.f90 @@ -9,6 +9,8 @@ module GwtDisvInputModule public gwt_disv_block_definitions public GwtDisvParamFoundType public gwt_disv_multi_package + public gwt_disv_advanced_package + public gwt_disv_subpackages type GwtDisvParamFoundType logical :: length_units = .false. @@ -33,6 +35,13 @@ module GwtDisvInputModule end type GwtDisvParamFoundType logical :: gwt_disv_multi_package = .false. + logical :: gwt_disv_advanced_package = .false. + + character(len=16), parameter :: & + gwt_disv_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwtdisv_length_units = InputParamDefinitionType & @@ -429,31 +438,36 @@ module GwtDisvInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'DIMENSIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'GRIDDATA', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'VERTICES', & ! blockname .true., & ! required .true., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'CELL2D', & ! blockname .true., & ! required .true., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterTransport/gwt1dsp1.f90 b/src/Model/GroundWaterTransport/gwt1dsp1.f90 index 0cd1f598b55..8e55dfd9859 100644 --- a/src/Model/GroundWaterTransport/gwt1dsp1.f90 +++ b/src/Model/GroundWaterTransport/gwt1dsp1.f90 @@ -627,7 +627,8 @@ subroutine source_griddata(this) ! ! -- reallocate diffc if not found if (.not. found%diffc) then - call mem_reallocate(this%diffc, 0, 'DIFFC', trim(this%memoryPath)) + call mem_reallocate(this%diffc, 0, 'DIFFC', trim(this%memoryPath), & + copy=.FALSE.) end if ! ! -- set this%idisp flag @@ -656,11 +657,13 @@ subroutine source_griddata(this) call mem_reassignptr(this%atv, 'ATV', trim(this%memoryPath), & 'ATH2', trim(this%memoryPath)) else - call mem_reallocate(this%alh, 0, 'ALH', trim(this%memoryPath)) - call mem_reallocate(this%alv, 0, 'ALV', trim(this%memoryPath)) - call mem_reallocate(this%ath1, 0, 'ATH1', trim(this%memoryPath)) - call mem_reallocate(this%ath2, 0, 'ATH2', trim(this%memoryPath)) - call mem_reallocate(this%atv, 0, 'ATV', trim(this%memoryPath)) + call mem_reallocate(this%alh, 0, 'ALH', trim(this%memoryPath), copy=.FALSE.) + call mem_reallocate(this%alv, 0, 'ALV', trim(this%memoryPath), copy=.FALSE.) + call mem_reallocate(this%ath1, 0, 'ATH1', trim(this%memoryPath), & + copy=.FALSE.) + call mem_reallocate(this%ath2, 0, 'ATH2', trim(this%memoryPath), & + copy=.FALSE.) + call mem_reallocate(this%atv, 0, 'ATV', trim(this%memoryPath), copy=.FALSE.) end if ! ! -- log griddata diff --git a/src/Model/GroundWaterTransport/gwt1dsp1idm.f90 b/src/Model/GroundWaterTransport/gwt1dsp1idm.f90 index 8b7a4e74332..d73436412ca 100644 --- a/src/Model/GroundWaterTransport/gwt1dsp1idm.f90 +++ b/src/Model/GroundWaterTransport/gwt1dsp1idm.f90 @@ -9,6 +9,8 @@ module GwtDspInputModule public gwt_dsp_block_definitions public GwtDspParamFoundType public gwt_dsp_multi_package + public gwt_dsp_advanced_package + public gwt_dsp_subpackages type GwtDspParamFoundType logical :: xt3d_off = .false. @@ -22,6 +24,13 @@ module GwtDspInputModule end type GwtDspParamFoundType logical :: gwt_dsp_multi_package = .false. + logical :: gwt_dsp_advanced_package = .false. + + character(len=16), parameter :: & + gwt_dsp_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwtdsp_xt3d_off = InputParamDefinitionType & @@ -199,13 +208,15 @@ module GwtDspInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'GRIDDATA', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterTransport/gwt1ic1idm.f90 b/src/Model/GroundWaterTransport/gwt1ic1idm.f90 index a2fa79f8d63..f6d45ec2adc 100644 --- a/src/Model/GroundWaterTransport/gwt1ic1idm.f90 +++ b/src/Model/GroundWaterTransport/gwt1ic1idm.f90 @@ -9,12 +9,21 @@ module GwtIcInputModule public gwt_ic_block_definitions public GwtIcParamFoundType public gwt_ic_multi_package + public gwt_ic_advanced_package + public gwt_ic_subpackages type GwtIcParamFoundType logical :: strt = .false. end type GwtIcParamFoundType logical :: gwt_ic_multi_package = .false. + logical :: gwt_ic_advanced_package = .false. + + character(len=16), parameter :: & + gwt_ic_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwtic_strt = InputParamDefinitionType & @@ -66,13 +75,15 @@ module GwtIcInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'GRIDDATA', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/src/Model/GroundWaterTransport/gwt1idm.f90 b/src/Model/GroundWaterTransport/gwt1idm.f90 index d2289c5c688..a1e4ee8ecc9 100644 --- a/src/Model/GroundWaterTransport/gwt1idm.f90 +++ b/src/Model/GroundWaterTransport/gwt1idm.f90 @@ -9,6 +9,8 @@ module GwtNamInputModule public gwt_nam_block_definitions public GwtNamParamFoundType public gwt_nam_multi_package + public gwt_nam_advanced_package + public gwt_nam_subpackages type GwtNamParamFoundType logical :: list = .false. @@ -21,6 +23,13 @@ module GwtNamInputModule end type GwtNamParamFoundType logical :: gwt_nam_multi_package = .false. + logical :: gwt_nam_advanced_package = .false. + + character(len=16), parameter :: & + gwt_nam_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & gwtnam_list = InputParamDefinitionType & @@ -183,13 +192,15 @@ module GwtNamInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'PACKAGES', & ! blockname .true., & ! required .true., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/src/Timing/simtdisidm.f90 b/src/Timing/simtdisidm.f90 index e5de3a1787f..fb246360097 100644 --- a/src/Timing/simtdisidm.f90 +++ b/src/Timing/simtdisidm.f90 @@ -9,6 +9,8 @@ module SimTdisInputModule public sim_tdis_block_definitions public SimTdisParamFoundType public sim_tdis_multi_package + public sim_tdis_advanced_package + public sim_tdis_subpackages type SimTdisParamFoundType logical :: time_units = .false. @@ -24,6 +26,13 @@ module SimTdisInputModule end type SimTdisParamFoundType logical :: sim_tdis_multi_package = .false. + logical :: sim_tdis_advanced_package = .false. + + character(len=16), parameter :: & + sim_tdis_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & simtdis_time_units = InputParamDefinitionType & @@ -240,19 +249,22 @@ module SimTdisInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'DIMENSIONS', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'PERIODDATA', & ! blockname .true., & ! required .true., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/src/Utilities/Constants.f90 b/src/Utilities/Constants.f90 index 718a9ae392c..4a6e08df077 100644 --- a/src/Utilities/Constants.f90 +++ b/src/Utilities/Constants.f90 @@ -48,6 +48,7 @@ module ConstantsModule integer(I4B), parameter :: NAMEDBOUNDFLAG = -9 !< named bound flag integer(I4B), parameter :: LENPAKLOC = 34 !< maximum length of a package location integer(I4B), parameter :: IZERO = 0 !< integer constant zero + integer(I4B), parameter :: INODATA = -2147483647 !< integer no data constant integer(I4B), parameter :: IWETLAKE = 10000 !< integer constant for a dry lake integer(I4B), parameter :: MAXADPIT = 100 !< maximum advanced package Newton-Raphson iterations ! diff --git a/src/Utilities/Idm/BoundInputContext.f90 b/src/Utilities/Idm/BoundInputContext.f90 index 2afa3bdf041..d2e45837ad4 100644 --- a/src/Utilities/Idm/BoundInputContext.f90 +++ b/src/Utilities/Idm/BoundInputContext.f90 @@ -7,15 +7,24 @@ module BoundInputContextModule use KindModule, only: DP, I4B, LGP - use ConstantsModule, only: DZERO, IZERO, LENAUXNAME, LENVARNAME, LENBOUNDNAME + use ConstantsModule, only: DZERO, IZERO, LENAUXNAME, & + LENVARNAME, LENBOUNDNAME use SimVariablesModule, only: errmsg use SimModule, only: store_error, store_error_filename use ModflowInputModule, only: ModflowInputType + use InputDefinitionModule, only: InputParamDefinitionType use CharacterStringModule, only: CharacterStringType implicit none private public :: BoundInputContextType + public :: ReadStateVarType + + !> @brief Pointer type for read state variable + !< + type ReadStateVarType + integer, pointer :: invar + end type ReadStateVarType !> @brief derived type for boundary package input context !! @@ -39,20 +48,16 @@ module BoundInputContextModule real(DP), dimension(:, :), pointer, & contiguous :: auxvar => null() !< auxiliary variable array integer(I4B), dimension(:), pointer, contiguous :: mshape => null() !< model shape - character(len=LENVARNAME), dimension(:), allocatable :: filtcols !< list input in scope columns - integer(I4B) :: nfiltcol !< list input number of in scope columns logical(LGP) :: readasarrays !< grid or list based input type(ModflowInputType) :: mf6_input !< description of input contains procedure :: init => bndctx_init procedure :: create_context procedure :: enable - procedure :: bound_params_allocate + procedure :: array_params_create procedure :: param_init - procedure :: allocate_read_state_var procedure :: destroy => bndctx_destroy - procedure :: set_filtered_cols - procedure :: filtered_cols + procedure :: rsv_alloc end type BoundInputContextType contains @@ -73,11 +78,6 @@ subroutine bndctx_init(this, mf6_input, readasarrays) ! -- create the dynamic package input context call this%create_context() ! - ! -- determine in scope list input columns - if (.not. readasarrays) then - call this%set_filtered_cols() - end if - ! ! --return return end subroutine bndctx_init @@ -91,9 +91,12 @@ subroutine create_context(this) use MemoryManagerExtModule, only: mem_set_value ! -- dummy class(BoundInputContextType) :: this - integer(I4B), dimension(:, :), pointer, contiguous :: cellid => null() + integer(I4B), dimension(:, :), pointer, contiguous :: cellid logical(LGP) :: found ! + ! -- initialize + nullify (cellid) + ! ! -- set pointers to defined scalars call mem_setptr(this%naux, 'NAUX', this%mf6_input%mempath) ! @@ -112,7 +115,6 @@ subroutine create_context(this) this%maxbound = 0 this%inamedbound = 0 this%iprpak = 0 - this%nfiltcol = 0 ! ! -- update optional scalars call mem_set_value(this%inamedbound, 'BOUNDNAMES', this%mf6_input%mempath, & @@ -184,102 +186,56 @@ subroutine enable(this) return end subroutine enable - !> @brief allocate a read state variable - !! - !! Create and set a read state variable, e.g. 'INRECHARGE', - !! which are updated per iper load as follows: - !! -1: unset, not in use - !! 0: not read in most recent period block - !! 1: numeric input read in most recent period block - !! 2: time series input read in most recent period block - !! - !< - function allocate_read_state_var(this, mf6varname) result(varname) - ! -- modules - use MemoryManagerModule, only: mem_setptr, mem_allocate - ! -- dummy - class(BoundInputContextType) :: this - character(len=*), intent(in) :: mf6varname - ! -- locals - character(len=LENVARNAME) :: varname - integer(I4B) :: ilen - integer(I4B), pointer :: intvar - character(len=2) :: prefix = 'IN' - ! - ! -- assign first column as the block number - ilen = len_trim(mf6varname) - ! - if (ilen > (LENVARNAME - len(prefix))) then - varname = prefix//mf6varname(1:(LENVARNAME - len(prefix))) - else - varname = prefix//trim(mf6varname) - end if - ! - call mem_allocate(intvar, varname, this%mf6_input%mempath) - intvar = -1 - ! - ! -- return - return - end function allocate_read_state_var - - !> @brief allocate dfn period block parameters + !> @brief allocate dfn array input period block parameters !! !! Currently supports numeric (i.e. array based) params !! !< - subroutine bound_params_allocate(this, sourcename) + subroutine array_params_create(this, params, nparam, input_name) ! -- modules + use ConstantsModule, only: DZERO, IZERO use MemoryManagerModule, only: mem_allocate - use InputDefinitionModule, only: InputParamDefinitionType + use DefinitionSelectModule, only: get_param_definition_type ! -- dummy class(BoundInputContextType) :: this - character(len=*) :: sourcename + character(len=*), dimension(:), allocatable, intent(in) :: params + integer(I4B), intent(in) :: nparam + character(len=*), intent(in) :: input_name + ! -- local type(InputParamDefinitionType), pointer :: idt integer(I4B), dimension(:), pointer, contiguous :: int1d real(DP), dimension(:), pointer, contiguous :: dbl1d real(DP), dimension(:, :), pointer, contiguous :: dbl2d integer(I4B) :: iparam, n, m ! - ! -- list input allocates via structarray - if (.not. this%readasarrays) then - call store_error('Programming error. (IDM) Bound context unsupported & - &list based param allocation.') - call store_error_filename(sourcename) - end if - ! ! -- allocate dfn input params - do iparam = 1, size(this%mf6_input%param_dfns) + do iparam = 1, nparam ! ! -- assign param definition pointer - idt => this%mf6_input%param_dfns(iparam) + idt => get_param_definition_type(this%mf6_input%param_dfns, & + this%mf6_input%component_type, & + this%mf6_input%subcomponent_type, & + 'PERIOD', params(iparam), '') ! if (idt%blockname == 'PERIOD') then - ! - ! allocate based on dfn datatype select case (idt%datatype) case ('INTEGER1D') - ! call mem_allocate(int1d, this%ncpl, idt%mf6varname, & this%mf6_input%mempath) - ! do n = 1, this%ncpl int1d(n) = IZERO end do ! case ('DOUBLE1D') - ! call mem_allocate(dbl1d, this%ncpl, idt%mf6varname, & this%mf6_input%mempath) - ! do n = 1, this%ncpl dbl1d(n) = DZERO end do ! case ('DOUBLE2D') - ! - call mem_allocate(dbl2d, this%naux, this%ncpl, & - idt%mf6varname, this%mf6_input%mempath) - ! + call mem_allocate(dbl2d, this%naux, this%ncpl, idt%mf6varname, & + this%mf6_input%mempath) do m = 1, this%ncpl do n = 1, this%naux dbl2d(n, m) = DZERO @@ -287,56 +243,49 @@ subroutine bound_params_allocate(this, sourcename) end do ! case default - call store_error('Programming error. (IDM) Bound context unsupported & - &data type allocation for param='//trim(idt%tagname)) - call store_error_filename(sourcename) + errmsg = 'IDM unimplemented. BoundInputContext::array_params_create & + &datatype='//trim(idt%datatype) + call store_error(errmsg) + call store_error_filename(input_name) end select - ! end if end do ! - ! -- enable - call this%enable() - ! ! -- return return - end subroutine bound_params_allocate + end subroutine array_params_create - subroutine param_init(this, datatype, varname, mempath, sourcename) + subroutine param_init(this, datatype, varname, input_name) ! -- modules use MemoryManagerModule, only: mem_setptr ! -- dummy class(BoundInputContextType) :: this character(len=*), intent(in) :: datatype character(len=*), intent(in) :: varname - character(len=*), intent(in) :: mempath - character(len=*), intent(in) :: sourcename - ! -- locals + character(len=*), intent(in) :: input_name + ! -- local integer(I4B), dimension(:), pointer, contiguous :: int1d real(DP), dimension(:), pointer, contiguous :: dbl1d real(DP), dimension(:, :), pointer, contiguous :: dbl2d type(CharacterStringType), dimension(:), pointer, & - contiguous :: charstr1d => null() + contiguous :: charstr1d integer(I4B) :: n, m ! select case (datatype) case ('INTEGER1D') - ! - call mem_setptr(int1d, varname, mempath) + call mem_setptr(int1d, varname, this%mf6_input%mempath) do n = 1, this%ncpl int1d(n) = IZERO end do ! case ('DOUBLE1D') - ! - call mem_setptr(dbl1d, varname, mempath) + call mem_setptr(dbl1d, varname, this%mf6_input%mempath) do n = 1, this%ncpl dbl1d(n) = DZERO end do ! case ('DOUBLE2D') - ! - call mem_setptr(dbl2d, varname, mempath) + call mem_setptr(dbl2d, varname, this%mf6_input%mempath) do m = 1, this%ncpl do n = 1, this%naux dbl2d(n, m) = DZERO @@ -344,18 +293,16 @@ subroutine param_init(this, datatype, varname, mempath, sourcename) end do ! case ('CHARSTR1D') - ! - call mem_setptr(charstr1d, varname, mempath) + call mem_setptr(charstr1d, varname, this%mf6_input%mempath) do n = 1, size(charstr1d) charstr1d(n) = '' end do ! case default - ! - call store_error('Programming error. (IDM) Bound context unsupported & - &data type initialization for param='//trim(varname)) - call store_error_filename(sourcename) - ! + errmsg = 'IDM unimplemented. BoundInputContext::param_init & + &datatype='//trim(datatype) + call store_error(errmsg) + call store_error_filename(input_name) end select ! ! -- return @@ -387,175 +334,47 @@ subroutine bndctx_destroy(this) nullify (this%auxvar) nullify (this%mshape) ! - deallocate (this%filtcols) - ! ! --return return end subroutine bndctx_destroy - !> @brief create array of in scope list input columns + !> @brief allocate a read state variable !! - !! Filter the recarray description of list input parameters - !! to determine which columns are to be read in this run. - !< - subroutine set_filtered_cols(this) - ! -- modules - use InputDefinitionModule, only: InputParamDefinitionType - use DefinitionSelectModule, only: get_aggregate_definition_type - use ArrayHandlersModule, only: expandarray - use InputOutputModule, only: parseline - ! -- dummy - class(BoundInputContextType) :: this - ! -- local - type(InputParamDefinitionType), pointer :: ra_idt - character(len=:), allocatable :: parse_str - character(len=LENVARNAME), dimension(:), allocatable :: dfncols - integer(I4B), dimension(:), allocatable :: idxs - integer(I4B) :: dfnncol, icol, keepcnt - logical(LGP) :: keep - ! - ! -- initialize - keepcnt = 0 - ! - ! -- get aggregate param definition for period block - ra_idt => & - get_aggregate_definition_type(this%mf6_input%aggregate_dfns, & - this%mf6_input%component_type, & - this%mf6_input%subcomponent_type, & - 'PERIOD') - ! - ! -- split recarray definition - parse_str = trim(ra_idt%datatype)//' ' - call parseline(parse_str, dfnncol, dfncols) - ! - ! -- determine which columns are in scope - do icol = 1, dfnncol - ! - keep = .false. - ! - if (dfncols(icol) == 'RECARRAY') then - ! no-op - else if (dfncols(icol) == 'AUX') then - if (this%naux > 0) then - keep = .true. - end if - else if (dfncols(icol) == 'BOUNDNAME') then - if (this%inamedbound /= 0) then - keep = .true. - end if - else - keep = pkg_param_in_scope(this%mf6_input, dfncols(icol)) - end if - ! - if (keep) then - keepcnt = keepcnt + 1 - call expandarray(idxs) - idxs(keepcnt) = icol - end if - end do - ! - ! -- update nfiltcol - this%nfiltcol = keepcnt - ! - ! -- allocate filtcols - allocate (this%filtcols(this%nfiltcol)) - ! - ! -- set filtcols - do icol = 1, this%nfiltcol - this%filtcols(icol) = dfncols(idxs(icol)) - end do - ! - ! -- cleanup - deallocate (dfncols) - deallocate (idxs) - deallocate (parse_str) - ! - ! -- return - return - end subroutine set_filtered_cols - - !> @brief allocate and set input array to filtered param set + !! Create and set a read state variable, e.g. 'INRECHARGE', + !! which are updated per iper load as follows: + !! -1: unset, not in use + !! 0: not read in most recent period block + !! 1: numeric input read in most recent period block + !! 2: time series input read in most recent period block !! !< - subroutine filtered_cols(this, cols, ncol) + function rsv_alloc(this, mf6varname) result(varname) ! -- modules + use ConstantsModule, only: LENVARNAME + use MemoryManagerModule, only: mem_setptr, mem_allocate ! -- dummy class(BoundInputContextType) :: this - character(len=LENVARNAME), dimension(:), allocatable, & - intent(inout) :: cols - integer(I4B), intent(inout) :: ncol - integer(I4B) :: n - ! - if (allocated(cols)) deallocate (cols) - ! - ncol = this%nfiltcol - ! - allocate (cols(ncol)) - ! - do n = 1, ncol - cols(n) = this%filtcols(n) - end do - ! - ! -- return - return - end subroutine filtered_cols - - !> @brief determine if input param is in scope for a package - !! - !< - function pkg_param_in_scope(mf6_input, tagname) result(in_scope) - ! -- modules - use MemoryManagerModule, only: get_isize, mem_setptr - use InputDefinitionModule, only: InputParamDefinitionType - use DefinitionSelectModule, only: get_param_definition_type - ! -- dummy - type(ModflowInputType), intent(in) :: mf6_input - character(len=*), intent(in) :: tagname - ! -- return - logical(LGP) :: in_scope - ! -- locals - type(InputParamDefinitionType), pointer :: idt - integer(I4B) :: pdim_isize, popt_isize - integer(I4B), pointer :: pdim - ! - ! -- initialize - in_scope = .false. + character(len=*), intent(in) :: mf6varname + ! -- local + character(len=LENVARNAME) :: varname + integer(I4B) :: ilen + integer(I4B), pointer :: intvar + character(len=2) :: prefix = 'IN' ! - idt => get_param_definition_type(mf6_input%param_dfns, & - mf6_input%component_type, & - mf6_input%subcomponent_type, & - 'PERIOD', tagname, '') + ! -- assign first column as the block number + ilen = len_trim(mf6varname) ! - if (idt%required) then - ! -- required params always included - in_scope = .true. + if (ilen > (LENVARNAME - len(prefix))) then + varname = prefix//mf6varname(1:(LENVARNAME - len(prefix))) else - ! - ! -- package specific logic to determine if input params to be read - select case (mf6_input%subcomponent_type) - case ('EVT') - ! - if (tagname == 'PXDP' .or. tagname == 'PETM') then - call get_isize('NSEG', mf6_input%mempath, pdim_isize) - if (pdim_isize > 0) then - call mem_setptr(pdim, 'NSEG', mf6_input%mempath) - if (pdim > 1) then - in_scope = .true. - end if - end if - else if (tagname == 'PETM0') then - call get_isize('SURFRATESPEC', mf6_input%mempath, popt_isize) - if (popt_isize > 0) then - in_scope = .true. - end if - end if - ! - case default - end select + varname = prefix//trim(mf6varname) end if ! + call mem_allocate(intvar, varname, this%mf6_input%mempath) + intvar = -1 + ! ! -- return return - end function pkg_param_in_scope + end function rsv_alloc end module BoundInputContextModule diff --git a/src/Utilities/Idm/DefinitionSelect.f90 b/src/Utilities/Idm/DefinitionSelect.f90 index 656312e9cf8..78fdb84e758 100644 --- a/src/Utilities/Idm/DefinitionSelect.f90 +++ b/src/Utilities/Idm/DefinitionSelect.f90 @@ -18,9 +18,112 @@ module DefinitionSelectModule public :: get_param_definition_type public :: get_aggregate_definition_type public :: split_record_definition + public :: idt_datatype + public :: idt_copy + public :: idt_parse_rectype contains + !> @brief allocate and set RECARRAY, KEYSTRING or RECORD param list + !< + subroutine idt_parse_rectype(idt, cols, ncol) + ! -- modules + use ConstantsModule, only: LINELENGTH + use InputOutputModule, only: parseline + ! -- dummy + type(InputParamDefinitionType), pointer, intent(in) :: idt + character(len=LINELENGTH), dimension(:), allocatable, & + intent(inout) :: cols + integer(I4B), intent(inout) :: ncol + ! -- local + character(len=:), allocatable :: parse_str + character(len=LINELENGTH), dimension(:), allocatable :: param_cols + integer(I4B) :: param_ncol, n + ! + ! -- initialize + if (allocated(cols)) deallocate (cols) + ncol = 0 + ! + ! -- split definition + parse_str = trim(idt%datatype)//' ' + call parseline(parse_str, param_ncol, param_cols) + ! + if (param_ncol > 1) then + if (param_cols(1) == 'RECARRAY' .or. & + param_cols(1) == 'KEYSTRING' .or. & + param_cols(1) == 'RECORD') then + ! -- exclude 1st column + allocate (cols(param_ncol - 1)) + do n = 2, param_ncol + cols(n - 1) = param_cols(n) + end do + ! + ! -- set ncol + ncol = param_ncol - 1 + end if + end if + ! + ! -- cleanup + if (allocated(param_cols)) deallocate (param_cols) + if (allocated(parse_str)) deallocate (parse_str) + ! + ! -- return + return + end subroutine idt_parse_rectype + + !> @brief return input definition type datatype + !< + function idt_datatype(idt) result(datatype) + ! -- modules + use ConstantsModule, only: LINELENGTH + ! -- dummy + type(InputParamDefinitionType), pointer, intent(in) :: idt + ! -- result + character(len=LINELENGTH) :: datatype + ! + if (idt%datatype(1:9) == 'KEYSTRING') then + datatype = 'KEYSTRING' + else if (idt%datatype(1:8) == 'RECARRAY') then + datatype = 'RECARRAY' + else if (idt%datatype(1:6) == 'RECORD') then + datatype = 'RECORD' + else + datatype = idt%datatype + end if + ! + ! -- return + return + end function idt_datatype + + !> @brief return allocated copy of an input definition type + !< + function idt_copy(idt) result(copy) + ! -- modules + ! -- dummy + type(InputParamDefinitionType), pointer, intent(in) :: idt + ! -- result + type(InputParamDefinitionType), pointer :: copy + ! + allocate (copy) + ! + ! -- copy from input dfn + copy%component_type = trim(idt%component_type) + copy%subcomponent_type = trim(idt%subcomponent_type) + copy%blockname = trim(idt%blockname) + copy%tagname = trim(idt%tagname) + copy%mf6varname = trim(idt%mf6varname) + copy%datatype = trim(idt%datatype) + copy%shape = trim(idt%shape) + copy%required = idt%required + copy%in_record = idt%in_record + copy%preserve_case = idt%preserve_case + copy%layered = idt%layered + copy%timeseries = idt%timeseries + ! + ! -- return + return + end function idt_copy + !> @brief Return parameter definition !< function get_param_definition_type(input_definition_types, & @@ -38,7 +141,7 @@ function get_param_definition_type(input_definition_types, & type(InputParamDefinitionType), pointer :: tmp_ptr integer(I4B) :: i ! - idt => null() + nullify (idt) do i = 1, size(input_definition_types) tmp_ptr => input_definition_types(i) if (tmp_ptr%component_type == component_type .and. & @@ -76,7 +179,7 @@ function get_aggregate_definition_type(input_definition_types, component_type, & type(InputParamDefinitionType), pointer :: tmp_ptr integer(I4B) :: i ! - idt => null() + nullify (idt) do i = 1, size(input_definition_types) tmp_ptr => input_definition_types(i) if (tmp_ptr%component_type == component_type .and. & @@ -134,7 +237,7 @@ subroutine split_record_definition(input_definition_types, component_type, & ! -- match for definition to split if (tmp_ptr%component_type == component_type .and. & tmp_ptr%subcomponent_type == subcomponent_type .and. & - tmp_ptr%datatype(1:6) == 'RECORD') then + idt_datatype(tmp_ptr) == 'RECORD') then ! ! -- set split string parse_str = trim(input_definition_types(i)%datatype)//' ' @@ -145,7 +248,6 @@ subroutine split_record_definition(input_definition_types, component_type, & ! -- check for match and manage memory if (nwords >= 2) then if (words(1) == 'RECORD' .and. words(2) == tagname) then - if (allocated(parse_str)) deallocate (parse_str) exit end if end if diff --git a/src/Utilities/Idm/DynamicParamFilter.f90 b/src/Utilities/Idm/DynamicParamFilter.f90 new file mode 100644 index 00000000000..29bcc89a4ce --- /dev/null +++ b/src/Utilities/Idm/DynamicParamFilter.f90 @@ -0,0 +1,401 @@ +!> @brief This module contains the DynamicParamFilterModule +!! +!! This module contains a type definition for filtering +!! out dynamic parameters that are not in scope for the run +!! +!< +module DynamicParamFilterModule + + use KindModule, only: DP, I4B, LGP + use ConstantsModule, only: LINELENGTH + use SimVariablesModule, only: errmsg + use SimModule, only: store_error, store_error_filename + use ModflowInputModule, only: ModflowInputType + use InputDefinitionModule, only: InputParamDefinitionType + use DefinitionSelectModule, only: get_param_definition_type, & + get_aggregate_definition_type, & + idt_datatype, idt_parse_rectype + use ArrayHandlersModule, only: expandarray + + implicit none + private + public :: DynamicParamFilterType + + !> @brief dynamic parameter filter type + !! + !! This type is used to filter out unneeded input parameters + !! for list and array based dynamic input. It also unpacks + !! composite dfn parameter types (RECORD, RECARRAY, and + !! KEYSTRING) and defines helper arrays for the processing + !! of input SETTINGS types. + !! + !< + type :: DynamicParamFilterType + type(ModflowInputType) :: mf6_input !< description of input + character(len=LINELENGTH), dimension(:), allocatable :: flt_params !< in scope param tags + integer(I4B) :: nfltparam !< number of in scope params + integer(I4B) :: naux + integer(I4B) :: inamedbound + integer(I4B) :: iout + contains + procedure :: init + procedure :: destroy + procedure :: set_filtered_list + procedure :: set_filtered_grid + procedure :: get_flt_params + procedure :: filter_settings_type + procedure :: filter_setting + end type DynamicParamFilterType + +contains + + !> @brief initialize dynamic param filter + !! + !< + subroutine init(this, mf6_input, readasarrays, naux, inamedbound, iout) + ! -- modules + ! -- dummy + class(DynamicParamFilterType) :: this + type(ModflowInputType), intent(in) :: mf6_input + logical(LGP), intent(in) :: readasarrays + integer(I4B), intent(in) :: naux + integer(I4B), intent(in) :: inamedbound + integer(I4B), intent(in) :: iout + ! -- local + ! + this%mf6_input = mf6_input + this%nfltparam = 0 + this%naux = naux + this%inamedbound = inamedbound + this%iout = iout + ! + ! -- determine in scope input params + if (readasarrays) then + call this%set_filtered_grid() + else + call this%set_filtered_list() + end if + ! + ! --return + return + end subroutine init + + !> @brief destroy dynamic param filter + !! + !< + subroutine destroy(this) + ! -- modules + ! -- dummy + class(DynamicParamFilterType) :: this + ! + ! -- deallocate + if (allocated(this%flt_params)) deallocate (this%flt_params) + ! + ! --return + return + end subroutine destroy + + !> @brief array based input dynamic param filter + !! + !< + subroutine set_filtered_grid(this) + ! -- modules + ! -- dummy + class(DynamicParamFilterType) :: this + ! -- local + type(InputParamDefinitionType), pointer :: idt + integer(I4B), dimension(:), allocatable :: idt_idxs + integer(I4B) :: keepcnt, iparam + logical(LGP) :: keep + ! + ! -- initialize + keepcnt = 0 + ! + ! -- allocate dfn input params + do iparam = 1, size(this%mf6_input%param_dfns) + ! + keep = .true. + ! + ! -- assign param definition pointer + idt => this%mf6_input%param_dfns(iparam) + ! + if (idt%blockname /= 'PERIOD') then + keep = .false. + end if + ! + if (idt%tagname == 'AUX') then + if (this%naux == 0) then + keep = .false. + end if + end if + ! + if (keep) then + keepcnt = keepcnt + 1 + call expandarray(idt_idxs) + idt_idxs(keepcnt) = iparam + end if + end do + ! + ! -- update nfltparam + this%nfltparam = keepcnt + ! + ! -- allocate filtcols + allocate (this%flt_params(this%nfltparam)) + ! + ! -- set filtcols + do iparam = 1, this%nfltparam + idt => this%mf6_input%param_dfns(idt_idxs(iparam)) + this%flt_params(iparam) = trim(idt%tagname) + end do + ! + ! -- cleanup + deallocate (idt_idxs) + ! + ! -- return + return + end subroutine set_filtered_grid + + !> @brief create array of in scope list input columns + !! + !! Filter the recarray description of list input parameters + !! to determine which columns are to be read in this run. + !< + subroutine set_filtered_list(this) + ! -- modules + ! -- dummy + class(DynamicParamFilterType) :: this + ! -- local + type(InputParamDefinitionType), pointer :: ra_idt, idt + character(len=LINELENGTH), dimension(:), allocatable :: ra_cols + integer(I4B) :: ra_ncol, icol, keepcnt + logical(LGP) :: keep + ! + ! -- initialize + keepcnt = 0 + ! + ! -- get aggregate param definition for period block + ra_idt => & + get_aggregate_definition_type(this%mf6_input%aggregate_dfns, & + this%mf6_input%component_type, & + this%mf6_input%subcomponent_type, & + 'PERIOD') + ! + ! -- split recarray definition + call idt_parse_rectype(ra_idt, ra_cols, ra_ncol) + ! + ! -- determine which columns are in scope + do icol = 1, ra_ncol + ! + keep = .false. + ! + ! -- set dfn pointer to recarray parameter + idt => get_param_definition_type(this%mf6_input%param_dfns, & + this%mf6_input%component_type, & + this%mf6_input%subcomponent_type, & + 'PERIOD', ra_cols(icol), '') + ! + if (ra_cols(icol) == 'RECARRAY') then + ! no-op + else if (ra_cols(icol) == 'AUX') then + if (this%naux > 0) then + keep = .true. + end if + else if (ra_cols(icol) == 'BOUNDNAME') then + if (this%inamedbound /= 0) then + keep = .true. + end if + else + if (idt_datatype(idt) == 'KEYSTRING') then + ! -- determine in scope params of settings type + call this%filter_settings_type(idt, keepcnt) + else + ! -- determine if the param is scope + keep = pkg_param_in_scope(this%mf6_input, ra_cols(icol)) + end if + end if + ! + if (keep) then + keepcnt = keepcnt + 1 + call expandarray(this%flt_params) + this%flt_params(keepcnt) = trim(ra_cols(icol)) + end if + end do + ! + ! -- update nfltparam + this%nfltparam = keepcnt + ! + ! -- cleanup + deallocate (ra_cols) + ! + ! -- return + return + end subroutine set_filtered_list + + !> @brief allocate and set input array to filtered param set + !! + !< + subroutine get_flt_params(this, cols, ncol) + ! -- modules + ! -- dummy + class(DynamicParamFilterType) :: this + character(len=LINELENGTH), dimension(:), allocatable, & + intent(inout) :: cols + integer(I4B), intent(inout) :: ncol + integer(I4B) :: n + ! + if (allocated(cols)) deallocate (cols) + ! + ncol = this%nfltparam + ! + allocate (cols(ncol)) + ! + do n = 1, ncol + cols(n) = this%flt_params(n) + end do + ! + ! -- return + return + end subroutine get_flt_params + + !> @brief filter a non-advanced package (e.g. TVK) setting type + !! + !< + subroutine filter_setting(this, setting_idt, keepcnt, ks_cols, ks_ncol) + ! -- modules + use MemoryManagerModule, only: get_isize, mem_setptr + ! -- dummy + class(DynamicParamFilterType) :: this + type(InputParamDefinitionType), pointer, intent(in) :: setting_idt + integer(I4B), intent(inout) :: keepcnt + character(len=LINELENGTH), dimension(:), allocatable, intent(in) :: ks_cols + integer(I4B), intent(in) :: ks_ncol + ! -- return + ! -- local + type(InputParamDefinitionType), pointer :: idt + character(len=LINELENGTH) :: datatype + integer(I4B) :: icol + ! + datatype = '' + ! + ! -- store the param as it will be a string array for the setting + keepcnt = keepcnt + 1 + call expandarray(this%flt_params) + this%flt_params(keepcnt) = trim(setting_idt%tagname) + ! + ! -- verify datatypes of associated parameters are consistent + do icol = 1, ks_ncol + ! + idt => get_param_definition_type(this%mf6_input%param_dfns, & + this%mf6_input%component_type, & + this%mf6_input%subcomponent_type, & + 'PERIOD', ks_cols(icol), '') + ! + if (datatype /= '' .and. datatype /= idt%datatype) then + errmsg = 'IDM unimplemented. DynamicParamFilterType::filter_setting & + &extended use case needed for setting params with non-& + &identical datatypes.' + call store_error(errmsg, .true.) + else + datatype = idt%datatype + end if + end do + ! + ! -- Store first as a template for the setting value. If datatype is + ! KEYWORD then there is no associated data column. + if (datatype /= 'KEYWORD') then + keepcnt = keepcnt + 1 + call expandarray(this%flt_params) + this%flt_params(keepcnt) = trim(ks_cols(1)) + end if + ! + ! -- return + return + end subroutine filter_setting + + !> @brief filter a package SETTING type + !! + !< + subroutine filter_settings_type(this, setting_idt, keepcnt) + ! -- modules + ! -- dummy + class(DynamicParamFilterType) :: this + type(InputParamDefinitionType), pointer, intent(in) :: setting_idt + integer(I4B), intent(inout) :: keepcnt + ! -- local + character(len=LINELENGTH), dimension(:), allocatable :: ks_cols + integer(I4B) :: ks_ncol + ! + ! -- split recarray definition + call idt_parse_rectype(setting_idt, ks_cols, ks_ncol) + ! + ! -- filter keystring type (e.g. TVK) + call this%filter_setting(setting_idt, keepcnt, ks_cols, ks_ncol) + ! + ! -- cleanup + deallocate (ks_cols) + ! + ! -- return + return + end subroutine filter_settings_type + + !> @brief determine if input param is in scope for a package + !! + !< + function pkg_param_in_scope(mf6_input, tagname) result(in_scope) + ! -- modules + use MemoryManagerModule, only: get_isize, mem_setptr + ! -- dummy + type(ModflowInputType), intent(in) :: mf6_input + character(len=*), intent(in) :: tagname + ! -- return + logical(LGP) :: in_scope + ! -- local + type(InputParamDefinitionType), pointer :: idt + integer(I4B) :: pdim_isize, popt_isize + integer(I4B), pointer :: pdim + ! + ! -- initialize + in_scope = .false. + ! + idt => get_param_definition_type(mf6_input%param_dfns, & + mf6_input%component_type, & + mf6_input%subcomponent_type, & + 'PERIOD', tagname, '') + ! + if (idt%required) then + ! -- required params always included + in_scope = .true. + else + ! + ! -- package specific logic to determine if input params to be read + select case (mf6_input%subcomponent_type) + case ('EVT') + ! + if (tagname == 'PXDP' .or. tagname == 'PETM') then + call get_isize('NSEG', mf6_input%mempath, pdim_isize) + if (pdim_isize > 0) then + call mem_setptr(pdim, 'NSEG', mf6_input%mempath) + if (pdim > 1) then + in_scope = .true. + end if + end if + else if (tagname == 'PETM0') then + call get_isize('SURFRATESPEC', mf6_input%mempath, popt_isize) + if (popt_isize > 0) then + in_scope = .true. + end if + end if + ! + case default + errmsg = 'IDM unimplemented. DynamicParamFilterType::pkg_param_in_scope & + &add case tagname='//trim(idt%tagname) + call store_error(errmsg, .true.) + !call store_error_filename(sourcename) + end select + end if + ! + ! -- return + return + end function pkg_param_in_scope + +end module DynamicParamFilterModule diff --git a/src/Utilities/Idm/IdmLoad.f90 b/src/Utilities/Idm/IdmLoad.f90 index 26c6aa21973..059f93e6abb 100644 --- a/src/Utilities/Idm/IdmLoad.f90 +++ b/src/Utilities/Idm/IdmLoad.f90 @@ -9,7 +9,7 @@ module IdmLoadModule use KindModule, only: DP, I4B, LGP use SimVariablesModule, only: errmsg use ConstantsModule, only: LINELENGTH, LENMEMPATH, LENMODELNAME, & - LENEXCHANGENAME, LENCOMPONENTNAME + LENCOMPONENTNAME use SimModule, only: store_error, store_error_filename use ListModule, only: ListType use InputLoadTypeModule, only: StaticPkgLoadBaseType, & @@ -121,26 +121,27 @@ end subroutine idm_da !> @brief load an integrated model package from supported source !< - subroutine model_pkg_load(model_pkg_inputs, itype, ipkg, iout) + recursive subroutine input_load(component_type, subcomponent_type, modelname, & + pkgname, pkgtype, filename, modelfname, iout) use ModelPackageInputsModule, only: ModelPackageInputsType use SourceLoadModule, only: create_input_loader - type(ModelPackageInputsType), intent(in) :: model_pkg_inputs - integer(I4B), intent(in) :: itype - integer(I4B), intent(in) :: ipkg + character(len=*), intent(in) :: component_type + character(len=*), intent(in) :: subcomponent_type + character(len=*), intent(in) :: pkgname + character(len=*), intent(in) :: pkgtype + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: modelname + character(len=*), intent(in) :: modelfname integer(I4B), intent(in) :: iout class(StaticPkgLoadBaseType), pointer :: static_loader class(DynamicPkgLoadBaseType), pointer :: dynamic_loader - class(ModelDynamicPkgsType), pointer :: dynamic_pkgs => null() + class(ModelDynamicPkgsType), pointer :: dynamic_pkgs + integer(I4B) :: n ! ! -- create model package loader static_loader => & - create_input_loader(model_pkg_inputs%component_type, & - model_pkg_inputs%pkglist(itype)%subcomponent_type, & - model_pkg_inputs%modelname, & - model_pkg_inputs%pkglist(itype)%pkgnames(ipkg), & - model_pkg_inputs%pkglist(itype)%pkgtype, & - model_pkg_inputs%pkglist(itype)%filenames(ipkg), & - model_pkg_inputs%modelfname) + create_input_loader(component_type, subcomponent_type, modelname, pkgname, & + pkgtype, filename, modelfname) ! ! -- load static input and set dynamic loader dynamic_loader => static_loader%load(iout) @@ -148,22 +149,37 @@ subroutine model_pkg_load(model_pkg_inputs, itype, ipkg, iout) if (associated(dynamic_loader)) then ! ! -- set pointer to model dynamic packages list - dynamic_pkgs => dynamic_model_pkgs(model_pkg_inputs%modelname, & - static_loader%component_input_name, & - iout) + dynamic_pkgs => dynamic_model_pkgs(modelname, & + static_loader%component_input_name, iout) ! ! -- add dynamic pkg loader to list call dynamic_pkgs%add(dynamic_loader) ! end if ! + ! -- create subpackage list + call static_loader%create_subpkg_list() + ! + ! -- load idm integrated subpackges + do n = 1, static_loader%subpkg_list%pnum + ! + ! -- load subpackage + call input_load(static_loader%subpkg_list%component_types(n), & + static_loader%subpkg_list%subcomponent_types(n), & + static_loader%mf6_input%component_name, & + static_loader%subpkg_list%subcomponent_types(n), & + static_loader%subpkg_list%pkgtypes(n), & + static_loader%subpkg_list%filenames(n), & + modelfname, iout) + end do + ! ! -- cleanup call static_loader%destroy() deallocate (static_loader) ! ! -- return return - end subroutine model_pkg_load + end subroutine input_load !> @brief load integrated model package files !< @@ -186,7 +202,13 @@ subroutine load_model_pkgs(model_pkg_inputs, iout) then ! ! -- only load if model pkg can read from input context - call model_pkg_load(model_pkg_inputs, itype, ipkg, iout) + call input_load(model_pkg_inputs%component_type, & + model_pkg_inputs%pkglist(itype)%subcomponent_type, & + model_pkg_inputs%modelname, & + model_pkg_inputs%pkglist(itype)%pkgnames(ipkg), & + model_pkg_inputs%pkglist(itype)%pkgtype, & + model_pkg_inputs%pkglist(itype)%filenames(ipkg), & + model_pkg_inputs%modelfname, iout) else ! ! -- open input file for package parser @@ -211,12 +233,11 @@ subroutine load_models(model_loadmask, iout) use CharacterStringModule, only: CharacterStringType use SimVariablesModule, only: idm_context use ModelPackageInputsModule, only: ModelPackageInputsType - use SourceCommonModule, only: idm_component_type use SourceLoadModule, only: load_modelnam ! -- dummy integer(I4B), dimension(:), intent(in) :: model_loadmask integer(I4B), intent(in) :: iout - ! -- locals + ! -- local character(len=LENMEMPATH) :: input_mempath type(CharacterStringType), dimension(:), contiguous, & pointer :: mtypes !< model types @@ -284,7 +305,7 @@ subroutine load_exchanges(model_loadmask, iout) ! -- dummy integer(I4B), dimension(:), intent(in) :: model_loadmask integer(I4B), intent(in) :: iout - ! -- locals + ! -- local type(CharacterStringType), dimension(:), contiguous, & pointer :: etypes !< exg types type(CharacterStringType), dimension(:), contiguous, & @@ -547,8 +568,12 @@ subroutine simnam_load_dim() pointer :: mtypes !< model types type(CharacterStringType), dimension(:), contiguous, & pointer :: etypes !< model types - integer(I4B), pointer :: nummodels => null() - integer(I4B), pointer :: numexchanges => null() + integer(I4B), pointer :: nummodels + integer(I4B), pointer :: numexchanges + ! + ! -- initialize + nullify (nummodels) + nullify (numexchanges) ! ! -- set memory paths sim_mempath = create_mem_path(component='SIM', context=idm_context) @@ -577,7 +602,10 @@ subroutine allocate_simnam_int(input_mempath, idt) use SimVariablesModule, only: isimcontinue, isimcheck, simfile character(len=LENMEMPATH), intent(in) :: input_mempath type(InputParamDefinitionType), pointer, intent(in) :: idt - integer(I4B), pointer :: intvar => null() + integer(I4B), pointer :: intvar + ! + ! -- initialize + nullify (intvar) ! ! -- allocate and set default call mem_allocate(intvar, idt%mf6varname, input_mempath) @@ -595,8 +623,8 @@ subroutine allocate_simnam_int(input_mempath, idt) intvar = 0 case default write (errmsg, '(a,a)') & - 'Programming error. Idm SIMNAM Load default value setting '& - &'is unhandled for this variable: ', & + 'IDM unimplemented. SIMNAM input variable default value '& + &'not set: ', & trim(idt%mf6varname) call store_error(errmsg) call store_error_filename(simfile) @@ -614,9 +642,9 @@ subroutine allocate_simnam_param(input_mempath, idt) use CharacterStringModule, only: CharacterStringType character(len=LENMEMPATH), intent(in) :: input_mempath type(InputParamDefinitionType), pointer, intent(in) :: idt - character(len=LINELENGTH), pointer :: cstr => null() + character(len=LINELENGTH), pointer :: cstr type(CharacterStringType), dimension(:), & - pointer, contiguous :: acharstr1d => null() + pointer, contiguous :: acharstr1d ! ! -- initialize ! @@ -642,7 +670,7 @@ subroutine allocate_simnam_param(input_mempath, idt) end if case default write (errmsg, '(a,a)') & - 'Programming error. IdmLoad unhandled datatype: ', & + 'IDM unimplmented. Unhandled SIMNAM datatype: ', & trim(idt%datatype) call store_error(errmsg) call store_error_filename(simfile) diff --git a/src/Utilities/Idm/InputDefinition.f90 b/src/Utilities/Idm/InputDefinition.f90 index 0d488e50d90..63197b415dc 100644 --- a/src/Utilities/Idm/InputDefinition.f90 +++ b/src/Utilities/Idm/InputDefinition.f90 @@ -1,51 +1,52 @@ !> @brief This module contains the InputDefinitionModule !! -!! This module contains helper objects for storing -!! information about how to read modflow input files. +!! This module contains type definitions that represent +!! descriptions of input from modflow 6 defintion files. !! !< module InputDefinitionModule use KindModule, only: LGP - use ConstantsModule, only: LENVARNAME + use ConstantsModule, only: LINELENGTH, LENVARNAME, LENCOMPONENTNAME implicit none private public :: InputParamDefinitionType, & InputBlockDefinitionType - !> @brief derived type for storing input definition + !> @brief Input paramater definition type !! - !! This derived type is used to store information for + !! This type is used to store information for !! each modflow input record !! !< type InputParamDefinitionType - character(len=100) :: component_type = '' - character(len=100) :: subcomponent_type = '' - character(len=100) :: blockname = '' - character(len=100) :: tagname = '' - character(len=LENVARNAME) :: mf6varname = '' - character(len=120) :: datatype = '' - character(len=100) :: shape = '' - logical(LGP) :: required = .false. - logical(LGP) :: in_record = .false. - logical(LGP) :: preserve_case = .false. - logical(LGP) :: layered = .false. - logical(LGP) :: timeseries = .false. + character(len=LENCOMPONENTNAME) :: component_type = '' !< type of component, e.g. GWF + character(len=LENCOMPONENTNAME) :: subcomponent_type = '' !< type of subcomponent, e.g. CHD + character(len=LINELENGTH) :: blockname = '' !< input block, e.g. DiMENSIONS + character(len=LINELENGTH) :: tagname = '' !< parameter user tag name + character(len=LENVARNAME) :: mf6varname = '' !< parameter internal managed memory name + character(len=LINELENGTH) :: datatype = '' !< parameter data type + character(len=LINELENGTH) :: shape = '' !< shape of data type + logical(LGP) :: required = .false. !< is the parameter required + logical(LGP) :: in_record = .false. !< is the parameter within an input record + logical(LGP) :: preserve_case = .false. !< should string case be preserved + logical(LGP) :: layered = .false. !< does the parameter support a layered read + logical(LGP) :: timeseries = .false. !< does the parameter support timeseries end type InputParamDefinitionType - !> @brief derived type for storing block information + !> @brief Input block definition type !! - !! This derived type is used to store information for + !! This type is used to store information for !! how to read a modflow block !! !< type InputBlockDefinitionType - character(len=100) :: blockname = '' - logical(LGP) :: required = .false. - logical(LGP) :: aggregate = .false. - logical(LGP) :: block_variable = .false. + character(len=LINELENGTH) :: blockname = '' !< name of block, e.g. DIMENSIONS + logical(LGP) :: required = .false. !< is the block required + logical(LGP) :: aggregate = .false. !< is this structarray style input + logical(LGP) :: block_variable = .false. !< does this block have a block variable + logical(LGP) :: timeseries = .false. !< does this block support timeseries end type InputBlockDefinitionType end module InputDefinitionModule diff --git a/src/Utilities/Idm/InputLoadType.f90 b/src/Utilities/Idm/InputLoadType.f90 index 24001ba17d6..58a65d6942f 100644 --- a/src/Utilities/Idm/InputLoadType.f90 +++ b/src/Utilities/Idm/InputLoadType.f90 @@ -1,13 +1,16 @@ !> @brief This module contains the InputLoadTypeModule !! -!! This module defines types that support generic IDP +!! This module defines types that support generic IDM !! static and dynamic input loading. !! !< module InputLoadTypeModule use KindModule, only: DP, I4B, LGP - use ConstantsModule, only: LINELENGTH, LENCOMPONENTNAME, LENMODELNAME + use ConstantsModule, only: LINELENGTH, LENCOMPONENTNAME, LENMODELNAME, & + LENVARNAME, LENMEMPATH, LENFTYPE + use SimVariablesModule, only: errmsg + use SimModule, only: store_error, store_error_filename use ModflowInputModule, only: ModflowInputType use ListModule, only: ListType use InputDefinitionModule, only: InputParamDefinitionType @@ -19,25 +22,43 @@ module InputLoadTypeModule public :: ModelDynamicPkgsType public :: AddDynamicModelToList, GetDynamicModelFromList public :: StaticPkgLoadType, DynamicPkgLoadType + public :: SubPackageListType - !> @brief derived type for source static load + !> @brief type representing package subpackage list + type :: SubPackageListType + character(len=LENCOMPONENTNAME), dimension(:), allocatable :: pkgtypes + character(len=LENCOMPONENTNAME), dimension(:), allocatable :: component_types + character(len=LENCOMPONENTNAME), dimension(:), & + allocatable :: subcomponent_types + character(len=LINELENGTH), dimension(:), allocatable :: filenames + character(len=LENMEMPATH) :: mempath + character(len=LENCOMPONENTNAME) :: component_name + integer(I4B) :: pnum + contains + procedure :: create => subpkg_create + procedure :: add => subpkg_add + procedure :: destroy => subpkg_destroy + end type SubPackageListType + + !> @brief Static loader type !! - !! This derived type is a base concrete type for a model - !! package static load + !! This type is a base concrete type for a static input loader !! !< type StaticPkgLoadType type(ModflowInputType) :: mf6_input !< description of modflow6 input character(len=LENCOMPONENTNAME) :: component_name !< name of component - character(len=LINELENGTH) :: component_input_name !< name of component input name, e.g. filename - character(len=LINELENGTH) :: input_name !< source name, e.g. name of input file - integer(I4B) :: iperblock + character(len=LINELENGTH) :: component_input_name !< component input name, e.g. model name file + character(len=LINELENGTH) :: input_name !< input name, e.g. package *.chd file + integer(I4B) :: iperblock !< index of period block on block definition list + type(SubPackageListType) :: subpkg_list contains procedure :: init => static_init + procedure :: create_subpkg_list procedure :: destroy => static_destroy end type StaticPkgLoadType - !> @brief base abstract type for source static load + !> @brief Base abstract type for static input loader !! !! IDM sources should extend and implement this type !! @@ -47,20 +68,23 @@ module InputLoadTypeModule procedure(load_if), deferred :: load end type StaticPkgLoadBaseType - !> @brief derived type for source dynamic load + !> @brief Dynamic loader type !! - !! This derived type is a base concrete type for a model - !! package dynamic (period) load + !! This type is a base concrete type for a dynamic (period) input loader !! !< type :: DynamicPkgLoadType type(ModflowInputType) :: mf6_input !< description of modflow6 input - character(len=LENMODELNAME) :: modelname !< name of model - character(len=LINELENGTH) :: modelfname !< name of model input file - character(len=LINELENGTH) :: sourcename !< source name, e.g. name of file - logical(LGP) :: readasarrays - integer(I4B) :: iperblock - integer(I4B) :: iout + character(len=LENCOMPONENTNAME) :: component_name !< name of component + character(len=LINELENGTH) :: component_input_name !< component input name, e.g. model name file + character(len=LINELENGTH) :: input_name !< input name, e.g. package *.chd file + logical(LGP) :: readasarrays !< is this array based input + logical(LGP) :: advanced !< is this an advanced package + logical(LGP) :: settings !< does this package have a SETTINGS dfn type + integer(I4B) :: iperblock !< index of period block on block definition list + integer(I4B) :: iout !< inunit number for logging + integer(I4B) :: nparam !< number of in scope params + character(len=LINELENGTH), dimension(:), allocatable :: param_names !< dynamic param tagnames contains procedure :: init => dynamic_init procedure :: df => dynamic_df @@ -68,7 +92,7 @@ module InputLoadTypeModule procedure :: destroy => dynamic_destroy end type DynamicPkgLoadType - !> @brief base abstract type for source dynamic load + !> @brief Base abstract type for dynamic input loader !! !! IDM sources should extend and implement this type !! @@ -93,9 +117,9 @@ subroutine period_load_if(this) end subroutine end interface - !> @brief derived type for storing a dynamic package load list + !> @brief type for storing a dynamic package load list !! - !! This derived type is used to store a list of package + !! This type is used to store a list of package !! dynamic load types for a model !! !< @@ -117,6 +141,114 @@ subroutine period_load_if(this) contains + !> @brief create a new package type + !< + subroutine subpkg_create(this, mempath, component_name) + ! -- modules + ! -- dummy + class(SubPackageListType) :: this + character(len=*), intent(in) :: mempath + character(len=*), intent(in) :: component_name + ! -- local + ! + ! -- initialize + this%pnum = 0 + this%mempath = mempath + this%component_name = component_name + ! + ! -- allocate arrays + allocate (this%pkgtypes(0)) + allocate (this%component_types(0)) + allocate (this%subcomponent_types(0)) + allocate (this%filenames(0)) + ! + ! -- return + return + end subroutine subpkg_create + + !> @brief create a new package type + !< + subroutine subpkg_add(this, pkgtype, component_type, subcomponent_type, & + tagname, filename) + ! -- modules + use ArrayHandlersModule, only: expandarray + use MemoryHelperModule, only: create_mem_path + use MemoryManagerModule, only: mem_allocate + use SimVariablesModule, only: idm_context + ! -- dummy + class(SubPackageListType) :: this + character(len=*), intent(in) :: pkgtype + character(len=*), intent(in) :: component_type + character(len=*), intent(in) :: subcomponent_type + character(len=*), intent(in) :: tagname + character(len=*), intent(in) :: filename + ! -- local + character(len=LENVARNAME) :: mempath_tag + character(len=LENMEMPATH), pointer :: subpkg_mempath + character(len=LINELENGTH), pointer :: input_fname + integer(I4B) :: idx, trimlen + ! + ! -- reallocate + call expandarray(this%pkgtypes) + call expandarray(this%component_types) + call expandarray(this%subcomponent_types) + call expandarray(this%filenames) + ! + ! -- add new package instance + this%pnum = this%pnum + 1 + this%pkgtypes(this%pnum) = pkgtype + this%component_types(this%pnum) = component_type + this%subcomponent_types(this%pnum) = subcomponent_type + this%filenames(this%pnum) = filename + ! + ! -- initialize mempath tag + mempath_tag = tagname + trimlen = len_trim(tagname) + idx = 0 + ! + ! -- create mempath tagname + idx = index(tagname, '_') + if (idx > 0) then + if (tagname(idx + 1:trimlen) == 'FILENAME') then + write (mempath_tag, '(a)') tagname(1:idx)//'MEMPATH' + end if + end if + ! + ! -- allocate mempath variable for subpackage + call mem_allocate(subpkg_mempath, LENMEMPATH, mempath_tag, & + this%mempath) + ! + ! -- create and set the mempath + subpkg_mempath = & + create_mem_path(this%component_name, & + subcomponent_type, idm_context) + ! + ! -- allocate and initialize filename for subpackage + call mem_allocate(input_fname, LINELENGTH, 'INPUT_FNAME', subpkg_mempath) + input_fname = filename + ! + ! -- return + return + end subroutine subpkg_add + + !> @brief create a new package type + !< + subroutine subpkg_destroy(this) + ! -- modules + ! -- dummy + class(SubPackageListType) :: this + ! -- local + ! + ! -- allocate arrays + deallocate (this%pkgtypes) + deallocate (this%component_types) + deallocate (this%subcomponent_types) + deallocate (this%filenames) + ! + ! -- return + return + end subroutine subpkg_destroy + !> @brief initialize static package loader !! !< @@ -135,6 +267,10 @@ subroutine static_init(this, mf6_input, component_name, component_input_name, & this%input_name = input_name this%iperblock = 0 ! + ! -- create subpackage list + call this%subpkg_list%create(this%mf6_input%mempath, & + this%mf6_input%component_name) + ! ! -- identify period block definition do iblock = 1, size(mf6_input%block_dfns) ! @@ -147,36 +283,98 @@ subroutine static_init(this, mf6_input, component_name, component_input_name, & return end subroutine static_init + !> @brief create the subpackage list + !! + !< + subroutine create_subpkg_list(this) + use IdmDfnSelectorModule, only: idm_subpackages, idm_integrated + use SourceCommonModule, only: filein_fname + class(StaticPkgLoadType), intent(inout) :: this + character(len=16), dimension(:), pointer :: subpkgs + character(len=LINELENGTH) :: tag, fname, pkgtype + character(len=LENFTYPE) :: c_type, sc_type + character(len=16) :: subpkg + integer(I4B) :: idx, n + ! + ! -- set pointer to package (idm integrated) subpackage list + subpkgs => idm_subpackages(this%mf6_input%component_type, & + this%mf6_input%subcomponent_type) + ! + ! -- check if tag matches subpackage + do n = 1, size(subpkgs) + subpkg = subpkgs(n) + idx = index(subpkg, '-') + ! -- split sp string into component/subcomponent + if (idx > 0) then + ! -- split string in component/subcomponent types + c_type = subpkg(1:idx - 1) + sc_type = subpkg(idx + 1:len_trim(subpkg)) + ! + if (idm_integrated(c_type, sc_type)) then + ! + ! -- set pkgtype and input filename tag + pkgtype = trim(sc_type)//'6' + tag = trim(pkgtype)//'_FILENAME' + ! + ! -- support single instance of each subpackage + if (filein_fname(fname, tag, this%mf6_input%mempath, & + this%input_name)) then + call this%subpkg_list%add(pkgtype, c_type, sc_type, & + trim(tag), trim(fname)) + end if + else + errmsg = 'Identified subpackage is not IDM integrated. Remove dfn & + &subpackage tagline for package "'//trim(subpkg)//'".' + call store_error(errmsg) + call store_error_filename(this%input_name) + end if + end if + end do + ! + ! -- return + return + end subroutine create_subpkg_list + subroutine static_destroy(this) class(StaticPkgLoadType), intent(inout) :: this ! + call this%subpkg_list%destroy() + ! return end subroutine static_destroy !> @brief initialize dynamic package loader !! !! Any managed memory pointed to from model/package context - !! must be allocated when derived dynamic loader is initialized. + !! must be allocated when dynamic loader is initialized. !! !< - subroutine dynamic_init(this, mf6_input, modelname, modelfname, source, & - iperblock, iout) + subroutine dynamic_init(this, mf6_input, component_name, component_input_name, & + input_name, iperblock, iout) use SimVariablesModule, only: errmsg - use SimModule, only: store_error, store_error_filename + use InputDefinitionModule, only: InputParamDefinitionType + use DefinitionSelectModule, only: idt_datatype + ! -- dummy class(DynamicPkgLoadType), intent(inout) :: this type(ModflowInputType), intent(in) :: mf6_input - character(len=*), intent(in) :: modelname - character(len=*), intent(in) :: modelfname - character(len=*), intent(in) :: source + character(len=*), intent(in) :: component_name + character(len=*), intent(in) :: component_input_name + character(len=*), intent(in) :: input_name integer(I4B), intent(in) :: iperblock integer(I4B), intent(in) :: iout + type(InputParamDefinitionType), pointer :: idt + integer(I4B) :: iparam ! this%mf6_input = mf6_input - this%modelname = modelname - this%modelfname = modelfname - this%sourcename = source + this%component_name = component_name + this%component_input_name = component_input_name + this%input_name = input_name this%iperblock = iperblock + this%advanced = .false. + this%settings = .false. + this%nparam = 0 this%iout = iout + nullify (idt) ! ! -- throw error and exit if not found if (this%iperblock == 0) then @@ -185,12 +383,26 @@ subroutine dynamic_init(this, mf6_input, modelname, modelfname, source, & &'dynamic package input block dfns: ', & trim(mf6_input%subcomponent_name) call store_error(errmsg) - call store_error_filename(this%sourcename) - else - ! - this%readasarrays = (.not. mf6_input%block_dfns(iperblock)%aggregate) + call store_error_filename(this%input_name) end if ! + ! -- determine if package has SETTINGS type dfn + do iparam = 1, size(mf6_input%param_dfns) + ! + ! -- assign param definition pointer + idt => this%mf6_input%param_dfns(iparam) + ! + if (idt%blockname == 'PERIOD') then + if (idt_datatype(idt) == 'KEYSTRING') then + this%settings = .true. + exit + end if + end if + end do + ! + ! -- set readasarrays + this%readasarrays = (.not. mf6_input%block_dfns(iperblock)%aggregate) + ! ! -- return return end subroutine dynamic_init @@ -399,7 +611,7 @@ function GetDynamicModelFromList(list, idx) result(res) class(*), pointer :: obj ! ! -- initialize res - res => null() + nullify (res) ! ! -- get the object from the list obj => list%GetItem(idx) diff --git a/src/Utilities/Idm/SourceCommon.f90 b/src/Utilities/Idm/SourceCommon.f90 index 3ba4640a2bf..b6b3f07244d 100644 --- a/src/Utilities/Idm/SourceCommon.f90 +++ b/src/Utilities/Idm/SourceCommon.f90 @@ -8,8 +8,8 @@ module SourceCommonModule use KindModule, only: DP, I4B, LGP use SimVariablesModule, only: errmsg - use ConstantsModule, only: LINELENGTH, LENMEMPATH, LENMODELNAME, LENFTYPE, & - LENPACKAGETYPE, LENPACKAGENAME, LENCOMPONENTNAME + use ConstantsModule, only: LINELENGTH, LENPACKAGETYPE, LENPACKAGENAME, & + LENCOMPONENTNAME use SimModule, only: store_error, store_error_filename implicit none @@ -38,12 +38,12 @@ function package_source_type(sourcename) result(sourcetype) character(len=*), intent(in) :: sourcename ! -- result character(len=LENPACKAGENAME) :: sourcetype - ! -- locals + ! -- local + character(len=LENPACKAGENAME) :: ext ! - sourcetype = sourcename - call upcase(sourcetype) + ext = file_ext(sourcename) ! - select case (sourcetype) + select case (ext) case default sourcetype = 'MF6FILE' end select @@ -168,7 +168,7 @@ end function idm_subcomponent_name !> @brief input file extension !! - !! Return the input file extension, or an empty string if + !! Return a file extension, or an empty string if !! not identified. !! !< @@ -180,24 +180,18 @@ function file_ext(filename) result(ext) ! -- return character(len=LENPACKAGETYPE) :: ext ! -- local - integer(I4B) :: i, istart, istop + integer(I4B) :: idx ! ! -- initialize ext = '' - istart = 0 - istop = len_trim(filename) + idx = 0 ! ! -- identify '.' character position from back of string - do i = istop, 1, -1 - if (filename(i:i) == '.') then - istart = i - exit - end if - end do + idx = index(filename, '.', back=.true.) ! ! - if (istart > 0) then - ext = filename(istart + 1:istop) + if (idx > 0) then + ext = filename(idx + 1:len_trim(filename)) end if ! ! -- return @@ -340,9 +334,12 @@ end subroutine set_model_shape subroutine mem_allocate_naux(mempath) use MemoryManagerModule, only: mem_allocate, mem_setptr, get_isize character(len=*), intent(in) :: mempath - integer(I4B), pointer :: naux => null() + integer(I4B), pointer :: naux integer(I4B) :: isize ! + ! -- initialize + nullify (naux) + ! ! -- allocate optional input scalars locally call get_isize('NAUX', mempath, isize) if (isize < 0) then diff --git a/src/Utilities/Idm/mf6blockfile/AsciiInputLoadType.f90 b/src/Utilities/Idm/mf6blockfile/AsciiInputLoadType.f90 index 081f31f1579..4f5b0078c4d 100644 --- a/src/Utilities/Idm/mf6blockfile/AsciiInputLoadType.f90 +++ b/src/Utilities/Idm/mf6blockfile/AsciiInputLoadType.f90 @@ -10,6 +10,7 @@ module AsciiInputLoadTypeModule use KindModule, only: DP, I4B, LGP use InputLoadTypeModule, only: DynamicPkgLoadType use BlockParserModule, only: BlockParserType + use ModflowInputModule, only: ModflowInputType implicit none private @@ -20,15 +21,29 @@ module AsciiInputLoadTypeModule !< type, abstract, extends(DynamicPkgLoadType) :: AsciiDynamicPkgLoadBaseType contains - procedure(ascii_period_load_if), deferred :: rp + procedure(load_init_if), deferred :: ainit !< source loader init + procedure(period_load_if), deferred :: rp !< source loader read and prepare end type AsciiDynamicPkgLoadBaseType abstract interface - subroutine ascii_period_load_if(this, parser) + subroutine period_load_if(this, parser) import AsciiDynamicPkgLoadBaseType, BlockParserType class(AsciiDynamicPkgLoadBaseType), intent(inout) :: this type(BlockParserType), pointer, intent(inout) :: parser !< block parser end subroutine + subroutine load_init_if(this, mf6_input, component_name, & + component_input_name, input_name, & + iperblock, parser, iout) + import I4B, AsciiDynamicPkgLoadBaseType, BlockParserType, ModflowInputType + class(AsciiDynamicPkgLoadBaseType), intent(inout) :: this + type(ModflowInputType), intent(in) :: mf6_input !< description of input + character(len=*), intent(in) :: component_name !< component name + character(len=*), intent(in) :: component_input_name !< component input name, e.g. model name file + character(len=*), intent(in) :: input_name !< input name, e.g. package *.chd file + integer(I4B), intent(in) :: iperblock !< index of period block on block definition list + type(BlockParserType), pointer, intent(inout) :: parser !< block parser + integer(I4B), intent(in) :: iout + end subroutine end interface end module AsciiInputLoadTypeModule diff --git a/src/Utilities/Idm/mf6blockfile/IdmMf6File.f90 b/src/Utilities/Idm/mf6blockfile/IdmMf6File.f90 index 365cafcdefb..c7e45b2afed 100644 --- a/src/Utilities/Idm/mf6blockfile/IdmMf6File.f90 +++ b/src/Utilities/Idm/mf6blockfile/IdmMf6File.f90 @@ -1,23 +1,20 @@ !> @brief This module contains the IdmMf6FileModule !! !! This module contains high-level routines for loading -!! MODFLOW 6 ASCII source input. +!! MODFLOW 6 ASCII source input. This module implements the +!! loader types that the IdmLoadModule creates and invokes. +!! It also creates and manages dynamic ASCII input loaders +!! for all supported types of MODFLOW 6 ASCII dynamic input. !! !< module IdmMf6FileModule use KindModule, only: DP, I4B, LGP use SimVariablesModule, only: errmsg - use ConstantsModule, only: LINELENGTH, LENMEMPATH, LENMODELNAME, & - LENPACKAGENAME, LENFTYPE, LENPACKAGETYPE, & - LENAUXNAME, LENBOUNDNAME, LENTIMESERIESNAME, & - LENLISTLABEL, LENVARNAME, DNODATA, & - DZERO, IZERO + use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, store_error_filename - use InputOutputModule, only: openfile, getunit use BlockParserModule, only: BlockParserType use ModflowInputModule, only: ModflowInputType, getModflowInput - use CharacterStringModule, only: CharacterStringType use InputLoadTypeModule, only: StaticPkgLoadBaseType, DynamicPkgLoadBaseType use AsciiInputLoadTypeModule, only: AsciiDynamicPkgLoadBaseType @@ -27,30 +24,7 @@ module IdmMf6FileModule public :: Mf6FileStaticPkgLoadType, Mf6FileDynamicPkgLoadType public :: open_mf6file - !> @brief derived type for storing package loader - !! - !! This derived type is used to store a pointer to a - !! package load procedure. This could be used to write - !! a custom package loader as a way to override the - !! generic_mf6_load routine. - !! - !< - type :: PackageLoad - procedure(IPackageLoad), nopass, pointer, public :: load_package => null() !< procedure pointer to the load routine - end type PackageLoad - - abstract interface - subroutine IPackageLoad(parser, mf6_input, iout) - use KindModule, only: DP, I4B - use BlockParserModule, only: BlockParserType - use ModflowInputModule, only: ModflowInputType - type(BlockParserType), intent(inout) :: parser !< block parser - type(ModflowInputType), intent(in) :: mf6_input !< description of input - integer(I4B), intent(in) :: iout !< unit number for output - end subroutine IPackageLoad - end interface - - !> @brief MF6File static loader derived type + !> @brief MF6File static loader type !< type, extends(StaticPkgLoadBaseType) :: Mf6FileStaticPkgLoadType contains @@ -59,18 +33,17 @@ end subroutine IPackageLoad procedure :: destroy => static_destroy end type Mf6FileStaticPkgLoadType - !> @brief MF6File dynamic loader derived type + !> @brief MF6File dynamic loader type !< type, extends(DynamicPkgLoadBaseType) :: Mf6FileDynamicPkgLoadType type(BlockParserType), pointer :: parser !< parser for MF6File period blocks - integer(I4B), pointer :: iper => null() - integer(I4B), pointer :: ionper => null() - class(AsciiDynamicPkgLoadBaseType), pointer :: block_loader => null() + integer(I4B), pointer :: iper + integer(I4B), pointer :: ionper + class(AsciiDynamicPkgLoadBaseType), pointer :: rp_loader contains procedure :: init => dynamic_init procedure :: df => dynamic_df procedure :: ad => dynamic_ad - procedure :: set => dynamic_set procedure :: rp => dynamic_rp procedure :: read_ionper => dynamic_read_ionper procedure :: create_loader => dynamic_create_loader @@ -79,60 +52,30 @@ end subroutine IPackageLoad contains - !> @brief generic procedure to MODFLOW 6 load routine + !> @brief input load for traditional mf6 simulation static input file !< - subroutine generic_mf6_load(parser, mf6_input, iout) - use LoadMf6FileModule, only: idm_load - type(BlockParserType), intent(inout) :: parser !< block parser - type(ModflowInputType), intent(in) :: mf6_input !< description of input - integer(I4B), intent(in) :: iout !< unit number for output - - call idm_load(parser, mf6_input, iout) - - end subroutine generic_mf6_load - - !> @brief input load for traditional mf6 simulation input file - !< - subroutine input_load(filename, mf6_input, component_filename, iout, & - mf6_parser) + subroutine input_load(filename, mf6_input, component_filename, iout) + use LoadMf6FileModule, only: LoadMf6FileType character(len=*), intent(in) :: filename type(ModflowInputType), intent(in) :: mf6_input character(len=*), intent(in) :: component_filename !< component (e.g. model) filename integer(I4B), intent(in) :: iout !< unit number for output - type(BlockParserType), pointer, optional, intent(inout) :: mf6_parser type(BlockParserType), allocatable, target :: parser !< block parser - type(PackageLoad) :: pkgloader + type(LoadMf6FileType) :: loader integer(I4B) :: inunit ! - ! -- set parser based package loader by file type - select case (mf6_input%pkgtype) - case default - ! - ! -- open input file - inunit = open_mf6file(mf6_input%pkgtype, filename, component_filename, iout) - ! - ! -- allocate and initialize parser - allocate (parser) - call parser%Initialize(inunit, iout) - ! - ! -- set load interface - pkgloader%load_package => generic_mf6_load - ! - end select + ! -- open input file + inunit = open_mf6file(mf6_input%pkgtype, filename, component_filename, iout) + ! + ! -- allocate and initialize parser + allocate (parser) + call parser%Initialize(inunit, iout) ! ! -- invoke the selected load routine - call pkgloader%load_package(parser, mf6_input, iout) + call loader%load(parser, mf6_input, filename, iout) ! - ! -- generate a dynamic loader parser if requested - if (present(mf6_parser)) then - ! - ! -- create dynamic parser - allocate (mf6_parser, source=parser) - else - ! - ! -- clear parser file handles - call parser%clear() - end if + ! -- clear parser file handles + call parser%clear() ! ! -- cleanup deallocate (parser) @@ -151,6 +94,7 @@ subroutine static_init(this, mf6_input, component_name, component_input_name, & character(len=*), intent(in) :: component_input_name character(len=*), intent(in) :: input_name ! + ! -- initialize base type call this%StaticPkgLoadType%init(mf6_input, component_name, & component_input_name, input_name) ! @@ -158,36 +102,28 @@ end subroutine static_init !> @brief load routine for static loader !< - function static_load(this, iout) result(period_loader) + function static_load(this, iout) result(rp_loader) class(Mf6FileStaticPkgLoadType), intent(inout) :: this integer(I4B), intent(in) :: iout - class(DynamicPkgLoadBaseType), pointer :: period_loader - class(Mf6FileDynamicPkgLoadType), pointer :: mf6_loader => null() - type(BlockParserType), pointer :: parser => null() + class(DynamicPkgLoadBaseType), pointer :: rp_loader + class(Mf6FileDynamicPkgLoadType), pointer :: mf6_loader ! - ! -- initialize - nullify (period_loader) + ! -- initialize return pointer + nullify (rp_loader) ! ! -- load model package to input context if (this%iperblock > 0) then ! - ! -- package is dynamic, allocate loader + ! -- allocate dynamic loader allocate (mf6_loader) ! - ! -- load static input - call input_load(this%input_name, this%mf6_input, & - this%component_input_name, iout, parser) - ! ! -- initialize dynamic loader call mf6_loader%init(this%mf6_input, this%component_name, & this%component_input_name, this%input_name, & this%iperblock, iout) ! - ! -- set parser - call mf6_loader%set(parser) - ! ! -- set return pointer to base dynamic loader - period_loader => mf6_loader + rp_loader => mf6_loader ! else ! @@ -205,34 +141,49 @@ end function static_load subroutine static_destroy(this) class(Mf6FileStaticPkgLoadType), intent(inout) :: this ! + ! -- deallocate base type call this%StaticPkgLoadType%destroy() ! end subroutine static_destroy !> @brief dynamic loader init !< - subroutine dynamic_init(this, mf6_input, modelname, modelfname, source, & - iperblock, iout) + subroutine dynamic_init(this, mf6_input, component_name, component_input_name, & + input_name, iperblock, iout) use InputDefinitionModule, only: InputParamDefinitionType use DefinitionSelectModule, only: get_param_definition_type use MemoryManagerModule, only: mem_allocate class(Mf6FileDynamicPkgLoadType), intent(inout) :: this type(ModflowInputType), intent(in) :: mf6_input - character(len=*), intent(in) :: modelname - character(len=*), intent(in) :: modelfname - character(len=*), intent(in) :: source + character(len=*), intent(in) :: component_name + character(len=*), intent(in) :: component_input_name + character(len=*), intent(in) :: input_name integer(I4B), intent(in) :: iperblock integer(I4B), intent(in) :: iout + integer(I4B) :: inunit ! - call this%DynamicPkgLoadType%init(mf6_input, modelname, modelfname, & - source, iperblock, iout) + ! -- initialize base loader + call this%DynamicPkgLoadType%init(mf6_input, component_name, & + component_input_name, input_name, & + iperblock, iout) ! + ! -- allocate scalars call mem_allocate(this%iper, 'IPER', this%mf6_input%mempath) call mem_allocate(this%ionper, 'IONPER', this%mf6_input%mempath) ! + ! -- initialize package + nullify (this%rp_loader) this%iper = 0 this%ionper = 0 ! + ! -- open input file + inunit = open_mf6file(mf6_input%pkgtype, input_name, & + component_input_name, iout) + ! + ! -- allocate and initialize parser + allocate (this%parser) + call this%parser%Initialize(inunit, iout) + ! ! -- allocate and initialize loader call this%create_loader() ! @@ -240,30 +191,16 @@ subroutine dynamic_init(this, mf6_input, modelname, modelfname, source, & return end subroutine dynamic_init - !> @brief dynamic loader set parser object - !< - subroutine dynamic_set(this, parser) - use InputDefinitionModule, only: InputParamDefinitionType - use DefinitionSelectModule, only: get_param_definition_type - class(Mf6FileDynamicPkgLoadType), intent(inout) :: this - type(BlockParserType), pointer, intent(inout) :: parser - ! - ! -- set the parser - this%parser => parser - ! - ! -- return - return - end subroutine dynamic_set - !> @brief define routine for dynamic loader !< subroutine dynamic_df(this) class(Mf6FileDynamicPkgLoadType), intent(inout) :: this ! - ! -- read first iper - call this%read_ionper() + ! -- invoke loader define + call this%rp_loader%df() ! - call this%block_loader%df() + ! -- read first ionper + call this%read_ionper() ! ! -- return return @@ -274,7 +211,8 @@ end subroutine dynamic_df subroutine dynamic_ad(this) class(Mf6FileDynamicPkgLoadType), intent(inout) :: this ! - call this%block_loader%ad() + ! -- invoke loader advance + call this%rp_loader%ad() ! ! -- return return @@ -285,16 +223,15 @@ end subroutine dynamic_ad subroutine dynamic_rp(this) ! -- modules use TdisModule, only: kper, nper - use MemoryManagerModule, only: mem_setptr ! -- dummy class(Mf6FileDynamicPkgLoadType), intent(inout) :: this - ! -- locals + ! -- local ! ! -- check if ready to load if (this%ionper /= kper) return ! ! -- dynamic load - call this%block_loader%rp(this%parser) + call this%rp_loader%rp(this%parser) ! ! -- update loaded iper this%iper = kper @@ -317,7 +254,7 @@ subroutine dynamic_read_ionper(this) use TdisModule, only: kper, nper ! -- dummy class(Mf6FileDynamicPkgLoadType), intent(inout) :: this - ! -- locals + ! -- local character(len=LINELENGTH) :: line logical(LGP) :: isblockfound integer(I4B) :: ierr @@ -364,29 +301,38 @@ end subroutine dynamic_read_ionper !> @brief allocate a dynamic loader based on load context !< subroutine dynamic_create_loader(this) - use StressListInputModule, only: StressListInputType - use StressGridInputModule, only: StressGridInputType + use Mf6FileGridInputModule, only: BoundGridInputType + use Mf6FileListInputModule, only: BoundListInputType, ListInputType ! -- dummy class(Mf6FileDynamicPkgLoadType), intent(inout) :: this - class(StressListInputType), pointer :: list_loader - class(StressGridInputType), pointer :: grid_loader + class(BoundListInputType), pointer :: bndlist_loader + class(BoundGridInputType), pointer :: bndgrid_loader + class(ListInputType), pointer :: list_loader ! ! -- allocate and set loader - if (this%readasarrays) then - allocate (grid_loader) - this%block_loader => grid_loader + if (this%settings) then + if (this%advanced) then + ! TODO: set error + else + allocate (list_loader) + this%rp_loader => list_loader + end if + else if (this%readasarrays) then + allocate (bndgrid_loader) + this%rp_loader => bndgrid_loader else - allocate (list_loader) - this%block_loader => list_loader + allocate (bndlist_loader) + this%rp_loader => bndlist_loader end if ! ! -- initialize loader - call this%block_loader%init(this%mf6_input, & - this%modelname, & - this%modelfname, & - this%sourcename, & - this%iperblock, & - this%iout) + call this%rp_loader%ainit(this%mf6_input, & + this%component_name, & + this%component_input_name, & + this%input_name, & + this%iperblock, & + this%parser, & + this%iout) ! ! -- return return @@ -395,14 +341,16 @@ end subroutine dynamic_create_loader !> @brief dynamic loader destroy !< subroutine dynamic_destroy(this) + use MemoryManagerModule, only: mem_deallocate class(Mf6FileDynamicPkgLoadType), intent(inout) :: this ! - ! -- deallocate input context - !call this%DynamicPkgLoadType%destroy() - ! ! -- deallocate loader - call this%block_loader%destroy() - deallocate (this%block_loader) + call this%rp_loader%destroy() + deallocate (this%rp_loader) + ! + ! -- deallocate scalars + call mem_deallocate(this%iper) + call mem_deallocate(this%ionper) ! ! -- deallocate parser call this%parser%clear() @@ -419,6 +367,7 @@ end subroutine dynamic_destroy !< function open_mf6file(filetype, filename, component_fname, iout) result(inunit) ! -- modules + use InputOutputModule, only: openfile, getunit ! -- dummy character(len=*), intent(in) :: filetype character(len=*), intent(in) :: filename @@ -426,7 +375,7 @@ function open_mf6file(filetype, filename, component_fname, iout) result(inunit) integer(I4B), intent(in) :: iout ! -- return integer(I4B) :: inunit - ! -- locals + ! -- local ! ! -- initialize inunit = 0 diff --git a/src/Utilities/Idm/mf6blockfile/LoadMf6File.f90 b/src/Utilities/Idm/mf6blockfile/LoadMf6File.f90 index bd33599f244..5220637192b 100644 --- a/src/Utilities/Idm/mf6blockfile/LoadMf6File.f90 +++ b/src/Utilities/Idm/mf6blockfile/LoadMf6File.f90 @@ -1,7 +1,7 @@ !> @brief This module contains the LoadMf6FileModule !! !! This module contains the input data model routines for -!! loading the data from a MODFLOW 6 input file using the +!! loading static data from a MODFLOW 6 input file using the !! block parser. !! !< @@ -10,7 +10,7 @@ module LoadMf6FileModule use KindModule, only: DP, I4B, LGP use SimVariablesModule, only: errmsg use SimModule, only: store_error - use ConstantsModule, only: LINELENGTH, LENMEMPATH, LENVARNAME + use ConstantsModule, only: LINELENGTH, LENVARNAME use BlockParserModule, only: BlockParserType use LayeredArrayReaderModule, only: read_dbl1d_layered, & read_dbl2d_layered, & @@ -29,89 +29,217 @@ module LoadMf6FileModule use ModflowInputModule, only: ModflowInputType, getModflowInput use MemoryManagerModule, only: mem_allocate, mem_setptr use MemoryHelperModule, only: create_mem_path + use StructArrayModule, only: StructArrayType use IdmLoggerModule, only: idm_log_var, idm_log_header, idm_log_close implicit none private - public :: idm_load + public :: LoadMf6FileType + + !> @brief Static parser based input loader + !! + !! This type defines a static input context loader + !! for traditional mf6 ascii input files. + !! + !< + type :: LoadMf6FileType + type(BlockParserType), pointer :: parser !< ascii block parser + integer(I4B), dimension(:), pointer, contiguous :: mshape => null() !< model shape + type(StructArrayType), pointer :: structarray => null() !< structarray for loading list input + type(ModflowInputType) :: mf6_input !< description of input + character(len=LINELENGTH) :: filename !< name of ascii input file + logical(LGP) :: ts_active !< is timeseries active + integer(I4B) :: iout !< inunit for list log + contains + procedure :: load + procedure :: init + procedure :: load_block + procedure :: finalize + procedure :: parse_block + procedure :: block_post_process + procedure :: parse_io_tag + procedure :: parse_keyword_tag + procedure :: parse_tag + procedure :: block_index_dfn + procedure :: parse_structarray_block + end type LoadMf6FileType contains - !> @brief procedure to load a file + !> @brief load all static input blocks !! - !! Use parser to load information from an input file into the __INPUT__ - !! memory context location of the memory manager. + !! Invoke this routine to load all static input blocks + !! in single call. !! !< - subroutine idm_load(parser, mf6_input, iout) - use SimVariablesModule, only: idm_context - use SourceCommonModule, only: set_model_shape, mem_allocate_naux - type(BlockParserType), intent(inout) :: parser !< block parser - type(ModflowInputType), intent(in) :: mf6_input !< ModflowInputType - integer(I4B), intent(in) :: iout !< unit number for output - integer(I4B) :: iblock !< consecutive block number as defined in definition file - character(len=LENMEMPATH) :: componentMemPath - integer(I4B), dimension(:), contiguous, pointer :: mshape => null() - character(len=LINELENGTH) :: filename !< input filename - ! - ! -- model shape memory path - componentMemPath = create_mem_path(component=mf6_input%component_name, & - context=idm_context) - ! - ! -- set filename - inquire (unit=parser%GetUnit(), name=filename) + subroutine load(this, parser, mf6_input, filename, iout) + ! -- modules + use MemoryManagerModule, only: get_isize + ! -- dummy + class(LoadMf6FileType) :: this + type(BlockParserType), target, intent(inout) :: parser + type(ModflowInputType), intent(in) :: mf6_input + character(len=*), intent(in) :: filename + integer(I4B), intent(in) :: iout + ! -- local + integer(I4B) :: iblk ! - ! -- log lst file header - call idm_log_header(mf6_input%component_name, & - mf6_input%subcomponent_name, iout) + ! -- initialize static load + call this%init(parser, mf6_input, filename, iout) ! ! -- process blocks - do iblock = 1, size(mf6_input%block_dfns) + do iblk = 1, size(this%mf6_input%block_dfns) ! ! -- don't load dynamic input data - if (mf6_input%block_dfns(iblock)%blockname == 'PERIOD') exit + if (this%mf6_input%block_dfns(iblk)%blockname == 'PERIOD') exit ! ! -- load the block - call parse_block(parser, mf6_input, iblock, mshape, filename, iout, .false.) - ! - ! -- - call block_post_process(mf6_input, mf6_input%block_dfns(iblock)%blockname, & - mshape, filename) + call this%load_block(iblk) ! end do ! - ! -- close logging statement - call idm_log_close(mf6_input%component_name, & - mf6_input%subcomponent_name, iout) - end subroutine idm_load + ! -- finalize static load + call this%finalize() + ! + ! --return + return + end subroutine load - subroutine block_post_process(mf6_input, blockname, mshape, filename) - use SourceCommonModule, only: set_model_shape, mem_allocate_naux - type(ModflowInputType), intent(in) :: mf6_input !< ModflowInputType - character(len=*), intent(in) :: blockname - integer(I4B), dimension(:), contiguous, pointer, intent(inout) :: mshape + !> @brief init + !! + !! init / finalize are only used when load_block() will be called + !! + !< + subroutine init(this, parser, mf6_input, filename, iout) + ! -- modules + use MemoryManagerModule, only: get_isize + ! -- dummy + class(LoadMf6FileType) :: this + type(BlockParserType), target, intent(inout) :: parser + type(ModflowInputType), intent(in) :: mf6_input character(len=*), intent(in) :: filename + integer(I4B), intent(in) :: iout + ! -- local + integer(I4B) :: isize + ! + this%parser => parser + this%mf6_input = mf6_input + this%filename = filename + this%ts_active = .false. + this%iout = iout + ! + call get_isize('MODEL_SHAPE', mf6_input%component_mempath, isize) + ! + if (isize > 0) then + call mem_setptr(this%mshape, 'MODEL_SHAPE', mf6_input%component_mempath) + end if + ! + ! -- log lst file header + call idm_log_header(this%mf6_input%component_name, & + this%mf6_input%subcomponent_name, this%iout) + ! + ! -- return + return + end subroutine init + + !> @brief load a single block + !! + !! Assumed in order load of single (next) block. If a + !! StructArray object is allocated to load this block + !! it persists until this routine (or finalize) is + !! called again. + !! + !< + subroutine load_block(this, iblk) + ! -- modules + use StructArrayModule, only: destructStructArray + ! -- dummy + class(LoadMf6FileType) :: this + integer(I4B), intent(in) :: iblk + ! -- local + ! + ! -- reset structarray if it was created for previous block + if (associated(this%structarray)) then + ! -- destroy the structured array reader + call destructStructArray(this%structarray) + end if + ! + ! -- load the block + call this%parse_block(iblk, .false.) + ! + ! -- post process block + call this%block_post_process(iblk) + ! + ! --return + return + end subroutine load_block + + !> @brief finalize + !! + !! init / finalize are only used when load_block() will be called + !! + !< + subroutine finalize(this) + ! -- modules + use StructArrayModule, only: destructStructArray + ! -- dummy + class(LoadMf6FileType) :: this + ! -- local + ! + ! -- cleanup + if (associated(this%structarray)) then + ! -- destroy the structured array reader + call destructStructArray(this%structarray) + end if + ! + ! -- close logging block + call idm_log_close(this%mf6_input%component_name, & + this%mf6_input%subcomponent_name, this%iout) + ! + ! -- return + return + end subroutine finalize + + !> @brief Post parse block handling + !! + !< + subroutine block_post_process(this, iblk) + ! -- modules + use MemoryManagerModule, only: get_isize + use SourceCommonModule, only: set_model_shape, mem_allocate_naux + ! -- dummy + class(LoadMf6FileType) :: this + integer(I4B), intent(in) :: iblk + ! -- local type(InputParamDefinitionType), pointer :: idt - integer(I4B) :: iparam + integer(I4B) :: iparam, ts6_size ! - select case (blockname) + select case (this%mf6_input%block_dfns(iblk)%blockname) case ('OPTIONS') ! -- allocate naux and set to 0 if not allocated - do iparam = 1, size(mf6_input%param_dfns) - idt => mf6_input%param_dfns(iparam) + do iparam = 1, size(this%mf6_input%param_dfns) + idt => this%mf6_input%param_dfns(iparam) ! if (idt%blockname == 'OPTIONS' .and. & idt%tagname == 'AUXILIARY') then - call mem_allocate_naux(mf6_input%mempath) + call mem_allocate_naux(this%mf6_input%mempath) exit end if end do + ! + ! -- determine if TS6 files were provided in OPTIONS block + call get_isize('TS6_FILENAME', this%mf6_input%mempath, ts6_size) + ! + if (ts6_size > 0) then + this%ts_active = .true. + end if + ! case ('DIMENSIONS') ! -- set model shape if discretization dimensions have been read - if (mf6_input%pkgtype(1:3) == 'DIS') then - call set_model_shape(mf6_input%pkgtype, filename, & - mf6_input%component_mempath, & - mf6_input%mempath, mshape) + if (this%mf6_input%pkgtype(1:3) == 'DIS') then + call set_model_shape(this%mf6_input%pkgtype, this%filename, & + this%mf6_input%component_mempath, & + this%mf6_input%mempath, this%mshape) end if case default end select @@ -120,24 +248,18 @@ subroutine block_post_process(mf6_input, blockname, mshape, filename) return end subroutine block_post_process - !> @brief procedure to load a block - !! - !! Use parser to load information from a block into the __INPUT__ - !! memory context location of the memory manager. Allow for recursive - !! calls for blocks that may appear multiple times in an input file. + !> @brief parse block !! !< - recursive subroutine parse_block(parser, mf6_input, iblock, mshape, filename, & - iout, recursive_call) + recursive subroutine parse_block(this, iblk, recursive_call) + ! -- modules use MemoryTypeModule, only: MemoryType use MemoryManagerModule, only: get_from_memorylist - type(BlockParserType), intent(inout) :: parser !< block parser - type(ModflowInputType), intent(in) :: mf6_input !< ModflowInputType - integer(I4B), intent(in) :: iblock !< consecutive block number as defined in definition file - integer(I4B), dimension(:), contiguous, pointer, intent(inout) :: mshape !< model shape - character(len=*), intent(in) :: filename !< input filename - integer(I4B), intent(in) :: iout !< unit number for output + ! -- dummy + class(LoadMf6FileType) :: this + integer(I4B), intent(in) :: iblk logical(LGP), intent(in) :: recursive_call !< true if recursive call + ! -- local logical(LGP) :: isblockfound logical(LGP) :: endOfBlock logical(LGP) :: supportOpenClose @@ -146,48 +268,49 @@ recursive subroutine parse_block(parser, mf6_input, iblock, mshape, filename, & type(MemoryType), pointer :: mt ! ! -- disu vertices/cell2d blocks are contingent on NVERT dimension - if (mf6_input%pkgtype == 'DISU6' .and. & - (mf6_input%block_dfns(iblock)%blockname == 'VERTICES' .or. & - mf6_input%block_dfns(iblock)%blockname == 'CELL2D')) then - call get_from_memorylist('NVERT', mf6_input%mempath, mt, found, .false.) + if (this%mf6_input%pkgtype == 'DISU6' .and. & + (this%mf6_input%block_dfns(iblk)%blockname == 'VERTICES' .or. & + this%mf6_input%block_dfns(iblk)%blockname == 'CELL2D')) then + call get_from_memorylist('NVERT', this%mf6_input%mempath, & + mt, found, .false.) if (.not. found) return if (mt%intsclr == 0) return end if ! ! -- block open/close support - supportOpenClose = (mf6_input%block_dfns(iblock)%blockname /= 'GRIDDATA') + supportOpenClose = (this%mf6_input%block_dfns(iblk)%blockname /= 'GRIDDATA') ! ! -- parser search for block - required = mf6_input%block_dfns(iblock)%required .and. .not. recursive_call - call parser%GetBlock(mf6_input%block_dfns(iblock)%blockname, isblockfound, & - ierr, supportOpenClose=supportOpenClose, & - blockRequired=required) + required = this%mf6_input%block_dfns(iblk)%required .and. .not. recursive_call + call this%parser%GetBlock(this%mf6_input%block_dfns(iblk)%blockname, & + isblockfound, ierr, & + supportOpenClose=supportOpenClose, & + blockRequired=required) ! ! -- process block if (isblockfound) then - if (mf6_input%block_dfns(iblock)%aggregate) then + if (this%mf6_input%block_dfns(iblk)%aggregate) then ! ! -- process block recarray type, set of variable 1d/2d types - call parse_structarray_block(parser, mf6_input, iblock, mshape, & - filename, iout) + call this%parse_structarray_block(iblk) + ! else do ! process each line in block - call parser%GetNextLine(endOfBlock) + call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit ! ! -- process line as tag(s) - call parse_tag(parser, mf6_input, iblock, mshape, filename, iout, & - .false.) + call this%parse_tag(iblk, .false.) + ! end do end if end if ! ! -- recurse if block is reloadable and was just read - if (mf6_input%block_dfns(iblock)%block_variable) then + if (this%mf6_input%block_dfns(iblk)%block_variable) then if (isblockfound) then - call parse_block(parser, mf6_input, iblock, mshape, filename, iout, & - .true.) + call this%parse_block(iblk, .true.) end if end if ! @@ -195,67 +318,99 @@ recursive subroutine parse_block(parser, mf6_input, iblock, mshape, filename, & return end subroutine parse_block - subroutine parse_iofile_tag(parser, mf6_input, iblock, mshape, tag, found, & - filename, iout) + subroutine parse_io_tag(this, iblk, pkgtype, which, tag) + ! -- modules + ! -- dummy + class(LoadMf6FileType) :: this + integer(I4B), intent(in) :: iblk + character(len=*), intent(in) :: pkgtype + character(len=*), intent(in) :: which + character(len=*), intent(in) :: tag + ! -- local + type(InputParamDefinitionType), pointer :: idt !< input data type object describing this record + ! + ! -- matches, read and load file name + idt => & + get_param_definition_type(this%mf6_input%param_dfns, & + this%mf6_input%component_type, & + this%mf6_input%subcomponent_type, & + this%mf6_input%block_dfns(iblk)%blockname, & + tag, this%filename) + ! + ! -- load io tag + call load_io_tag(this%parser, idt, this%mf6_input%mempath, which, this%iout) + ! + ! -- return + return + end subroutine parse_io_tag + + subroutine parse_keyword_tag(this, iblk, tag, idt) + ! -- modules use DefinitionSelectModule, only: split_record_definition - type(BlockParserType), intent(inout) :: parser !< block parser - type(ModflowInputType), intent(in) :: mf6_input !< ModflowInputType - integer(I4B), intent(in) :: iblock !< consecutive block number as defined in definition file - integer(I4B), dimension(:), contiguous, pointer, intent(inout) :: mshape !< model shape + ! -- dummy + class(LoadMf6FileType) :: this + integer(I4B), intent(in) :: iblk character(len=LINELENGTH), intent(in) :: tag - logical(LGP), intent(inout) :: found !< file tag was identified and loaded - character(len=*), intent(in) :: filename !< input filename - integer(I4B), intent(in) :: iout !< unit number for output - type(InputParamDefinitionType), pointer :: idt !< input data type object describing this record + type(InputParamDefinitionType), pointer, intent(in) :: idt + ! -- local character(len=40), dimension(:), allocatable :: words integer(I4B) :: nwords character(len=LINELENGTH) :: io_tag + logical(LGP) :: found ! ! -- initialization found = .false. ! - ! -- get tokens in matching definition - call split_record_definition(mf6_input%param_dfns, & - mf6_input%component_type, & - mf6_input%subcomponent_type, & - tag, nwords, words) - ! - ! -- a filein/fileout record tag definition has 4 tokens - if (nwords == 4) then + ! -- if in record tag check and load if input/output file + if (idt%in_record) then ! - ! -- verify third definition token is FILEIN/FILEOUT - if (words(3) == 'FILEIN' .or. words(3) == 'FILEOUT') then - ! - ! -- read 3rd token - call parser%GetStringCaps(io_tag) + ! -- get tokens in matching definition + call split_record_definition(this%mf6_input%param_dfns, & + this%mf6_input%component_type, & + this%mf6_input%subcomponent_type, & + tag, nwords, words) + ! + ! -- a filein/fileout record tag definition has 4 tokens + if (nwords == 4) then ! - ! -- check if 3rd token matches definition - if (.not. (io_tag == words(3))) then - errmsg = 'Expected "'//trim(words(3))//'" following keyword "'// & - trim(tag)//'" but instead found "'//trim(io_tag)//'"' - call store_error(errmsg) - call parser%StoreErrorUnit() - else + ! -- verify third definition token is FILEIN/FILEOUT + if (words(3) == 'FILEIN' .or. words(3) == 'FILEOUT') then ! - ! -- matches, read and load file name - idt => & - get_param_definition_type(mf6_input%param_dfns, & - mf6_input%component_type, & - mf6_input%subcomponent_type, & - mf6_input%block_dfns(iblock)%blockname, & - words(4), filename) + ! -- read 3rd token + call this%parser%GetStringCaps(io_tag) ! - call load_io_tag(parser, idt, mf6_input%mempath, words(3), iout) + ! -- check if 3rd token matches definition + if (io_tag == words(3)) then + call this%parse_io_tag(iblk, words(2), words(3), words(4)) + found = .true. + else + errmsg = 'Expected "'//trim(words(3))//'" following keyword "'// & + trim(tag)//'" but instead found "'//trim(io_tag)//'"' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end if ! - ! -- io tag loaded - found = .true. end if end if + ! + ! -- deallocate words + if (allocated(words)) deallocate (words) + end if + ! + if (.not. found) then + ! -- load standard keyword tag + call load_keyword_type(this%parser, idt, this%mf6_input%mempath, this%iout) + ! + ! -- check/set as dev option + if (idt%tagname(1:4) == 'DEV_' .and. & + this%mf6_input%block_dfns(iblk)%blockname == 'OPTIONS') then + call this%parser%DevOpt() + end if end if ! - ! -- deallocate words - if (allocated(words)) deallocate (words) - end subroutine parse_iofile_tag + ! -- return + return + end subroutine parse_keyword_tag !> @brief load an individual input record into memory !! @@ -264,21 +419,18 @@ end subroutine parse_iofile_tag !! tags are on a single line. !! !< - recursive subroutine parse_tag(parser, mf6_input, iblock, mshape, filename, & - iout, recursive_call) - type(BlockParserType), intent(inout) :: parser !< block parser - type(ModflowInputType), intent(in) :: mf6_input !< ModflowInputType - integer(I4B), intent(in) :: iblock !< consecutive block number as defined in definition file - integer(I4B), dimension(:), contiguous, pointer, intent(inout) :: mshape !< model shape - character(len=*), intent(in) :: filename !< input filename - integer(I4B), intent(in) :: iout !< unit number for output + recursive subroutine parse_tag(this, iblk, recursive_call) + ! -- modules + ! -- dummy + class(LoadMf6FileType) :: this + integer(I4B), intent(in) :: iblk logical(LGP), intent(in) :: recursive_call !< true if recursive call + ! -- local character(len=LINELENGTH) :: tag type(InputParamDefinitionType), pointer :: idt !< input data type object describing this record - logical(LGP) :: found_io_tag ! ! -- read tag name - call parser%GetStringCaps(tag) + call this%parser%GetStringCaps(tag) if (recursive_call) then if (tag == '') then ! no data on line so return @@ -287,100 +439,87 @@ recursive subroutine parse_tag(parser, mf6_input, iblock, mshape, filename, & end if ! ! -- find keyword in input definition - idt => get_param_definition_type(mf6_input%param_dfns, & - mf6_input%component_type, & - mf6_input%subcomponent_type, & - mf6_input%block_dfns(iblock)%blockname, & - tag, filename) + idt => get_param_definition_type(this%mf6_input%param_dfns, & + this%mf6_input%component_type, & + this%mf6_input%subcomponent_type, & + this%mf6_input%block_dfns(iblk)%blockname, & + tag, this%filename) ! ! -- allocate and load data type select case (idt%datatype) case ('KEYWORD') - ! - ! -- initialize, not a filein/fileout tag - found_io_tag = .false. - ! - ! -- if in record tag check and load if input/output file - if (idt%in_record) then - ! - ! -- identify and load the file name - call parse_iofile_tag(parser, mf6_input, iblock, mshape, tag, & - found_io_tag, filename, iout) - end if - ! - if (.not. found_io_tag) then - ! - ! -- load standard keyword tag - call load_keyword_type(parser, idt, mf6_input%mempath, iout) - end if - ! - ! -- check/set as dev option - if (mf6_input%block_dfns(iblock)%blockname == 'OPTIONS' .and. & - idt%tagname(1:4) == 'DEV_') then - call parser%DevOpt() - end if + call this%parse_keyword_tag(iblk, tag, idt) case ('STRING') if (idt%shape == 'NAUX') then - call load_auxvar_names(parser, idt, mf6_input%mempath, iout) + call load_auxvar_names(this%parser, idt, this%mf6_input%mempath, & + this%iout) else - call load_string_type(parser, idt, mf6_input%mempath, iout) + call load_string_type(this%parser, idt, this%mf6_input%mempath, this%iout) end if case ('INTEGER') - call load_integer_type(parser, idt, mf6_input%mempath, iout) + call load_integer_type(this%parser, idt, this%mf6_input%mempath, this%iout) case ('INTEGER1D') - call load_integer1d_type(parser, idt, mf6_input%mempath, mshape, iout) + call load_integer1d_type(this%parser, idt, this%mf6_input%mempath, & + this%mshape, this%iout) case ('INTEGER2D') - call load_integer2d_type(parser, idt, mf6_input%mempath, mshape, iout) + call load_integer2d_type(this%parser, idt, this%mf6_input%mempath, & + this%mshape, this%iout) case ('INTEGER3D') - call load_integer3d_type(parser, idt, mf6_input%mempath, mshape, iout) + call load_integer3d_type(this%parser, idt, this%mf6_input%mempath, & + this%mshape, this%iout) case ('DOUBLE') - call load_double_type(parser, idt, mf6_input%mempath, iout) + call load_double_type(this%parser, idt, this%mf6_input%mempath, this%iout) case ('DOUBLE1D') - call load_double1d_type(parser, idt, mf6_input%mempath, mshape, iout) + call load_double1d_type(this%parser, idt, this%mf6_input%mempath, & + this%mshape, this%iout) case ('DOUBLE2D') - call load_double2d_type(parser, idt, mf6_input%mempath, mshape, iout) + call load_double2d_type(this%parser, idt, this%mf6_input%mempath, & + this%mshape, this%iout) case ('DOUBLE3D') - call load_double3d_type(parser, idt, mf6_input%mempath, mshape, iout) + call load_double3d_type(this%parser, idt, this%mf6_input%mempath, & + this%mshape, this%iout) case default write (errmsg, '(a,a)') 'Failure reading data for tag: ', trim(tag) call store_error(errmsg) - call parser%StoreErrorUnit() + call this%parser%StoreErrorUnit() end select ! ! -- continue line if in same record if (idt%in_record) then ! ! recursively call parse tag again to read rest of line - call parse_tag(parser, mf6_input, iblock, mshape, filename, iout, .true.) + call this%parse_tag(iblk, .true.) end if ! - ! -- + ! -- return return end subroutine parse_tag - function block_index_dfn(mf6_input, iblock, iout) result(idt) - type(ModflowInputType), intent(in) :: mf6_input !< ModflowInputType - integer(I4B), intent(in) :: iblock !< consecutive block number as defined in definition file - integer(I4B), intent(in) :: iout !< unit number for output + function block_index_dfn(this, iblk) result(idt) + ! -- modules + ! -- dummy + class(LoadMf6FileType) :: this + integer(I4B), intent(in) :: iblk + ! -- local type(InputParamDefinitionType) :: idt !< input data type object describing this record character(len=LENVARNAME) :: varname integer(I4B) :: ilen character(len=3) :: block_suffix = 'NUM' ! ! -- assign first column as the block number - ilen = len_trim(mf6_input%block_dfns(iblock)%blockname) + ilen = len_trim(this%mf6_input%block_dfns(iblk)%blockname) ! if (ilen > (LENVARNAME - len(block_suffix))) then varname = & - mf6_input%block_dfns(iblock)% & + this%mf6_input%block_dfns(iblk)% & blockname(1:(LENVARNAME - len(block_suffix)))//block_suffix else - varname = trim(mf6_input%block_dfns(iblock)%blockname)//block_suffix + varname = trim(this%mf6_input%block_dfns(iblk)%blockname)//block_suffix end if ! - idt%component_type = trim(mf6_input%component_type) - idt%subcomponent_type = trim(mf6_input%subcomponent_type) - idt%blockname = trim(mf6_input%block_dfns(iblock)%blockname) + idt%component_type = trim(this%mf6_input%component_type) + idt%subcomponent_type = trim(this%mf6_input%subcomponent_type) + idt%blockname = trim(this%mf6_input%block_dfns(iblk)%blockname) idt%tagname = varname idt%mf6varname = varname idt%datatype = 'INTEGER' @@ -397,37 +536,34 @@ end function block_index_dfn !! vector. !! !< - subroutine parse_structarray_block(parser, mf6_input, iblock, mshape, & - filename, iout) - use StructArrayModule, only: StructArrayType, constructStructArray, & - destructStructArray - type(BlockParserType), intent(inout) :: parser !< block parser - type(ModflowInputType), intent(in) :: mf6_input !< ModflowInputType - integer(I4B), intent(in) :: iblock !< consecutive block number as defined in definition file - integer(I4B), dimension(:), contiguous, pointer, intent(inout) :: mshape !< model shape - character(len=*), intent(in) :: filename !< input filename - integer(I4B), intent(in) :: iout !< unit number for output + subroutine parse_structarray_block(this, iblk) + ! -- modules + use StructArrayModule, only: StructArrayType, constructStructArray + ! -- dummy + class(LoadMf6FileType) :: this + integer(I4B), intent(in) :: iblk + ! -- local type(InputParamDefinitionType), pointer :: idt !< input data type object describing this record type(InputParamDefinitionType), target :: blockvar_idt integer(I4B) :: blocknum, iwords - integer(I4B), pointer :: nrow => null() + integer(I4B), pointer :: nrow integer(I4B) :: nrows, nrowsread integer(I4B) :: icol integer(I4B) :: ncol integer(I4B) :: nwords character(len=16), dimension(:), allocatable :: words - type(StructArrayType), pointer :: struct_array character(len=:), allocatable :: parse_str ! ! -- set input definition for this block - idt => get_aggregate_definition_type(mf6_input%aggregate_dfns, & - mf6_input%component_type, & - mf6_input%subcomponent_type, & - mf6_input%block_dfns(iblock)%blockname) + idt => & + get_aggregate_definition_type(this%mf6_input%aggregate_dfns, & + this%mf6_input%component_type, & + this%mf6_input%subcomponent_type, & + this%mf6_input%block_dfns(iblk)%blockname) ! ! -- if block is reloadable read the block number - if (mf6_input%block_dfns(iblock)%block_variable) then - blocknum = parser%GetInteger() + if (this%mf6_input%block_dfns(iblk)%block_variable) then + blocknum = this%parser%GetInteger() else blocknum = 0 end if @@ -442,16 +578,16 @@ subroutine parse_structarray_block(parser, mf6_input, iblock, mshape, & ! ! -- use shape to set the max num of rows if (idt%shape /= '') then - call mem_setptr(nrow, idt%shape, mf6_input%mempath) + call mem_setptr(nrow, idt%shape, this%mf6_input%mempath) nrows = nrow else nrows = 0 end if ! ! -- create a structured array - struct_array => constructStructArray(mf6_input, ncol, nrows, blocknum, & - mf6_input%mempath, & - mf6_input%component_mempath) + this%structarray => constructStructArray(this%mf6_input, ncol, nrows, & + blocknum, this%mf6_input%mempath, & + this%mf6_input%component_mempath) ! ! -- create structarray vectors for each column do icol = 1, ncol @@ -460,10 +596,10 @@ subroutine parse_structarray_block(parser, mf6_input, iblock, mshape, & if (blocknum > 0) then if (icol == 1) then ! - blockvar_idt = block_index_dfn(mf6_input, iblock, iout) + blockvar_idt = this%block_index_dfn(iblk) idt => blockvar_idt ! - call struct_array%mem_create_vector(icol, idt) + call this%structarray%mem_create_vector(icol, idt) ! ! -- continue as this column managed by internally SA object cycle @@ -478,23 +614,22 @@ subroutine parse_structarray_block(parser, mf6_input, iblock, mshape, & end if ! ! -- set pointer to input definition for this 1d vector - idt => get_param_definition_type(mf6_input%param_dfns, & - mf6_input%component_type, & - mf6_input%subcomponent_type, & - mf6_input%block_dfns(iblock)%blockname, & - words(iwords), filename) + idt => & + get_param_definition_type(this%mf6_input%param_dfns, & + this%mf6_input%component_type, & + this%mf6_input%subcomponent_type, & + this%mf6_input%block_dfns(iblk)%blockname, & + words(iwords), this%filename) ! ! -- allocate variable in memory manager - call struct_array%mem_create_vector(icol, idt) + call this%structarray%mem_create_vector(icol, idt) end do ! ! -- read the structured array - nrowsread = struct_array%read_from_parser(parser, .false., iout) - ! - ! -- destroy the structured array reader - call destructStructArray(struct_array) + nrowsread = this%structarray%read_from_parser(this%parser, this%ts_active, & + this%iout) ! - ! -- + ! -- return return end subroutine parse_structarray_block diff --git a/src/Utilities/Idm/mf6blockfile/StressGridInput.f90 b/src/Utilities/Idm/mf6blockfile/Mf6FileGridInput.f90 similarity index 60% rename from src/Utilities/Idm/mf6blockfile/StressGridInput.f90 rename to src/Utilities/Idm/mf6blockfile/Mf6FileGridInput.f90 index 1cade321848..7779c383995 100644 --- a/src/Utilities/Idm/mf6blockfile/StressGridInput.f90 +++ b/src/Utilities/Idm/mf6blockfile/Mf6FileGridInput.f90 @@ -1,13 +1,13 @@ -!> @brief This module contains the StressGridInputModule +!> @brief This module contains the Mf6FileGridInputModule !! !! This module contains the routines for reading period block !! array based input. !! !< -module StressGridInputModule +module Mf6FileGridInputModule use KindModule, only: I4B, DP, LGP - use ConstantsModule, only: DZERO, IZERO, LINELENGTH, LENMEMPATH, LENVARNAME, & + use ConstantsModule, only: DZERO, IZERO, LINELENGTH, LENVARNAME, & LENTIMESERIESNAME, LENAUXNAME use SimVariablesModule, only: errmsg use SimModule, only: store_error, store_error_filename @@ -16,73 +16,76 @@ module StressGridInputModule use CharacterStringModule, only: CharacterStringType use BlockParserModule, only: BlockParserType use ModflowInputModule, only: ModflowInputType, getModflowInput - use BoundInputContextModule, only: BoundInputContextType + use BoundInputContextModule, only: BoundInputContextType, ReadStateVarType use TimeArraySeriesManagerModule, only: TimeArraySeriesManagerType, & tasmanager_cr use AsciiInputLoadTypeModule, only: AsciiDynamicPkgLoadBaseType + use DynamicParamFilterModule, only: DynamicParamFilterType implicit none private - public :: StressGridInputType - - !> @brief Pointer type for read state variable - !< - type ReadStateVar - integer, pointer :: invar - end type ReadStateVar + public :: BoundGridInputType !> @brief Ascii grid based dynamic loader type !< - type, extends(AsciiDynamicPkgLoadBaseType) :: StressGridInputType + type, extends(AsciiDynamicPkgLoadBaseType) :: BoundGridInputType integer(I4B) :: tas_active !< Are TAS6 inputs defined - integer(I4B) :: nparam !< number of dynamic parameters other than AUX type(CharacterStringType), dimension(:), contiguous, & - pointer :: aux_tasnames => null() !< array of AUXVAR TAS names + pointer :: aux_tasnames !< array of AUXVAR TAS names type(CharacterStringType), dimension(:), contiguous, & - pointer :: param_tasnames => null() !< array of dynamic param TAS names - character(len=LENVARNAME), dimension(:), & - allocatable :: param_names !< dynamic param names - type(ReadStateVar), dimension(:), allocatable :: param_reads !< read states for current load - integer(I4B), dimension(:), allocatable :: idt_idxs !< idt indexes corresponding to dfn param list - type(TimeArraySeriesManagerType), pointer :: tasmanager => null() !< TAS manager object - type(BoundInputContextType) :: bndctx !< boundary package input context + pointer :: param_tasnames !< array of dynamic param TAS names + type(ReadStateVarType), dimension(:), allocatable :: param_reads !< read states for current load + type(TimeArraySeriesManagerType), pointer :: tasmanager !< TAS manager + type(BoundInputContextType) :: bound_context + type(DynamicParamFilterType) :: filter contains - procedure :: init => ingrid_init - procedure :: df => ingrid_df - procedure :: ad => ingrid_ad - procedure :: rp => ingrid_rp - procedure :: destroy => ingrid_destroy - procedure :: reset => ingrid_reset - procedure :: params_alloc => ingrid_params_alloc - procedure :: param_load => ingrid_param_load - procedure :: tas_arrays_alloc => ingrid_tas_arrays_alloc - procedure :: tas_links_create => ingrid_tas_links_create - end type StressGridInputType + procedure :: ainit => bndgrid_init + procedure :: df => bndgrid_df + procedure :: ad => bndgrid_ad + procedure :: rp => bndgrid_rp + procedure :: destroy => bndgrid_destroy + procedure :: reset => bndgrid_reset + procedure :: params_alloc => bndgrid_params_alloc + procedure :: param_load => bndgrid_param_load + procedure :: tas_arrays_alloc => bndgrid_tas_arrays_alloc + procedure :: tas_links_create => bndgrid_tas_links_create + end type BoundGridInputType contains - subroutine ingrid_init(this, mf6_input, modelname, modelfname, & - source, iperblock, iout) + subroutine bndgrid_init(this, mf6_input, component_name, & + component_input_name, input_name, & + iperblock, parser, iout) use MemoryManagerModule, only: get_isize - class(StressGridInputType), intent(inout) :: this + use BlockParserModule, only: BlockParserType + use LoadMf6FileModule, only: LoadMf6FileType + class(BoundGridInputType), intent(inout) :: this type(ModflowInputType), intent(in) :: mf6_input - character(len=*), intent(in) :: modelname - character(len=*), intent(in) :: modelfname - character(len=*), intent(in) :: source + character(len=*), intent(in) :: component_name + character(len=*), intent(in) :: component_input_name + character(len=*), intent(in) :: input_name integer(I4B), intent(in) :: iperblock + type(BlockParserType), pointer, intent(inout) :: parser integer(I4B), intent(in) :: iout + type(LoadMf6FileType) :: loader type(CharacterStringType), dimension(:), pointer, & contiguous :: tas_fnames character(len=LINELENGTH) :: fname integer(I4B) :: tas6_size, n ! - call this%DynamicPkgLoadType%init(mf6_input, modelname, modelfname, & - source, iperblock, iout) + ! -- initialize base type + call this%DynamicPkgLoadType%init(mf6_input, component_name, & + component_input_name, & + input_name, iperblock, iout) ! -- initialize + nullify (this%aux_tasnames) + nullify (this%param_tasnames) this%tas_active = 0 - this%nparam = 0 this%iout = iout ! + ! -- load static input + call loader%load(parser, mf6_input, this%input_name, iout) + ! ! -- create tasmanager allocate (this%tasmanager) call tasmanager_cr(this%tasmanager, modelname=this%mf6_input%component_name, & @@ -106,7 +109,7 @@ subroutine ingrid_init(this, mf6_input, modelname, modelfname, & end if ! ! -- initialize input context memory - call this%bndctx%init(mf6_input, .true.) + call this%bound_context%init(mf6_input, this%readasarrays) ! ! -- allocate dfn params call this%params_alloc() @@ -116,29 +119,30 @@ subroutine ingrid_init(this, mf6_input, modelname, modelfname, & ! ! -- return return - end subroutine ingrid_init + end subroutine bndgrid_init - subroutine ingrid_df(this) + subroutine bndgrid_df(this) ! -- modules - class(StressGridInputType), intent(inout) :: this !< Mf6FileGridInputType + ! -- dummy + class(BoundGridInputType), intent(inout) :: this !< Mf6FileGridInputType ! call this%tasmanager%tasmanager_df() ! ! -- return return - end subroutine ingrid_df + end subroutine bndgrid_df - subroutine ingrid_ad(this) + subroutine bndgrid_ad(this) ! -- modules - class(StressGridInputType), intent(inout) :: this !< Mf6FileGridInputType + class(BoundGridInputType), intent(inout) :: this !< Mf6FileGridInputType ! call this%tasmanager%ad() ! ! -- return return - end subroutine ingrid_ad + end subroutine bndgrid_ad - subroutine ingrid_rp(this, parser) + subroutine bndgrid_rp(this, parser) ! -- modules use MemoryManagerModule, only: mem_setptr use BlockParserModule, only: BlockParserType @@ -147,9 +151,9 @@ subroutine ingrid_rp(this, parser) use ArrayHandlersModule, only: ifind use SourceCommonModule, only: ifind_charstr use IdmLoggerModule, only: idm_log_header, idm_log_close, idm_log_var - class(StressGridInputType), intent(inout) :: this !< Mf6FileGridInputType + class(BoundGridInputType), intent(inout) :: this !< Mf6FileGridInputType type(BlockParserType), pointer, intent(inout) :: parser - ! -- locals + ! -- local logical(LGP) :: endOfBlock character(len=LINELENGTH) :: keyword, param_tag type(InputParamDefinitionType), pointer :: idt @@ -176,7 +180,7 @@ subroutine ingrid_rp(this, parser) call parser%GetStringCaps(param_tag) ! ! -- is param tag an auxvar? - iaux = ifind_charstr(this%bndctx%auxname_cst, param_tag) + iaux = ifind_charstr(this%bound_context%auxname_cst, param_tag) ! ! -- any auvxar corresponds to the definition tag 'AUX' if (iaux > 0) param_tag = 'AUX' @@ -185,7 +189,7 @@ subroutine ingrid_rp(this, parser) idt => get_param_definition_type(this%mf6_input%param_dfns, & this%mf6_input%component_type, & this%mf6_input%subcomponent_type, & - 'PERIOD', param_tag, this%sourcename) + 'PERIOD', param_tag, this%input_name) ! ! -- look for TAS keyword if tas is active if (this%tas_active /= 0) then @@ -228,24 +232,21 @@ subroutine ingrid_rp(this, parser) ! ! -- return return - end subroutine ingrid_rp + end subroutine bndgrid_rp - subroutine ingrid_destroy(this) + subroutine bndgrid_destroy(this) ! -- modules - class(StressGridInputType), intent(inout) :: this !< Mf6FileGridInputType + class(BoundGridInputType), intent(inout) :: this !< Mf6FileGridInputType ! deallocate (this%tasmanager) ! ! -- return return - end subroutine ingrid_destroy + end subroutine bndgrid_destroy - subroutine ingrid_reset(this) + subroutine bndgrid_reset(this) ! -- modules - use MemoryManagerModule, only: mem_deallocate, mem_setptr, get_isize - use InputDefinitionModule, only: InputParamDefinitionType - use DefinitionSelectModule, only: get_param_definition_type - class(StressGridInputType), intent(inout) :: this !< StressGridInputType + class(BoundGridInputType), intent(inout) :: this !< BoundGridInputType integer(I4B) :: n, m ! if (this%tas_active /= 0) then @@ -254,96 +255,65 @@ subroutine ingrid_reset(this) call this%tasmanager%reset(this%mf6_input%subcomponent_name) ! ! -- reinitialize tas name arrays - call this%bndctx%param_init('CHARSTR1D', 'AUXTASNAME', & - this%mf6_input%mempath, this%sourcename) - call this%bndctx%param_init('CHARSTR1D', 'PARAMTASNAME', & - this%mf6_input%mempath, this%sourcename) + call this%bound_context%param_init('CHARSTR1D', 'AUXTASNAME', & + this%input_name) + call this%bound_context%param_init('CHARSTR1D', 'PARAMTASNAME', & + this%input_name) end if ! do n = 1, this%nparam - if (this%param_reads(n)%invar /= 0) then - ! - ! -- reset read state - this%param_reads(n)%invar = 0 - ! - end if + ! -- reset read state + this%param_reads(n)%invar = 0 end do ! ! -- explicitly reset auxvar array each period - do m = 1, this%bndctx%ncpl - do n = 1, this%bndctx%naux - this%bndctx%auxvar(n, m) = DZERO + do m = 1, this%bound_context%ncpl + do n = 1, this%bound_context%naux + this%bound_context%auxvar(n, m) = DZERO end do end do ! ! -- return return - end subroutine ingrid_reset + end subroutine bndgrid_reset - subroutine ingrid_params_alloc(this) + subroutine bndgrid_params_alloc(this) ! -- modules - use MemoryManagerModule, only: mem_allocate - use InputDefinitionModule, only: InputParamDefinitionType - use DefinitionSelectModule, only: get_param_definition_type - use ArrayHandlersModule, only: expandarray ! -- dummy - class(StressGridInputType), intent(inout) :: this !< StressGridInputType - type(InputParamDefinitionType), pointer :: idt - character(len=LENVARNAME), dimension(:), allocatable :: read_state_varnames + class(BoundGridInputType), intent(inout) :: this !< BoundGridInputType + character(len=LENVARNAME) :: rs_varname integer(I4B), pointer :: intvar integer(I4B) :: iparam ! - ! -- allocate period dfn params - call this%bndctx%bound_params_allocate(this%sourcename) + ! -- set in scope param names + call this%filter%init(this%mf6_input, this%readasarrays, & + this%bound_context%naux, & + this%bound_context%inamedbound, & + this%iout) + call this%filter%get_flt_params(this%param_names, this%nparam) ! - ! -- allocate dfn input params - do iparam = 1, size(this%mf6_input%param_dfns) - ! - ! -- assign param definition pointer - idt => this%mf6_input%param_dfns(iparam) - ! - if (idt%blockname == 'PERIOD') then - ! - ! -- store parameter info - if (idt%tagname /= 'AUX') then - this%nparam = this%nparam + 1 - ! - ! -- reallocate param info arrays - call expandarray(this%param_names) - call expandarray(this%idt_idxs) - call expandarray(read_state_varnames) - ! - ! -- internal mf6 param name - this%param_names(this%nparam) = idt%mf6varname - ! -- idt list index of param - this%idt_idxs(this%nparam) = iparam - ! -- allocate and store name of read state variable - read_state_varnames(this%nparam) = & - this%bndctx%allocate_read_state_var(idt%mf6varname) - ! - end if - ! - end if - end do + call this%bound_context%array_params_create(this%param_names, this%nparam, & + this%input_name) + call this%bound_context%enable() ! ! -- allocate and set param_reads pointer array allocate (this%param_reads(this%nparam)) ! ! store read state variable pointers do iparam = 1, this%nparam - call mem_setptr(intvar, read_state_varnames(iparam), this%mf6_input%mempath) + ! -- allocate and store name of read state variable + rs_varname = this%bound_context%rsv_alloc(this%param_names(iparam)) + call mem_setptr(intvar, rs_varname, this%mf6_input%mempath) this%param_reads(iparam)%invar => intvar + this%param_reads(iparam)%invar = 0 end do ! - ! -- cleanup - deallocate (read_state_varnames) - ! ! -- return return - end subroutine ingrid_params_alloc + end subroutine bndgrid_params_alloc - subroutine ingrid_param_load(this, parser, datatype, varname, & - tagname, mempath, iaux) + subroutine bndgrid_param_load(this, parser, datatype, varname, & + tagname, mempath, iaux) ! -- modules use MemoryManagerModule, only: mem_setptr use ArrayHandlersModule, only: ifind @@ -354,14 +324,14 @@ subroutine ingrid_param_load(this, parser, datatype, varname, & use Integer1dReaderModule, only: read_int1d use IdmLoggerModule, only: idm_log_var ! -- dummy - class(StressGridInputType), intent(inout) :: this !< StressGridInputType + class(BoundGridInputType), intent(inout) :: this !< BoundGridInputType type(BlockParserType), intent(in) :: parser character(len=*), intent(in) :: datatype character(len=*), intent(in) :: varname character(len=*), intent(in) :: tagname character(len=*), intent(in) :: mempath integer(I4B), intent(in) :: iaux - ! -- locals + ! -- local integer(I4B), dimension(:), pointer, contiguous :: int1d real(DP), dimension(:), pointer, contiguous :: dbl1d real(DP), dimension(:, :), pointer, contiguous :: dbl2d @@ -388,9 +358,10 @@ subroutine ingrid_param_load(this, parser, datatype, varname, & ! case default ! - call store_error('Programming error. (IDM) unsupported memload & - &data type for param='//trim(tagname)) - call store_error_filename(this%sourcename) + errmsg = 'IDM unimplemented. Mf6FileGridInput::param_load & + &datatype='//trim(datatype) + call store_error(errmsg) + call store_error_filename(this%input_name) ! end select ! @@ -403,27 +374,26 @@ subroutine ingrid_param_load(this, parser, datatype, varname, & ! ! -- return return - end subroutine ingrid_param_load + end subroutine bndgrid_param_load - subroutine ingrid_tas_arrays_alloc(this) + subroutine bndgrid_tas_arrays_alloc(this) ! -- modules use MemoryManagerModule, only: mem_allocate - class(StressGridInputType), intent(inout) :: this !< StressGridInputType + class(BoundGridInputType), intent(inout) :: this !< BoundGridInputType ! ! -- count params other than AUX if (this%tas_active /= 0) then ! - call mem_allocate(this%aux_tasnames, LENTIMESERIESNAME, this%bndctx%naux, & - 'AUXTASNAME', this%mf6_input%mempath) + call mem_allocate(this%aux_tasnames, LENTIMESERIESNAME, & + this%bound_context%naux, 'AUXTASNAME', & + this%mf6_input%mempath) call mem_allocate(this%param_tasnames, LENTIMESERIESNAME, this%nparam, & 'PARAMTASNAME', this%mf6_input%mempath) ! - call this%bndctx%param_init('CHARSTR1D', 'AUXTASNAME', & - this%mf6_input%mempath, & - this%sourcename) - call this%bndctx%param_init('CHARSTR1D', 'PARAMTASNAME', & - this%mf6_input%mempath, & - this%sourcename) + call this%bound_context%param_init('CHARSTR1D', 'AUXTASNAME', & + this%input_name) + call this%bound_context%param_init('CHARSTR1D', 'PARAMTASNAME', & + this%input_name) ! else ! @@ -436,16 +406,17 @@ subroutine ingrid_tas_arrays_alloc(this) ! ! -- return return - end subroutine ingrid_tas_arrays_alloc + end subroutine bndgrid_tas_arrays_alloc ! FLUX and SFAC are handled in model context - subroutine ingrid_tas_links_create(this, inunit) + subroutine bndgrid_tas_links_create(this, inunit) ! -- modules use InputDefinitionModule, only: InputParamDefinitionType + use DefinitionSelectModule, only: get_param_definition_type ! -- dummy - class(StressGridInputType), intent(inout) :: this !< StressGridInputType + class(BoundGridInputType), intent(inout) :: this !< BoundGridInputType integer(I4B), intent(in) :: inunit - ! -- locals + ! -- local type(InputParamDefinitionType), pointer :: idt ! -- non-contiguous beacuse a slice of bound is passed real(DP), dimension(:), pointer :: auxArrayPtr, bndArrayPtr @@ -463,51 +434,46 @@ subroutine ingrid_tas_links_create(this, inunit) convertflux = .false. ! ! Create AUX Time Array Series links - do n = 1, this%bndctx%naux + do n = 1, this%bound_context%naux tas_name = this%aux_tasnames(n) ! if (tas_name /= '') then - ! ! -- set auxvar pointer - auxArrayPtr => this%bndctx%auxvar(n, :) - ! - aux_name = this%bndctx%auxname_cst(n) - ! + auxArrayPtr => this%bound_context%auxvar(n, :) + aux_name = this%bound_context%auxname_cst(n) call this%tasmanager%MakeTasLink(this%mf6_input%subcomponent_name, & - auxArrayPtr, this%bndctx%iprpak, & + auxArrayPtr, this%bound_context%iprpak, & tas_name, aux_name, convertFlux, & nodelist, inunit) end if - ! end do ! ! Create BND Time Array Series links do n = 1, this%nparam - ! ! -- assign param definition pointer - idt => this%mf6_input%param_dfns(this%idt_idxs(n)) + idt => get_param_definition_type(this%mf6_input%param_dfns, & + this%mf6_input%component_type, & + this%mf6_input%subcomponent_type, & + 'PERIOD', this%param_names(n), & + this%input_name) ! if (idt%timeseries) then - ! if (this%param_reads(n)%invar == 2) then tas_name = this%param_tasnames(n) - ! call mem_setptr(bound, idt%mf6varname, this%mf6_input%mempath) - ! ! -- set bound pointer bndArrayPtr => bound(:) - ! call this%tasmanager%MakeTasLink(this%mf6_input%subcomponent_name, & - bndArrayPtr, this%bndctx%iprpak, & + bndArrayPtr, & + this%bound_context%iprpak, & tas_name, idt%mf6varname, & convertFlux, nodelist, inunit) end if end if end do - ! ! -- return return - end subroutine ingrid_tas_links_create + end subroutine bndgrid_tas_links_create -end module StressGridInputModule +end module Mf6FileGridInputModule diff --git a/src/Utilities/Idm/mf6blockfile/Mf6FileListInput.f90 b/src/Utilities/Idm/mf6blockfile/Mf6FileListInput.f90 new file mode 100644 index 00000000000..ce6ab28260e --- /dev/null +++ b/src/Utilities/Idm/mf6blockfile/Mf6FileListInput.f90 @@ -0,0 +1,898 @@ +!> @brief This module contains the Mf6FileListInputModule +!! +!! This module contains the routines for reading period block +!! list based input. +!! +!< +module Mf6FileListInputModule + + use KindModule, only: I4B, DP, LGP + use ConstantsModule, only: DZERO, IZERO, LINELENGTH, LENMEMPATH, LENVARNAME, & + LENTIMESERIESNAME, LENAUXNAME, LENBOUNDNAME, & + LENCOMPONENTNAME + use SimVariablesModule, only: errmsg + use SimModule, only: store_error, count_errors, store_error_unit + use InputOutputModule, only: openfile, getunit + use InputDefinitionModule, only: InputParamDefinitionType + use MemoryManagerModule, only: mem_setptr + use CharacterStringModule, only: CharacterStringType + use ModflowInputModule, only: ModflowInputType, getModflowInput + use TimeSeriesManagerModule, only: TimeSeriesManagerType, tsmanager_cr + use StructArrayModule, only: StructArrayType, constructStructArray, & + destructStructArray + use AsciiInputLoadTypeModule, only: AsciiDynamicPkgLoadBaseType + use BoundInputContextModule, only: BoundInputContextType + use StructVectorModule, only: StructVectorType, TSStringLocType + use DynamicParamFilterModule, only: DynamicParamFilterType + + implicit none + private + public :: BoundListInputType, ListInputType + + !> @brief Abstract base class for ascii list loaders + !! + !! Abstract class with types and routines common to Ascii list + !! based loaders. + !! + !< + type, abstract, extends(AsciiDynamicPkgLoadBaseType) :: ListInputBaseType + integer(I4B) :: ts_active + integer(I4B) :: ibinary + integer(I4B) :: oc_inunit + type(TimeSeriesManagerType), pointer :: tsmanager => null() + type(StructArrayType), pointer :: structarray => null() + type(DynamicParamFilterType) :: filter + contains + procedure :: base_init + procedure :: base_destroy + procedure :: df + procedure :: ad + procedure :: reset + procedure :: read_control_record + end type ListInputBaseType + + !> @brief Non-boundary package list loader. + !! + !! Supports packages such as STO, TVK and TVS. + !! All of these packages contain SETTING dfn types (KEYSTRING + !! datatypes), however in these packages they behave + !! differently than those in advanced packages. + !! + !< + type, extends(ListInputBaseType) :: ListInputType + integer(I4B), pointer :: iprpak => null() ! print input option + type(InputParamDefinitionType), pointer :: setting_idt => null() + type(InputParamDefinitionType), pointer :: setval_idt => null() + contains + procedure :: ainit => list_init + procedure :: rp => list_rp + procedure :: destroy => list_destroy + procedure :: ts_link_bnd => list_ts_link_bnd + procedure :: ts_link_aux => list_ts_link_aux + procedure :: ts_link => list_ts_link + procedure :: ts_update => list_ts_update + procedure :: create_structarray => list_create_structarray + end type ListInputType + + !> @brief Boundary package list loader. + !! + !! Creates boundary input context for a package, + !! (e.g. CHD or MAW) and updates that context in + !! read and prepare (RP) routines. + !! + !< + type, extends(ListInputBaseType) :: BoundListInputType + integer(I4B) :: iboundname + type(BoundInputContextType) :: bound_context + contains + procedure :: ainit => bndlist_init + procedure :: rp => bndlist_rp + procedure :: destroy => bndlist_destroy + procedure :: ts_link_bnd => bndlist_ts_link_bnd + procedure :: ts_link_aux => bndlist_ts_link_aux + procedure :: ts_link => bndlist_ts_link + procedure :: ts_update => bndlist_ts_update + procedure :: create_structarray => bndlist_create_structarray + end type BoundListInputType + +contains + + subroutine bndlist_init(this, mf6_input, component_name, component_input_name, & + input_name, iperblock, parser, iout) + use BlockParserModule, only: BlockParserType + use LoadMf6FileModule, only: LoadMf6FileType + class(BoundListInputType), intent(inout) :: this + type(ModflowInputType), intent(in) :: mf6_input + character(len=*), intent(in) :: component_name + character(len=*), intent(in) :: component_input_name + character(len=*), intent(in) :: input_name + integer(I4B), intent(in) :: iperblock + type(BlockParserType), pointer, intent(inout) :: parser + integer(I4B), intent(in) :: iout + type(LoadMf6FileType) :: loader + character(len=LINELENGTH) :: blockname + integer(I4B) :: iblk + ! + ! -- initialize scalars + this%iboundname = 0 + ! + ! -- initialize base class + call this%base_init(mf6_input, component_name, component_input_name, & + input_name, iperblock, parser, loader, iout) + ! + ! -- initialize package input context + call this%bound_context%init(mf6_input, this%readasarrays) + ! + ! -- load blocks after OPTIONS and DIMENSIONS + do iblk = 1, size(this%mf6_input%block_dfns) + ! + ! -- log block header via loader or directly here? + ! + ! -- set blockname + blockname = this%mf6_input%block_dfns(iblk)%blockname + ! + ! -- base_init loads OPTIONS and DIMENSIONS blocks if defined + if (blockname == 'OPTIONS' .or. blockname == 'DIMENSIONS') cycle + if (blockname == 'PERIOD') exit + ! + ! -- load block + call loader%load_block(iblk) + ! + if (this%mf6_input%block_dfns(iblk)%aggregate) then + if (this%mf6_input%block_dfns(iblk)%timeseries) then + if (this%ts_active > 0) then + call this%ts_update(loader%structarray) + end if + end if + end if + ! + end do + ! + call loader%finalize() + ! + ! -- initialize input param filter + call this%filter%init(this%mf6_input, this%readasarrays, & + this%bound_context%naux, & + this%bound_context%inamedbound, & + this%iout) + ! + ! -- store in scope SA cols for list input + call this%filter%get_flt_params(this%param_names, this%nparam) + ! + ! -- construct and set up the struct array object + call this%create_structarray() + ! + ! -- finalize input context setup + call this%bound_context%enable() + ! + ! -- return + return + end subroutine bndlist_init + + subroutine bndlist_rp(this, parser) + ! -- modules + use BlockParserModule, only: BlockParserType + use StructVectorModule, only: StructVectorType + use IdmLoggerModule, only: idm_log_header, idm_log_close + ! -- dummy + class(BoundListInputType), intent(inout) :: this + type(BlockParserType), pointer, intent(inout) :: parser + ! -- local + logical(LGP) :: ts_active + ! + call this%reset() + ! + call this%read_control_record(parser) + ! + ! -- log lst file header + call idm_log_header(this%mf6_input%component_name, & + this%mf6_input%subcomponent_name, this%iout) + ! + if (this%ibinary == 1) then + ! + this%bound_context%nbound = & + this%structarray%read_from_binary(this%oc_inunit, this%iout) + ! + call parser%terminateblock() + ! + close (this%oc_inunit) + this%ibinary = 0 + this%oc_inunit = 0 + ! + else + ! + ts_active = (this%ts_active /= 0) + ! + this%bound_context%nbound = & + this%structarray%read_from_parser(parser, ts_active, this%iout) + end if + ! + ! update ts links + if (this%ts_active /= 0) then + call this%ts_update(this%structarray) + end if + ! + ! -- close logging statement + call idm_log_close(this%mf6_input%component_name, & + this%mf6_input%subcomponent_name, this%iout) + ! + ! -- return + return + end subroutine bndlist_rp + + subroutine bndlist_destroy(this) + ! -- modules + class(BoundListInputType), intent(inout) :: this !< BoundListInputType + ! + call this%base_destroy() + call this%bound_context%destroy() + ! + ! -- return + return + end subroutine bndlist_destroy + + subroutine bndlist_ts_link_bnd(this, structvector, ts_strloc) + ! -- modules + use TimeSeriesLinkModule, only: TimeSeriesLinkType + use TimeSeriesManagerModule, only: read_value_or_time_series + use StructVectorModule, only: StructVectorType, TSStringLocType + ! -- dummy + class(BoundListInputType), intent(inout) :: this + type(StructVectorType), pointer, intent(in) :: structvector + type(TSStringLocType), pointer, intent(in) :: ts_strloc + ! -- local + real(DP), pointer :: bndElem + type(TimeSeriesLinkType), pointer :: tsLinkBnd + type(StructVectorType), pointer :: sv_bound + character(len=LENBOUNDNAME) :: boundname + ! + nullify (tsLinkBnd) + ! + ! -- set bound element + bndElem => structvector%dbl1d(ts_strloc%row) + ! + ! -- set link + call read_value_or_time_series(ts_strloc%token, ts_strloc%row, & + ts_strloc%structarray_col, bndElem, & + this%mf6_input%subcomponent_name, & + 'BND', this%tsmanager, & + this%bound_context%iprpak, tsLinkBnd) + ! + if (associated(tsLinkBnd)) then + ! + ! -- set variable name + tsLinkBnd%Text = structvector%idt%mf6varname + ! + ! -- set boundname if provided + if (this%bound_context%inamedbound > 0) then + sv_bound => this%structarray%get(this%iboundname) + boundname = sv_bound%charstr1d(ts_strloc%row) + tsLinkBnd%BndName = boundname + end if + end if + ! + ! -- return + return + end subroutine bndlist_ts_link_bnd + + subroutine bndlist_ts_link_aux(this, structvector, ts_strloc) + ! -- modules + use TimeSeriesLinkModule, only: TimeSeriesLinkType + use TimeSeriesManagerModule, only: read_value_or_time_series + use StructVectorModule, only: StructVectorType, TSStringLocType + ! -- dummy + class(BoundListInputType), intent(inout) :: this + type(StructVectorType), pointer, intent(in) :: structvector + type(TSStringLocType), pointer, intent(in) :: ts_strloc + ! -- local + real(DP), pointer :: bndElem + type(TimeSeriesLinkType), pointer :: tsLinkAux + type(StructVectorType), pointer :: sv_bound + character(len=LENBOUNDNAME) :: boundname + ! + nullify (tsLinkAux) + ! + ! -- set bound element + bndElem => structvector%dbl2d(ts_strloc%col, ts_strloc%row) + ! + ! -- set link + call read_value_or_time_series(ts_strloc%token, ts_strloc%row, & + ts_strloc%structarray_col, bndElem, & + this%mf6_input%subcomponent_name, & + 'AUX', this%tsmanager, & + this%bound_context%iprpak, tsLinkAux) + + if (associated(tsLinkAux)) then + ! + ! -- set variable name + tsLinkAux%Text = this%bound_context%auxname_cst(ts_strloc%col) + ! + ! -- set boundname if provided + if (this%bound_context%inamedbound > 0) then + sv_bound => this%structarray%get(this%iboundname) + boundname = sv_bound%charstr1d(ts_strloc%row) + tsLinkAux%BndName = boundname + end if + ! + end if + ! + ! -- return + return + end subroutine bndlist_ts_link_aux + + subroutine bndlist_ts_update(this, structarray) + ! -- modules + use StructVectorModule, only: TSStringLocType + use StructVectorModule, only: StructVectorType + ! -- dummy + class(BoundListInputType), intent(inout) :: this + type(StructArrayType), pointer, intent(inout) :: structarray + ! -- local + integer(I4B) :: n, m + type(TSStringLocType), pointer :: ts_strloc + type(StructVectorType), pointer :: sv + ! + do m = 1, structarray%count() + + sv => structarray%get(m) + + if (sv%idt%timeseries) then + ! + do n = 1, sv%ts_strlocs%count() + ts_strloc => sv%get_ts_strloc(n) + call this%ts_link(sv, ts_strloc) + end do + ! + call sv%clear() + end if + end do + ! + ! -- return + return + end subroutine bndlist_ts_update + + subroutine bndlist_ts_link(this, structvector, ts_strloc) + ! -- modules + use StructVectorModule, only: StructVectorType, TSStringLocType + ! -- dummy + class(BoundListInputType), intent(inout) :: this + type(StructVectorType), pointer, intent(in) :: structvector + type(TSStringLocType), pointer, intent(in) :: ts_strloc + ! -- local + ! + select case (structvector%memtype) + case (2) ! -- dbl1d + ! + call this%ts_link_bnd(structvector, ts_strloc) + ! + case (6) ! -- dbl2d + ! + call this%ts_link_aux(structvector, ts_strloc) + ! + case default + end select + ! + ! -- return + return + end subroutine bndlist_ts_link + + subroutine bndlist_create_structarray(this) + ! -- modules + use InputDefinitionModule, only: InputParamDefinitionType + use DefinitionSelectModule, only: get_param_definition_type + ! -- dummy + class(BoundListInputType), intent(inout) :: this + ! -- local + type(InputParamDefinitionType), pointer :: idt + integer(I4B) :: icol + ! + ! -- construct and set up the struct array object + this%structarray => constructStructArray(this%mf6_input, this%nparam, & + this%bound_context%maxbound, 0, & + this%mf6_input%mempath, & + this%mf6_input%component_mempath) + ! + ! -- set up struct array + do icol = 1, this%nparam + ! + idt => get_param_definition_type(this%mf6_input%param_dfns, & + this%mf6_input%component_type, & + this%mf6_input%subcomponent_type, & + 'PERIOD', & + this%param_names(icol), this%input_name) + ! + ! -- allocate variable in memory manager + call this%structarray%mem_create_vector(icol, idt) + ! + ! -- store boundname index when found + if (idt%mf6varname == 'BOUNDNAME') this%iboundname = icol + ! + end do + ! + ! -- return + return + end subroutine bndlist_create_structarray + + subroutine list_init(this, mf6_input, component_name, component_input_name, & + input_name, iperblock, parser, iout) + use MemoryManagerExtModule, only: mem_set_value + use BlockParserModule, only: BlockParserType + use LoadMf6FileModule, only: LoadMf6FileType + class(ListInputType), intent(inout) :: this + type(ModflowInputType), intent(in) :: mf6_input + character(len=*), intent(in) :: component_name + character(len=*), intent(in) :: component_input_name + character(len=*), intent(in) :: input_name + integer(I4B), intent(in) :: iperblock + type(BlockParserType), pointer, intent(inout) :: parser + integer(I4B), intent(in) :: iout + type(LoadMf6FileType) :: loader + character(len=LINELENGTH) :: blockname + integer(I4B) :: iblk + logical(LGP) :: found + ! + ! -- initialize + nullify (this%setting_idt) + nullify (this%setval_idt) + ! + ! -- allocate and update local iprpak input param + allocate (this%iprpak) + this%iprpak = 0 + call mem_set_value(this%iprpak, 'IPRPAK', this%mf6_input%mempath, found) + ! + ! -- base initializer + call this%base_init(mf6_input, component_name, component_input_name, & + input_name, iperblock, parser, loader, iout) + ! + ! -- load OPTIONS and DIMENSIONS blocks + do iblk = 1, size(this%mf6_input%block_dfns) + ! + ! -- log block header via loader or directly here? + ! + ! -- set blockname + blockname = this%mf6_input%block_dfns(iblk)%blockname + ! + ! -- step 1 loads OPTIONS and DIMENSIONS blocks if defined + if (blockname == 'OPTIONS' .or. blockname == 'DIMENSIONS') cycle + if (blockname == 'PERIOD') exit + ! + ! -- load block + call loader%load_block(iblk) + ! + if (this%mf6_input%block_dfns(iblk)%aggregate) then + if (this%mf6_input%block_dfns(iblk)%timeseries) then + if (this%ts_active > 0) then + !call this%ts_update(loader%structarray) + ! -- TODO error? + end if + end if + end if + ! + end do + ! + call loader%finalize() + ! + ! -- initialize parameter filter object + call this%filter%init(mf6_input, this%readasarrays, 0, 0, iout) + ! + ! -- set SA cols in scope for list input + call this%filter%get_flt_params(this%param_names, this%nparam) + ! + ! -- construct and set up the struct array object + call this%create_structarray() + ! + ! -- return + return + end subroutine list_init + + subroutine list_rp(this, parser) + ! -- modules + use BlockParserModule, only: BlockParserType + use StructVectorModule, only: StructVectorType + ! -- dummy + class(ListInputType), intent(inout) :: this + type(BlockParserType), pointer, intent(inout) :: parser + ! -- local + logical(LGP) :: ts_active + integer(I4B) :: readcnt + ! + call this%reset() + ! + ! + ts_active = (this%ts_active /= 0) + ! + ! + if (this%settings) then + readcnt = this%structarray%read_from_parser_setting(parser, ts_active, & + this%iout) + else + readcnt = this%structarray%read_from_parser(parser, ts_active, 0) + end if + ! + ! update ts links + if (this%ts_active /= 0) then + call this%ts_update() + end if + ! + ! -- return + return + end subroutine list_rp + + subroutine list_destroy(this) + class(ListInputType), intent(inout) :: this + ! + deallocate (this%iprpak) + ! + if (associated(this%setting_idt)) deallocate (this%setting_idt) + if (associated(this%setval_idt)) deallocate (this%setval_idt) + ! + call this%base_destroy() + ! + end subroutine list_destroy + + subroutine list_ts_link_bnd(this, structvector, ts_strloc) + ! -- modules + use TimeSeriesLinkModule, only: TimeSeriesLinkType + use TimeSeriesManagerModule, only: read_value_or_time_series + use StructVectorModule, only: StructVectorType, TSStringLocType + ! -- dummy + class(ListInputType), intent(inout) :: this + type(StructVectorType), pointer, intent(in) :: structvector + type(TSStringLocType), pointer, intent(in) :: ts_strloc + ! -- local + real(DP), pointer :: bndElem + type(TimeSeriesLinkType), pointer :: tsLinkBnd + ! + nullify (tsLinkBnd) + ! + ! -- set bound element + bndElem => structvector%dbl1d(ts_strloc%row) + ! + ! -- set link + call read_value_or_time_series(ts_strloc%token, ts_strloc%row, & + ts_strloc%structarray_col, bndElem, & + this%mf6_input%subcomponent_name, & + 'BND', this%tsmanager, & + this%iprpak, tsLinkBnd) + ! + ! -- return + return + end subroutine list_ts_link_bnd + + subroutine list_ts_link_aux(this, structvector, ts_strloc) + ! -- modules + use TimeSeriesLinkModule, only: TimeSeriesLinkType + use TimeSeriesManagerModule, only: read_value_or_time_series + use StructVectorModule, only: StructVectorType, TSStringLocType + ! -- dummy + class(ListInputType), intent(inout) :: this + type(StructVectorType), pointer, intent(in) :: structvector + type(TSStringLocType), pointer, intent(in) :: ts_strloc + ! -- local + real(DP), pointer :: bndElem + type(TimeSeriesLinkType), pointer :: tsLinkAux + ! + nullify (tsLinkAux) + ! + ! -- set bound element + bndElem => structvector%dbl2d(ts_strloc%col, ts_strloc%row) + ! + ! -- set link + call read_value_or_time_series(ts_strloc%token, ts_strloc%row, & + ts_strloc%structarray_col, bndElem, & + this%mf6_input%subcomponent_name, & + 'AUX', this%tsmanager, & + this%iprpak, tsLinkAux) + ! + ! -- return + return + end subroutine list_ts_link_aux + + subroutine list_ts_link(this, structvector, ts_strloc) + ! -- modules + use StructVectorModule, only: StructVectorType, TSStringLocType + ! -- dummy + class(ListInputType), intent(inout) :: this + type(StructVectorType), pointer, intent(in) :: structvector + type(TSStringLocType), pointer, intent(in) :: ts_strloc + ! -- local + ! + select case (structvector%memtype) + case (2) ! -- dbl1d + ! + call this%ts_link_aux(structvector, ts_strloc) + ! + case (6) ! -- dbl2d + ! + call this%ts_link_bnd(structvector, ts_strloc) + ! + case default + ! TODO: IDM UNIMPLEMENTED + end select + ! + ! -- return + return + end subroutine list_ts_link + + subroutine list_ts_update(this) + ! -- modules + use StructVectorModule, only: TSStringLocType + use StructVectorModule, only: StructVectorType + ! -- dummy + class(ListInputType), intent(inout) :: this + ! -- local + integer(I4B) :: n, m + type(TSStringLocType), pointer :: ts_strloc + type(StructVectorType), pointer :: sv + ! + do m = 1, this%structarray%count() + + sv => this%structarray%get(m) + + if (sv%idt%timeseries) then + ! + do n = 1, sv%ts_strlocs%count() + ts_strloc => sv%get_ts_strloc(n) + call this%ts_link(sv, ts_strloc) + end do + ! + call sv%clear() + end if + end do + ! + ! -- return + return + end subroutine list_ts_update + + subroutine list_create_structarray(this) + ! -- modules + use InputDefinitionModule, only: InputParamDefinitionType + use DefinitionSelectModule, only: get_param_definition_type, & + idt_datatype, idt_copy + ! -- dummy + class(ListInputType), intent(inout) :: this + ! -- local + type(InputParamDefinitionType), pointer :: idt + integer(I4B) :: icol + ! + ! -- construct and set up the struct array object + this%structarray => constructStructArray(this%mf6_input, this%nparam, 0, & ! maxbound + 0, this%mf6_input%mempath, & + this%mf6_input%component_mempath) + ! + ! -- set up struct array + do icol = 1, this%nparam + ! + idt => get_param_definition_type(this%mf6_input%param_dfns, & + this%mf6_input%component_type, & + this%mf6_input%subcomponent_type, & + 'PERIOD', & + this%param_names(icol), this%input_name) + ! -- check for settings dfn types + if (idt_datatype(idt) == 'KEYSTRING') then + ! -- create and store the setting dfn type + this%setting_idt => idt_copy(idt) + this%setting_idt%mf6varname = 'SETTING' + call this%structarray%mem_create_vector(icol, this%setting_idt) + cycle + else if (associated(this%setting_idt)) then + ! -- only create once regardless of number of params + if (.not. associated(this%setval_idt)) then + ! -- create and store the setting value dfn type + this%setval_idt => idt_copy(idt) + this%setval_idt%tagname = 'SETTING_VALUE' + this%setval_idt%mf6varname = 'SETTING_VALUE' + call this%structarray%mem_create_vector(icol, this%setval_idt) + end if + cycle + end if + ! + ! -- allocate variable in memory manager + call this%structarray%mem_create_vector(icol, idt) + ! + end do + ! + ! -- return + return + end subroutine list_create_structarray + + subroutine base_init(this, mf6_input, component_name, component_input_name, & + input_name, iperblock, parser, loader, iout) + use ConstantsModule, only: LENCOMPONENTNAME + use BlockParserModule, only: BlockParserType + use LoadMf6FileModule, only: LoadMf6FileType + use MemoryManagerModule, only: get_isize + use IdmLoggerModule, only: idm_log_header + class(ListInputBaseType), intent(inout) :: this + type(ModflowInputType), intent(in) :: mf6_input + character(len=*), intent(in) :: component_name + character(len=*), intent(in) :: component_input_name + character(len=*), intent(in) :: input_name + integer(I4B), intent(in) :: iperblock + type(BlockParserType), intent(inout) :: parser + type(LoadMf6FileType), intent(inout) :: loader + integer(I4B), intent(in) :: iout + type(CharacterStringType), dimension(:), pointer, & + contiguous :: ts_fnames + character(len=LINELENGTH) :: fname + integer(I4B) :: ts6_size, n + character(len=LINELENGTH) :: blockname + integer(I4B) :: iblk + ! + ! -- init loader + call this%DynamicPkgLoadType%init(mf6_input, component_name, & + component_input_name, input_name, & + iperblock, iout) + ! + ! -- initialize + this%ts_active = 0 + this%ibinary = 0 + this%oc_inunit = 0 + ! + ! -- initialize static loader + call loader%init(parser, mf6_input, this%input_name, iout) + ! + ! -- load OPTIONS and DIMENSIONS blocks + do iblk = 1, size(this%mf6_input%block_dfns) + ! + ! -- set blockname + blockname = this%mf6_input%block_dfns(iblk)%blockname + ! + ! -- step 1 loads OPTIONS and DIMENSIONS blocks if defined + if (blockname /= 'OPTIONS' .and. blockname /= 'DIMENSIONS') exit + ! + ! -- load block + call loader%load_block(iblk) + ! + end do + ! + ! -- create tsmanager + allocate (this%tsmanager) + call tsmanager_cr(this%tsmanager, iout) + ! + ! -- determine if TS6 files were provided in OPTIONS block + call get_isize('TS6_FILENAME', this%mf6_input%mempath, ts6_size) + ! + if (ts6_size > 0) then + ! + this%ts_active = 1 + call mem_setptr(ts_fnames, 'TS6_FILENAME', this%mf6_input%mempath) + ! + do n = 1, size(ts_fnames) + fname = ts_fnames(n) + call this%tsmanager%add_tsfile(fname, GetUnit()) + end do + ! + end if + ! + ! -- define TS manager + call this%tsmanager%tsmanager_df() + ! + ! -- return + return + end subroutine base_init + + subroutine base_destroy(this) + ! -- modules + class(ListInputBaseType), intent(inout) :: this !< ListInputType + ! + deallocate (this%tsmanager) + ! + ! -- deallocate StructArray + call destructStructArray(this%structarray) + ! + ! -- return + return + end subroutine base_destroy + + subroutine df(this) + ! -- modules + ! -- dummy + class(ListInputBaseType), intent(inout) :: this !< ListInputType + ! + ! -- define tsmanager + !call this%tsmanager%tsmanager_df() + ! + ! -- return + return + end subroutine df + + subroutine ad(this) + ! -- modules + class(ListInputBaseType), intent(inout) :: this !< ListInputType + ! + ! -- advance timeseries + call this%tsmanager%ad() + ! + ! -- return + return + end subroutine ad + + subroutine reset(this) + ! -- modules + class(ListInputBaseType), intent(inout) :: this !< ListInputType + ! + ! -- reset tsmanager + call this%tsmanager%reset(this%mf6_input%subcomponent_name) + ! + ! -- return + return + end subroutine reset + + subroutine read_control_record(this, parser) + ! -- modules + use InputOutputModule, only: urword + use OpenSpecModule, only: form, access + use ConstantsModule, only: LINELENGTH + use BlockParserModule, only: BlockParserType + ! -- dummy + class(ListInputBaseType), intent(inout) :: this + type(BlockParserType), intent(inout) :: parser + ! -- local + integer(I4B) :: lloc, istart, istop, idum, inunit, itmp, ierr + integer(I4B) :: nunopn = 99 + character(len=:), allocatable :: line + character(len=LINELENGTH) :: fname + logical :: exists + real(DP) :: r + ! -- formats + character(len=*), parameter :: fmtocne = & + &"('Specified OPEN/CLOSE file ',(A),' does not exist')" + character(len=*), parameter :: fmtobf = & + &"(1X,/1X,'OPENING BINARY FILE ON UNIT ',I0,':',/1X,A)" + ! + inunit = parser%getunit() + ! + ! -- Read to the first non-commented line + lloc = 1 + call parser%line_reader%rdcom(inunit, this%iout, line, ierr) + call urword(line, lloc, istart, istop, 1, idum, r, this%iout, inunit) + ! + if (line(istart:istop) == 'OPEN/CLOSE') then + ! + ! -- get filename + call urword(line, lloc, istart, istop, 0, idum, r, & + this%iout, inunit) + ! + fname = line(istart:istop) + ! + ! -- check to see if file OPEN/CLOSE file exists + inquire (file=fname, exist=exists) + ! + if (.not. exists) then + write (errmsg, fmtocne) line(istart:istop) + call store_error(errmsg) + call store_error('Specified OPEN/CLOSE file does not exist') + call store_error_unit(inunit) + end if + ! + ! -- Check for (BINARY) keyword + call urword(line, lloc, istart, istop, 1, idum, r, & + this%iout, inunit) + ! + if (line(istart:istop) == '(BINARY)') this%ibinary = 1 + ! + ! -- Open the file depending on ibinary flag + if (this%ibinary == 1) then + this%oc_inunit = nunopn + itmp = this%iout + ! + if (this%iout > 0) then + itmp = 0 + write (this%iout, fmtobf) this%oc_inunit, trim(adjustl(fname)) + end if + ! + call openfile(this%oc_inunit, itmp, fname, 'OPEN/CLOSE', & + fmtarg_opt=form, accarg_opt=access) + end if + end if + ! + if (this%ibinary == 0) then + call parser%line_reader%bkspc(parser%getunit()) + end if + ! + ! -- return + return + end subroutine read_control_record + +end module Mf6FileListInputModule diff --git a/src/Utilities/Idm/mf6blockfile/StressListInput.f90 b/src/Utilities/Idm/mf6blockfile/StressListInput.f90 deleted file mode 100644 index 8528397ad27..00000000000 --- a/src/Utilities/Idm/mf6blockfile/StressListInput.f90 +++ /dev/null @@ -1,439 +0,0 @@ -!> @brief This module contains the StressListInputModule -!! -!! This module contains the routines for reading period block -!! list based input. -!! -!< -module StressListInputModule - - use KindModule, only: I4B, DP, LGP - use ConstantsModule, only: DZERO, IZERO, LINELENGTH, LENMEMPATH, LENVARNAME, & - LENTIMESERIESNAME, LENAUXNAME, LENBOUNDNAME - use SimVariablesModule, only: errmsg - use SimModule, only: store_error, count_errors, store_error_unit - use InputOutputModule, only: openfile, getunit - use InputDefinitionModule, only: InputParamDefinitionType - use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_setptr - use CharacterStringModule, only: CharacterStringType - use ModflowInputModule, only: ModflowInputType, getModflowInput - use TimeSeriesManagerModule, only: TimeSeriesManagerType, tsmanager_cr - use BoundInputContextModule, only: BoundInputContextType - use StructArrayModule, only: StructArrayType, constructStructArray, & - destructStructArray - use AsciiInputLoadTypeModule, only: AsciiDynamicPkgLoadBaseType - - implicit none - private - public :: StressListInputType - - !> @brief Ascii list based dynamic loader type - !< - type, extends(AsciiDynamicPkgLoadBaseType) :: StressListInputType - integer(I4B) :: ts_active - integer(I4B) :: ibinary - integer(I4B) :: oc_inunit - integer(I4B) :: ncol - integer(I4B) :: iboundname - character(len=LENVARNAME), dimension(:), allocatable :: cols - type(TimeSeriesManagerType), pointer :: tsmanager => null() - type(StructArrayType), pointer :: structarray - type(BoundInputContextType) :: bndctx - contains - procedure :: init => inlist_init - procedure :: df => inlist_df - procedure :: ad => inlist_ad - procedure :: rp => inlist_rp - procedure :: destroy => inlist_destroy - procedure :: reset => inlist_reset - procedure :: ts_link => inlist_ts_link - procedure :: ts_update => inlist_ts_update - procedure :: create_structarray - procedure :: read_control_record - end type StressListInputType - -contains - - subroutine inlist_init(this, mf6_input, modelname, modelfname, & - source, iperblock, iout) - use MemoryManagerModule, only: get_isize - class(StressListInputType), intent(inout) :: this - type(ModflowInputType), intent(in) :: mf6_input - character(len=*), intent(in) :: modelname - character(len=*), intent(in) :: modelfname - character(len=*), intent(in) :: source - integer(I4B), intent(in) :: iperblock - integer(I4B), intent(in) :: iout - type(CharacterStringType), dimension(:), pointer, & - contiguous :: ts_fnames - character(len=LINELENGTH) :: fname - integer(I4B) :: ts6_size, n - ! - call this%DynamicPkgLoadType%init(mf6_input, modelname, modelfname, & - source, iperblock, iout) - ! - ! -- initialize - this%ts_active = 0 - this%ibinary = 0 - this%oc_inunit = 0 - ! - ! -- create tsmanager - allocate (this%tsmanager) - call tsmanager_cr(this%tsmanager, iout) - ! - ! -- determine if TS6 files were provided in OPTIONS block - call get_isize('TS6_FILENAME', this%mf6_input%mempath, ts6_size) - ! - if (ts6_size > 0) then - ! - this%ts_active = 1 - call mem_setptr(ts_fnames, 'TS6_FILENAME', this%mf6_input%mempath) - ! - do n = 1, size(ts_fnames) - fname = ts_fnames(n) - call this%tsmanager%add_tsfile(fname, GetUnit()) - end do - ! - end if - ! - ! -- initialize package input context - call this%bndctx%init(mf6_input, .false.) - ! - ! -- set SA cols in scope for list input - call this%bndctx%filtered_cols(this%cols, this%ncol) - ! - ! -- construct and set up the struct array object - call this%create_structarray() - ! - ! -- finalize input context setup - call this%bndctx%enable() - ! - ! -- return - return - end subroutine inlist_init - - subroutine inlist_df(this) - ! -- modules - class(StressListInputType), intent(inout) :: this !< StressListInputType - ! - ! -- define tsmanager - call this%tsmanager%tsmanager_df() - ! - ! -- return - return - end subroutine inlist_df - - subroutine inlist_ad(this) - ! -- modules - class(StressListInputType), intent(inout) :: this !< StressListInputType - ! - ! -- advance tsmanager - call this%tsmanager%ad() - ! - ! -- return - return - end subroutine inlist_ad - - subroutine inlist_rp(this, parser) - ! -- modules - use BlockParserModule, only: BlockParserType - use StructVectorModule, only: StructVectorType - use IdmLoggerModule, only: idm_log_header, idm_log_close - ! -- dummy - class(StressListInputType), intent(inout) :: this - type(BlockParserType), pointer, intent(inout) :: parser - ! -- locals - logical(LGP) :: ts_active - ! - call this%reset() - ! - call this%read_control_record(parser) - ! - ! -- log lst file header - call idm_log_header(this%mf6_input%component_name, & - this%mf6_input%subcomponent_name, this%iout) - ! - if (this%ibinary == 1) then - ! - this%bndctx%nbound = & - this%structarray%read_from_binary(this%oc_inunit, this%iout) - ! - call parser%terminateblock() - ! - close (this%oc_inunit) - this%ibinary = 0 - this%oc_inunit = 0 - ! - else - ! - ts_active = (this%ts_active /= 0) - ! - this%bndctx%nbound = & - this%structarray%read_from_parser(parser, & - ts_active, this%iout) - end if - ! - ! update ts links - if (this%ts_active /= 0) then - call this%ts_update() - end if - ! - ! -- close logging statement - call idm_log_close(this%mf6_input%component_name, & - this%mf6_input%subcomponent_name, this%iout) - ! - ! -- return - return - end subroutine inlist_rp - - subroutine inlist_destroy(this) - ! -- modules - class(StressListInputType), intent(inout) :: this !< StressListInputType - ! - deallocate (this%cols) - deallocate (this%tsmanager) - call destructStructArray(this%structarray) - call this%bndctx%destroy() - ! - ! -- return - return - end subroutine inlist_destroy - - subroutine inlist_reset(this) - ! -- modules - class(StressListInputType), intent(inout) :: this !< StressListInputType - ! - ! -- reset tsmanager - call this%tsmanager%reset(this%mf6_input%subcomponent_name) - ! - ! -- return - return - end subroutine inlist_reset - - subroutine inlist_ts_link(this, structvector, ts_strloc) - ! -- modules - use TimeSeriesLinkModule, only: TimeSeriesLinkType - use TimeSeriesManagerModule, only: read_value_or_time_series - use StructVectorModule, only: StructVectorType, TSStringLocType - !use ArrayHandlersModule, only: ifind - ! -- dummy - class(StressListInputType), intent(inout) :: this - type(StructVectorType), pointer, intent(in) :: structvector - type(TSStringLocType), pointer, intent(in) :: ts_strloc - ! -- locals - real(DP), pointer :: bndElem => null() - type(TimeSeriesLinkType), pointer :: tsLinkBnd => null() - type(TimeSeriesLinkType), pointer :: tsLinkAux => null() - type(StructVectorType), pointer :: sv_bound - character(len=LENBOUNDNAME) :: boundname - ! - select case (structvector%memtype) - case (2) - ! - tsLinkBnd => NULL() - ! - ! -- set bound element - bndElem => structvector%dbl1d(ts_strloc%row) - ! - ! -- set link - call read_value_or_time_series(ts_strloc%token, ts_strloc%row, & - ts_strloc%structarray_col, bndElem, & - this%mf6_input%subcomponent_name, & - 'BND', this%tsmanager, & - this%bndctx%iprpak, tsLinkBnd) - ! - if (associated(tsLinkBnd)) then - ! - ! -- set variable name - tsLinkBnd%Text = structvector%idt%mf6varname - ! - ! -- set boundname if provided - if (this%bndctx%inamedbound > 0) then - sv_bound => this%structarray%get(this%iboundname) - boundname = sv_bound%charstr1d(ts_strloc%row) - tsLinkBnd%BndName = boundname - end if - - ! Flux is handled from model context - - end if - ! - case (6) - ! - tsLinkAux => NULL() - ! - ! -- set bound element - bndElem => structvector%dbl2d(ts_strloc%col, ts_strloc%row) - ! - ! -- set link - call read_value_or_time_series(ts_strloc%token, ts_strloc%row, & - ts_strloc%structarray_col, bndElem, & - this%mf6_input%subcomponent_name, & - 'AUX', this%tsmanager, & - this%bndctx%iprpak, tsLinkAux) - - if (associated(tsLinkAux)) then - ! - ! -- set variable name - tsLinkAux%Text = this%bndctx%auxname_cst(ts_strloc%col) - ! - ! -- set boundname if provided - if (this%bndctx%inamedbound > 0) then - sv_bound => this%structarray%get(this%iboundname) - boundname = sv_bound%charstr1d(ts_strloc%row) - tsLinkAux%BndName = boundname - end if - ! - end if - ! - case default - end select - ! - ! -- return - return - end subroutine inlist_ts_link - - subroutine inlist_ts_update(this) - ! -- modules - use StructVectorModule, only: TSStringLocType - use StructVectorModule, only: StructVectorType - ! -- dummy - class(StressListInputType), intent(inout) :: this - ! -- locals - integer(I4B) :: n, m - type(TSStringLocType), pointer :: ts_strloc - type(StructVectorType), pointer :: sv - ! - ! - do m = 1, this%structarray%count() - - sv => this%structarray%get(m) - - if (sv%idt%timeseries) then - ! - do n = 1, sv%ts_strlocs%count() - ts_strloc => sv%get_ts_strloc(n) - call this%ts_link(sv, ts_strloc) - end do - ! - call sv%clear() - end if - end do - ! - ! -- return - return - end subroutine inlist_ts_update - - subroutine create_structarray(this) - ! -- modules - use InputDefinitionModule, only: InputParamDefinitionType - use DefinitionSelectModule, only: get_param_definition_type - ! -- dummy - class(StressListInputType), intent(inout) :: this - ! -- locals - type(InputParamDefinitionType), pointer :: idt - integer(I4B) :: icol - ! - ! -- construct and set up the struct array object - this%structarray => constructStructArray(this%mf6_input, this%ncol, & - this%bndctx%maxbound, 0, & - this%mf6_input%mempath, & - this%mf6_input%component_mempath) - ! - ! -- set up struct array - do icol = 1, this%ncol - ! - idt => get_param_definition_type(this%mf6_input%param_dfns, & - this%mf6_input%component_type, & - this%mf6_input%subcomponent_type, & - 'PERIOD', & - this%cols(icol), this%sourcename) - ! - ! -- allocate variable in memory manager - call this%structarray%mem_create_vector(icol, idt) - ! - ! -- store boundname index when found - if (idt%mf6varname == 'BOUNDNAME') this%iboundname = icol - ! - end do - ! - ! -- return - return - end subroutine create_structarray - - subroutine read_control_record(this, parser) - ! -- modules - use InputOutputModule, only: urword - use OpenSpecModule, only: form, access - use ConstantsModule, only: LINELENGTH - use BlockParserModule, only: BlockParserType - ! -- dummy - class(StressListInputType), intent(inout) :: this - type(BlockParserType), intent(inout) :: parser - ! -- local - integer(I4B) :: lloc, istart, istop, idum, inunit, itmp, ierr - integer(I4B) :: nunopn = 99 - character(len=:), allocatable :: line - character(len=LINELENGTH) :: fname - logical :: exists - real(DP) :: r - ! -- formats - character(len=*), parameter :: fmtocne = & - &"('Specified OPEN/CLOSE file ',(A),' does not exist')" - character(len=*), parameter :: fmtobf = & - &"(1X,/1X,'OPENING BINARY FILE ON UNIT ',I0,':',/1X,A)" - ! - inunit = parser%getunit() - ! - ! -- Read to the first non-commented line - lloc = 1 - call parser%line_reader%rdcom(inunit, this%iout, line, ierr) - call urword(line, lloc, istart, istop, 1, idum, r, this%iout, inunit) - ! - if (line(istart:istop) == 'OPEN/CLOSE') then - ! - ! -- get filename - call urword(line, lloc, istart, istop, 0, idum, r, & - this%iout, inunit) - ! - fname = line(istart:istop) - ! - ! -- check to see if file OPEN/CLOSE file exists - inquire (file=fname, exist=exists) - ! - if (.not. exists) then - write (errmsg, fmtocne) line(istart:istop) - call store_error(errmsg) - call store_error('Specified OPEN/CLOSE file does not exist') - call store_error_unit(inunit) - end if - ! - ! -- Check for (BINARY) keyword - call urword(line, lloc, istart, istop, 1, idum, r, & - this%iout, inunit) - ! - if (line(istart:istop) == '(BINARY)') this%ibinary = 1 - ! - ! -- Open the file depending on ibinary flag - if (this%ibinary == 1) then - this%oc_inunit = nunopn - itmp = this%iout - ! - if (this%iout > 0) then - itmp = 0 - write (this%iout, fmtobf) this%oc_inunit, trim(adjustl(fname)) - end if - ! - call openfile(this%oc_inunit, itmp, fname, 'OPEN/CLOSE', & - fmtarg_opt=form, accarg_opt=access) - end if - end if - ! - if (this%ibinary == 0) then - call parser%line_reader%bkspc(parser%getunit()) - end if - ! - ! -- return - return - end subroutine read_control_record - -end module StressListInputModule diff --git a/src/Utilities/Idm/mf6blockfile/StructArray.f90 b/src/Utilities/Idm/mf6blockfile/StructArray.f90 index 49befb0b53a..82cb2bd50af 100644 --- a/src/Utilities/Idm/mf6blockfile/StructArray.f90 +++ b/src/Utilities/Idm/mf6blockfile/StructArray.f90 @@ -8,33 +8,37 @@ module StructArrayModule use KindModule, only: I4B, DP, LGP - use ConstantsModule, only: DZERO, IZERO, LINELENGTH, LENMEMPATH, LENVARNAME + use ConstantsModule, only: DZERO, IZERO, DNODATA, INODATA, & + LINELENGTH, LENMEMPATH, LENVARNAME use SimVariablesModule, only: errmsg use SimModule, only: store_error use StructVectorModule, only: StructVectorType use InputDefinitionModule, only: InputParamDefinitionType + use DefinitionSelectModule, only: idt_datatype use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_setptr use CharacterStringModule, only: CharacterStringType use STLVecIntModule, only: STLVecInt use IdmLoggerModule, only: idm_log_var use BlockParserModule, only: BlockParserType use ModflowInputModule, only: ModflowInputType + use ArrayHandlersModule, only: expandarray implicit none private public :: StructArrayType public :: constructStructArray, destructStructArray - !> @brief derived type for structured array + !> @brief type for structured array !! - !! This derived type is used to read and store a - !! list that consists of multiple one-dimensional + !! This type is used to read and store a list + !! that consists of multiple one-dimensional !! vectors. !! !< type StructArrayType integer(I4B) :: ncol integer(I4B) :: nrow + integer(I4B) :: ntags integer(I4B) :: blocknum logical(LGP) :: deferred_shape = .false. integer(I4B) :: deferred_size_init = 5 @@ -43,6 +47,7 @@ module StructArrayModule type(StructVectorType), dimension(:), allocatable :: struct_vectors integer(I4B), dimension(:), allocatable :: startidx integer(I4B), dimension(:), allocatable :: numcols + character(len=LINELENGTH), dimension(:), allocatable :: tagnames type(ModflowInputType) :: mf6_input contains procedure :: mem_create_vector @@ -53,10 +58,13 @@ module StructArrayModule procedure :: allocate_charstr_type procedure :: allocate_int1d_type procedure :: allocate_dbl1d_type + procedure :: write_struct_vector procedure :: read_from_parser procedure :: read_from_binary + procedure :: read_from_parser_setting procedure :: memload_vectors procedure :: load_deferred_vector + procedure :: reset_deferred_vector procedure :: log_structarray_vars procedure :: check_reallocate @@ -91,6 +99,8 @@ function constructStructArray(mf6_input, ncol, nrow, blocknum, mempath, & struct_array%deferred_shape = .true. end if ! + struct_array%ntags = 0 + ! ! -- set blocknum if (blocknum > 0) then struct_array%blocknum = blocknum @@ -113,6 +123,8 @@ end function constructStructArray subroutine destructStructArray(struct_array) type(StructArrayType), pointer, intent(inout) :: struct_array !< StructArrayType to destroy + ! TODO: add sv destroy routine to call mem_deallocate + ! iterate through here deallocate (struct_array%struct_vectors) deallocate (struct_array%startidx) deallocate (struct_array%numcols) @@ -134,6 +146,10 @@ subroutine mem_create_vector(this, icol, idt) sv%idt => idt sv%icol = icol ! + this%ntags = this%ntags + 1 + call expandarray(this%tagnames) + this%tagnames(this%ntags) = idt%tagname + ! ! -- set size if (this%deferred_shape) then sv%size = this%deferred_size_init @@ -168,6 +184,14 @@ subroutine mem_create_vector(this, icol, idt) call this%allocate_dbl1d_type(sv) numcol = sv%intshape ! + case default + if (idt_datatype(idt) == 'KEYSTRING') then + call this%allocate_charstr_type(sv) + else + errmsg = 'IDM unimplemented. StructArray::mem_create_vector & + &type='//trim(idt%datatype) + call store_error(errmsg, .true.) + end if end select ! ! -- set the object in the Struct Array @@ -209,18 +233,20 @@ subroutine allocate_int_type(this, sv) class(StructArrayType) :: this !< StructArrayType type(StructVectorType), intent(inout) :: sv integer(I4B), dimension(:), pointer, contiguous :: int1d - integer(I4B) :: j + integer(I4B) :: j, nrow ! if (this%deferred_shape) then ! -- shape not known, allocate locally + nrow = this%deferred_size_init allocate (int1d(this%deferred_size_init)) else ! -- shape known, allocate in managed memory + nrow = this%nrow call mem_allocate(int1d, this%nrow, sv%idt%mf6varname, this%mempath) end if ! ! -- initialize vector values - do j = 1, this%nrow + do j = 1, nrow int1d(j) = IZERO end do ! @@ -237,17 +263,20 @@ subroutine allocate_dbl_type(this, sv) class(StructArrayType) :: this !< StructArrayType type(StructVectorType), intent(inout) :: sv real(DP), dimension(:), pointer, contiguous :: dbl1d - integer(I4B) :: j + integer(I4B) :: j, nrow ! if (this%deferred_shape) then ! -- shape not known, allocate locally + nrow = this%deferred_size_init allocate (dbl1d(this%deferred_size_init)) else ! -- shape known, allocate in managed memory + nrow = this%nrow call mem_allocate(dbl1d, this%nrow, sv%idt%mf6varname, this%mempath) end if ! - do j = 1, this%nrow + ! -- initialize + do j = 1, nrow dbl1d(j) = DZERO end do ! @@ -299,6 +328,7 @@ subroutine allocate_int1d_type(this, sv) character(len=LENMODELNAME) :: mname type(CharacterStringType), dimension(:), contiguous, & pointer :: charstr1d + integer(I4B) :: nrow, n, m ! if (sv%idt%shape == 'NCELLDIM') then ! @@ -330,15 +360,22 @@ subroutine allocate_int1d_type(this, sv) ! if (this%deferred_shape) then ! -- shape not known, allocate locally + nrow = this%deferred_size_init allocate (int2d(ncelldim, this%deferred_size_init)) + ! else ! -- shape known, allocate in managed memory + nrow = this%nrow call mem_allocate(int2d, ncelldim, this%nrow, & sv%idt%mf6varname, this%mempath) end if ! ! -- initialize - int2d = IZERO + do m = 1, nrow + do n = 1, ncelldim + int2d(n, m) = IZERO + end do + end do ! sv%memtype = 5 sv%int2d => int2d @@ -372,7 +409,7 @@ subroutine allocate_dbl1d_type(this, sv) type(StructVectorType), intent(inout) :: sv real(DP), dimension(:, :), pointer, contiguous :: dbl2d integer(I4B), pointer :: naux, nseg, nseg_1 - integer(I4B) :: nseg1_isize + integer(I4B) :: nseg1_isize, n, m ! if (sv%idt%shape == 'NAUX') then call mem_setptr(naux, sv%idt%shape, this%mempath) @@ -380,7 +417,11 @@ subroutine allocate_dbl1d_type(this, sv) call mem_allocate(dbl2d, naux, this%nrow, sv%idt%mf6varname, this%mempath) ! ! -- initialize - dbl2d = DZERO + do m = 1, this%nrow + do n = 1, naux + dbl2d(n, m) = DZERO + end do + end do ! sv%memtype = 6 sv%dbl2d => dbl2d @@ -401,15 +442,19 @@ subroutine allocate_dbl1d_type(this, sv) call mem_allocate(dbl2d, nseg_1, this%nrow, sv%idt%mf6varname, this%mempath) ! ! -- initialize - dbl2d = DZERO + do m = 1, this%nrow + do n = 1, nseg_1 + dbl2d(n, m) = DZERO + end do + end do ! sv%memtype = 6 sv%dbl2d => dbl2d sv%intshape => nseg_1 ! else - errmsg = 'Programming error. IDM SA 2d real input param unsupported & - &shape "'//trim(sv%idt%shape)//'".' + errmsg = 'IDM unimplemented. StructArray::allocate_dbl1d_type & + & unsupported shape "'//trim(sv%idt%shape)//'".' call store_error(errmsg, terminate=.TRUE.) end if ! @@ -427,6 +472,7 @@ subroutine load_deferred_vector(this, icol) real(DP), dimension(:), pointer, contiguous :: p_dbl1d type(CharacterStringType), dimension(:), pointer, contiguous :: p_charstr1d character(len=LENVARNAME) :: varname + integer(I4B) :: dim_size ! ! -- set varname varname = this%struct_vectors(icol)%idt%mf6varname @@ -439,7 +485,7 @@ subroutine load_deferred_vector(this, icol) ! case (1) ! -- memtype integer ! - if (isize > 0) then + if (isize > -1) then ! -- variable exists, reallocate and append call mem_setptr(p_int1d, varname, this%mempath) ! -- Currently deferred vectors are appended to managed @@ -470,20 +516,30 @@ subroutine load_deferred_vector(this, icol) ! case (2) ! -- memtype real ! - call mem_allocate(p_dbl1d, this%nrow, varname, this%mempath) - ! - do i = 1, this%nrow - p_dbl1d(i) = this%struct_vectors(icol)%dbl1d(i) - end do + if (isize > -1) then + call mem_setptr(p_dbl1d, varname, this%mempath) + call mem_reallocate(p_dbl1d, this%nrow + isize, varname, & + this%mempath) + ! + do i = 1, this%nrow + p_dbl1d(isize + i) = this%struct_vectors(icol)%dbl1d(i) + end do + else + call mem_allocate(p_dbl1d, this%nrow, varname, this%mempath) + ! + do i = 1, this%nrow + p_dbl1d(i) = this%struct_vectors(icol)%dbl1d(i) + end do + end if ! deallocate (this%struct_vectors(icol)%dbl1d) ! - ! -- this%struct_vectors(icol)%dbl1d => p_dbl1d this%struct_vectors(icol)%size = this%nrow ! case (3) ! -- memtype charstring - if (isize > 0) then + ! + if (isize > -1) then call mem_setptr(p_charstr1d, varname, this%mempath) call mem_reallocate(p_charstr1d, LINELENGTH, this%nrow + isize, varname, & this%mempath) @@ -503,17 +559,34 @@ subroutine load_deferred_vector(this, icol) ! deallocate (this%struct_vectors(icol)%charstr1d) ! + this%struct_vectors(icol)%charstr1d => p_charstr1d + this%struct_vectors(icol)%size = this%nrow + ! case (4) ! -- memtype intvector ! no-op case (5) - call mem_allocate(p_int2d, this%struct_vectors(icol)%intshape, this%nrow, & - varname, this%mempath) - ! - do i = 1, this%nrow - do j = 1, this%struct_vectors(icol)%intshape - p_int2d(j, i) = this%struct_vectors(icol)%int2d(j, i) + if (isize > -1) then + call mem_setptr(p_int2d, varname, this%mempath) + call mem_reallocate(p_int2d, this%struct_vectors(icol)%intshape, & + this%nrow, varname, this%mempath) + + !dim1_size = size(, 1) + dim_size = size(this%struct_vectors(icol)%int2d, dim=2) + do i = 1, this%nrow + do j = 1, this%struct_vectors(icol)%intshape + p_int2d(j, isize + i) = this%struct_vectors(icol)%int2d(j, i) + end do end do - end do + else + call mem_allocate(p_int2d, this%struct_vectors(icol)%intshape, & + this%nrow, varname, this%mempath) + ! + do i = 1, this%nrow + do j = 1, this%struct_vectors(icol)%intshape + p_int2d(j, i) = this%struct_vectors(icol)%int2d(j, i) + end do + end do + end if ! deallocate (this%struct_vectors(icol)%int2d) ! @@ -522,7 +595,8 @@ subroutine load_deferred_vector(this, icol) ! ! TODO: case (6) case default - errmsg = 'Programming error. IDM load_deferred_vector unsupported memtype.' + errmsg = 'IDM unimplemented. StructArray::load_deferred_vector & + &unsupported memtype.' call store_error(errmsg, terminate=.TRUE.) end select ! @@ -575,6 +649,91 @@ subroutine memload_vectors(this) return end subroutine memload_vectors + subroutine reset_deferred_vector(this, icol) + use MemoryManagerModule, only: get_isize, mem_deallocate + class(StructArrayType) :: this !< StructArrayType + integer(I4B), intent(in) :: icol + integer(I4B) :: isize + integer(I4B), dimension(:), pointer, contiguous :: p_int1d + integer(I4B), dimension(:, :), pointer, contiguous :: p_int2d + real(DP), dimension(:), pointer, contiguous :: p_dbl1d + type(CharacterStringType), dimension(:), pointer, contiguous :: p_charstr1d + character(len=LENVARNAME) :: varname + ! + ! -- set varname + varname = this%struct_vectors(icol)%idt%mf6varname + ! + ! -- check if already mem managed variable + call get_isize(varname, this%mempath, isize) + ! + ! -- allocate and load based on memtype + select case (this%struct_vectors(icol)%memtype) + ! + case (1) ! -- memtype integer + ! + if (isize > -1) then + call mem_reallocate(this%struct_vectors(icol)%int1d, 0, varname, & + this%mempath, copy=.FALSE.) + end if + ! + ! -- allocate local memory + allocate (p_int1d(this%deferred_size_init)) + ! + ! -- update structvector + this%struct_vectors(icol)%int1d => p_int1d + this%struct_vectors(icol)%size = this%deferred_size_init + ! + case (2) ! -- memtype real + ! + if (isize > -1) then + call mem_reallocate(this%struct_vectors(icol)%dbl1d, 0, varname, & + this%mempath, copy=.FALSE.) + end if + ! + allocate (p_dbl1d(this%deferred_size_init)) + ! + this%struct_vectors(icol)%dbl1d => p_dbl1d + this%struct_vectors(icol)%size = this%deferred_size_init + ! + case (3) ! -- memtype charstring + ! + if (isize > -1) then + call mem_reallocate(this%struct_vectors(icol)%charstr1d, LINELENGTH, 0, & + varname, this%mempath, copy=.FALSE.) + end if + ! + allocate (p_charstr1d(this%deferred_size_init)) + ! + this%struct_vectors(icol)%charstr1d => p_charstr1d + this%struct_vectors(icol)%size = this%deferred_size_init + ! + case (4) ! -- memtype intvector + ! no-op + ! + case (5) ! -- memtype int2d + ! + if (isize > -1) then + call mem_reallocate(this%struct_vectors(icol)%int2d, 0, & + 0, varname, this%mempath, copy=.FALSE.) + end if + ! + allocate (p_int2d(this%struct_vectors(icol)%intshape, & + this%deferred_size_init)) + ! + this%struct_vectors(icol)%int2d => p_int2d + this%struct_vectors(icol)%size = this%deferred_size_init + ! + ! TODO: case (6) + case default + errmsg = 'IDM unimplemented. StructArray::reset_deferred_vector & + &unsupported memtype.' + call store_error(errmsg, terminate=.TRUE.) + end select + ! + ! -- return + return + end subroutine reset_deferred_vector + !> @brief log information about the StructArrayType !< subroutine log_structarray_vars(this, iout) @@ -733,9 +892,10 @@ subroutine check_reallocate(this) this%struct_vectors(j)%int2d => p_int2d this%struct_vectors(j)%size = newsize end if - !TODO: case (6) + ! TODO: case (6) case default - errmsg = 'Programming error. IDM check_reallocate unsupported memtype.' + errmsg = 'IDM unimplemented. StructArray::check_reallocate & + &unsupported memtype.' call store_error(errmsg, terminate=.TRUE.) end select end do @@ -744,6 +904,104 @@ subroutine check_reallocate(this) return end subroutine check_reallocate + subroutine write_struct_vector(this, parser, sv_col, irow, timeseries, & + iout, auxcol) + class(StructArrayType) :: this !< StructArrayType + type(BlockParserType), intent(inout) :: parser !< block parser to read from + integer(I4B), intent(in) :: sv_col + integer(I4B), intent(in) :: irow + logical(LGP), intent(in) :: timeseries + integer(I4B), intent(in) :: iout !< unit number for output + integer(I4B), optional, intent(in) :: auxcol + integer(I4B) :: n, intval, numval, icol + character(len=LINELENGTH) :: str + character(len=:), allocatable :: line + logical(LGP) :: preserve_case + ! + select case (this%struct_vectors(sv_col)%memtype) + ! + case (1) ! -- memtype integer + ! + ! -- if reloadable block and first col, store blocknum + if (sv_col == 1 .and. this%blocknum > 0) then + ! -- store blocknum + this%struct_vectors(sv_col)%int1d(irow) = this%blocknum + else + ! -- read and store int + this%struct_vectors(sv_col)%int1d(irow) = parser%GetInteger() + end if + ! + case (2) ! -- memtype real + ! + if (this%struct_vectors(sv_col)%idt%timeseries .and. timeseries) then + call parser%GetString(str) + if (present(auxcol)) then + icol = auxcol + else + icol = 1 + end if + this%struct_vectors(sv_col)%dbl1d(irow) = & + this%struct_vectors(sv_col)%read_token(str, this%startidx(sv_col), & + icol, irow) + else + this%struct_vectors(sv_col)%dbl1d(irow) = parser%GetDouble() + end if + ! + case (3) ! -- memtype charstring + ! + if (this%struct_vectors(sv_col)%idt%shape /= '') then + ! -- if last column with any shape, store rest of line + if (sv_col == this%ncol) then + call parser%GetRemainingLine(line) + this%struct_vectors(sv_col)%charstr1d(irow) = line + deallocate (line) + end if + else + ! + ! -- read string token + preserve_case = (.not. this%struct_vectors(sv_col)%idt%preserve_case) + call parser%GetString(str, preserve_case) + this%struct_vectors(sv_col)%charstr1d(irow) = str + end if + ! + case (4) ! -- memtype intvector + ! + ! -- get shape for this row + numval = this%struct_vectors(sv_col)%intvector_shape(irow) + ! + ! -- read and store row values + do n = 1, numval + intval = parser%GetInteger() + call this%struct_vectors(sv_col)%intvector%push_back(intval) + end do + ! + case (5) ! -- memtype int2d + ! + ! -- read and store row values + do n = 1, this%struct_vectors(sv_col)%intshape + this%struct_vectors(sv_col)%int2d(n, irow) = parser%GetInteger() + end do + ! + case (6) ! -- memtype dbl2d + ! + ! -- read and store row values + do n = 1, this%struct_vectors(sv_col)%intshape + if (this%struct_vectors(sv_col)%idt%timeseries .and. timeseries) then + call parser%GetString(str) + icol = this%startidx(sv_col) + n - 1 + this%struct_vectors(sv_col)%dbl2d(n, irow) = & + this%struct_vectors(sv_col)%read_token(str, icol, n, irow) + else + this%struct_vectors(sv_col)%dbl2d(n, irow) = parser%GetDouble() + end if + end do + ! + end select + ! + ! -- return + return + end subroutine write_struct_vector + !> @brief read from the block parser to fill the StructArrayType !< function read_from_parser(this, parser, timeseries, iout) result(irow) @@ -751,12 +1009,8 @@ function read_from_parser(this, parser, timeseries, iout) result(irow) type(BlockParserType) :: parser !< block parser to read from logical(LGP), intent(in) :: timeseries integer(I4B), intent(in) :: iout !< unit number for output - integer(I4B) :: irow - logical(LGP) :: endOfBlock, preserve_case - integer(I4B) :: j, k - integer(I4B) :: intval, numval - character(len=LINELENGTH) :: str - character(len=:), allocatable :: line + integer(I4B) :: irow, j + logical(LGP) :: endOfBlock ! ! -- initialize index irow irow = 0 @@ -786,80 +1040,8 @@ function read_from_parser(this, parser, timeseries, iout) result(irow) ! -- handle line reads by column memtype do j = 1, this%ncol ! - select case (this%struct_vectors(j)%memtype) - ! - case (1) ! -- memtype integer - ! - ! -- if reloadable block and first col, store blocknum - if (j == 1 .and. this%blocknum > 0) then - ! -- store blocknum - this%struct_vectors(j)%int1d(irow) = this%blocknum - else - ! -- read and store int - this%struct_vectors(j)%int1d(irow) = parser%GetInteger() - end if - ! - case (2) ! -- memtype real - ! - if (this%struct_vectors(j)%idt%timeseries .and. timeseries) then - call parser%GetString(str) - this%struct_vectors(j)%dbl1d(irow) = & - this%struct_vectors(j)%read_token(str, this%startidx(j), 1, irow) - else - this%struct_vectors(j)%dbl1d(irow) = parser%GetDouble() - end if - ! - case (3) ! -- memtype charstring - ! - !if (this%struct_vectors(j)%idt%shape == ':') then - if (this%struct_vectors(j)%idt%shape /= '') then - ! -- if last column with any shape, store rest of line - if (j == this%ncol) then - call parser%GetRemainingLine(line) - this%struct_vectors(j)%charstr1d(irow) = line - deallocate (line) - end if - else - ! - ! -- read string token - preserve_case = (.not. this%struct_vectors(j)%idt%preserve_case) - call parser%GetString(str, preserve_case) - this%struct_vectors(j)%charstr1d(irow) = str - end if - ! - case (4) ! -- memtype intvector - ! - ! -- get shape for this row - numval = this%struct_vectors(j)%intvector_shape(irow) - ! - ! -- read and store row values - do k = 1, numval - intval = parser%GetInteger() - call this%struct_vectors(j)%intvector%push_back(intval) - end do - ! - case (5) ! -- memtype int2d - ! - ! -- read and store row values - do k = 1, this%struct_vectors(j)%intshape - this%struct_vectors(j)%int2d(k, irow) = parser%GetInteger() - end do - ! - case (6) ! -- memtype dbl2d - ! - ! -- read and store row values - do k = 1, this%struct_vectors(j)%intshape - if (this%struct_vectors(j)%idt%timeseries .and. timeseries) then - call parser%GetString(str) - this%struct_vectors(j)%dbl2d(k, irow) = & - this%struct_vectors(j)%read_token(str, this%startidx(j) + k - 1, & - k, irow) - else - this%struct_vectors(j)%dbl2d(k, irow) = parser%GetDouble() - end if - end do - ! - end select + call this%write_struct_vector(parser, j, irow, timeseries, iout) + ! end do end do ! @@ -892,8 +1074,8 @@ function read_from_binary(this, inunit, iout) result(irow) ! -- set error and exit if deferred shape if (this%deferred_shape) then ! - errmsg = 'Programming error. IDM SA deferred shape currently not & - &supported for binary inputs.' + errmsg = 'IDM unimplemented. StructArray::read_from_binary deferred shape & + ¬ supported for binary inputs.' call store_error(errmsg, terminate=.TRUE.) ! end if @@ -918,8 +1100,8 @@ function read_from_binary(this, inunit, iout) result(irow) read (inunit, iostat=ierr) this%struct_vectors(j)%dbl1d(irow) case (3) ! -- memtype charstring ! - errmsg = 'Programming error. IDM SA input string types currently not & - &supported for binary inputs.' + errmsg = 'IDM unimplemented. StructArray::read_from_binary string & + &types not supported for binary inputs.' call store_error(errmsg, terminate=.TRUE.) ! case (4) ! -- memtype intvector @@ -995,4 +1177,119 @@ function read_from_binary(this, inunit, iout) result(irow) return end function read_from_binary + !> @brief read from the block parser to fill the StructArrayType + !< + function read_from_parser_setting(this, parser, timeseries, iout) & + result(irow) + use DefinitionSelectModule, only: get_aggregate_definition_type, & + get_param_definition_type, & + idt_parse_rectype + use ArrayHandlersModule, only: ifind + class(StructArrayType) :: this !< StructArrayType + type(BlockParserType) :: parser !< block parser to read from + logical(LGP), intent(in) :: timeseries + integer(I4B), intent(in) :: iout !< unit number for output + integer(I4B) :: irow + type(InputParamDefinitionType), pointer :: ra_idt + type(InputParamDefinitionType), pointer :: idt + character(len=LINELENGTH), dimension(:), allocatable :: ra_cols + integer(I4B), dimension(:), allocatable :: iparams + integer(I4B) :: icol, iparam, iparam_setval, ra_ncol + logical(LGP) :: endOfBlock + ! + ! -- reset sv arrays if shape deferred + if (this%deferred_shape) then + this%nrow = 0 + do icol = 1, this%ncol + call this%reset_deferred_vector(icol) + end do + end if + ! + ! -- get aggregate param definition for period block + ra_idt => & + get_aggregate_definition_type(this%mf6_input%aggregate_dfns, & + this%mf6_input%component_type, & + this%mf6_input%subcomponent_type, & + 'PERIOD') + ! + ! -- split recarray definition + call idt_parse_rectype(ra_idt, ra_cols, ra_ncol) + ! + ! -- allocate iparams + allocate (iparams(ra_ncol)) + ! + ! -- store tag indexes for columns + do icol = 1, ra_ncol + ! + idt => get_param_definition_type(this%mf6_input%param_dfns, & + this%mf6_input%component_type, & + this%mf6_input%subcomponent_type, & + 'PERIOD', ra_cols(icol), '') + ! + iparam = ifind(this%tagnames, idt%tagname) + iparams(icol) = iparam + ! + end do + ! + ! -- set the SETTING_VALUE col index + iparam_setval = ifind(this%tagnames, 'SETTING_VALUE') + ! + ! -- initialize index irow + irow = 0 + ! + ! -- read entire block + do + ! + ! -- read next line + call parser%GetNextLine(endOfBlock) + ! + if (endOfBlock) then + ! -- no more lines + exit + ! + else if (this%deferred_shape) then + ! + ! -- shape unknown, track lines read + this%nrow = this%nrow + 1 + ! + ! -- check and update memory allocation + call this%check_reallocate() + end if + ! + ! -- update irow index + irow = irow + 1 + ! + ! -- read and load columns + do icol = 1, ra_ncol + ! + call this%write_struct_vector(parser, iparams(icol), irow, & + timeseries, iout) + ! + end do + ! + ! -- read and store the setting value when expected to exist + if (iparam_setval > 0) then + call this%write_struct_vector(parser, iparam_setval, irow, & + timeseries, iout) + end if + ! + ! + end do + ! + ! -- if deferred shape vectors were read, load to input path + call this%memload_vectors() + ! + ! -- log loaded variables + if (iout > 0) then + call this%log_structarray_vars(iout) + end if + ! + ! -- cleanup + if (allocated(ra_cols)) deallocate (ra_cols) + if (allocated(iparams)) deallocate (iparams) + ! + ! -- return + return + end function read_from_parser_setting + end module StructArrayModule diff --git a/src/Utilities/Idm/selector/IdmDfnSelector.f90 b/src/Utilities/Idm/selector/IdmDfnSelector.f90 index 57c272f4c31..fd48ad194fa 100644 --- a/src/Utilities/Idm/selector/IdmDfnSelector.f90 +++ b/src/Utilities/Idm/selector/IdmDfnSelector.f90 @@ -17,6 +17,8 @@ module IdmDfnSelectorModule public :: aggregate_definitions public :: block_definitions public :: idm_multi_package + public :: idm_advanced_package + public :: idm_subpackages public :: idm_integrated public :: idm_component @@ -108,6 +110,52 @@ function idm_multi_package(component, subcomponent) result(multi_package) return end function idm_multi_package + function idm_advanced_package(component, subcomponent) result(advanced_package) + character(len=*), intent(in) :: component + character(len=*), intent(in) :: subcomponent + logical :: advanced_package + select case (component) + case ('GWF') + advanced_package = gwf_idm_advanced_package(subcomponent) + case ('GWT') + advanced_package = gwt_idm_advanced_package(subcomponent) + case ('GWE') + advanced_package = gwe_idm_advanced_package(subcomponent) + case ('EXG') + advanced_package = exg_idm_advanced_package(subcomponent) + case ('SIM') + advanced_package = sim_idm_advanced_package(subcomponent) + case default + call store_error('Idm selector component not found; '//& + &'component="'//trim(component)//& + &'", subcomponent="'//trim(subcomponent)//'".', .true.) + end select + return + end function idm_advanced_package + + function idm_subpackages(component, subcomponent) result(subpackages) + character(len=*), intent(in) :: component + character(len=*), intent(in) :: subcomponent + character(len=16), dimension(:), pointer :: subpackages + select case (component) + case ('GWF') + subpackages => gwf_idm_subpackages(subcomponent) + case ('GWT') + subpackages => gwt_idm_subpackages(subcomponent) + case ('GWE') + subpackages => gwe_idm_subpackages(subcomponent) + case ('EXG') + subpackages => exg_idm_subpackages(subcomponent) + case ('SIM') + subpackages => sim_idm_subpackages(subcomponent) + case default + call store_error('Idm selector component not found; '//& + &'component="'//trim(component)//& + &'", subcomponent="'//trim(subcomponent)//'".', .true.) + end select + return + end function idm_subpackages + function idm_integrated(component, subcomponent) result(integrated) character(len=*), intent(in) :: component character(len=*), intent(in) :: subcomponent diff --git a/src/Utilities/Idm/selector/IdmExgDfnSelector.f90 b/src/Utilities/Idm/selector/IdmExgDfnSelector.f90 index 558a9decc27..df5fa77408c 100644 --- a/src/Utilities/Idm/selector/IdmExgDfnSelector.f90 +++ b/src/Utilities/Idm/selector/IdmExgDfnSelector.f90 @@ -17,6 +17,8 @@ module IdmExgDfnSelectorModule public :: exg_aggregate_definitions public :: exg_block_definitions public :: exg_idm_multi_package + public :: exg_idm_advanced_package + public :: exg_idm_subpackages public :: exg_idm_integrated contains @@ -33,6 +35,12 @@ subroutine set_block_pointer(input_dfn, input_dfn_target) input_dfn => input_dfn_target end subroutine set_block_pointer + subroutine set_subpkg_pointer(subpkg_list, subpkg_list_target) + character(len=16), dimension(:), pointer :: subpkg_list + character(len=16), dimension(:), target :: subpkg_list_target + subpkg_list => subpkg_list_target + end subroutine set_subpkg_pointer + function exg_param_definitions(subcomponent) result(input_definition) character(len=*), intent(in) :: subcomponent type(InputParamDefinitionType), dimension(:), pointer :: input_definition @@ -115,6 +123,45 @@ function exg_idm_multi_package(subcomponent) result(multi_package) return end function exg_idm_multi_package + function exg_idm_advanced_package(subcomponent) result(advanced_package) + character(len=*), intent(in) :: subcomponent + logical :: advanced_package + advanced_package = .false. + select case (subcomponent) + case ('GWFGWF') + advanced_package = exg_gwfgwf_advanced_package + case ('GWFGWT') + advanced_package = exg_gwfgwt_advanced_package + case ('GWFGWE') + advanced_package = exg_gwfgwe_advanced_package + case ('GWTGWT') + advanced_package = exg_gwtgwt_advanced_package + case ('GWEGWE') + advanced_package = exg_gwegwe_advanced_package + case default + end select + return + end function exg_idm_advanced_package + + function exg_idm_subpackages(subcomponent) result(subpackages) + character(len=*), intent(in) :: subcomponent + character(len=16), dimension(:), pointer :: subpackages + select case (subcomponent) + case ('GWFGWF') + call set_subpkg_pointer(subpackages, exg_gwfgwf_subpackages) + case ('GWFGWT') + call set_subpkg_pointer(subpackages, exg_gwfgwt_subpackages) + case ('GWFGWE') + call set_subpkg_pointer(subpackages, exg_gwfgwe_subpackages) + case ('GWTGWT') + call set_subpkg_pointer(subpackages, exg_gwtgwt_subpackages) + case ('GWEGWE') + call set_subpkg_pointer(subpackages, exg_gwegwe_subpackages) + case default + end select + return + end function exg_idm_subpackages + function exg_idm_integrated(subcomponent) result(integrated) character(len=*), intent(in) :: subcomponent logical :: integrated diff --git a/src/Utilities/Idm/selector/IdmGweDfnSelector.f90 b/src/Utilities/Idm/selector/IdmGweDfnSelector.f90 index bbf704b441a..f844bfc3139 100644 --- a/src/Utilities/Idm/selector/IdmGweDfnSelector.f90 +++ b/src/Utilities/Idm/selector/IdmGweDfnSelector.f90 @@ -19,6 +19,8 @@ module IdmGweDfnSelectorModule public :: gwe_aggregate_definitions public :: gwe_block_definitions public :: gwe_idm_multi_package + public :: gwe_idm_advanced_package + public :: gwe_idm_subpackages public :: gwe_idm_integrated contains @@ -35,6 +37,12 @@ subroutine set_block_pointer(input_dfn, input_dfn_target) input_dfn => input_dfn_target end subroutine set_block_pointer + subroutine set_subpkg_pointer(subpkg_list, subpkg_list_target) + character(len=16), dimension(:), pointer :: subpkg_list + character(len=16), dimension(:), target :: subpkg_list_target + subpkg_list => subpkg_list_target + end subroutine set_subpkg_pointer + function gwe_param_definitions(subcomponent) result(input_definition) character(len=*), intent(in) :: subcomponent type(InputParamDefinitionType), dimension(:), pointer :: input_definition @@ -133,6 +141,53 @@ function gwe_idm_multi_package(subcomponent) result(multi_package) return end function gwe_idm_multi_package + function gwe_idm_advanced_package(subcomponent) result(advanced_package) + character(len=*), intent(in) :: subcomponent + logical :: advanced_package + advanced_package = .false. + select case (subcomponent) + case ('DIS') + advanced_package = gwe_dis_advanced_package + case ('DISU') + advanced_package = gwe_disu_advanced_package + case ('DISV') + advanced_package = gwe_disv_advanced_package + case ('CND') + advanced_package = gwe_cnd_advanced_package + case ('CTP') + advanced_package = gwe_ctp_advanced_package + case ('IC') + advanced_package = gwe_ic_advanced_package + case ('NAM') + advanced_package = gwe_nam_advanced_package + case default + end select + return + end function gwe_idm_advanced_package + + function gwe_idm_subpackages(subcomponent) result(subpackages) + character(len=*), intent(in) :: subcomponent + character(len=16), dimension(:), pointer :: subpackages + select case (subcomponent) + case ('DIS') + call set_subpkg_pointer(subpackages, gwe_dis_subpackages) + case ('DISU') + call set_subpkg_pointer(subpackages, gwe_disu_subpackages) + case ('DISV') + call set_subpkg_pointer(subpackages, gwe_disv_subpackages) + case ('CND') + call set_subpkg_pointer(subpackages, gwe_cnd_subpackages) + case ('CTP') + call set_subpkg_pointer(subpackages, gwe_ctp_subpackages) + case ('IC') + call set_subpkg_pointer(subpackages, gwe_ic_subpackages) + case ('NAM') + call set_subpkg_pointer(subpackages, gwe_nam_subpackages) + case default + end select + return + end function gwe_idm_subpackages + function gwe_idm_integrated(subcomponent) result(integrated) character(len=*), intent(in) :: subcomponent logical :: integrated diff --git a/src/Utilities/Idm/selector/IdmGwfDfnSelector.f90 b/src/Utilities/Idm/selector/IdmGwfDfnSelector.f90 index 7cfc9ccd101..c2cff5a44b0 100644 --- a/src/Utilities/Idm/selector/IdmGwfDfnSelector.f90 +++ b/src/Utilities/Idm/selector/IdmGwfDfnSelector.f90 @@ -27,6 +27,8 @@ module IdmGwfDfnSelectorModule public :: gwf_aggregate_definitions public :: gwf_block_definitions public :: gwf_idm_multi_package + public :: gwf_idm_advanced_package + public :: gwf_idm_subpackages public :: gwf_idm_integrated contains @@ -43,6 +45,12 @@ subroutine set_block_pointer(input_dfn, input_dfn_target) input_dfn => input_dfn_target end subroutine set_block_pointer + subroutine set_subpkg_pointer(subpkg_list, subpkg_list_target) + character(len=16), dimension(:), pointer :: subpkg_list + character(len=16), dimension(:), target :: subpkg_list_target + subpkg_list => subpkg_list_target + end subroutine set_subpkg_pointer + function gwf_param_definitions(subcomponent) result(input_definition) character(len=*), intent(in) :: subcomponent type(InputParamDefinitionType), dimension(:), pointer :: input_definition @@ -205,6 +213,85 @@ function gwf_idm_multi_package(subcomponent) result(multi_package) return end function gwf_idm_multi_package + function gwf_idm_advanced_package(subcomponent) result(advanced_package) + character(len=*), intent(in) :: subcomponent + logical :: advanced_package + advanced_package = .false. + select case (subcomponent) + case ('CHD') + advanced_package = gwf_chd_advanced_package + case ('DIS') + advanced_package = gwf_dis_advanced_package + case ('DISU') + advanced_package = gwf_disu_advanced_package + case ('DISV') + advanced_package = gwf_disv_advanced_package + case ('DRN') + advanced_package = gwf_drn_advanced_package + case ('EVT') + advanced_package = gwf_evt_advanced_package + case ('EVTA') + advanced_package = gwf_evta_advanced_package + case ('GHB') + advanced_package = gwf_ghb_advanced_package + case ('IC') + advanced_package = gwf_ic_advanced_package + case ('NPF') + advanced_package = gwf_npf_advanced_package + case ('RCH') + advanced_package = gwf_rch_advanced_package + case ('RCHA') + advanced_package = gwf_rcha_advanced_package + case ('RIV') + advanced_package = gwf_riv_advanced_package + case ('WEL') + advanced_package = gwf_wel_advanced_package + case ('NAM') + advanced_package = gwf_nam_advanced_package + case default + end select + return + end function gwf_idm_advanced_package + + function gwf_idm_subpackages(subcomponent) result(subpackages) + character(len=*), intent(in) :: subcomponent + character(len=16), dimension(:), pointer :: subpackages + select case (subcomponent) + case ('CHD') + call set_subpkg_pointer(subpackages, gwf_chd_subpackages) + case ('DIS') + call set_subpkg_pointer(subpackages, gwf_dis_subpackages) + case ('DISU') + call set_subpkg_pointer(subpackages, gwf_disu_subpackages) + case ('DISV') + call set_subpkg_pointer(subpackages, gwf_disv_subpackages) + case ('DRN') + call set_subpkg_pointer(subpackages, gwf_drn_subpackages) + case ('EVT') + call set_subpkg_pointer(subpackages, gwf_evt_subpackages) + case ('EVTA') + call set_subpkg_pointer(subpackages, gwf_evta_subpackages) + case ('GHB') + call set_subpkg_pointer(subpackages, gwf_ghb_subpackages) + case ('IC') + call set_subpkg_pointer(subpackages, gwf_ic_subpackages) + case ('NPF') + call set_subpkg_pointer(subpackages, gwf_npf_subpackages) + case ('RCH') + call set_subpkg_pointer(subpackages, gwf_rch_subpackages) + case ('RCHA') + call set_subpkg_pointer(subpackages, gwf_rcha_subpackages) + case ('RIV') + call set_subpkg_pointer(subpackages, gwf_riv_subpackages) + case ('WEL') + call set_subpkg_pointer(subpackages, gwf_wel_subpackages) + case ('NAM') + call set_subpkg_pointer(subpackages, gwf_nam_subpackages) + case default + end select + return + end function gwf_idm_subpackages + function gwf_idm_integrated(subcomponent) result(integrated) character(len=*), intent(in) :: subcomponent logical :: integrated diff --git a/src/Utilities/Idm/selector/IdmGwtDfnSelector.f90 b/src/Utilities/Idm/selector/IdmGwtDfnSelector.f90 index f9e71164ffa..dd623402944 100644 --- a/src/Utilities/Idm/selector/IdmGwtDfnSelector.f90 +++ b/src/Utilities/Idm/selector/IdmGwtDfnSelector.f90 @@ -19,6 +19,8 @@ module IdmGwtDfnSelectorModule public :: gwt_aggregate_definitions public :: gwt_block_definitions public :: gwt_idm_multi_package + public :: gwt_idm_advanced_package + public :: gwt_idm_subpackages public :: gwt_idm_integrated contains @@ -35,6 +37,12 @@ subroutine set_block_pointer(input_dfn, input_dfn_target) input_dfn => input_dfn_target end subroutine set_block_pointer + subroutine set_subpkg_pointer(subpkg_list, subpkg_list_target) + character(len=16), dimension(:), pointer :: subpkg_list + character(len=16), dimension(:), target :: subpkg_list_target + subpkg_list => subpkg_list_target + end subroutine set_subpkg_pointer + function gwt_param_definitions(subcomponent) result(input_definition) character(len=*), intent(in) :: subcomponent type(InputParamDefinitionType), dimension(:), pointer :: input_definition @@ -133,6 +141,53 @@ function gwt_idm_multi_package(subcomponent) result(multi_package) return end function gwt_idm_multi_package + function gwt_idm_advanced_package(subcomponent) result(advanced_package) + character(len=*), intent(in) :: subcomponent + logical :: advanced_package + advanced_package = .false. + select case (subcomponent) + case ('DIS') + advanced_package = gwt_dis_advanced_package + case ('DISU') + advanced_package = gwt_disu_advanced_package + case ('DISV') + advanced_package = gwt_disv_advanced_package + case ('DSP') + advanced_package = gwt_dsp_advanced_package + case ('CNC') + advanced_package = gwt_cnc_advanced_package + case ('IC') + advanced_package = gwt_ic_advanced_package + case ('NAM') + advanced_package = gwt_nam_advanced_package + case default + end select + return + end function gwt_idm_advanced_package + + function gwt_idm_subpackages(subcomponent) result(subpackages) + character(len=*), intent(in) :: subcomponent + character(len=16), dimension(:), pointer :: subpackages + select case (subcomponent) + case ('DIS') + call set_subpkg_pointer(subpackages, gwt_dis_subpackages) + case ('DISU') + call set_subpkg_pointer(subpackages, gwt_disu_subpackages) + case ('DISV') + call set_subpkg_pointer(subpackages, gwt_disv_subpackages) + case ('DSP') + call set_subpkg_pointer(subpackages, gwt_dsp_subpackages) + case ('CNC') + call set_subpkg_pointer(subpackages, gwt_cnc_subpackages) + case ('IC') + call set_subpkg_pointer(subpackages, gwt_ic_subpackages) + case ('NAM') + call set_subpkg_pointer(subpackages, gwt_nam_subpackages) + case default + end select + return + end function gwt_idm_subpackages + function gwt_idm_integrated(subcomponent) result(integrated) character(len=*), intent(in) :: subcomponent logical :: integrated diff --git a/src/Utilities/Idm/selector/IdmSimDfnSelector.f90 b/src/Utilities/Idm/selector/IdmSimDfnSelector.f90 index d5701798ccb..6090c51289d 100644 --- a/src/Utilities/Idm/selector/IdmSimDfnSelector.f90 +++ b/src/Utilities/Idm/selector/IdmSimDfnSelector.f90 @@ -14,6 +14,8 @@ module IdmSimDfnSelectorModule public :: sim_aggregate_definitions public :: sim_block_definitions public :: sim_idm_multi_package + public :: sim_idm_advanced_package + public :: sim_idm_subpackages public :: sim_idm_integrated contains @@ -30,6 +32,12 @@ subroutine set_block_pointer(input_dfn, input_dfn_target) input_dfn => input_dfn_target end subroutine set_block_pointer + subroutine set_subpkg_pointer(subpkg_list, subpkg_list_target) + character(len=16), dimension(:), pointer :: subpkg_list + character(len=16), dimension(:), target :: subpkg_list_target + subpkg_list => subpkg_list_target + end subroutine set_subpkg_pointer + function sim_param_definitions(subcomponent) result(input_definition) character(len=*), intent(in) :: subcomponent type(InputParamDefinitionType), dimension(:), pointer :: input_definition @@ -88,6 +96,33 @@ function sim_idm_multi_package(subcomponent) result(multi_package) return end function sim_idm_multi_package + function sim_idm_advanced_package(subcomponent) result(advanced_package) + character(len=*), intent(in) :: subcomponent + logical :: advanced_package + advanced_package = .false. + select case (subcomponent) + case ('NAM') + advanced_package = sim_nam_advanced_package + case ('TDIS') + advanced_package = sim_tdis_advanced_package + case default + end select + return + end function sim_idm_advanced_package + + function sim_idm_subpackages(subcomponent) result(subpackages) + character(len=*), intent(in) :: subcomponent + character(len=16), dimension(:), pointer :: subpackages + select case (subcomponent) + case ('NAM') + call set_subpkg_pointer(subpackages, sim_nam_subpackages) + case ('TDIS') + call set_subpkg_pointer(subpackages, sim_tdis_subpackages) + case default + end select + return + end function sim_idm_subpackages + function sim_idm_integrated(subcomponent) result(integrated) character(len=*), intent(in) :: subcomponent logical :: integrated diff --git a/src/Utilities/Memory/MemoryManager.f90 b/src/Utilities/Memory/MemoryManager.f90 index da17dabe6f4..4c6af4443be 100644 --- a/src/Utilities/Memory/MemoryManager.f90 +++ b/src/Utilities/Memory/MemoryManager.f90 @@ -1175,15 +1175,16 @@ end subroutine checkin_charstr1d !> @brief Reallocate a 1-dimensional defined length string array !< - subroutine reallocate_str1d(astr, ilen, nrow, name, mem_path) + subroutine reallocate_str1d(astr, ilen, nrow, name, mem_path, copy) integer(I4B), intent(in) :: ilen !< string length integer(I4B), intent(in) :: nrow !< number of rows character(len=ilen), dimension(:), pointer, contiguous, intent(inout) :: astr !< the reallocated string array character(len=*), intent(in) :: name !< variable name character(len=*), intent(in) :: mem_path !< path where variable is stored + logical(LGP), optional, intent(in) :: copy !< copy memory from old to new array ! -- local type(MemoryType), pointer :: mt - logical(LGP) :: found + logical(LGP) :: found, do_copy character(len=ilen), dimension(:), allocatable :: astrtemp integer(I4B) :: istat integer(I4B) :: isize @@ -1191,84 +1192,91 @@ subroutine reallocate_str1d(astr, ilen, nrow, name, mem_path) integer(I4B) :: nrow_old integer(I4B) :: n ! + ! -- initialize do_copy + do_copy = .true. + ! + ! -- override with optional argument + if (present(copy)) do_copy = copy + ! ! -- Find and assign mt call get_from_memorylist(name, mem_path, mt, found) ! + ! -- calculate isize + isize = nrow + ! ! -- reallocate astr1d - if (found) then - isize_old = mt%isize + isize_old = mt%isize + nrow_old = 0 + if (do_copy) then if (isize_old > 0) then nrow_old = size(astr) - else - nrow_old = 0 - end if - ! - ! -- calculate isize - isize = nrow - ! - ! -- allocate astrtemp - allocate (astrtemp(nrow), stat=istat, errmsg=errmsg) - if (istat /= 0) then - call allocate_error(name, mem_path, istat, isize) - end if - ! - ! -- copy existing values - do n = 1, nrow_old - astrtemp(n) = astr(n) - end do - ! - ! -- fill new values with missing values - do n = nrow_old + 1, nrow - astrtemp(n) = '' - end do - ! - ! -- deallocate mt pointer, repoint, recalculate isize - deallocate (astr) - ! - ! -- allocate astr1d - allocate (astr(nrow), stat=istat, errmsg=errmsg) - if (istat /= 0) then - call allocate_error(name, mem_path, istat, isize) + ! -- set error attempting to copy to smaller array + if (nrow_old > isize) then + errmsg = "mem_reallocate for variable '"//trim(name)//"' unable "// & + "to copy existing values to reduced size array." + call store_error(errmsg, terminate=.TRUE.) + end if end if - ! - ! -- fill the reallocate character array - do n = 1, nrow - astr(n) = astrtemp(n) - end do - ! - ! -- deallocate temporary storage - deallocate (astrtemp) - ! - ! -- reset memory manager values - mt%element_size = ilen - mt%isize = isize - mt%nrealloc = mt%nrealloc + 1 - mt%master = .true. - nvalues_astr = nvalues_astr + isize - isize_old - write (mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, nrow - else - errmsg = "Programming error, variable '"//trim(name)//"' from '"// & - trim(mem_path)//"' is not defined in the memory manager. Use "// & - "mem_allocate instead." - call store_error(errmsg, terminate=.TRUE.) end if ! + ! -- allocate astrtemp + allocate (astrtemp(nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, mem_path, istat, isize) + end if + ! + ! -- copy existing values + do n = 1, nrow_old + astrtemp(n) = astr(n) + end do + ! + ! -- fill new values with missing values + do n = nrow_old + 1, nrow + astrtemp(n) = '' + end do + ! + ! -- deallocate mt pointer, repoint, recalculate isize + deallocate (astr) + ! + ! -- allocate astr1d + allocate (astr(nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, mem_path, istat, isize) + end if + ! + ! -- fill the reallocate character array + do n = 1, nrow + astr(n) = astrtemp(n) + end do + ! + ! -- deallocate temporary storage + deallocate (astrtemp) + ! + ! -- reset memory manager values + mt%element_size = ilen + mt%isize = isize + mt%nrealloc = mt%nrealloc + 1 + mt%master = .true. + nvalues_astr = nvalues_astr + isize - isize_old + write (mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, nrow + ! ! -- return return end subroutine reallocate_str1d !> @brief Reallocate a 1-dimensional deferred length string array !< - subroutine reallocate_charstr1d(acharstr1d, ilen, nrow, name, mem_path) + subroutine reallocate_charstr1d(acharstr1d, ilen, nrow, name, mem_path, copy) type(CharacterStringType), dimension(:), pointer, contiguous, & intent(inout) :: acharstr1d !< the reallocated charstring array integer(I4B), intent(in) :: ilen !< string length integer(I4B), intent(in) :: nrow !< number of rows character(len=*), intent(in) :: name !< variable name character(len=*), intent(in) :: mem_path !< path where variable is stored + logical(LGP), optional, intent(in) :: copy !< copy memory from old to new array ! -- local type(MemoryType), pointer :: mt - logical(LGP) :: found + logical(LGP) :: found, do_copy type(CharacterStringType), dimension(:), allocatable :: astrtemp character(len=ilen) :: string integer(I4B) :: istat @@ -1277,86 +1285,93 @@ subroutine reallocate_charstr1d(acharstr1d, ilen, nrow, name, mem_path) integer(I4B) :: nrow_old integer(I4B) :: n ! + ! -- initialize do_copy + do_copy = .true. + ! + ! -- override with optional argument + if (present(copy)) do_copy = copy + ! ! -- Initialize string string = '' ! ! -- Find and assign mt call get_from_memorylist(name, mem_path, mt, found) ! + ! -- calculate isize + isize = nrow + ! ! -- reallocate astr1d - if (found) then - isize_old = mt%isize + isize_old = mt%isize + nrow_old = 0 + if (do_copy) then if (isize_old > 0) then nrow_old = size(acharstr1d) - else - nrow_old = 0 - end if - ! - ! -- calculate isize - isize = nrow - ! - ! -- allocate astrtemp - allocate (astrtemp(nrow), stat=istat, errmsg=errmsg) - if (istat /= 0) then - call allocate_error(name, mem_path, istat, isize) - end if - ! - ! -- copy existing values - do n = 1, nrow_old - astrtemp(n) = acharstr1d(n) - end do - ! - ! -- fill new values with missing values - do n = nrow_old + 1, nrow - astrtemp(n) = string - end do - ! - ! -- deallocate mt pointer, repoint, recalculate isize - deallocate (acharstr1d) - ! - ! -- allocate astr1d - allocate (acharstr1d(nrow), stat=istat, errmsg=errmsg) - if (istat /= 0) then - call allocate_error(name, mem_path, istat, isize) + ! -- set error attempting to copy to smaller array + if (nrow_old > isize) then + errmsg = "mem_reallocate for variable '"//trim(name)//"' unable "// & + "to copy existing values to reduced size array." + call store_error(errmsg, terminate=.TRUE.) + end if end if - ! - ! -- fill the reallocated character array - do n = 1, nrow - acharstr1d(n) = astrtemp(n) - end do - ! - ! -- deallocate temporary storage - deallocate (astrtemp) - ! - ! -- reset memory manager values - mt%acharstr1d => acharstr1d - mt%element_size = ilen - mt%isize = isize - mt%nrealloc = mt%nrealloc + 1 - mt%master = .true. - nvalues_astr = nvalues_astr + isize - isize_old - write (mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, nrow - else - errmsg = "Programming error, variable '"//trim(name)//"' from '"// & - trim(mem_path)//"' is not defined in the memory manager. Use "// & - "mem_allocate instead." - call store_error(errmsg, terminate=.TRUE.) end if ! + ! -- allocate astrtemp + allocate (astrtemp(nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, mem_path, istat, isize) + end if + ! + ! -- copy existing values + do n = 1, nrow_old + astrtemp(n) = acharstr1d(n) + end do + ! + ! -- fill new values with missing values + do n = nrow_old + 1, nrow + astrtemp(n) = string + end do + ! + ! -- deallocate mt pointer, repoint, recalculate isize + deallocate (acharstr1d) + ! + ! -- allocate astr1d + allocate (acharstr1d(nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, mem_path, istat, isize) + end if + ! + ! -- fill the reallocated character array + do n = 1, nrow + acharstr1d(n) = astrtemp(n) + end do + ! + ! -- deallocate temporary storage + deallocate (astrtemp) + ! + ! -- reset memory manager values + mt%acharstr1d => acharstr1d + mt%element_size = ilen + mt%isize = isize + mt%nrealloc = mt%nrealloc + 1 + mt%master = .true. + nvalues_astr = nvalues_astr + isize - isize_old + write (mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, nrow + ! ! -- return return end subroutine reallocate_charstr1d !> @brief Reallocate a 1-dimensional integer array !< - subroutine reallocate_int1d(aint, nrow, name, mem_path) + subroutine reallocate_int1d(aint, nrow, name, mem_path, copy) integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< the reallocated integer array integer(I4B), intent(in) :: nrow !< number of rows character(len=*), intent(in) :: name !< variable name character(len=*), intent(in) :: mem_path !< path where variable is stored + logical(LGP), optional, intent(in) :: copy !< copy memory from old to new array ! -- local type(MemoryType), pointer :: mt - logical(LGP) :: found + logical(LGP) :: found, do_copy integer(I4B) :: istat integer(I4B) :: isize integer(I4B) :: i @@ -1364,17 +1379,37 @@ subroutine reallocate_int1d(aint, nrow, name, mem_path) integer(I4B) :: ifill ! -- code ! + ! -- initialize do_copy + do_copy = .true. + ! + ! -- override with optional argument + if (present(copy)) do_copy = copy + ! ! -- Find and assign mt call get_from_memorylist(name, mem_path, mt, found) ! ! -- Allocate aint and then refill isize = nrow isizeold = size(mt%aint1d) - ifill = min(isizeold, isize) + ! + ifill = 0 + if (do_copy) then + if (isizeold > 0) then + ifill = isizeold + ! -- set error attempting to copy to smaller array + if (ifill > isize) then + errmsg = "mem_reallocate for variable '"//trim(name)//"' unable "// & + "to copy existing values to reduced size array." + call store_error(errmsg, terminate=.TRUE.) + end if + end if + end if + ! allocate (aint(nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if + ! do i = 1, ifill aint(i) = mt%aint1d(i) end do @@ -1394,15 +1429,16 @@ end subroutine reallocate_int1d !> @brief Reallocate a 2-dimensional integer array !< - subroutine reallocate_int2d(aint, ncol, nrow, name, mem_path) + subroutine reallocate_int2d(aint, ncol, nrow, name, mem_path, copy) integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< the reallocated 2d integer array integer(I4B), intent(in) :: ncol !< number of columns integer(I4B), intent(in) :: nrow !< number of rows character(len=*), intent(in) :: name !< variable name character(len=*), intent(in) :: mem_path !< path where variable is stored + logical(LGP), optional, intent(in) :: copy !< copy memory from old to new array ! -- local type(MemoryType), pointer :: mt - logical(LGP) :: found + logical(LGP) :: found, do_copy integer(I4B) :: istat integer(I4B), dimension(2) :: ishape integer(I4B) :: i @@ -1411,6 +1447,12 @@ subroutine reallocate_int2d(aint, ncol, nrow, name, mem_path) integer(I4B) :: isizeold ! -- code ! + ! -- initialize do_copy + do_copy = .true. + ! + ! -- override with optional argument + if (present(copy)) do_copy = copy + ! ! -- Find and assign mt call get_from_memorylist(name, mem_path, mt, found) ! @@ -1418,15 +1460,28 @@ subroutine reallocate_int2d(aint, ncol, nrow, name, mem_path) ishape = shape(mt%aint2d) isize = nrow * ncol isizeold = ishape(1) * ishape(2) + ! + if (do_copy) then + ! -- set error attempting to copy to smaller array + if (ncol < ishape(1) .or. nrow < ishape(2)) then + errmsg = "mem_reallocate for variable '"//trim(name)//"' unable "// & + "to copy existing values to reduced size array." + call store_error(errmsg, terminate=.TRUE.) + end if + end if + ! allocate (aint(ncol, nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if - do i = 1, ishape(2) - do j = 1, ishape(1) - aint(j, i) = mt%aint2d(j, i) + ! + if (do_copy) then + do i = 1, ishape(2) + do j = 1, ishape(1) + aint(j, i) = mt%aint2d(j, i) + end do end do - end do + end if ! ! -- deallocate mt pointer, repoint, recalculate isize deallocate (mt%aint2d) @@ -1444,11 +1499,12 @@ end subroutine reallocate_int2d !> @brief Reallocate a 1-dimensional real array !< - subroutine reallocate_dbl1d(adbl, nrow, name, mem_path) + subroutine reallocate_dbl1d(adbl, nrow, name, mem_path, copy) real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< the reallocated 1d real array integer(I4B), intent(in) :: nrow !< number of rows character(len=*), intent(in) :: name !< variable name character(len=*), intent(in) :: mem_path !< path where variable is stored + logical(LGP), optional, intent(in) :: copy !< copy memory from old to new array ! -- local type(MemoryType), pointer :: mt integer(I4B) :: istat @@ -1456,20 +1512,40 @@ subroutine reallocate_dbl1d(adbl, nrow, name, mem_path) integer(I4B) :: i integer(I4B) :: isizeold integer(I4B) :: ifill - logical(LGP) :: found + logical(LGP) :: found, do_copy ! -- code ! + ! -- initialize do_copy + do_copy = .true. + ! + ! -- override with optional argument + if (present(copy)) do_copy = copy + ! ! -- Find and assign mt call get_from_memorylist(name, mem_path, mt, found) ! ! -- Allocate adbl and then refill isize = nrow isizeold = size(mt%adbl1d) - ifill = min(isizeold, isize) + ! + ifill = 0 + if (do_copy) then + if (isizeold > 0) then + ifill = isizeold + ! -- set error attempting to copy to smaller array + if (ifill > isize) then + errmsg = "mem_reallocate for variable '"//trim(name)//"' unable "// & + "to copy existing values to reduced size array." + call store_error(errmsg, terminate=.TRUE.) + end if + end if + end if + ! allocate (adbl(nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if + ! do i = 1, ifill adbl(i) = mt%adbl1d(i) end do @@ -1490,15 +1566,16 @@ end subroutine reallocate_dbl1d !> @brief Reallocate a 2-dimensional real array !< - subroutine reallocate_dbl2d(adbl, ncol, nrow, name, mem_path) + subroutine reallocate_dbl2d(adbl, ncol, nrow, name, mem_path, copy) real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl !< the reallocated 2d real array integer(I4B), intent(in) :: ncol !< number of columns integer(I4B), intent(in) :: nrow !< number of rows character(len=*), intent(in) :: name !< variable name character(len=*), intent(in) :: mem_path !< path where variable is stored + logical(LGP), optional, intent(in) :: copy !< copy memory from old to new array ! -- local type(MemoryType), pointer :: mt - logical(LGP) :: found + logical(LGP) :: found, do_copy integer(I4B) :: istat integer(I4B), dimension(2) :: ishape integer(I4B) :: i @@ -1507,6 +1584,12 @@ subroutine reallocate_dbl2d(adbl, ncol, nrow, name, mem_path) integer(I4B) :: isizeold ! -- code ! + ! -- initialize do_copy + do_copy = .true. + ! + ! -- override with optional argument + if (present(copy)) do_copy = copy + ! ! -- Find and assign mt call get_from_memorylist(name, mem_path, mt, found) ! @@ -1514,15 +1597,28 @@ subroutine reallocate_dbl2d(adbl, ncol, nrow, name, mem_path) ishape = shape(mt%adbl2d) isize = nrow * ncol isizeold = ishape(1) * ishape(2) + ! + if (do_copy) then + ! -- set error attempting to copy to smaller array + if (ncol < ishape(1) .or. nrow < ishape(2)) then + errmsg = "mem_reallocate for variable '"//trim(name)//"' unable "// & + "to copy existing values to reduced size array." + call store_error(errmsg, terminate=.TRUE.) + end if + end if + ! allocate (adbl(ncol, nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if - do i = 1, ishape(2) - do j = 1, ishape(1) - adbl(j, i) = mt%adbl2d(j, i) + ! + if (do_copy) then + do i = 1, ishape(2) + do j = 1, ishape(1) + adbl(j, i) = mt%adbl2d(j, i) + end do end do - end do + end if ! ! -- deallocate mt pointer, repoint, recalculate isize deallocate (mt%adbl2d) diff --git a/src/meson.build b/src/meson.build index 24ef7691927..2298bc14d97 100644 --- a/src/meson.build +++ b/src/meson.build @@ -197,6 +197,7 @@ modflow_sources = files( 'Utilities' / 'ArrayRead' / 'LayeredArrayReader.f90', 'Utilities' / 'Idm' / 'BoundInputContext.f90', 'Utilities' / 'Idm' / 'DefinitionSelect.f90', + 'Utilities' / 'Idm' / 'DynamicParamFilter.f90', 'Utilities' / 'Idm' / 'IdmLoad.f90', 'Utilities' / 'Idm' / 'IdmLogger.f90', 'Utilities' / 'Idm' / 'InputDefinition.f90', @@ -208,8 +209,8 @@ modflow_sources = files( 'Utilities' / 'Idm' / 'mf6blockfile' / 'AsciiInputLoadType.f90', 'Utilities' / 'Idm' / 'mf6blockfile' / 'IdmMf6File.f90', 'Utilities' / 'Idm' / 'mf6blockfile' / 'LoadMf6File.f90', - 'Utilities' / 'Idm' / 'mf6blockfile' / 'StressGridInput.f90', - 'Utilities' / 'Idm' / 'mf6blockfile' / 'StressListInput.f90', + 'Utilities' / 'Idm' / 'mf6blockfile' / 'Mf6FileGridInput.f90', + 'Utilities' / 'Idm' / 'mf6blockfile' / 'Mf6FileListInput.f90', 'Utilities' / 'Idm' / 'mf6blockfile' / 'StructArray.f90', 'Utilities' / 'Idm' / 'mf6blockfile' / 'StructVector.f90', 'Utilities' / 'Idm' / 'selector' / 'IdmDfnSelector.f90', diff --git a/src/simnamidm.f90 b/src/simnamidm.f90 index f2a53f30a12..e5aaefd56fe 100644 --- a/src/simnamidm.f90 +++ b/src/simnamidm.f90 @@ -9,6 +9,8 @@ module SimNamInputModule public sim_nam_block_definitions public SimNamParamFoundType public sim_nam_multi_package + public sim_nam_advanced_package + public sim_nam_subpackages type SimNamParamFoundType logical :: continue = .false. @@ -31,6 +33,13 @@ module SimNamInputModule end type SimNamParamFoundType logical :: sim_nam_multi_package = .false. + logical :: sim_nam_advanced_package = .false. + + character(len=16), parameter :: & + sim_nam_subpackages(*) = & + [ & + ' ' & + ] type(InputParamDefinitionType), parameter :: & simnam_continue = InputParamDefinitionType & @@ -409,31 +418,36 @@ module SimNamInputModule 'OPTIONS', & ! blockname .false., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'TIMING', & ! blockname .true., & ! required .false., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'MODELS', & ! blockname .true., & ! required .true., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'EXCHANGES', & ! blockname .true., & ! required .true., & ! aggregate - .false. & ! block_variable + .false., & ! block_variable + .false. & ! timeseries ), & InputBlockDefinitionType( & 'SOLUTIONGROUP', & ! blockname .true., & ! required .true., & ! aggregate - .true. & ! block_variable + .true., & ! block_variable + .false. & ! timeseries ) & ] diff --git a/utils/idmloader/scripts/dfn2f90.py b/utils/idmloader/scripts/dfn2f90.py index f53fa3e1150..bb9cd9241d4 100644 --- a/utils/idmloader/scripts/dfn2f90.py +++ b/utils/idmloader/scripts/dfn2f90.py @@ -28,6 +28,8 @@ def __init__( self._aggregate_varnames = [] self._warnings = [] self._multi_package = False + self._advanced_package = False + self._subpackage = [] self.component, self.subcomponent = self._dfnfspec.stem.upper().split( "-" @@ -74,9 +76,29 @@ def write_f90(self, ofspec=None): smult = ".true." f.write( f" logical :: {self.component.lower()}_" - f"{self.subcomponent.lower()}_multi_package = {smult}\n\n" + f"{self.subcomponent.lower()}_multi_package = {smult}\n" ) + # advanced package + adv = ".false." + if self._advanced_package: + adv = ".true." + f.write( + f" logical :: {self.component.lower()}_" + f"{self.subcomponent.lower()}_advanced_package = {adv}\n\n" + ) + + # subpackage + f.write( + f" character(len=16), parameter :: &\n" + f" {self.component.lower()}_{self.subcomponent.lower()}_subpackages(*) = &\n" + ) + if not len(self._subpackage): + self._subpackage.append(''.ljust(16)) + f.write(f" [ &\n") + f.write(" '" + "', &\n '" .join(self._subpackage) + "' &\n") + f.write(f" ]\n\n") + # params if len(self._param_varnames): f.write(self._param_str) @@ -192,6 +214,14 @@ def _set_var_d(self): # flopy multi-package if "flopy multi-package" in line.strip(): self._multi_package = True + elif "package-type" in line.strip(): + pkg_tags = line.strip().split() + if pkg_tags[2] == "advanced-stress-package": + self._advanced_package = True + elif "mf6 subpackage" in line.strip(): + sp = line.replace("# mf6 subpackage ", "").strip() + sp = sp.upper() + self._subpackage.append(sp.ljust(16)) continue ll = line.strip().split() @@ -221,7 +251,7 @@ def _set_var_d(self): self._var_d = vardict def _construct_f90_block_statement( - self, blockname, required=False, aggregate=False, block_var=False + self, blockname, required=False, aggregate=False, block_var=False, timeseries=False ): f90statement = f" InputBlockDefinitionType( &\n" f90statement += f" '{blockname}', & ! blockname\n" @@ -237,9 +267,14 @@ def _construct_f90_block_statement( f90statement += f" .false., & ! aggregate\n" if block_var: - f90statement += f" .true. & ! block_variable\n" + f90statement += f" .true., & ! block_variable\n" else: - f90statement += f" .false. & ! block_variable\n" + f90statement += f" .false., & ! block_variable\n" + + if timeseries: + f90statement += f" .true. & ! timeseries\n" + else: + f90statement += f" .false. & ! timeseries\n" f90statement += f" ), &" @@ -328,6 +363,7 @@ def _set_blk_param_strs(self, blockname, component, subcomponent): required_l = [] has_block_var = False is_aggregate_blk = False + is_timeseries_blk = False aggregate_required = False # comment @@ -430,6 +466,7 @@ def _set_blk_param_strs(self, blockname, component, subcomponent): if "time_series" in v: if v["time_series"] == "true": timeseries = ".true." + is_timeseries_blk = True else: timeseries = ".false." @@ -494,6 +531,7 @@ def _set_blk_param_strs(self, blockname, component, subcomponent): required=required, aggregate=is_aggregate_blk, block_var=has_block_var, + timeseries=is_timeseries_blk, ) + "\n" ) @@ -515,7 +553,11 @@ def _source_file_header(self, component, subcomponent): f" public {component.capitalize()}{subcomponent.capitalize()}" f"ParamFoundType\n" f" public {component.lower()}_{subcomponent.lower()}_" - f"multi_package\n\n" + f"multi_package\n" + f" public {component.lower()}_{subcomponent.lower()}_" + f"advanced_package\n" + f" public {component.lower()}_{subcomponent.lower()}_" + f"subpackages\n\n" ) return s @@ -585,6 +627,8 @@ def _write_master(self): self._write_master_defn(fh, defn="aggregate", dtype="param") self._write_master_defn(fh, defn="block", dtype="block") self._write_master_multi(fh) + self._write_master_adv(fh) + self._write_master_sub(fh) self._write_master_integration(fh) self._write_master_component(fh) fh.write(f"end module IdmDfnSelectorModule\n") @@ -623,9 +667,9 @@ def _write_selectors(self): dtype="block", ) self._write_selector_multi(fh, component=c, sc_list=self._d[c]) - self._write_selector_integration( - fh, component=c, sc_list=self._d[c] - ) + self._write_selector_adv(fh, component=c, sc_list=self._d[c]) + self._write_selector_sub(fh, component=c, sc_list=self._d[c]) + self._write_selector_integration(fh, component=c, sc_list=self._d[c]) fh.write(f"end module Idm{c.title()}DfnSelectorModule\n") def _write_selector_decl(self, fh=None, component=None, sc_list=None): @@ -655,6 +699,8 @@ def _write_selector_decl(self, fh=None, component=None, sc_list=None): f" public :: {c.lower()}_aggregate_definitions\n" f" public :: {c.lower()}_block_definitions\n" f" public :: {c.lower()}_idm_multi_package\n" + f" public :: {c.lower()}_idm_advanced_package\n" + f" public :: {c.lower()}_idm_subpackages\n" f" public :: {c.lower()}_idm_integrated\n\n" ) s += f"contains\n\n" @@ -682,6 +728,16 @@ def _write_selector_helpers(self, fh=None): f" end subroutine set_block_pointer\n\n" ) + s += ( + f" subroutine set_subpkg_pointer(subpkg_list, subpkg_list_target)\n" + f" character(len=16), dimension(:), " + f"pointer :: subpkg_list\n" + f" character(len=16), dimension(:), " + f"target :: subpkg_list_target\n" + f" subpkg_list => subpkg_list_target\n" + f" end subroutine set_subpkg_pointer\n\n" + ) + fh.write(s) def _write_selector_defn( @@ -747,9 +803,62 @@ def _write_selector_multi(self, fh=None, component=None, sc_list=None): fh.write(s) - def _write_selector_integration( - self, fh=None, component=None, sc_list=None - ): + def _write_selector_adv(self, fh=None, component=None, sc_list=None): + c = component + + s = ( + f" function {c.lower()}_idm_advanced_package(subcomponent) " + f"result(advanced_package)\n" + f" character(len=*), intent(in) :: subcomponent\n" + f" logical :: advanced_package\n" + f" advanced_package = .false.\n" + f" select case (subcomponent)\n" + ) + + for sc in sc_list: + s += ( + f" case ('{sc}')\n" + f" advanced_package = {c.lower()}_{sc.lower()}_" + f"advanced_package\n" + ) + + s += ( + f" case default\n" + f" end select\n" + f" return\n" + f" end function {c.lower()}_idm_advanced_package\n\n" + ) + + fh.write(s) + + def _write_selector_sub(self, fh=None, component=None, sc_list=None): + c = component + + s = ( + f" function {c.lower()}_idm_subpackages(subcomponent) " + f"result(subpackages)\n" + f" character(len=*), intent(in) :: subcomponent\n" + f" character(len=16), dimension(:), pointer :: subpackages\n" + f" select case (subcomponent)\n" + ) + + for sc in sc_list: + s += ( + f" case ('{sc}')\n" + f" call set_subpkg_pointer(subpackages, " + f"{c.lower()}_{sc.lower()}_subpackages)\n" + ) + + s += ( + f" case default\n" + f" end select\n" + f" return\n" + f" end function {c.lower()}_idm_subpackages\n\n" + ) + + fh.write(s) + + def _write_selector_integration(self, fh=None, component=None, sc_list=None): c = component s = ( @@ -798,6 +907,8 @@ def _write_master_decl(self, fh=None): f" public :: aggregate_definitions\n" f" public :: block_definitions\n" f" public :: idm_multi_package\n" + f" public :: idm_advanced_package\n" + f" public :: idm_subpackages\n" f" public :: idm_integrated\n" f" public :: idm_component\n\n" f"contains\n\n" @@ -863,6 +974,66 @@ def _write_master_multi(self, fh=None): fh.write(s) + def _write_master_adv(self, fh=None): + s = ( + f" function idm_advanced_package(component, subcomponent) " + f"result(advanced_package)\n" + f" character(len=*), intent(in) :: component\n" + f" character(len=*), intent(in) :: subcomponent\n" + f" logical :: advanced_package\n" + f" select case (component)\n" + ) + + for c in dfn_d: + s += ( + f" case ('{c}')\n" + f" advanced_package = {c.lower()}_idm_advanced_" + f"package(subcomponent)\n" + ) + + s += ( + f" case default\n" + f" call store_error('Idm selector component not found; '//&\n" + f" &'component=\"'//trim(component)//&\n" + f" &'\", subcomponent=\"'//trim(subcomponent)" + f"//'\".', .true.)\n" + f" end select\n" + f" return\n" + f" end function idm_advanced_package\n\n" + ) + + fh.write(s) + + def _write_master_sub(self, fh=None): + s = ( + f" function idm_subpackages(component, subcomponent) " + f"result(subpackages)\n" + f" character(len=*), intent(in) :: component\n" + f" character(len=*), intent(in) :: subcomponent\n" + f" character(len=16), dimension(:), pointer :: subpackages\n" + f" select case (component)\n" + ) + + for c in dfn_d: + s += ( + f" case ('{c}')\n" + f" subpackages => {c.lower()}_idm_" + f"subpackages(subcomponent)\n" + ) + + s += ( + f" case default\n" + f" call store_error('Idm selector component not found; '//&\n" + f" &'component=\"'//trim(component)//&\n" + f" &'\", subcomponent=\"'//trim(subcomponent)" + f"//'\".', .true.)\n" + f" end select\n" + f" return\n" + f" end function idm_subpackages\n\n" + ) + + fh.write(s) + def _write_master_integration(self, fh=None): s = ( f" function idm_integrated(component, subcomponent) "