From 5869d4ac7ad5b4f193e97a6e92d2cc4a5db1abc7 Mon Sep 17 00:00:00 2001 From: mjreno Date: Mon, 17 Oct 2022 09:58:20 -0400 Subject: [PATCH] feature(input-data-model): add idm core with initial package use (#1064) * introduce dfn derived fortran input definition format * add script to generate input definitions * add generic input loader for mf6 file types * add mem_set_value interface * update dis, disv, disu, npf, dsp to source input from input data path * pass invalid npf,dsp inunit number from interface model * add doxygen comments for IDM routines * fprettify Co-authored-by: mjreno Co-authored-by: Langevin, Christian D --- doc/mf6io/mf6ivar/dfn/gwf-disu.dfn | 3 + doc/mf6io/mf6ivar/dfn/gwf-disv.dfn | 8 +- doc/mf6io/mf6ivar/dfn/gwf-npf.dfn | 73 +- make/makefile | 298 +++--- msvs/mf6core.vfproj | 15 + src/Model/Connection/GwfInterfaceModel.f90 | 4 +- src/Model/Connection/GwtInterfaceModel.f90 | 2 +- src/Model/GroundWaterFlow/gwf3dis8.f90 | 435 ++++----- src/Model/GroundWaterFlow/gwf3dis8idm.f90 | 261 +++++ src/Model/GroundWaterFlow/gwf3disu8.f90 | 890 +++++++++--------- src/Model/GroundWaterFlow/gwf3disu8idm.f90 | 547 +++++++++++ src/Model/GroundWaterFlow/gwf3disv8.f90 | 718 +++++++------- src/Model/GroundWaterFlow/gwf3disv8idm.f90 | 406 ++++++++ src/Model/GroundWaterFlow/gwf3npf8.f90 | 756 +++++++-------- src/Model/GroundWaterFlow/gwf3npf8idm.f90 | 664 +++++++++++++ src/Model/GroundWaterTransport/gwt1dsp.f90 | 388 ++++---- src/Model/GroundWaterTransport/gwt1dspidm.f90 | 171 ++++ src/Model/ModelUtilities/Connections.f90 | 14 +- .../ModelUtilities/DiscretizationBase.f90 | 10 +- src/Utilities/Idm/IdmLogger.f90 | 209 ++++ src/Utilities/Idm/IdmMf6FileLoader.f90 | 92 ++ src/Utilities/Idm/InputDefinition.f90 | 48 + src/Utilities/Idm/InputDefinitionSelector.f90 | 196 ++++ src/Utilities/Idm/LoadMf6FileType.f90 | 704 ++++++++++++++ src/Utilities/Idm/ModflowInput.f90 | 93 ++ src/Utilities/Idm/StructArray.f90 | 289 ++++++ src/Utilities/Idm/StructVector.f90 | 38 + src/Utilities/Memory/Memory.f90 | 65 ++ src/Utilities/Memory/MemoryList.f90 | 8 + src/Utilities/Memory/MemoryManagerExt.f90 | 369 ++++++++ src/Utilities/SimVariables.f90 | 1 + src/meson.build | 14 + utils/idmloader/README.md | 3 + utils/idmloader/scripts/dfn2f90.py | 411 ++++++++ utils/mf5to6/make/makefile | 8 +- 35 files changed, 6357 insertions(+), 1854 deletions(-) create mode 100644 src/Model/GroundWaterFlow/gwf3dis8idm.f90 create mode 100644 src/Model/GroundWaterFlow/gwf3disu8idm.f90 create mode 100644 src/Model/GroundWaterFlow/gwf3disv8idm.f90 create mode 100644 src/Model/GroundWaterFlow/gwf3npf8idm.f90 create mode 100644 src/Model/GroundWaterTransport/gwt1dspidm.f90 create mode 100644 src/Utilities/Idm/IdmLogger.f90 create mode 100644 src/Utilities/Idm/IdmMf6FileLoader.f90 create mode 100644 src/Utilities/Idm/InputDefinition.f90 create mode 100644 src/Utilities/Idm/InputDefinitionSelector.f90 create mode 100644 src/Utilities/Idm/LoadMf6FileType.f90 create mode 100644 src/Utilities/Idm/ModflowInput.f90 create mode 100644 src/Utilities/Idm/StructArray.f90 create mode 100644 src/Utilities/Idm/StructVector.f90 create mode 100644 src/Utilities/Memory/MemoryManagerExt.f90 create mode 100644 utils/idmloader/README.md create mode 100644 utils/idmloader/scripts/dfn2f90.py diff --git a/doc/mf6io/mf6ivar/dfn/gwf-disu.dfn b/doc/mf6io/mf6ivar/dfn/gwf-disu.dfn index e3590bf2519..8c131363e2f 100644 --- a/doc/mf6io/mf6ivar/dfn/gwf-disu.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwf-disu.dfn @@ -48,6 +48,7 @@ optional true default_value 0.0 longname vertical length dimension for top and bottom checking description checks are performed to ensure that the top of a cell is not higher than the bottom of an overlying cell. This option can be used to specify the tolerance that is used for checking. If top of a cell is above the bottom of an overlying cell by a value less than this tolerance, then the program will not terminate with an error. The default value is zero. This option should generally not be used. +mf6internal voffsettol # --------------------- gwf disu dimensions --------------------- @@ -173,6 +174,7 @@ jagged_array iac block vertices name vertices type recarray iv xv yv +shape (nvert) reader urword optional false longname vertices data @@ -215,6 +217,7 @@ description is the y-coordinate for the vertex. block cell2d name cell2d type recarray icell2d xc yc ncvert icvert +shape (nodes) reader urword optional false longname cell2d data diff --git a/doc/mf6io/mf6ivar/dfn/gwf-disv.dfn b/doc/mf6io/mf6ivar/dfn/gwf-disv.dfn index 53ae67bd945..a22fe1c9f03 100644 --- a/doc/mf6io/mf6ivar/dfn/gwf-disv.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwf-disv.dfn @@ -71,7 +71,7 @@ description is the total number of (x, y) vertex pairs used to characterize the block griddata name top type double precision -shape (ncpl) +shape (ncpl, 1) reader readarray longname model top elevation description is the top elevation for each cell in the top model layer. @@ -79,7 +79,7 @@ description is the top elevation for each cell in the top model layer. block griddata name botm type double precision -shape (nlay, ncpl) +shape (ncpl, 1, nlay) reader readarray layered true longname model bottom elevation @@ -88,7 +88,7 @@ description is the bottom elevation for each cell. block griddata name idomain type integer -shape (nlay, ncpl) +shape (ncpl, 1, nlay) reader readarray layered true optional true @@ -101,6 +101,7 @@ description is an optional array that characterizes the existence status of a ce block vertices name vertices type recarray iv xv yv +shape (nvert) reader urword optional false longname vertices data @@ -143,6 +144,7 @@ description is the y-coordinate for the vertex. block cell2d name cell2d type recarray icell2d xc yc ncvert icvert +shape (ncpl) reader urword optional false longname cell2d data diff --git a/doc/mf6io/mf6ivar/dfn/gwf-npf.dfn b/doc/mf6io/mf6ivar/dfn/gwf-npf.dfn index 76d4d01663f..1c18223cc5a 100644 --- a/doc/mf6io/mf6ivar/dfn/gwf-npf.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwf-npf.dfn @@ -7,6 +7,16 @@ reader urword optional true longname keyword to save NPF flows description keyword to indicate that budget flow terms will be written to the file specified with ``BUDGET SAVE FILE'' in Output Control. +mf6internal ipakcb + +block options +name print_flows +type keyword +reader urword +optional true +longname keyword to print NPF flows to listing file +description keyword to indicate that calculated flows between cells will be printed to the listing file for every stress period time step in which ``BUDGET PRINT'' is specified in Output Control. If there is no Output Control option and ``PRINT\_FLOWS'' is specified, then flow rates are printed for the last time step of each stress period. This option can produce extremely large list files because all cell-by-cell flows are printed. It should only be used with the NPF Package for models that have a small number of cells. +mf6internal iprflow block options name alternative_cell_averaging @@ -16,6 +26,7 @@ reader urword optional true longname conductance weighting option description is a text keyword to indicate that an alternative method will be used for calculating the conductance for horizontal cell connections. The text value for ALTERNATIVE\_CELL\_AVERAGING can be ``LOGARITHMIC'', ``AMT-LMK'', or ``AMT-HMK''. ``AMT-LMK'' signifies that the conductance will be calculated using arithmetic-mean thickness and logarithmic-mean hydraulic conductivity. ``AMT-HMK'' signifies that the conductance will be calculated using arithmetic-mean thickness and harmonic-mean hydraulic conductivity. If the user does not specify a value for ALTERNATIVE\_CELL\_AVERAGING, then the harmonic-mean method will be used. This option cannot be used if the XT3D option is invoked. +mf6internal cellavg block options name thickstrt @@ -24,6 +35,7 @@ reader urword optional true longname keyword to activate THICKSTRT option description indicates that cells having a negative ICELLTYPE are confined, and their cell thickness for conductance calculations will be computed as STRT-BOT rather than TOP-BOT. +mf6internal ithickstrt block options name cvoptions @@ -40,6 +52,7 @@ type keyword reader urword longname keyword to activate VARIABLECV option description keyword to indicate that the vertical conductance will be calculated using the saturated thickness and properties of the overlying cell and the thickness and properties of the underlying cell. If the DEWATERED keyword is also specified, then the vertical conductance is calculated using only the saturated thickness and properties of the overlying cell if the head in the underlying cell is below its top. If these keywords are not specified, then the default condition is to calculate the vertical conductance at the start of the simulation using the initial head and the cell properties. The vertical conductance remains constant for the entire simulation. +mf6internal ivarcv block options name dewatered @@ -49,6 +62,7 @@ reader urword optional true longname keyword to activate DEWATERED option description If the DEWATERED keyword is specified, then the vertical conductance is calculated using only the saturated thickness and properties of the overlying cell if the head in the underlying cell is below its top. +mf6internal idewatcv block options name perched @@ -57,6 +71,7 @@ reader urword optional true longname keyword to activate PERCHED option description keyword to indicate that when a cell is overlying a dewatered convertible cell, the head difference used in Darcy's Law is equal to the head in the overlying cell minus the bottom elevation of the overlying cell. If not specified, then the default is to use the head difference between the two cells. +mf6internal iperched block options name rewet_record @@ -74,6 +89,7 @@ reader urword optional false longname keyword to activate rewetting description activates model rewetting. Rewetting is off by default. +mf6internal irewet block options name wetfct @@ -117,6 +133,7 @@ type keyword reader urword longname keyword to activate XT3D description keyword indicating that the XT3D formulation will be used. If the RHS keyword is also included, then the XT3D additional terms will be added to the right-hand side. If the RHS keyword is excluded, then the XT3D terms will be put into the coefficient matrix. Use of XT3D will substantially increase the computational effort, but will result in improved accuracy for anisotropic conductivity fields and for unstructured grids in which the CVFD requirement is violated. XT3D requires additional information about the shapes of grid cells. If XT3D is active and the DISU Package is used, then the user will need to provide in the DISU Package the angldegx array in the CONNECTIONDATA block and the VERTICES and CELL2D blocks. +mf6internal ixt3d block options name rhs @@ -126,6 +143,7 @@ reader urword optional true longname keyword to XT3D on right hand side description If the RHS keyword is also included, then the XT3D additional terms will be added to the right-hand side. If the RHS keyword is excluded, then the XT3D terms will be put into the coefficient matrix. +mf6internal ixt3drhs block options name save_specific_discharge @@ -134,6 +152,7 @@ reader urword optional true longname keyword to save specific discharge description keyword to indicate that x, y, and z components of specific discharge will be calculated at cell centers and written to the budget file, which is specified with ``BUDGET SAVE FILE'' in Output Control. If this option is activated, then additional information may be required in the discretization packages and the GWF Exchange package (if GWF models are coupled). Specifically, ANGLDEGX must be specified in the CONNECTIONDATA block of the DISU Package; ANGLDEGX must also be specified for the GWF Exchange as an auxiliary variable. +mf6internal isavspdis block options name save_saturation @@ -142,6 +161,7 @@ reader urword optional true longname keyword to save saturation description keyword to indicate that cell saturation will be written to the budget file, which is specified with ``BUDGET SAVE FILE'' in Output Control. Saturation will be saved to the budget file as an auxiliary variable saved with the DATA-SAT text label. Saturation is a cell variable that ranges from zero to one and can be used by post processing programs to determine how much of a cell volume is saturated. If ICELLTYPE is 0, then saturation is always one. +mf6internal isavsat block options name k22overk @@ -150,6 +170,7 @@ reader urword optional true longname keyword to indicate that specified K22 is a ratio description keyword to indicate that specified K22 is a ratio of K22 divided by K. If this option is specified, then the K22 array entered in the NPF Package will be multiplied by K after being read. +mf6internal ik22overk block options name k33overk @@ -158,10 +179,11 @@ reader urword optional true longname keyword to indicate that specified K33 is a ratio description keyword to indicate that specified K33 is a ratio of K33 divided by K. If this option is specified, then the K33 array entered in the NPF Package will be multiplied by K after being read. +mf6internal ik33overk block options name tvk_filerecord -type record tvk6 filein tvk_filename +type record tvk6 filein tvk6_filename shape reader urword tagged true @@ -192,7 +214,7 @@ longname file keyword description keyword to specify that an input filename is expected next. block options -name tvk_filename +name tvk6_filename type string preserve_case true in_record true @@ -202,6 +224,52 @@ tagged false longname file name of TVK information description defines a time-varying hydraulic conductivity (TVK) input file. Records in the TVK file can be used to change hydraulic conductivity properties at specified times or stress periods. +# dev options + +block options +name dev_no_newton +type keyword +reader urword +optional true +longname turn off Newton for unconfined cells +description turn off Newton for unconfined cells +mf6internal inewton + +block options +name dev_modflowusg_upstream_weighted_saturation +type keyword +reader urword +optional true +longname use MODFLOW-USG upstream-weighted saturation approach +description use MODFLOW-USG upstream-weighted saturation approach +mf6internal iusgnrhc + +block options +name dev_modflownwt_upstream_weighting +type keyword +reader urword +optional true +longname use MODFLOW-NWT approach for upstream weighting +description use MODFLOW-NWT approach for upstream weighting +mf6internal inwtupw + +block options +name dev_minimum_saturated_thickness +type double precision +reader urword +optional true +longname set minimum allowed saturated thickness +description set minimum allowed saturated thickness +mf6internal satmin + +block options +name dev_omega +type double precision +reader urword +optional true +longname set saturation omega value +description set saturation omega value +mf6internal satomega # --------------------- gwf npf griddata --------------------- @@ -294,4 +362,3 @@ layered true optional true longname wetdry threshold and factor description is a combination of the wetting threshold and a flag to indicate which neighboring cells can cause a cell to become wet. If WETDRY $<$ 0, only a cell below a dry cell can cause the cell to become wet. If WETDRY $>$ 0, the cell below a dry cell and horizontally adjacent cells can cause a cell to become wet. If WETDRY is 0, the cell cannot be wetted. The absolute value of WETDRY is the wetting threshold. When the sum of BOT and the absolute value of WETDRY at a dry cell is equaled or exceeded by the head at an adjacent cell, the cell is wetted. WETDRY must be specified if ``REWET'' is specified in the OPTIONS block. If ``REWET'' is not specified in the options block, then WETDRY can be entered, and memory will be allocated for it, even though it is not used. - diff --git a/make/makefile b/make/makefile index 45eb23efb4d..83a6bc5c5fb 100644 --- a/make/makefile +++ b/make/makefile @@ -7,25 +7,26 @@ include ./makedefaults SOURCEDIR1=../src SOURCEDIR2=../src/Exchange SOURCEDIR3=../src/Model -SOURCEDIR4=../src/Model/Geometry -SOURCEDIR5=../src/Model/ModelUtilities -SOURCEDIR6=../src/Model/Connection +SOURCEDIR4=../src/Model/Connection +SOURCEDIR5=../src/Model/Geometry +SOURCEDIR6=../src/Model/GroundWaterFlow SOURCEDIR7=../src/Model/GroundWaterTransport -SOURCEDIR8=../src/Model/GroundWaterFlow +SOURCEDIR8=../src/Model/ModelUtilities SOURCEDIR9=../src/Solution SOURCEDIR10=../src/Solution/LinearMethods SOURCEDIR11=../src/Timing SOURCEDIR12=../src/Utilities -SOURCEDIR13=../src/Utilities/TimeSeries +SOURCEDIR13=../src/Utilities/Idm SOURCEDIR14=../src/Utilities/Libraries -SOURCEDIR15=../src/Utilities/Libraries/rcm -SOURCEDIR16=../src/Utilities/Libraries/sparsekit -SOURCEDIR17=../src/Utilities/Libraries/sparskit2 -SOURCEDIR18=../src/Utilities/Libraries/blas -SOURCEDIR19=../src/Utilities/Libraries/daglib -SOURCEDIR20=../src/Utilities/Observation -SOURCEDIR21=../src/Utilities/OutputControl -SOURCEDIR22=../src/Utilities/Memory +SOURCEDIR15=../src/Utilities/Libraries/blas +SOURCEDIR16=../src/Utilities/Libraries/daglib +SOURCEDIR17=../src/Utilities/Libraries/rcm +SOURCEDIR18=../src/Utilities/Libraries/sparsekit +SOURCEDIR19=../src/Utilities/Libraries/sparskit2 +SOURCEDIR20=../src/Utilities/Memory +SOURCEDIR21=../src/Utilities/Observation +SOURCEDIR22=../src/Utilities/OutputControl +SOURCEDIR23=../src/Utilities/TimeSeries VPATH = \ ${SOURCEDIR1} \ @@ -49,179 +50,194 @@ ${SOURCEDIR18} \ ${SOURCEDIR19} \ ${SOURCEDIR20} \ ${SOURCEDIR21} \ -${SOURCEDIR22} +${SOURCEDIR22} \ +${SOURCEDIR23} .SUFFIXES: .f90 .F90 .o OBJECTS = \ -$(OBJDIR)/CharString.o \ $(OBJDIR)/kind.o \ -$(OBJDIR)/blas1_d.o \ $(OBJDIR)/Constants.o \ -$(OBJDIR)/InterfaceMap.o \ -$(OBJDIR)/dag_module.o \ -$(OBJDIR)/GwtDspOptions.o \ -$(OBJDIR)/ims8misc.o \ -$(OBJDIR)/rcm.o \ -$(OBJDIR)/CsrUtils.o \ -$(OBJDIR)/compilerversion.o \ -$(OBJDIR)/ims8reordering.o \ -$(OBJDIR)/GwfBuyInputData.o \ -$(OBJDIR)/sparsekit.o \ -$(OBJDIR)/GwfStorageUtils.o \ -$(OBJDIR)/Xt3dAlgorithm.o \ -$(OBJDIR)/BaseGeometry.o \ -$(OBJDIR)/defmacro.o \ -$(OBJDIR)/ilut.o \ $(OBJDIR)/SimVariables.o \ -$(OBJDIR)/SmoothingFunctions.o \ -$(OBJDIR)/HashTable.o \ -$(OBJDIR)/Sparse.o \ -$(OBJDIR)/GwtAdvOptions.o \ -$(OBJDIR)/OpenSpec.o \ -$(OBJDIR)/GwfNpfOptions.o \ -$(OBJDIR)/SfrCrossSectionUtils.o \ $(OBJDIR)/genericutils.o \ -$(OBJDIR)/List.o \ -$(OBJDIR)/ObsOutput.o \ -$(OBJDIR)/version.o \ +$(OBJDIR)/compilerversion.o \ $(OBJDIR)/ArrayHandlers.o \ -$(OBJDIR)/StringList.o \ -$(OBJDIR)/TimeSeriesRecord.o \ -$(OBJDIR)/Timer.o \ -$(OBJDIR)/mf6lists.o \ +$(OBJDIR)/version.o \ $(OBJDIR)/Message.o \ +$(OBJDIR)/defmacro.o \ $(OBJDIR)/Sim.o \ -$(OBJDIR)/Iunit.o \ -$(OBJDIR)/VectorInt.o \ -$(OBJDIR)/Budget.o \ -$(OBJDIR)/sort.o \ -$(OBJDIR)/MemoryHelper.o \ +$(OBJDIR)/OpenSpec.o \ $(OBJDIR)/InputOutput.o \ -$(OBJDIR)/CircularGeometry.o \ -$(OBJDIR)/ArrayReaders.o \ -$(OBJDIR)/BlockParser.o \ -$(OBJDIR)/ims8base.o \ -$(OBJDIR)/comarg.o \ -$(OBJDIR)/BudgetFileReader.o \ -$(OBJDIR)/PrintSaveManager.o \ -$(OBJDIR)/DisvGeom.o \ -$(OBJDIR)/NameFile.o \ -$(OBJDIR)/TimeSeries.o \ -$(OBJDIR)/RectangularGeometry.o \ -$(OBJDIR)/TimeSeriesFileList.o \ -$(OBJDIR)/ObsOutputList.o \ -$(OBJDIR)/TimeSeriesLink.o \ -$(OBJDIR)/HeadFileReader.o \ $(OBJDIR)/TableTerm.o \ $(OBJDIR)/Table.o \ -$(OBJDIR)/ListReader.o \ -$(OBJDIR)/SfrCrossSectionManager.o \ +$(OBJDIR)/MemoryHelper.o \ +$(OBJDIR)/CharString.o \ $(OBJDIR)/Memory.o \ +$(OBJDIR)/List.o \ $(OBJDIR)/MemoryList.o \ +$(OBJDIR)/TimeSeriesRecord.o \ +$(OBJDIR)/BlockParser.o \ $(OBJDIR)/MemoryManager.o \ -$(OBJDIR)/MemorySetHandler.o \ -$(OBJDIR)/GwfMvrPeriodData.o \ -$(OBJDIR)/ims8linear.o \ -$(OBJDIR)/MappedVariable.o \ -$(OBJDIR)/BaseModel.o \ -$(OBJDIR)/PackageBudget.o \ -$(OBJDIR)/PackageMover.o \ -$(OBJDIR)/DistributedData.o \ +$(OBJDIR)/TimeSeries.o \ $(OBJDIR)/ats.o \ +$(OBJDIR)/TimeSeriesLink.o \ +$(OBJDIR)/TimeSeriesFileList.o \ $(OBJDIR)/tdis.o \ -$(OBJDIR)/Connections.o \ +$(OBJDIR)/HashTable.o \ +$(OBJDIR)/Sparse.o \ +$(OBJDIR)/DisvGeom.o \ +$(OBJDIR)/ArrayReaders.o \ $(OBJDIR)/TimeSeriesManager.o \ -$(OBJDIR)/Mover.o \ -$(OBJDIR)/UzfCellGroup.o \ -$(OBJDIR)/BaseExchange.o \ +$(OBJDIR)/SmoothingFunctions.o \ +$(OBJDIR)/ListReader.o \ +$(OBJDIR)/Connections.o \ $(OBJDIR)/DiscretizationBase.o \ -$(OBJDIR)/NumericalPackage.o \ -$(OBJDIR)/Observe.o \ -$(OBJDIR)/BaseSolution.o \ -$(OBJDIR)/gwf3disv8.o \ -$(OBJDIR)/OutputControlData.o \ -$(OBJDIR)/gwf3dis8.o \ $(OBJDIR)/TimeArray.o \ -$(OBJDIR)/gwf3ic8.o \ -$(OBJDIR)/gwf3tvbase8.o \ +$(OBJDIR)/ObsOutput.o \ $(OBJDIR)/TimeArraySeries.o \ -$(OBJDIR)/gwt1ic1.o \ +$(OBJDIR)/ObsOutputList.o \ +$(OBJDIR)/Observe.o \ +$(OBJDIR)/InputDefinition.o \ $(OBJDIR)/TimeArraySeriesLink.o \ -$(OBJDIR)/gwf3disu8.o \ -$(OBJDIR)/BudgetTerm.o \ -$(OBJDIR)/TimeArraySeriesManager.o \ -$(OBJDIR)/Xt3dInterface.o \ -$(OBJDIR)/ObsContainer.o \ -$(OBJDIR)/SolutionGroup.o \ -$(OBJDIR)/GwtSpc.o \ -$(OBJDIR)/gwf3tvs8.o \ $(OBJDIR)/ObsUtility.o \ -$(OBJDIR)/OutputControl.o \ -$(OBJDIR)/gwf3tvk8.o \ -$(OBJDIR)/gwf3hfb8.o \ -$(OBJDIR)/BudgetObject.o \ +$(OBJDIR)/ObsContainer.o \ +$(OBJDIR)/VectorInt.o \ +$(OBJDIR)/gwt1dspidm.o \ +$(OBJDIR)/gwf3npf8idm.o \ +$(OBJDIR)/gwf3disv8idm.o \ +$(OBJDIR)/gwf3disu8idm.o \ +$(OBJDIR)/gwf3dis8idm.o \ +$(OBJDIR)/TimeArraySeriesManager.o \ +$(OBJDIR)/PackageMover.o \ $(OBJDIR)/Obs3.o \ -$(OBJDIR)/gwf3npf8.o \ -$(OBJDIR)/gwt1obs1.o \ -$(OBJDIR)/gwf3mvr8.o \ -$(OBJDIR)/gwt1oc1.o \ -$(OBJDIR)/gwf3sto8.o \ +$(OBJDIR)/NumericalPackage.o \ +$(OBJDIR)/Budget.o \ +$(OBJDIR)/BudgetFileReader.o \ +$(OBJDIR)/StructVector.o \ +$(OBJDIR)/IdmLogger.o \ +$(OBJDIR)/InputDefinitionSelector.o \ $(OBJDIR)/BoundaryPackage.o \ -$(OBJDIR)/gwf3oc8.o \ -$(OBJDIR)/gwf3rch8.o \ -$(OBJDIR)/gwf3obs8.o \ -$(OBJDIR)/gwf3ghb8.o \ -$(OBJDIR)/gwf3uzf8.o \ -$(OBJDIR)/gwt1src1.o \ -$(OBJDIR)/gwf3wel8.o \ -$(OBJDIR)/gwf3lak8.o \ -$(OBJDIR)/gwf3maw8.o \ -$(OBJDIR)/gwf3sfr8.o \ -$(OBJDIR)/gwf3api8.o \ -$(OBJDIR)/gwf3riv8.o \ -$(OBJDIR)/gwf3buy8.o \ -$(OBJDIR)/gwf3chd8.o \ -$(OBJDIR)/gwf3evt8.o \ -$(OBJDIR)/gwf3csub8.o \ -$(OBJDIR)/gwf3drn8.o \ -$(OBJDIR)/gwt1fmi1.o \ -$(OBJDIR)/gwt1cnc1.o \ +$(OBJDIR)/BaseModel.o \ +$(OBJDIR)/BudgetTerm.o \ +$(OBJDIR)/StructArray.o \ +$(OBJDIR)/ModflowInput.o \ $(OBJDIR)/NumericalModel.o \ -$(OBJDIR)/gwt1dsp.o \ +$(OBJDIR)/mf6lists.o \ +$(OBJDIR)/PackageBudget.o \ +$(OBJDIR)/HeadFileReader.o \ +$(OBJDIR)/BudgetObject.o \ +$(OBJDIR)/sort.o \ +$(OBJDIR)/SfrCrossSectionUtils.o \ +$(OBJDIR)/PrintSaveManager.o \ +$(OBJDIR)/Xt3dAlgorithm.o \ +$(OBJDIR)/gwf3tvbase8.o \ +$(OBJDIR)/LoadMf6FileType.o \ +$(OBJDIR)/DistributedModel.o \ +$(OBJDIR)/BaseExchange.o \ +$(OBJDIR)/UzfCellGroup.o \ +$(OBJDIR)/gwt1fmi1.o \ +$(OBJDIR)/SfrCrossSectionManager.o \ +$(OBJDIR)/dag_module.o \ +$(OBJDIR)/OutputControlData.o \ +$(OBJDIR)/gwf3ic8.o \ +$(OBJDIR)/Xt3dInterface.o \ +$(OBJDIR)/gwf3tvk8.o \ +$(OBJDIR)/MemoryManagerExt.o \ +$(OBJDIR)/IdmMf6FileLoader.o \ +$(OBJDIR)/GwfNpfOptions.o \ +$(OBJDIR)/CellWithNbrs.o \ +$(OBJDIR)/NumericalExchange.o \ +$(OBJDIR)/Iunit.o \ +$(OBJDIR)/gwf3uzf8.o \ $(OBJDIR)/gwt1apt1.o \ +$(OBJDIR)/GwtSpc.o \ +$(OBJDIR)/gwf3sfr8.o \ +$(OBJDIR)/OutputControl.o \ +$(OBJDIR)/gwt1ic1.o \ +$(OBJDIR)/gwf3maw8.o \ +$(OBJDIR)/gwf3lak8.o \ +$(OBJDIR)/gwt1mst1.o \ +$(OBJDIR)/GwtDspOptions.o \ +$(OBJDIR)/gwf3npf8.o \ +$(OBJDIR)/GwtAdvOptions.o \ +$(OBJDIR)/gwf3tvs8.o \ +$(OBJDIR)/GwfStorageUtils.o \ +$(OBJDIR)/Mover.o \ +$(OBJDIR)/GwfMvrPeriodData.o \ +$(OBJDIR)/ims8misc.o \ +$(OBJDIR)/GwfBuyInputData.o \ +$(OBJDIR)/InterfaceMap.o \ +$(OBJDIR)/gwf3disu8.o \ +$(OBJDIR)/GridSorting.o \ +$(OBJDIR)/DisConnExchange.o \ +$(OBJDIR)/CsrUtils.o \ +$(OBJDIR)/MappedVariable.o \ $(OBJDIR)/TransportModel.o \ +$(OBJDIR)/NameFile.o \ $(OBJDIR)/gwt1uzt1.o \ -$(OBJDIR)/gwt1adv1.o \ $(OBJDIR)/gwt1ssm1.o \ -$(OBJDIR)/gwt1mst1.o \ +$(OBJDIR)/gwt1src1.o \ $(OBJDIR)/gwt1sft1.o \ -$(OBJDIR)/NumericalExchange.o \ +$(OBJDIR)/gwt1oc1.o \ +$(OBJDIR)/gwt1obs1.o \ $(OBJDIR)/gwt1mwt1.o \ -$(OBJDIR)/GhostNode.o \ $(OBJDIR)/gwt1mvt1.o \ $(OBJDIR)/gwt1lkt1.o \ $(OBJDIR)/gwt1ist1.o \ -$(OBJDIR)/DistributedModel.o \ +$(OBJDIR)/gwt1dsp.o \ +$(OBJDIR)/gwt1cnc1.o \ +$(OBJDIR)/gwt1adv1.o \ +$(OBJDIR)/gwf3disv8.o \ +$(OBJDIR)/gwf3dis8.o \ +$(OBJDIR)/gwf3api8.o \ +$(OBJDIR)/gwf3wel8.o \ +$(OBJDIR)/gwf3riv8.o \ +$(OBJDIR)/gwf3rch8.o \ +$(OBJDIR)/gwf3sto8.o \ +$(OBJDIR)/gwf3oc8.o \ +$(OBJDIR)/gwf3obs8.o \ +$(OBJDIR)/gwf3mvr8.o \ +$(OBJDIR)/gwf3hfb8.o \ +$(OBJDIR)/gwf3csub8.o \ +$(OBJDIR)/gwf3buy8.o \ +$(OBJDIR)/GhostNode.o \ +$(OBJDIR)/gwf3ghb8.o \ +$(OBJDIR)/gwf3evt8.o \ +$(OBJDIR)/gwf3drn8.o \ +$(OBJDIR)/gwf3chd8.o \ +$(OBJDIR)/ims8reordering.o \ +$(OBJDIR)/GridConnection.o \ +$(OBJDIR)/DistributedData.o \ $(OBJDIR)/gwt1.o \ -$(OBJDIR)/NumericalSolution.o \ -$(OBJDIR)/DisConnExchange.o \ $(OBJDIR)/gwf3.o \ -$(OBJDIR)/CellWithNbrs.o \ -$(OBJDIR)/GridSorting.o \ +$(OBJDIR)/ims8base.o \ +$(OBJDIR)/SpatialModelConnection.o \ +$(OBJDIR)/GwtInterfaceModel.o \ $(OBJDIR)/GwtGwtExchange.o \ -$(OBJDIR)/GwfGwfExchange.o \ -$(OBJDIR)/GridConnection.o \ $(OBJDIR)/GwfInterfaceModel.o \ -$(OBJDIR)/GwtInterfaceModel.o \ -$(OBJDIR)/SpatialModelConnection.o \ -$(OBJDIR)/GwfGwfConnection.o \ +$(OBJDIR)/GwfGwfExchange.o \ +$(OBJDIR)/BaseSolution.o \ +$(OBJDIR)/Timer.o \ +$(OBJDIR)/ims8linear.o \ $(OBJDIR)/GwtGwtConnection.o \ +$(OBJDIR)/GwfGwfConnection.o \ +$(OBJDIR)/SolutionGroup.o \ +$(OBJDIR)/NumericalSolution.o \ $(OBJDIR)/GwfGwtExchange.o \ -$(OBJDIR)/ConnectionBuilder.o \ $(OBJDIR)/SimulationCreate.o \ +$(OBJDIR)/ConnectionBuilder.o \ +$(OBJDIR)/comarg.o \ $(OBJDIR)/mf6core.o \ -$(OBJDIR)/mf6.o +$(OBJDIR)/BaseGeometry.o \ +$(OBJDIR)/mf6.o \ +$(OBJDIR)/StringList.o \ +$(OBJDIR)/MemorySetHandler.o \ +$(OBJDIR)/ilut.o \ +$(OBJDIR)/sparsekit.o \ +$(OBJDIR)/rcm.o \ +$(OBJDIR)/blas1_d.o \ +$(OBJDIR)/RectangularGeometry.o \ +$(OBJDIR)/CircularGeometry.o # Define the objects that make up the program $(PROGRAM) : $(OBJECTS) diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index 91c9f7e40ad..975d2eb3bd0 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -80,8 +80,11 @@ + + + @@ -91,6 +94,7 @@ + @@ -108,6 +112,7 @@ + @@ -157,6 +162,15 @@ + + + + + + + + + @@ -168,6 +182,7 @@ + diff --git a/src/Model/Connection/GwfInterfaceModel.f90 b/src/Model/Connection/GwfInterfaceModel.f90 index 63c8f28fb89..a4dfe220e1a 100644 --- a/src/Model/Connection/GwfInterfaceModel.f90 +++ b/src/Model/Connection/GwfInterfaceModel.f90 @@ -70,8 +70,8 @@ subroutine gwfifm_cr(this, name, iout, gridConn) ! create discretization and packages call disu_cr(this%dis, this%name, -1, this%iout) - call npf_cr(this%npf, this%name, this%innpf, this%iout) - call xt3d_cr(this%xt3d, this%name, this%innpf, this%iout) + call npf_cr(this%npf, this%name, -this%innpf, this%iout) + call xt3d_cr(this%xt3d, this%name, -this%innpf, this%iout) call buy_cr(this%buy, this%name, this%inbuy, this%iout) end subroutine gwfifm_cr diff --git a/src/Model/Connection/GwtInterfaceModel.f90 b/src/Model/Connection/GwtInterfaceModel.f90 index 61235a2b5c1..472a63e980e 100644 --- a/src/Model/Connection/GwtInterfaceModel.f90 +++ b/src/Model/Connection/GwtInterfaceModel.f90 @@ -81,7 +81,7 @@ subroutine gwtifmod_cr(this, name, iout, gridConn) call disu_cr(this%dis, this%name, -1, this%iout) call fmi_cr(this%fmi, this%name, 0, this%iout) call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi) - call dsp_cr(this%dsp, this%name, dsp_unit, this%iout, this%fmi) + call dsp_cr(this%dsp, this%name, -dsp_unit, this%iout, this%fmi) call gwt_obs_cr(this%obs, inobs) end subroutine gwtifmod_cr diff --git a/src/Model/GroundWaterFlow/gwf3dis8.f90 b/src/Model/GroundWaterFlow/gwf3dis8.f90 index 31939d472cc..54017c42265 100644 --- a/src/Model/GroundWaterFlow/gwf3dis8.f90 +++ b/src/Model/GroundWaterFlow/gwf3dis8.f90 @@ -2,13 +2,14 @@ module GwfDisModule use ArrayReadersModule, only: ReadArray use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH, DHALF, DZERO + use ConstantsModule, only: LINELENGTH, DHALF, DZERO, LENMEMPATH, LENVARNAME use BaseDisModule, only: DisBaseType use InputOutputModule, only: get_node, URWORD, ulasav, ulaprufw, ubdsv1, & ubdsv06 use SimModule, only: count_errors, store_error, store_error_unit use BlockParserModule, only: BlockParserType use MemoryManagerModule, only: mem_allocate + use MemoryHelperModule, only: create_mem_path use TdisModule, only: kstp, kper, pertim, totim, delt implicit none @@ -47,9 +48,12 @@ module GwfDisModule procedure :: connection_vector procedure :: connection_normal ! -- private - procedure :: read_options - procedure :: read_dimensions - procedure :: read_mf6_griddata + procedure :: source_options + procedure :: source_dimensions + procedure :: source_griddata + procedure :: log_options + procedure :: log_dimensions + procedure :: log_griddata procedure :: grid_finalize procedure :: write_grb procedure :: allocate_scalars @@ -69,11 +73,19 @@ subroutine dis_cr(dis, name_model, inunit, iout) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ + ! -- modules + use IdmMf6FileLoaderModule, only: input_load + use ConstantsModule, only: LENPACKAGETYPE + ! -- dummy class(DisBaseType), pointer :: dis character(len=*), intent(in) :: name_model integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout + ! -- locals type(GwfDisType), pointer :: disnew + character(len=*), parameter :: fmtheader = & + "(1X, /1X, 'DIS -- STRUCTURED GRID DISCRETIZATION PACKAGE,', & + &' VERSION 2 : 3/27/2014 - INPUT READ FROM UNIT ', I0, /)" ! ------------------------------------------------------------------------------ allocate (disnew) dis => disnew @@ -81,8 +93,22 @@ subroutine dis_cr(dis, name_model, inunit, iout) dis%inunit = inunit dis%iout = iout ! - ! -- Initialize block parser - call dis%parser%Initialize(dis%inunit, dis%iout) + ! -- if reading from file + if (inunit > 0) then + ! + ! -- Identify package + if (iout > 0) then + write (iout, fmtheader) inunit + end if + ! + ! -- Initialize block parser + call dis%parser%Initialize(inunit, iout) + ! + ! -- Use the input data model routines to load the input data + ! into memory + call input_load(dis%parser, 'DIS6', 'GWF', 'DIS', name_model, 'DIS', & + [character(len=LENPACKAGETYPE) ::], iout) + end if ! ! -- Return return @@ -90,7 +116,7 @@ end subroutine dis_cr subroutine dis3d_df(this) ! ****************************************************************************** -! read_from_file -- Allocate and read discretization information +! dis3d_df -- Define ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -102,22 +128,17 @@ subroutine dis3d_df(this) ! -- locals ! ------------------------------------------------------------------------------ ! - ! -- read data from file + ! -- Transfer the data from the memory manager into this package object if (this%inunit /= 0) then ! - ! -- Identify package - write (this%iout, 1) this%inunit -1 format(1X, /1X, 'DIS -- STRUCTURED GRID DISCRETIZATION PACKAGE,', & - ' VERSION 2 : 3/27/2014 - INPUT READ FROM UNIT ', I0, //) - ! - ! -- Read options - call this%read_options() + ! -- source input options + call this%source_options() ! - ! -- Read dimensions block - call this%read_dimensions() + ! -- source input dimensions + call this%source_dimensions() ! - ! -- Read GRIDDATA block - call this%read_mf6_griddata() + ! -- source input griddata + call this%source_griddata() end if ! ! -- Final grid initialization @@ -136,11 +157,18 @@ subroutine dis3d_da(this) ! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate + use MemoryManagerExtModule, only: memorylist_remove + use SimVariablesModule, only: idm_context ! -- dummy class(GwfDisType) :: this ! -- locals ! ------------------------------------------------------------------------------ ! + ! -- Deallocate idm memory + call memorylist_remove(this%name_model, 'DIS', idm_context) + call memorylist_remove(component=this%name_model, & + context=idm_context) + ! ! -- DisBaseType deallocate call this%DisBaseType%dis_da() ! @@ -164,136 +192,101 @@ subroutine dis3d_da(this) return end subroutine dis3d_da - subroutine read_options(this) -! ****************************************************************************** -! read_options -- Read options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ + !> @brief Copy options from IDM into package + !< + subroutine source_options(this) ! -- modules - use ConstantsModule, only: LINELENGTH + use KindModule, only: LGP + use MemoryTypeModule, only: MemoryType + use MemoryManagerExtModule, only: mem_set_value + use SimVariablesModule, only: idm_context ! -- dummy class(GwfDisType) :: this ! -- locals - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock -! ------------------------------------------------------------------------------ - ! - ! -- get options block - call this%parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) - ! - ! -- set default options - this%lenuni = 0 - ! - ! -- parse options block if detected - if (isfound) then - write (this%iout, '(1x,a)') 'PROCESSING DISCRETIZATION OPTIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('LENGTH_UNITS') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FEET') then - this%lenuni = 1 - write (this%iout, '(4x,a)') 'MODEL LENGTH UNIT IS FEET' - elseif (keyword == 'METERS') then - this%lenuni = 2 - write (this%iout, '(4x,a)') 'MODEL LENGTH UNIT IS METERS' - elseif (keyword == 'CENTIMETERS') then - this%lenuni = 3 - write (this%iout, '(4x,a)') 'MODEL LENGTH UNIT IS CENTIMETERS' - else - write (this%iout, '(4x,a)') 'UNKNOWN UNIT: ', trim(keyword) - write (this%iout, '(4x,a)') 'SETTING TO: ', 'UNDEFINED' - end if - case ('NOGRB') - write (this%iout, '(4x,a)') 'BINARY GRB FILE WILL NOT BE WRITTEN' - this%writegrb = .false. - case ('XORIGIN') - this%xorigin = this%parser%GetDouble() - write (this%iout, '(4x,a,1pg24.15)') 'XORIGIN SPECIFIED AS ', & - this%xorigin - case ('YORIGIN') - this%yorigin = this%parser%GetDouble() - write (this%iout, '(4x,a,1pg24.15)') 'YORIGIN SPECIFIED AS ', & - this%yorigin - case ('ANGROT') - this%angrot = this%parser%GetDouble() - write (this%iout, '(4x,a,1pg24.15)') 'ANGROT SPECIFIED AS ', & - this%angrot - case default - write (errmsg, '(4x,a,a)') '****ERROR. UNKNOWN DIS OPTION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - end select - end do - write (this%iout, '(1x,a)') 'END OF DISCRETIZATION OPTIONS' - else - write (this%iout, '(1x,a)') 'NO OPTION BLOCK DETECTED.' - end if - if (this%lenuni == 0) then - write (this%iout, '(1x,a)') 'MODEL LENGTH UNIT IS UNDEFINED' + character(len=LENMEMPATH) :: idmMemoryPath + character(len=LENVARNAME), dimension(3) :: lenunits = & + &[character(len=LENVARNAME) :: 'FEET', 'METERS', 'CENTIMETERS'] + logical, dimension(5) :: afound + ! + ! -- set memory path + idmMemoryPath = create_mem_path(this%name_model, 'DIS', idm_context) + ! + ! -- update defaults with idm sourced values + call mem_set_value(this%lenuni, 'LENGTH_UNITS', idmMemoryPath, lenunits, & + afound(1)) + call mem_set_value(this%nogrb, 'NOGRB', idmMemoryPath, afound(2)) + call mem_set_value(this%xorigin, 'XORIGIN', idmMemoryPath, afound(3)) + call mem_set_value(this%yorigin, 'YORIGIN', idmMemoryPath, afound(4)) + call mem_set_value(this%angrot, 'ANGROT', idmMemoryPath, afound(5)) + ! + ! -- log values to list file + if (this%iout > 0) then + call this%log_options(afound) end if ! ! -- Return return - end subroutine read_options + end subroutine source_options - subroutine read_dimensions(this) -! ****************************************************************************** -! read_dimensions -- Read dimensions -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH + !> @brief Write user options to list file + !< + subroutine log_options(this, afound) + class(GwfDisType) :: this + logical, dimension(:), intent(in) :: afound + + write (this%iout, '(1x,a)') 'Setting Discretization Options' + + if (afound(1)) then + write (this%iout, '(4x,a,i0)') 'MODEL LENGTH UNIT [0=UND, 1=FEET, & + &2=METERS, 3=CENTIMETERS] SET AS ', this%lenuni + end if + + if (afound(2)) then + write (this%iout, '(4x,a,i0)') 'BINARY GRB FILE [0=GRB, 1=NOGRB] & + &SET AS ', this%nogrb + end if + + if (afound(3)) then + write (this%iout, '(4x,a,G0)') 'XORIGIN = ', this%xorigin + end if + + if (afound(4)) then + write (this%iout, '(4x,a,G0)') 'YORIGIN = ', this%yorigin + end if + + if (afound(5)) then + write (this%iout, '(4x,a,G0)') 'ANGROT = ', this%angrot + end if + + write (this%iout, '(1x,a,/)') 'End Setting Discretization Options' + + end subroutine log_options + + !> @brief Copy dimensions from IDM into package + !< + subroutine source_dimensions(this) + use KindModule, only: LGP + use MemoryTypeModule, only: MemoryType + use MemoryManagerExtModule, only: mem_set_value + use SimVariablesModule, only: idm_context ! -- dummy class(GwfDisType) :: this ! -- locals - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ierr + character(len=LENMEMPATH) :: idmMemoryPath integer(I4B) :: i, j, k - logical :: isfound, endOfBlock -! ------------------------------------------------------------------------------ + logical, dimension(3) :: afound ! - ! -- get dimensions block - call this%parser%GetBlock('DIMENSIONS', isfound, ierr, & - supportOpenClose=.true.) - ! - ! -- parse dimensions block if detected - if (isfound) then - write (this%iout, '(1x,a)') 'PROCESSING DISCRETIZATION DIMENSIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('NLAY') - this%nlay = this%parser%GetInteger() - write (this%iout, '(4x,a,i7)') 'NLAY = ', this%nlay - case ('NROW') - this%nrow = this%parser%GetInteger() - write (this%iout, '(4x,a,i7)') 'NROW = ', this%nrow - case ('NCOL') - this%ncol = this%parser%GetInteger() - write (this%iout, '(4x,a,i7)') 'NCOL = ', this%ncol - case default - write (errmsg, '(4x,a,a)') '****ERROR. UNKNOWN DIS DIMENSION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - end select - end do - write (this%iout, '(1x,a)') 'END OF DISCRETIZATION DIMENSIONS' - else - call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') - call this%parser%StoreErrorUnit() + ! -- set memory path + idmMemoryPath = create_mem_path(this%name_model, 'DIS', idm_context) + ! + ! -- update defaults with idm sourced values + call mem_set_value(this%nlay, 'NLAY', idmMemoryPath, afound(1)) + call mem_set_value(this%nrow, 'NROW', idmMemoryPath, afound(2)) + call mem_set_value(this%ncol, 'NCOL', idmMemoryPath, afound(3)) + ! + ! -- log simulation values + if (this%iout > 0) then + call this%log_dimensions(afound) end if ! ! -- verify dimensions were set @@ -338,116 +331,100 @@ subroutine read_dimensions(this) ! ! -- Return return - end subroutine read_dimensions + end subroutine source_dimensions + + !> @brief Write dimensions to list file + !< + subroutine log_dimensions(this, afound) + class(GwfDisType) :: this + logical, dimension(:), intent(in) :: afound + + write (this%iout, '(1x,a)') 'Setting Discretization Dimensions' + + if (afound(1)) then + write (this%iout, '(4x,a,i0)') 'NLAY = ', this%nlay + end if + + if (afound(2)) then + write (this%iout, '(4x,a,i0)') 'NROW = ', this%nrow + end if + + if (afound(3)) then + write (this%iout, '(4x,a,i0)') 'NCOL = ', this%ncol + end if + + write (this%iout, '(1x,a,/)') 'End Setting Discretization Dimensions' + + end subroutine log_dimensions - subroutine read_mf6_griddata(this) + subroutine source_griddata(this) ! ****************************************************************************** -! read_mf6_griddata -- Read griddata from a MODFLOW 6 ascii file +! source_griddata -- update simulation mempath griddata ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use SimModule, only: count_errors, store_error - use ConstantsModule, only: LINELENGTH, DZERO - use MemoryManagerModule, only: mem_allocate + use MemoryManagerExtModule, only: mem_set_value + use SimVariablesModule, only: idm_context ! -- dummy class(GwfDisType) :: this ! -- locals - character(len=LINELENGTH) :: keyword - integer(I4B) :: n - integer(I4B) :: nvals - integer(I4B) :: ierr - logical :: isfound, endOfBlock - integer(I4B), parameter :: nname = 5 - logical, dimension(nname) :: lname - character(len=24), dimension(nname) :: aname - character(len=300) :: ermsg + character(len=LENMEMPATH) :: idmMemoryPath + logical, dimension(5) :: afound ! -- formats - ! -- data - data aname(1)/' DELR'/ - data aname(2)/' DELC'/ - data aname(3)/'TOP ELEVATION OF LAYER 1'/ - data aname(4)/' MODEL LAYER BOTTOM EL.'/ - data aname(5)/' IDOMAIN'/ ! ------------------------------------------------------------------------------ - do n = 1, size(aname) - lname(n) = .false. - end do ! - ! -- Read GRIDDATA block - call this%parser%GetBlock('GRIDDATA', isfound, ierr) - lname(:) = .false. - if (isfound) then - write (this%iout, '(1x,a)') 'PROCESSING GRIDDATA' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('DELR') - call ReadArray(this%parser%iuactive, this%delr, aname(1), & - this%ndim, this%ncol, this%iout, 0) - lname(1) = .true. - case ('DELC') - call ReadArray(this%parser%iuactive, this%delc, aname(2), & - this%ndim, this%nrow, this%iout, 0) - lname(2) = .true. - case ('TOP') - call ReadArray(this%parser%iuactive, this%top2d(:, :), aname(3), & - this%ndim, this%ncol, this%nrow, this%iout, 0) - lname(3) = .true. - case ('BOTM') - call this%parser%GetStringCaps(keyword) - if (keyword .EQ. 'LAYERED') then - call ReadArray(this%parser%iuactive, this%bot3d(:, :, :), & - aname(4), this%ndim, this%ncol, this%nrow, & - this%nlay, this%iout, 1, this%nlay) - else - nvals = this%ncol * this%nrow * this%nlay - call ReadArray(this%parser%iuactive, this%bot3d(:, :, :), & - aname(4), this%ndim, nvals, this%iout) - end if - lname(4) = .true. - case ('IDOMAIN') - call this%parser%GetStringCaps(keyword) - if (keyword .EQ. 'LAYERED') then - call ReadArray(this%parser%iuactive, this%idomain, aname(5), & - this%ndim, this%ncol, this%nrow, this%nlay, & - this%iout, 1, this%nlay) - else - call ReadArray(this%parser%iuactive, this%idomain, aname(5), & - this%ndim, this%nodesuser, 1, 1, this%iout, 0, 0) - end if - lname(5) = .true. - case default - write (ermsg, '(4x,a,a)') 'ERROR. UNKNOWN GRIDDATA TAG: ', & - trim(keyword) - call store_error(ermsg) - call this%parser%StoreErrorUnit() - end select - end do - write (this%iout, '(1x,a)') 'END PROCESSING GRIDDATA' - else - call store_error('ERROR. REQUIRED GRIDDATA BLOCK NOT FOUND.') - call this%parser%StoreErrorUnit() - end if + ! -- set memory path + idmMemoryPath = create_mem_path(this%name_model, 'DIS', idm_context) ! - ! -- Verify all required items were read (IDOMAIN not required) - do n = 1, nname - 1 - if (.not. lname(n)) then - write (ermsg, '(1x,a,a)') & - 'ERROR. REQUIRED INPUT WAS NOT SPECIFIED: ', aname(n) - call store_error(ermsg) - end if - end do - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() + ! -- update defaults with idm sourced values + call mem_set_value(this%delr, 'DELR', idmMemoryPath, afound(1)) + call mem_set_value(this%delc, 'DELC', idmMemoryPath, afound(2)) + call mem_set_value(this%top2d, 'TOP', idmMemoryPath, afound(3)) + call mem_set_value(this%bot3d, 'BOTM', idmMemoryPath, afound(4)) + call mem_set_value(this%idomain, 'IDOMAIN', idmMemoryPath, afound(5)) + ! + ! -- log simulation values + if (this%iout > 0) then + call this%log_griddata(afound) end if ! ! -- Return return - end subroutine read_mf6_griddata + end subroutine source_griddata + + !> @brief Write dimensions to list file + !< + subroutine log_griddata(this, afound) + class(GwfDisType) :: this + logical, dimension(:), intent(in) :: afound + + write (this%iout, '(1x,a)') 'Setting Discretization Griddata' + + if (afound(1)) then + write (this%iout, '(4x,a)') 'DELR set from input file' + end if + + if (afound(2)) then + write (this%iout, '(4x,a)') 'DELC set from input file' + end if + + if (afound(3)) then + write (this%iout, '(4x,a)') 'TOP set from input file' + end if + + if (afound(4)) then + write (this%iout, '(4x,a)') 'BOTM set from input file' + end if + + if (afound(5)) then + write (this%iout, '(4x,a)') 'IDOMAIN set from input file' + end if + + write (this%iout, '(1x,a,/)') 'End Setting Discretization Griddata' + + end subroutine log_griddata subroutine grid_finalize(this) ! ****************************************************************************** @@ -457,7 +434,6 @@ subroutine grid_finalize(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use SimModule, only: count_errors, store_error use ConstantsModule, only: LINELENGTH, DZERO use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -1366,7 +1342,6 @@ subroutine read_int_array(this, line, lloc, istart, istop, iout, in, & ! ------------------------------------------------------------------------------ ! -- modules use InputOutputModule, only: urword - use SimModule, only: store_error use ConstantsModule, only: LINELENGTH ! -- dummy class(GwfDisType), intent(inout) :: this @@ -1436,7 +1411,6 @@ subroutine read_dbl_array(this, line, lloc, istart, istop, iout, in, & ! ------------------------------------------------------------------------------ ! -- modules use InputOutputModule, only: urword - use SimModule, only: store_error use ConstantsModule, only: LINELENGTH ! -- dummy class(GwfDisType), intent(inout) :: this @@ -1709,7 +1683,6 @@ subroutine nlarray_to_nodelist(this, nodelist, maxbnd, nbound, aname, & ! ------------------------------------------------------------------------------ ! -- modules use InputOutputModule, only: get_node - use SimModule, only: store_error use ConstantsModule, only: LINELENGTH ! -- dummy class(GwfDisType) :: this diff --git a/src/Model/GroundWaterFlow/gwf3dis8idm.f90 b/src/Model/GroundWaterFlow/gwf3dis8idm.f90 new file mode 100644 index 00000000000..69df46d4ee3 --- /dev/null +++ b/src/Model/GroundWaterFlow/gwf3dis8idm.f90 @@ -0,0 +1,261 @@ +module GwfDisInputModule + use InputDefinitionModule, only: InputParamDefinitionType, & + InputBlockDefinitionType + private + public gwf_dis_param_definitions + public gwf_dis_aggregate_definitions + public gwf_dis_block_definitions + + type(InputParamDefinitionType), parameter :: & + gwfdis_length_units = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DIS', & ! subcomponent + 'OPTIONS', & ! block + 'LENGTH_UNITS', & ! tag name + 'LENGTH_UNITS', & ! fortran variable + 'STRING', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdis_nogrb = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DIS', & ! subcomponent + 'OPTIONS', & ! block + 'NOGRB', & ! tag name + 'NOGRB', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdis_xorigin = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DIS', & ! subcomponent + 'OPTIONS', & ! block + 'XORIGIN', & ! tag name + 'XORIGIN', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdis_yorigin = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DIS', & ! subcomponent + 'OPTIONS', & ! block + 'YORIGIN', & ! tag name + 'YORIGIN', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdis_angrot = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DIS', & ! subcomponent + 'OPTIONS', & ! block + 'ANGROT', & ! tag name + 'ANGROT', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdis_nlay = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DIS', & ! subcomponent + 'DIMENSIONS', & ! block + 'NLAY', & ! tag name + 'NLAY', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdis_nrow = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DIS', & ! subcomponent + 'DIMENSIONS', & ! block + 'NROW', & ! tag name + 'NROW', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdis_ncol = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DIS', & ! subcomponent + 'DIMENSIONS', & ! block + 'NCOL', & ! tag name + 'NCOL', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdis_delr = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DIS', & ! subcomponent + 'GRIDDATA', & ! block + 'DELR', & ! tag name + 'DELR', & ! fortran variable + 'DOUBLE1D', & ! type + 'NCOL', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdis_delc = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DIS', & ! subcomponent + 'GRIDDATA', & ! block + 'DELC', & ! tag name + 'DELC', & ! fortran variable + 'DOUBLE1D', & ! type + 'NROW', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdis_top = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DIS', & ! subcomponent + 'GRIDDATA', & ! block + 'TOP', & ! tag name + 'TOP', & ! fortran variable + 'DOUBLE2D', & ! type + 'NCOL, NROW', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdis_botm = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DIS', & ! subcomponent + 'GRIDDATA', & ! block + 'BOTM', & ! tag name + 'BOTM', & ! fortran variable + 'DOUBLE3D', & ! type + 'NCOL, NROW, NLAY', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdis_idomain = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DIS', & ! subcomponent + 'GRIDDATA', & ! block + 'IDOMAIN', & ! tag name + 'IDOMAIN', & ! fortran variable + 'INTEGER3D', & ! type + 'NCOL, NROW, NLAY', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwf_dis_param_definitions(*) = & + [ & + gwfdis_length_units, & + gwfdis_nogrb, & + gwfdis_xorigin, & + gwfdis_yorigin, & + gwfdis_angrot, & + gwfdis_nlay, & + gwfdis_nrow, & + gwfdis_ncol, & + gwfdis_delr, & + gwfdis_delc, & + gwfdis_top, & + gwfdis_botm, & + gwfdis_idomain & + ] + + type(InputParamDefinitionType), parameter :: & + gwf_dis_aggregate_definitions(*) = & + [ & + InputParamDefinitionType :: & + ] + + type(InputBlockDefinitionType), parameter :: & + gwf_dis_block_definitions(*) = & + [ & + InputBlockDefinitionType( & + 'OPTIONS', & ! blockname + .false., & ! required + .false. & ! aggregate + ), & + InputBlockDefinitionType( & + 'DIMENSIONS', & ! blockname + .true., & ! required + .false. & ! aggregate + ), & + InputBlockDefinitionType( & + 'GRIDDATA', & ! blockname + .true., & ! required + .false. & ! aggregate + ) & + ] + +end module GwfDisInputModule diff --git a/src/Model/GroundWaterFlow/gwf3disu8.f90 b/src/Model/GroundWaterFlow/gwf3disu8.f90 index 1bac6688493..21cd3bebab4 100644 --- a/src/Model/GroundWaterFlow/gwf3disu8.f90 +++ b/src/Model/GroundWaterFlow/gwf3disu8.f90 @@ -2,7 +2,8 @@ module GwfDisuModule use ArrayReadersModule, only: ReadArray use KindModule, only: DP, I4B, LGP - use ConstantsModule, only: LINELENGTH, DZERO, DONE + use ConstantsModule, only: LINELENGTH, LENMEMPATH, LENVARNAME, & + DZERO, DONE use ConnectionsModule, only: iac_to_ia use InputOutputModule, only: URWORD, ulasav, ulaprufw, ubdsv1, ubdsv06 use SimModule, only: count_errors, store_error, store_error_unit @@ -41,6 +42,7 @@ module GwfDisuModule logical(LGP) :: readFromFile ! True, when DIS is read from file (almost always) contains procedure :: dis_df => disu_df + procedure :: disu_load procedure :: dis_da => disu_da procedure :: get_dis_type => get_dis_type procedure :: disu_ck @@ -60,12 +62,17 @@ module GwfDisuModule procedure :: allocate_scalars procedure :: allocate_arrays procedure :: allocate_arrays_mem - procedure :: read_options - procedure :: read_dimensions - procedure :: read_mf6_griddata - procedure :: read_connectivity - procedure :: read_vertices - procedure :: read_cell2d + procedure :: source_options + procedure :: source_dimensions + procedure :: source_griddata + procedure :: source_connectivity + procedure :: source_vertices + procedure :: source_cell2d + procedure :: log_options + procedure :: log_dimensions + procedure :: log_griddata + procedure :: log_connectivity + procedure :: define_cellverts procedure :: write_grb ! ! -- Read a node-sized model array (reduced or not) @@ -82,6 +89,9 @@ subroutine disu_cr(dis, name_model, inunit, iout) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ + ! -- modules + use IdmMf6FileLoaderModule, only: input_load + use ConstantsModule, only: LENPACKAGETYPE ! -- dummy class(DisBaseType), pointer :: dis character(len=*), intent(in) :: name_model @@ -89,6 +99,9 @@ subroutine disu_cr(dis, name_model, inunit, iout) integer(I4B), intent(in) :: iout ! -- local type(GwfDisuType), pointer :: disnew + character(len=*), parameter :: fmtheader = & + "(1X, /1X, 'DISU -- UNSTRUCTURED GRID DISCRETIZATION PACKAGE,', & + &' VERSION 2 : 3/27/2014 - INPUT READ FROM UNIT ', I0, //)" ! ------------------------------------------------------------------------------ ! ! -- Create a new discretization object @@ -100,50 +113,75 @@ subroutine disu_cr(dis, name_model, inunit, iout) dis%inunit = inunit dis%iout = iout ! - ! -- Initialize block parser - call dis%parser%Initialize(dis%inunit, dis%iout) + ! -- if reading from file + if (inunit > 0) then + ! + ! -- Identify package + if (iout > 0) then + write (iout, fmtheader) inunit + end if + ! + ! -- initialize parser and load the disu input file + call dis%parser%Initialize(inunit, iout) + ! + ! -- Use the input data model routines to load the input data + ! into memory + call input_load(dis%parser, 'DISU6', 'GWF', 'DISU', name_model, 'DISU', & + [character(len=LENPACKAGETYPE) ::], iout) + ! + ! -- load disu + call disnew%disu_load() + end if ! ! -- Return return end subroutine disu_cr - subroutine disu_df(this) + subroutine disu_load(this) ! ****************************************************************************** -! disu_df -- Read discretization information from DISU input file +! disu_load -- transfer data into this discretization object ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ + use MemoryHelperModule, only: create_mem_path ! -- dummy class(GwfDisuType) :: this ! ------------------------------------------------------------------------------ ! - ! -- read data from file - if (this%inunit /= 0) then - ! - ! -- Identify package - write (this%iout, 1) this%inunit -1 format(1X, /1X, 'DISU -- UNSTRUCTURED GRID DISCRETIZATION PACKAGE,', & - ' VERSION 2 : 3/27/2014 - INPUT READ FROM UNIT ', I0, //) - ! - call this%read_options() - call this%read_dimensions() - call this%read_mf6_griddata() - call this%read_connectivity() - ! - ! -- If NVERT specified and greater than 0, then read VERTICES and CELL2D - if (this%nvert > 0) then - call this%read_vertices() - call this%read_cell2d() - else - ! -- connection direction information cannot be calculated - this%icondir = 0 - end if + ! -- source input data + call this%source_options() + call this%source_dimensions() + call this%source_griddata() + call this%source_connectivity() + ! + ! -- If NVERT specified and greater than 0, then source VERTICES and CELL2D + if (this%nvert > 0) then + call this%source_vertices() + call this%source_cell2d() + else + ! -- connection direction information cannot be calculated + this%icondir = 0 end if ! ! -- Make some final disu checks on the non-reduced user-provided ! input call this%disu_ck() + ! + ! -- Return + return + end subroutine disu_load + + subroutine disu_df(this) +! ****************************************************************************** +! disu_df -- Read discretization information from DISU input file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfDisuType) :: this +! ------------------------------------------------------------------------------ ! ! -- Finalize the grid by creating the connection object and reducing the ! grid using IDOMAIN, if necessary @@ -409,10 +447,17 @@ subroutine disu_da(this) ! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate + use MemoryManagerExtModule, only: memorylist_remove + use SimVariablesModule, only: idm_context ! -- dummy class(GwfDisuType) :: this ! ------------------------------------------------------------------------------ ! + ! -- Deallocate idm memory + call memorylist_remove(this%name_model, 'DISU', idm_context) + call memorylist_remove(component=this%name_model, & + context=idm_context) + ! ! -- scalars call mem_deallocate(this%njausr) call mem_deallocate(this%nvert) @@ -506,142 +551,145 @@ subroutine nodeu_to_array(this, nodeu, arr) return end subroutine nodeu_to_array - subroutine read_options(this) + !> @brief Write user options to list file + !< + subroutine log_options(this, afound) + class(GwfDisuType) :: this + logical, dimension(:), intent(in) :: afound + + write (this%iout, '(1x,a)') 'Setting Discretization Options' + + if (afound(1)) then + write (this%iout, '(4x,a,i0)') 'MODEL LENGTH UNIT [0=UND, 1=FEET, & + &2=METERS, 3=CENTIMETERS] SET AS ', this%lenuni + end if + + if (afound(2)) then + write (this%iout, '(4x,a,i0)') 'BINARY GRB FILE [0=GRB, 1=NOGRB] & + &SET AS ', this%nogrb + end if + + if (afound(3)) then + write (this%iout, '(4x,a,G0)') 'XORIGIN = ', this%xorigin + end if + + if (afound(4)) then + write (this%iout, '(4x,a,G0)') 'YORIGIN = ', this%yorigin + end if + + if (afound(5)) then + write (this%iout, '(4x,a,G0)') 'ANGROT = ', this%angrot + end if + + if (afound(6)) then + write (this%iout, '(4x,a,G0)') 'VERTICAL_OFFSET_TOLERANCE = ', & + this%voffsettol + end if + + write (this%iout, '(1x,a,/)') 'End Setting Discretization Options' + + end subroutine log_options + + !> @brief Copy options from IDM into package + !< + subroutine source_options(this) ! ****************************************************************************** -! read_options -- Read discretization options +! source_options -- source options from memory manager input path ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - use MemoryManagerModule, only: mem_allocate - implicit none + ! -- modules + use KindModule, only: LGP + use MemoryHelperModule, only: create_mem_path + use MemoryManagerExtModule, only: mem_set_value + use SimVariablesModule, only: idm_context + ! -- dummy class(GwfDisuType) :: this - character(len=LINELENGTH) :: keyword - integer(I4B) :: ierr, nerr - logical :: isfound, endOfBlock + ! -- locals + character(len=LENMEMPATH) :: idmMemoryPath + character(len=LENVARNAME), dimension(3) :: lenunits = & + &[character(len=LENVARNAME) :: 'FEET', 'METERS', 'CENTIMETERS'] + logical, dimension(6) :: afound ! ------------------------------------------------------------------------------ ! - ! -- get options block - call this%parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) - ! - ! -- set default options - this%lenuni = 0 - ! - ! -- parse options block if detected - if (isfound) then - write (this%iout, '(1x,a)') 'PROCESSING DISCRETIZATION OPTIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('LENGTH_UNITS') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FEET') then - this%lenuni = 1 - write (this%iout, '(4x,a)') 'MODEL LENGTH UNIT IS FEET' - elseif (keyword == 'METERS') then - this%lenuni = 2 - write (this%iout, '(4x,a)') 'MODEL LENGTH UNIT IS METERS' - elseif (keyword == 'CENTIMETERS') then - this%lenuni = 3 - write (this%iout, '(4x,a)') 'MODEL LENGTH UNIT IS CENTIMETERS' - else - write (this%iout, '(4x,a)') 'UNKNOWN UNIT: ', trim(keyword) - write (this%iout, '(4x,a)') 'SETTING TO: ', 'UNDEFINED' - end if - case ('NOGRB') - write (this%iout, '(4x,a)') 'BINARY GRB FILE WILL NOT BE WRITTEN' - this%writegrb = .false. - case ('XORIGIN') - this%xorigin = this%parser%GetDouble() - write (this%iout, '(4x,a,1pg24.15)') 'XORIGIN SPECIFIED AS ', & - this%xorigin - case ('YORIGIN') - this%yorigin = this%parser%GetDouble() - write (this%iout, '(4x,a,1pg24.15)') 'YORIGIN SPECIFIED AS ', & - this%yorigin - case ('ANGROT') - this%angrot = this%parser%GetDouble() - write (this%iout, '(4x,a,1pg24.15)') 'ANGROT SPECIFIED AS ', & - this%angrot - case ('VERTICAL_OFFSET_TOLERANCE') - this%voffsettol = this%parser%GetDouble() - write (this%iout, '(4x,a,1pg24.15)') & - 'VERTICAL OFFSET TOLERANCE SPECIFIED AS ', this%voffsettol - case default - write (errmsg, '(a)') 'Unknown DISU option: '//trim(keyword) - call store_error(errmsg) - end select - end do - write (this%iout, '(1x,a)') 'END OF DISCRETIZATION OPTIONS' - else - write (this%iout, '(1x,a)') 'NO OPTION BLOCK DETECTED.' - end if - if (this%lenuni == 0) then - write (this%iout, '(1x,a)') 'MODEL LENGTH UNIT IS UNDEFINED' - end if - ! - nerr = count_errors() - if (nerr > 0) then - call this%parser%StoreErrorUnit() + ! -- set memory path + idmMemoryPath = create_mem_path(this%name_model, 'DISU', idm_context) + ! + ! -- update defaults with idm sourced values + call mem_set_value(this%lenuni, 'LENGTH_UNITS', idmMemoryPath, lenunits, & + afound(1)) + call mem_set_value(this%nogrb, 'NOGRB', idmMemoryPath, afound(2)) + call mem_set_value(this%xorigin, 'XORIGIN', idmMemoryPath, afound(3)) + call mem_set_value(this%yorigin, 'YORIGIN', idmMemoryPath, afound(4)) + call mem_set_value(this%angrot, 'ANGROT', idmMemoryPath, afound(5)) + call mem_set_value(this%voffsettol, 'VOFFSETTOL', idmMemoryPath, afound(6)) + ! + ! -- log values to list file + if (this%iout > 0) then + call this%log_options(afound) end if ! ! -- Return return - end subroutine read_options + end subroutine source_options - subroutine read_dimensions(this) + !> @brief Write dimensions to list file + !< + subroutine log_dimensions(this, afound) + class(GwfDisuType) :: this + logical, dimension(:), intent(in) :: afound + + write (this%iout, '(1x,a)') 'Setting Discretization Dimensions' + + if (afound(1)) then + write (this%iout, '(4x,a,i0)') 'NODES = ', this%nodesuser + end if + + if (afound(2)) then + write (this%iout, '(4x,a,i0)') 'NJA = ', this%njausr + end if + + if (afound(3)) then + write (this%iout, '(4x,a,i0)') 'NVERT = ', this%nvert + end if + + write (this%iout, '(1x,a,/)') 'End Setting Discretization Dimensions' + + end subroutine log_dimensions + + !> @brief Copy dimensions from IDM into package + !< + subroutine source_dimensions(this) ! ****************************************************************************** -! read_dimensions -- Read discretization information from file +! source_dimensions -- source dimensions from memory manager input path ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - use MemoryManagerModule, only: mem_allocate - implicit none + use KindModule, only: LGP + use MemoryHelperModule, only: create_mem_path + use MemoryManagerExtModule, only: mem_set_value + use SimVariablesModule, only: idm_context + ! -- dummy class(GwfDisuType) :: this - character(len=LINELENGTH) :: keyword - integer(I4B) :: n, ierr - logical :: isfound, endOfBlock + ! -- locals + character(len=LENMEMPATH) :: idmMemoryPath + integer(I4B) :: n + logical, dimension(3) :: afound ! ------------------------------------------------------------------------------ ! - ! -- Initialize dimensions - this%nodesuser = -1 - this%njausr = -1 - ! - ! -- get options block - call this%parser%GetBlock('DIMENSIONS', isfound, ierr, & - supportOpenClose=.true.) - ! - ! -- parse options block if detected - if (isfound) then - write (this%iout, '(1x,a)') 'PROCESSING DISCRETIZATION DIMENSIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('NODES') - this%nodesuser = this%parser%GetInteger() - write (this%iout, '(4x,a,i0)') 'NODES = ', this%nodesuser - case ('NJA') - this%njausr = this%parser%GetInteger() - write (this%iout, '(4x,a,i0)') 'NJA = ', this%njausr - case ('NVERT') - this%nvert = this%parser%GetInteger() - write (this%iout, '(3x,a,i0)') 'NVERT = ', this%nvert - write (this%iout, '(3x,a)') 'VERTICES AND CELL2D BLOCKS WILL '// & - 'BE READ BELOW. ' - case default - write (errmsg, '(a)') 'Unknown DISU dimension: '//trim(keyword) - call store_error(errmsg) - end select - end do - write (this%iout, '(1x,a)') 'END OF DISCRETIZATION OPTIONS' - else - call store_error('Required dimensions block not found.') + ! -- set memory path + idmMemoryPath = create_mem_path(this%name_model, 'DISU', idm_context) + ! + ! -- update defaults with idm sourced values + call mem_set_value(this%nodesuser, 'NODES', idmMemoryPath, afound(1)) + call mem_set_value(this%njausr, 'NJA', idmMemoryPath, afound(2)) + call mem_set_value(this%nvert, 'NVERT', idmMemoryPath, afound(3)) + ! + ! -- log simulation values + if (this%iout > 0) then + call this%log_dimensions(afound) end if ! ! -- verify dimensions were set @@ -686,406 +734,312 @@ subroutine read_dimensions(this) ! ! -- Return return - end subroutine read_dimensions + end subroutine source_dimensions + + !> @brief Write griddata found to list file + !< + subroutine log_griddata(this, afound) + class(GwfDisuType) :: this + logical, dimension(:), intent(in) :: afound + + write (this%iout, '(1x,a)') 'Setting Discretization Griddata' - subroutine read_mf6_griddata(this) + if (afound(1)) then + write (this%iout, '(4x,a)') 'TOP set from input file' + end if + + if (afound(2)) then + write (this%iout, '(4x,a)') 'BOT set from input file' + end if + + if (afound(3)) then + write (this%iout, '(4x,a)') 'AREA set from input file' + end if + + if (afound(4)) then + write (this%iout, '(4x,a)') 'IDOMAIN set from input file' + end if + + write (this%iout, '(1x,a,/)') 'End Setting Discretization Griddata' + + end subroutine log_griddata + + subroutine source_griddata(this) ! ****************************************************************************** -! read_mf6_griddata -- Read discretization data +! source_griddata -- source griddata from memory manager input path ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use MemoryManagerModule, only: mem_allocate + use MemoryHelperModule, only: create_mem_path + use MemoryManagerExtModule, only: mem_set_value + use SimVariablesModule, only: idm_context ! -- dummy class(GwfDisuType) :: this - ! -- local - character(len=LINELENGTH) :: keyword - integer(I4B) :: n - integer(I4B) :: ierr - logical :: isfound, endOfBlock - integer(I4B), parameter :: nname = 4 - logical, dimension(nname) :: lname - character(len=24), dimension(nname) :: aname(nname) + ! -- locals + character(len=LENMEMPATH) :: idmMemoryPath + logical, dimension(4) :: afound ! -- formats - ! -- data - data aname(1)/' TOP'/ - data aname(2)/' BOT'/ - data aname(3)/' AREA'/ - data aname(4)/' IDOMAIN'/ ! ------------------------------------------------------------------------------ ! - ! -- get disdata block - call this%parser%GetBlock('GRIDDATA', isfound, ierr) - lname(:) = .false. - if (isfound) then - write (this%iout, '(1x,a)') 'PROCESSING GRIDDATA' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('TOP') - call ReadArray(this%parser%iuactive, this%top1d, aname(1), & - this%ndim, this%nodesuser, this%iout, 0) - lname(1) = .true. - case ('BOT') - call ReadArray(this%parser%iuactive, this%bot1d, aname(2), & - this%ndim, this%nodesuser, this%iout, 0) - lname(2) = .true. - case ('AREA') - call ReadArray(this%parser%iuactive, this%area1d, aname(3), & - this%ndim, this%nodesuser, this%iout, 0) - lname(3) = .true. - case ('IDOMAIN') - call ReadArray(this%parser%iuactive, this%idomain, aname(4), & - this%ndim, this%nodesuser, this%iout, 0) - lname(4) = .true. - case default - write (errmsg, '(a)') 'Unknown GRIDDATA tag: '//trim(keyword) - call store_error(errmsg) - end select - end do - write (this%iout, '(1x,a)') 'END PROCESSING GRIDDATA' - else - call store_error('Required GRIDDATA block not found.') - end if + ! -- set memory path + idmMemoryPath = create_mem_path(this%name_model, 'DISU', idm_context) ! - ! -- verify all items were read - do n = 1, nname - if (n == 4) cycle - if (.not. lname(n)) then - write (errmsg, '(a)') 'Required input was not specified: ', trim(aname(n)) - call store_error(errmsg) - end if - end do + ! -- update defaults with idm sourced values + call mem_set_value(this%top1d, 'TOP', idmMemoryPath, afound(1)) + call mem_set_value(this%bot1d, 'BOT', idmMemoryPath, afound(2)) + call mem_set_value(this%area1d, 'AREA', idmMemoryPath, afound(3)) + call mem_set_value(this%idomain, 'IDOMAIN', idmMemoryPath, afound(4)) ! - ! -- terminate if errors were detected - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() + ! -- log simulation values + if (this%iout > 0) then + call this%log_griddata(afound) end if ! ! -- Return return - end subroutine read_mf6_griddata + end subroutine source_griddata + + !> @brief Write griddata found to list file + !< + subroutine log_connectivity(this, afound, iac) + class(GwfDisuType) :: this + logical, dimension(:), intent(in) :: afound + integer(I4B), dimension(:), contiguous, pointer, intent(in) :: iac + + write (this%iout, '(1x,a)') 'Setting Discretization Connectivity' + + if (associated(iac)) then + write (this%iout, '(4x,a)') 'IAC set from input file' + end if + + if (afound(1)) then + write (this%iout, '(4x,a)') 'JA set from input file' + end if + + if (afound(2)) then + write (this%iout, '(4x,a)') 'IHC set from input file' + end if + + if (afound(3)) then + write (this%iout, '(4x,a)') 'CL12 set from input file' + end if + + if (afound(4)) then + write (this%iout, '(4x,a)') 'HWVA set from input file' + end if + + if (afound(5)) then + write (this%iout, '(4x,a)') 'ANGLDEGX set from input file' + end if - subroutine read_connectivity(this) + write (this%iout, '(1x,a,/)') 'End Setting Discretization Connectivity' + + end subroutine log_connectivity + + subroutine source_connectivity(this) ! ****************************************************************************** -! read_connectivity -- Read user-specified connectivity information +! source_connectivity -- source connection data from memory manager input path ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use ConstantsModule, only: DHALF, DPIO180, DNODATA + use MemoryHelperModule, only: create_mem_path + use MemoryManagerModule, only: mem_setptr + use MemoryManagerExtModule, only: mem_set_value + use SimVariablesModule, only: idm_context ! -- dummy class(GwfDisuType) :: this - ! -- local - character(len=LINELENGTH) :: keyword - integer(I4B) :: n - integer(I4B) :: ierr - logical :: isfound, endOfBlock - integer(I4B), parameter :: nname = 6 - logical, dimension(nname) :: lname - character(len=24), dimension(nname) :: aname(nname) + ! -- locals + character(len=LENMEMPATH) :: idmMemoryPath + logical, dimension(5) :: afound + integer(I4B), dimension(:), contiguous, pointer :: iac => null() ! -- formats - ! -- data - data aname(1)/' IAC'/ - data aname(2)/' JA'/ - data aname(3)/' IHC'/ - data aname(4)/' CL12'/ - data aname(5)/' HWVA'/ - data aname(6)/' ANGLDEGX'/ ! ------------------------------------------------------------------------------ ! - ! -- get connectiondata block - call this%parser%GetBlock('CONNECTIONDATA', isfound, ierr) - lname(:) = .false. - if (isfound) then - write (this%iout, '(1x,a)') 'PROCESSING CONNECTIONDATA' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('IAC') - call ReadArray(this%parser%iuactive, this%iainp, aname(1), 1, & - this%nodesuser, this%iout, 0) - lname(1) = .true. - ! - ! -- Convert iac to ia - call iac_to_ia(this%iainp) - case ('JA') - call ReadArray(this%parser%iuactive, this%jainp, aname(2), 1, & - this%njausr, this%iout, 0) - lname(2) = .true. - case ('IHC') - call ReadArray(this%parser%iuactive, this%ihcinp, aname(3), 1, & - this%njausr, this%iout, 0) - lname(3) = .true. - case ('CL12') - call ReadArray(this%parser%iuactive, this%cl12inp, aname(4), 1, & - this%njausr, this%iout, 0) - lname(4) = .true. - case ('HWVA') - call ReadArray(this%parser%iuactive, this%hwvainp, aname(5), 1, & - this%njausr, this%iout, 0) - lname(5) = .true. - case ('ANGLDEGX') - call ReadArray(this%parser%iuactive, this%angldegxinp, aname(6), 1, & - this%njausr, this%iout, 0) - lname(6) = .true. - case default - write (errmsg, '(4x,a,a)') 'Unknown CONNECTIONDATA tag: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - end select - end do - write (this%iout, '(1x,a)') 'END PROCESSING CONNECTIONDATA' - else - call store_error('Required CONNECTIONDATA block not found.') - call this%parser%StoreErrorUnit() - end if + ! -- set memory path + idmMemoryPath = create_mem_path(this%name_model, 'DISU', idm_context) ! - ! -- store whether angledegx was read - if (lname(6)) this%iangledegx = 1 + ! -- update defaults with idm sourced values + call mem_set_value(this%jainp, 'JA', idmMemoryPath, afound(1)) + call mem_set_value(this%ihcinp, 'IHC', idmMemoryPath, afound(2)) + call mem_set_value(this%cl12inp, 'CL12', idmMemoryPath, afound(3)) + call mem_set_value(this%hwvainp, 'HWVA', idmMemoryPath, afound(4)) + call mem_set_value(this%angldegxinp, 'ANGLDEGX', idmMemoryPath, afound(5)) ! - ! -- verify all items were read - do n = 1, nname - ! - ! -- skip angledegx because it is not required - if (aname(n) == aname(6)) cycle - ! - ! -- error if not read - if (.not. lname(n)) then - write (errmsg, '(1x,a,a)') & - 'REQUIRED CONNECTIONDATA INPUT WAS NOT SPECIFIED: ', & - adjustl(trim(aname(n))) - call store_error(errmsg) - end if - end do - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - end if - if (.not. lname(6)) then - write (this%iout, '(1x,a)') 'ANGLDEGX NOT FOUND IN CONNECTIONDATA '// & - 'BLOCK. SOME CAPABILITIES MAY BE LIMITED.' + ! -- set pointer to iac input array + call mem_setptr(iac, 'IAC', idmMemoryPath) + ! + ! -- Convert iac to ia + if (associated(iac)) call iac_to_ia(iac, this%iainp) + ! + ! -- Set angldegx flag if found + if (afound(5)) this%iangledegx = 1 + ! + ! -- log simulation values + if (this%iout > 0) then + call this%log_connectivity(afound, iac) end if ! ! -- Return return - end subroutine read_connectivity + end subroutine source_connectivity - subroutine read_vertices(this) + subroutine source_vertices(this) ! ****************************************************************************** -! read_vertices -- Read data +! source_vertices -- source vertex data from memory manager input path ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules + use MemoryManagerModule, only: mem_setptr + use MemoryHelperModule, only: create_mem_path + use MemoryManagerExtModule, only: mem_set_value + use SimVariablesModule, only: idm_context ! -- dummy class(GwfDisuType) :: this + ! -- local integer(I4B) :: i - integer(I4B) :: ierr, ival - logical :: isfound, endOfBlock - real(DP) :: xmin, xmax, ymin, ymax + character(len=LENMEMPATH) :: idmMemoryPath + real(DP), dimension(:), contiguous, pointer :: vert_x => null() + real(DP), dimension(:), contiguous, pointer :: vert_y => null() ! -- formats - character(len=*), parameter :: fmtvnum = & - "('ERROR. VERTEX NUMBER NOT CONSECUTIVE. LOOKING FOR ',i0,& - &' BUT FOUND ', i0)" - character(len=*), parameter :: fmtnvert = & - &"(3x, 'SUCCESSFULLY READ ',i0,' (X,Y) COORDINATES')" - character(len=*), parameter :: fmtcoord = & - &"(3x, a,' COORDINATE = ', 1(1pg24.15))" ! ------------------------------------------------------------------------------ ! - ! --Read DISDATA block - call this%parser%GetBlock('VERTICES', isfound, ierr, & - supportOpenClose=.true.) - if (isfound) then - write (this%iout, '(/,1x,a)') 'PROCESSING VERTICES' + ! -- set memory path + idmMemoryPath = create_mem_path(this%name_model, 'DISU', idm_context) + ! + ! -- set pointers to memory manager input arrays + call mem_setptr(vert_x, 'XV', idmMemoryPath) + call mem_setptr(vert_y, 'YV', idmMemoryPath) + ! + ! -- set vertices 2d array + if (associated(vert_x) .and. associated(vert_y)) then do i = 1, this%nvert - call this%parser%GetNextLine(endOfBlock) - ! - ! -- vertex number - ival = this%parser%GetInteger() - if (ival /= i) then - write (errmsg, fmtvnum) i, ival - call store_error(errmsg) - call this%parser%StoreErrorUnit() - end if - ! - ! -- x - this%vertices(1, i) = this%parser%GetDouble() - ! - ! -- y - this%vertices(2, i) = this%parser%GetDouble() - ! - ! -- set min/max coords - if (i == 1) then - xmin = this%vertices(1, i) - xmax = xmin - ymin = this%vertices(2, i) - ymax = ymin - else - xmin = min(xmin, this%vertices(1, i)) - xmax = max(xmax, this%vertices(1, i)) - ymin = min(ymin, this%vertices(2, i)) - ymax = max(ymax, this%vertices(2, i)) - end if + this%vertices(1, i) = vert_x(i) + this%vertices(2, i) = vert_y(i) end do - ! - ! -- Terminate the block - call this%parser%terminateblock() else - call store_error('Required vertices block not found.') - call this%parser%StoreErrorUnit() + call store_error('Required Vertex arrays not found.') end if ! - ! -- Write information - write (this%iout, fmtnvert) this%nvert - write (this%iout, fmtcoord) 'MINIMUM X', xmin - write (this%iout, fmtcoord) 'MAXIMUM X', xmax - write (this%iout, fmtcoord) 'MINIMUM Y', ymin - write (this%iout, fmtcoord) 'MAXIMUM Y', ymax - write (this%iout, '(1x,a)') 'END PROCESSING VERTICES' + ! -- log + if (this%iout > 0) then + write (this%iout, '(1x,a)') 'Discretization Vertex data loaded' + end if ! ! -- Return return - end subroutine read_vertices + end subroutine source_vertices - subroutine read_cell2d(this) + subroutine define_cellverts(this, icell2d, ncvert, icvert) + ! -- modules + use SparseModule, only: sparsematrix + ! -- dummy + class(GwfDisuType) :: this + integer(I4B), dimension(:), contiguous, pointer, intent(in) :: icell2d + integer(I4B), dimension(:), contiguous, pointer, intent(in) :: ncvert + integer(I4B), dimension(:), contiguous, pointer, intent(in) :: icvert + ! -- locals + type(sparsematrix) :: vert_spm + integer(I4B) :: i, j, ierr + integer(I4B) :: icv_idx, startvert, maxnnz = 5 +! ------------------------------------------------------------------------------ + ! + ! -- initialize sparse matrix + call vert_spm%init(this%nodesuser, this%nvert, maxnnz) + ! + ! -- add sparse matrix connections from input memory paths + icv_idx = 1 + do i = 1, this%nodesuser + if (icell2d(i) /= i) call store_error('ICELL2D input sequence violation.') + do j = 1, ncvert(i) + call vert_spm%addconnection(i, icvert(icv_idx), 0) + if (j == 1) then + startvert = icvert(icv_idx) + elseif (j == ncvert(i) .and. (icvert(icv_idx) /= startvert)) then + call vert_spm%addconnection(i, startvert, 0) + end if + icv_idx = icv_idx + 1 + end do + end do + ! + ! -- allocate and fill iavert and javert + call mem_allocate(this%iavert, this%nodesuser + 1, 'IAVERT', this%memoryPath) + call mem_allocate(this%javert, vert_spm%nnz, 'JAVERT', this%memoryPath) + call vert_spm%filliaja(this%iavert, this%javert, ierr) + call vert_spm%destroy() + ! + ! -- Return + return + end subroutine define_cellverts + + subroutine source_cell2d(this) ! ****************************************************************************** -! read_cell2d -- Read information describing the two dimensional (x, y) -! configuration of each cell. +! source_cell2d -- source cell2d data from memory manager input path ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use SparseModule, only: sparsematrix + use MemoryHelperModule, only: create_mem_path + use MemoryManagerModule, only: mem_setptr + use MemoryManagerExtModule, only: mem_set_value + use SimVariablesModule, only: idm_context ! -- dummy class(GwfDisuType) :: this - integer(I4B) :: i, j, ivert, ivert1, ncvert - integer(I4B) :: ierr, ival - logical :: isfound, endOfBlock - integer(I4B) :: maxvert, maxvertcell, iuext - real(DP) :: xmin, xmax, ymin, ymax - integer(I4B), dimension(:), allocatable :: maxnnz - type(sparsematrix) :: vertspm + ! -- locals + character(len=LENMEMPATH) :: idmMemoryPath + integer(I4B), dimension(:), contiguous, pointer :: icell2d => null() + integer(I4B), dimension(:), contiguous, pointer :: ncvert => null() + integer(I4B), dimension(:), contiguous, pointer :: icvert => null() + real(DP), dimension(:), contiguous, pointer :: cell_x => null() + real(DP), dimension(:), contiguous, pointer :: cell_y => null() + integer(I4B) :: i ! -- formats - character(len=*), parameter :: fmtcnum = & - "('ERROR. CELL NUMBER NOT CONSECUTIVE. LOOKING FOR ',i0,& - &' BUT FOUND ', i0)" - character(len=*), parameter :: fmtncpl = & - &"(3x, 'SUCCESSFULLY READ ',i0,' CELL2D INFORMATION ENTRIES')" - character(len=*), parameter :: fmtcoord = & - &"(3x, a,' CELL CENTER = ', 1(1pg24.15))" - character(len=*), parameter :: fmtmaxvert = & - &"(3x, 'MAXIMUM NUMBER OF CELL2D VERTICES IS ',i0,' FOR CELL ', i0)" ! ------------------------------------------------------------------------------ ! - ! -- initialize - maxvert = 0 - maxvertcell = 0 + ! -- set memory path + idmMemoryPath = create_mem_path(this%name_model, 'DISU', idm_context) ! - ! -- Initialize estimate of the max number of vertices for each cell - ! (using 5 as default) and initialize the sparse matrix, which will - ! temporarily store the vertex numbers for each cell. This will - ! be converted to iavert and javert after all cell vertices have - ! been read. - allocate (maxnnz(this%nodesuser)) - do i = 1, this%nodesuser - maxnnz(i) = 5 - end do - call vertspm%init(this%nodesuser, this%nvert, maxnnz) + ! -- set pointers to input path ncvert and icvert + call mem_setptr(icell2d, 'ICELL2D', idmMemoryPath) + call mem_setptr(ncvert, 'NCVERT', idmMemoryPath) + call mem_setptr(icvert, 'ICVERT', idmMemoryPath) + ! + ! -- + if (associated(icell2d) .and. associated(ncvert) & + .and. associated(icvert)) then + call this%define_cellverts(icell2d, ncvert, icvert) + else + call store_error('Required cell vertex arrays not found.') + end if ! - ! --Read CELL2D block - call this%parser%GetBlock('CELL2D', isfound, ierr, supportOpenClose=.true.) - if (isfound) then - write (this%iout, '(/,1x,a)') 'PROCESSING CELL2D' + ! -- set pointers to cell center arrays + call mem_setptr(cell_x, 'XC', idmMemoryPath) + call mem_setptr(cell_y, 'YC', idmMemoryPath) + ! + ! -- set cell centers + if (associated(cell_x) .and. associated(cell_y)) then do i = 1, this%nodesuser - call this%parser%GetNextLine(endOfBlock) - ! - ! -- cell number - ival = this%parser%GetInteger() - if (ival /= i) then - write (errmsg, fmtcnum) i, ival - call store_error(errmsg) - call store_error_unit(iuext) - end if - ! - ! -- Cell x center - this%cellxy(1, i) = this%parser%GetDouble() - ! - ! -- Cell y center - this%cellxy(2, i) = this%parser%GetDouble() - ! - ! -- Number of vertices for this cell - ncvert = this%parser%GetInteger() - if (ncvert > maxvert) then - maxvert = ncvert - maxvertcell = i - end if - ! - ! -- Read each vertex number, and then close the polygon if - ! the last vertex does not equal the first vertex - do j = 1, ncvert - ivert = this%parser%GetInteger() - call vertspm%addconnection(i, ivert, 0) - ! - ! -- If necessary, repeat the last vertex in order to close the cell - if (j == 1) then - ivert1 = ivert - elseif (j == ncvert) then - if (ivert1 /= ivert) then - call vertspm%addconnection(i, ivert1, 0) - end if - end if - end do - ! - ! -- set min/max coords - if (i == 1) then - xmin = this%cellxy(1, i) - xmax = xmin - ymin = this%cellxy(2, i) - ymax = ymin - else - xmin = min(xmin, this%cellxy(1, i)) - xmax = max(xmax, this%cellxy(1, i)) - ymin = min(ymin, this%cellxy(2, i)) - ymax = max(ymax, this%cellxy(2, i)) - end if + this%cellxy(1, i) = cell_x(i) + this%cellxy(2, i) = cell_y(i) end do - ! - ! -- Terminate the block - call this%parser%terminateblock() else - call store_error('Required CELL2D block not found.') - call this%parser%StoreErrorUnit() + call store_error('Required cell center arrays not found.') end if ! - ! -- Convert vertspm into ia/ja form - call mem_allocate(this%iavert, this%nodesuser + 1, 'IAVERT', this%memoryPath) - call mem_allocate(this%javert, vertspm%nnz, 'JAVERT', this%memoryPath) - - call vertspm%filliaja(this%iavert, this%javert, ierr) - call vertspm%destroy() - ! - ! -- Write information - write (this%iout, fmtncpl) this%nodesuser - write (this%iout, fmtcoord) 'MINIMUM X', xmin - write (this%iout, fmtcoord) 'MAXIMUM X', xmax - write (this%iout, fmtcoord) 'MINIMUM Y', ymin - write (this%iout, fmtcoord) 'MAXIMUM Y', ymax - write (this%iout, fmtmaxvert) maxvert, maxvertcell - write (this%iout, '(1x,a)') 'END PROCESSING VERTICES' + ! -- log + if (this%iout > 0) then + write (this%iout, '(1x,a)') 'Discretization Cell2d data loaded' + end if ! ! -- Return return - end subroutine read_cell2d + end subroutine source_cell2d subroutine write_grb(this, icelltype) ! ****************************************************************************** diff --git a/src/Model/GroundWaterFlow/gwf3disu8idm.f90 b/src/Model/GroundWaterFlow/gwf3disu8idm.f90 new file mode 100644 index 00000000000..f696aa8db6e --- /dev/null +++ b/src/Model/GroundWaterFlow/gwf3disu8idm.f90 @@ -0,0 +1,547 @@ +module GwfDisuInputModule + use InputDefinitionModule, only: InputParamDefinitionType, & + InputBlockDefinitionType + private + public gwf_disu_param_definitions + public gwf_disu_aggregate_definitions + public gwf_disu_block_definitions + + type(InputParamDefinitionType), parameter :: & + gwfdisu_length_units = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'OPTIONS', & ! block + 'LENGTH_UNITS', & ! tag name + 'LENGTH_UNITS', & ! fortran variable + 'STRING', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_nogrb = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'OPTIONS', & ! block + 'NOGRB', & ! tag name + 'NOGRB', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_xorigin = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'OPTIONS', & ! block + 'XORIGIN', & ! tag name + 'XORIGIN', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_yorigin = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'OPTIONS', & ! block + 'YORIGIN', & ! tag name + 'YORIGIN', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_angrot = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'OPTIONS', & ! block + 'ANGROT', & ! tag name + 'ANGROT', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_voffsettol = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'OPTIONS', & ! block + 'VERTICAL_OFFSET_TOLERANCE', & ! tag name + 'VOFFSETTOL', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_nodes = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'DIMENSIONS', & ! block + 'NODES', & ! tag name + 'NODES', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_nja = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'DIMENSIONS', & ! block + 'NJA', & ! tag name + 'NJA', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_nvert = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'DIMENSIONS', & ! block + 'NVERT', & ! tag name + 'NVERT', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_top = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'GRIDDATA', & ! block + 'TOP', & ! tag name + 'TOP', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_bot = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'GRIDDATA', & ! block + 'BOT', & ! tag name + 'BOT', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_area = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'GRIDDATA', & ! block + 'AREA', & ! tag name + 'AREA', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_idomain = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'GRIDDATA', & ! block + 'IDOMAIN', & ! tag name + 'IDOMAIN', & ! fortran variable + 'INTEGER1D', & ! type + 'NODES', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_iac = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'CONNECTIONDATA', & ! block + 'IAC', & ! tag name + 'IAC', & ! fortran variable + 'INTEGER1D', & ! type + 'NODES', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_ja = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'CONNECTIONDATA', & ! block + 'JA', & ! tag name + 'JA', & ! fortran variable + 'INTEGER1D', & ! type + 'NJA', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_ihc = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'CONNECTIONDATA', & ! block + 'IHC', & ! tag name + 'IHC', & ! fortran variable + 'INTEGER1D', & ! type + 'NJA', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_cl12 = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'CONNECTIONDATA', & ! block + 'CL12', & ! tag name + 'CL12', & ! fortran variable + 'DOUBLE1D', & ! type + 'NJA', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_hwva = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'CONNECTIONDATA', & ! block + 'HWVA', & ! tag name + 'HWVA', & ! fortran variable + 'DOUBLE1D', & ! type + 'NJA', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_angldegx = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'CONNECTIONDATA', & ! block + 'ANGLDEGX', & ! tag name + 'ANGLDEGX', & ! fortran variable + 'DOUBLE1D', & ! type + 'NJA', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_iv = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'VERTICES', & ! block + 'IV', & ! tag name + 'IV', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_xv = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'VERTICES', & ! block + 'XV', & ! tag name + 'XV', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_yv = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'VERTICES', & ! block + 'YV', & ! tag name + 'YV', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_icell2d = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'CELL2D', & ! block + 'ICELL2D', & ! tag name + 'ICELL2D', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_xc = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'CELL2D', & ! block + 'XC', & ! tag name + 'XC', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_yc = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'CELL2D', & ! block + 'YC', & ! tag name + 'YC', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_ncvert = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'CELL2D', & ! block + 'NCVERT', & ! tag name + 'NCVERT', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_icvert = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'CELL2D', & ! block + 'ICVERT', & ! tag name + 'ICVERT', & ! fortran variable + 'INTEGER1D', & ! type + 'NCVERT', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwf_disu_param_definitions(*) = & + [ & + gwfdisu_length_units, & + gwfdisu_nogrb, & + gwfdisu_xorigin, & + gwfdisu_yorigin, & + gwfdisu_angrot, & + gwfdisu_voffsettol, & + gwfdisu_nodes, & + gwfdisu_nja, & + gwfdisu_nvert, & + gwfdisu_top, & + gwfdisu_bot, & + gwfdisu_area, & + gwfdisu_idomain, & + gwfdisu_iac, & + gwfdisu_ja, & + gwfdisu_ihc, & + gwfdisu_cl12, & + gwfdisu_hwva, & + gwfdisu_angldegx, & + gwfdisu_iv, & + gwfdisu_xv, & + gwfdisu_yv, & + gwfdisu_icell2d, & + gwfdisu_xc, & + gwfdisu_yc, & + gwfdisu_ncvert, & + gwfdisu_icvert & + ] + + type(InputParamDefinitionType), parameter :: & + gwfdisu_vertices = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'VERTICES', & ! block + 'VERTICES', & ! tag name + 'VERTICES', & ! fortran variable + 'RECARRAY IV XV YV', & ! type + 'NVERT', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisu_cell2d = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISU', & ! subcomponent + 'CELL2D', & ! block + 'CELL2D', & ! tag name + 'CELL2D', & ! fortran variable + 'RECARRAY ICELL2D XC YC NCVERT ICVERT', & ! type + 'NODES', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwf_disu_aggregate_definitions(*) = & + [ & + gwfdisu_vertices, & + gwfdisu_cell2d & + ] + + type(InputBlockDefinitionType), parameter :: & + gwf_disu_block_definitions(*) = & + [ & + InputBlockDefinitionType( & + 'OPTIONS', & ! blockname + .false., & ! required + .false. & ! aggregate + ), & + InputBlockDefinitionType( & + 'DIMENSIONS', & ! blockname + .true., & ! required + .false. & ! aggregate + ), & + InputBlockDefinitionType( & + 'GRIDDATA', & ! blockname + .true., & ! required + .false. & ! aggregate + ), & + InputBlockDefinitionType( & + 'CONNECTIONDATA', & ! blockname + .true., & ! required + .false. & ! aggregate + ), & + InputBlockDefinitionType( & + 'VERTICES', & ! blockname + .true., & ! required + .true. & ! aggregate + ), & + InputBlockDefinitionType( & + 'CELL2D', & ! blockname + .true., & ! required + .true. & ! aggregate + ) & + ] + +end module GwfDisuInputModule diff --git a/src/Model/GroundWaterFlow/gwf3disv8.f90 b/src/Model/GroundWaterFlow/gwf3disv8.f90 index 515efb20a66..72d3c164ceb 100644 --- a/src/Model/GroundWaterFlow/gwf3disv8.f90 +++ b/src/Model/GroundWaterFlow/gwf3disv8.f90 @@ -2,7 +2,8 @@ module GwfDisvModule use ArrayReadersModule, only: ReadArray use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH, DZERO, DONE, DHALF + use ConstantsModule, only: LINELENGTH, LENMEMPATH, LENVARNAME, DZERO, DONE, & + DHALF use BaseDisModule, only: DisBaseType use InputOutputModule, only: get_node, URWORD, ulasav, ulaprufw, ubdsv1, & ubdsv06 @@ -10,6 +11,7 @@ module GwfDisvModule use DisvGeom, only: DisvGeomType use BlockParserModule, only: BlockParserType use MemoryManagerModule, only: mem_allocate + use MemoryHelperModule, only: create_mem_path use TdisModule, only: kstp, kper, pertim, totim, delt implicit none @@ -30,6 +32,7 @@ module GwfDisvModule contains procedure :: dis_df => disv_df procedure :: dis_da => disv_da + procedure :: disv_load procedure :: get_dis_type => get_dis_type procedure, public :: record_array procedure, public :: read_layer_array @@ -47,11 +50,15 @@ module GwfDisvModule procedure :: supports_layers procedure :: get_ncpl ! -- private - procedure :: read_options - procedure :: read_dimensions - procedure :: read_vertices - procedure :: read_cell2d - procedure :: read_mf6_griddata + procedure :: source_options + procedure :: source_dimensions + procedure :: source_griddata + procedure :: source_vertices + procedure :: source_cell2d + procedure :: log_options + procedure :: log_dimensions + procedure :: log_griddata + procedure :: define_cellverts procedure :: grid_finalize procedure :: connect procedure :: write_grb @@ -73,11 +80,16 @@ subroutine disv_cr(dis, name_model, inunit, iout) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ + use IdmMf6FileLoaderModule, only: input_load + use ConstantsModule, only: LENPACKAGETYPE class(DisBaseType), pointer :: dis character(len=*), intent(in) :: name_model integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout type(GwfDisvType), pointer :: disnew + character(len=*), parameter :: fmtheader = & + "(1X, /1X, 'DISV -- VERTEX GRID DISCRETIZATION PACKAGE,', & + &' VERSION 1 : 12/23/2015 - INPUT READ FROM UNIT ', I0, //)" ! ------------------------------------------------------------------------------ allocate (disnew) dis => disnew @@ -85,16 +97,33 @@ subroutine disv_cr(dis, name_model, inunit, iout) dis%inunit = inunit dis%iout = iout ! - ! -- Initialize block parser - call dis%parser%Initialize(dis%inunit, dis%iout) + ! -- if reading from file + if (inunit > 0) then + ! + ! -- Identify package + if (iout > 0) then + write (iout, fmtheader) inunit + end if + ! + ! -- initialize parser and load the disv input file + call dis%parser%Initialize(dis%inunit, dis%iout) + ! + ! -- Use the input data model routines to load the input data + ! into memory + call input_load(dis%parser, 'DISV6', 'GWF', 'DISV', name_model, 'DISV', & + [character(len=LENPACKAGETYPE) ::], iout) + ! + ! -- load disv + call disnew%disv_load() + end if ! ! -- Return return end subroutine disv_cr - subroutine disv_df(this) + subroutine disv_load(this) ! ****************************************************************************** -! read_from_file -- Allocate and read discretization information +! disv_load -- transfer data into this discretization object ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -104,29 +133,29 @@ subroutine disv_df(this) ! -- locals ! ------------------------------------------------------------------------------ ! - ! -- read data from file - if (this%inunit /= 0) then - ! - ! -- Identify package - write (this%iout, 1) this%inunit -1 format(1X, /1X, 'DISV -- VERTEX GRID DISCRETIZATION PACKAGE,', & - ' VERSION 1 : 12/23/2015 - INPUT READ FROM UNIT ', I0, //) - ! - ! -- Read options - call this%read_options() - ! - ! -- Read dimensions block - call this%read_dimensions() - ! - ! -- Read GRIDDATA block - call this%read_mf6_griddata() - ! - ! -- Read VERTICES block - call this%read_vertices() - ! - ! -- Read CELL2D block - call this%read_cell2d() - end if + ! -- source input data + call this%source_options() + call this%source_dimensions() + call this%source_griddata() + call this%source_vertices() + call this%source_cell2d() + ! + ! -- Return + return + end subroutine disv_load + + subroutine disv_df(this) +! ****************************************************************************** +! disv_df -- Define +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfDisvType) :: this + ! -- locals +! ------------------------------------------------------------------------------ ! ! -- Final grid initialization call this%grid_finalize() @@ -144,11 +173,18 @@ subroutine disv_da(this) ! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate + use MemoryManagerExtModule, only: memorylist_remove + use SimVariablesModule, only: idm_context ! -- dummy class(GwfDisvType) :: this ! -- locals ! ------------------------------------------------------------------------------ ! + ! -- Deallocate idm memory + call memorylist_remove(this%name_model, 'DISV', idm_context) + call memorylist_remove(component=this%name_model, & + context=idm_context) + ! ! -- DisBaseType deallocate call this%DisBaseType%dis_da() ! @@ -172,135 +208,113 @@ subroutine disv_da(this) return end subroutine disv_da - subroutine read_options(this) + !> @brief Copy options from IDM into package + !< + subroutine source_options(this) ! ****************************************************************************** -! read_options -- Read options +! source_options -- source options from memory manager input path ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ + ! -- modules + use KindModule, only: LGP + use MemoryManagerExtModule, only: mem_set_value + use SimVariablesModule, only: idm_context ! -- dummy class(GwfDisvType) :: this ! -- locals - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock + character(len=LENMEMPATH) :: idmMemoryPath + character(len=LENVARNAME), dimension(3) :: lenunits = & + &[character(len=LENVARNAME) :: 'FEET', 'METERS', 'CENTIMETERS'] + logical, dimension(5) :: afound ! ------------------------------------------------------------------------------ ! - ! -- get options block - call this%parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) - ! - ! -- set default options - this%lenuni = 0 - ! - ! -- parse options block if detected - if (isfound) then - write (this%iout, '(/,1x,a)') 'PROCESSING DISCRETIZATION OPTIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('LENGTH_UNITS') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FEET') then - this%lenuni = 1 - write (this%iout, '(4x,a)') 'MODEL LENGTH UNIT IS FEET' - elseif (keyword == 'METERS') then - this%lenuni = 2 - write (this%iout, '(4x,a)') 'MODEL LENGTH UNIT IS METERS' - elseif (keyword == 'CENTIMETERS') then - this%lenuni = 3 - write (this%iout, '(4x,a)') 'MODEL LENGTH UNIT IS CENTIMETERS' - else - write (this%iout, '(4x,a)') 'UNKNOWN UNIT: ', trim(keyword) - write (this%iout, '(4x,a)') 'SETTING TO: ', 'UNDEFINED' - end if - case ('NOGRB') - write (this%iout, '(4x,a)') 'BINARY GRB FILE WILL NOT BE WRITTEN' - this%writegrb = .false. - case ('XORIGIN') - this%xorigin = this%parser%GetDouble() - write (this%iout, '(4x,a,1pg24.15)') 'XORIGIN SPECIFIED AS ', & - this%xorigin - case ('YORIGIN') - this%yorigin = this%parser%GetDouble() - write (this%iout, '(4x,a,1pg24.15)') 'YORIGIN SPECIFIED AS ', & - this%yorigin - case ('ANGROT') - this%angrot = this%parser%GetDouble() - write (this%iout, '(4x,a,1pg24.15)') 'ANGROT SPECIFIED AS ', & - this%angrot - case default - write (errmsg, '(4x,a,a)') 'Unknown DIS option: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - end select - end do - else - write (this%iout, '(1x,a)') 'NO DISV OPTION BLOCK DETECTED.' - end if - if (this%lenuni == 0) then - write (this%iout, '(3x,a)') 'MODEL LENGTH UNIT IS UNDEFINED' - end if - if (isfound) then - write (this%iout, '(1x,a)') 'END OF DISCRETIZATION OPTIONS' + ! -- set memory path + idmMemoryPath = create_mem_path(this%name_model, 'DISV', idm_context) + ! + ! -- update defaults with idm sourced values + call mem_set_value(this%lenuni, 'LENGTH_UNITS', idmMemoryPath, lenunits, & + afound(1)) + call mem_set_value(this%nogrb, 'NOGRB', idmMemoryPath, afound(2)) + call mem_set_value(this%xorigin, 'XORIGIN', idmMemoryPath, afound(3)) + call mem_set_value(this%yorigin, 'YORIGIN', idmMemoryPath, afound(4)) + call mem_set_value(this%angrot, 'ANGROT', idmMemoryPath, afound(5)) + ! + ! -- log values to list file + if (this%iout > 0) then + call this%log_options(afound) end if ! ! -- Return return - end subroutine read_options + end subroutine source_options - subroutine read_dimensions(this) + !> @brief Write user options to list file + !< + subroutine log_options(this, afound) + class(GwfDisvType) :: this + logical, dimension(:), intent(in) :: afound + + write (this%iout, '(1x,a)') 'Setting Discretization Options' + + if (afound(1)) then + write (this%iout, '(4x,a,i0)') 'MODEL LENGTH UNIT [0=UND, 1=FEET, & + &2=METERS, 3=CENTIMETERS] SET AS ', this%lenuni + end if + + if (afound(2)) then + write (this%iout, '(4x,a,i0)') 'BINARY GRB FILE [0=GRB, 1=NOGRB] & + &SET AS ', this%nogrb + end if + + if (afound(3)) then + write (this%iout, '(4x,a,G0)') 'XORIGIN = ', this%xorigin + end if + + if (afound(4)) then + write (this%iout, '(4x,a,G0)') 'YORIGIN = ', this%yorigin + end if + + if (afound(5)) then + write (this%iout, '(4x,a,G0)') 'ANGROT = ', this%angrot + end if + + write (this%iout, '(1x,a,/)') 'End Setting Discretization Options' + + end subroutine log_options + + !> @brief Copy dimensions from IDM into package + !< + subroutine source_dimensions(this) ! ****************************************************************************** -! read_dimensions -- Read dimensions +! source_dimensions -- source dimensions from memory manager input path ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ + use KindModule, only: LGP + use MemoryManagerExtModule, only: mem_set_value + use SimVariablesModule, only: idm_context ! -- dummy class(GwfDisvType) :: this ! -- locals - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock - integer(I4B) :: j - integer(I4B) :: k + character(len=LENMEMPATH) :: idmMemoryPath + integer(I4B) :: j, k + logical, dimension(3) :: afound ! ------------------------------------------------------------------------------ ! - ! -- get dimensions block - call this%parser%GetBlock('DIMENSIONS', isfound, ierr, & - supportOpenClose=.true.) - ! - ! -- parse dimensions block if detected - if (isfound) then - write (this%iout, '(/,1x,a)') 'PROCESSING DISCRETIZATION DIMENSIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('NLAY') - this%nlay = this%parser%GetInteger() - write (this%iout, '(3x,a,i0)') 'NLAY = ', this%nlay - case ('NCPL') - this%ncpl = this%parser%GetInteger() - write (this%iout, '(3x,a,i0)') 'NCPL = ', this%ncpl - case ('NVERT') - this%nvert = this%parser%GetInteger() - write (this%iout, '(3x,a,i0)') 'NVERT = ', this%nvert - case default - write (errmsg, '(4x,a,a)') 'Unknown DISV dimension: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - end select - end do - else - call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') - call this%parser%StoreErrorUnit() + ! -- set memory path + idmMemoryPath = create_mem_path(this%name_model, 'DISV', idm_context) + ! + ! -- update defaults with idm sourced values + call mem_set_value(this%nlay, 'NLAY', idmMemoryPath, afound(1)) + call mem_set_value(this%ncpl, 'NCPL', idmMemoryPath, afound(2)) + call mem_set_value(this%nvert, 'NVERT', idmMemoryPath, afound(3)) + ! + ! -- log simulation values + if (this%iout > 0) then + call this%log_dimensions(afound) end if ! ! -- verify dimensions were set @@ -319,7 +333,6 @@ subroutine read_dimensions(this) 'NVERT WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') call this%parser%StoreErrorUnit() end if - write (this%iout, '(1x,a)') 'END OF DISCRETIZATION DIMENSIONS' ! ! -- Calculate nodesuser this%nodesuser = this%nlay * this%ncpl @@ -344,107 +357,90 @@ subroutine read_dimensions(this) ! ! -- Return return - end subroutine read_dimensions + end subroutine source_dimensions - subroutine read_mf6_griddata(this) + !> @brief Write dimensions to list file + !< + subroutine log_dimensions(this, afound) + class(GwfDisvType) :: this + logical, dimension(:), intent(in) :: afound + + write (this%iout, '(1x,a)') 'Setting Discretization Dimensions' + + if (afound(1)) then + write (this%iout, '(4x,a,i0)') 'NLAY = ', this%nlay + end if + + if (afound(2)) then + write (this%iout, '(4x,a,i0)') 'NCPL = ', this%ncpl + end if + + if (afound(3)) then + write (this%iout, '(4x,a,i0)') 'NVERT = ', this%nvert + end if + + write (this%iout, '(1x,a,/)') 'End Setting Discretization Dimensions' + + end subroutine log_dimensions + + subroutine source_griddata(this) ! ****************************************************************************** -! read_mf6_griddata -- Read grid data from a MODFLOW 6 ascii file +! source_griddata -- source griddata from memory manager input path ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules + use MemoryManagerExtModule, only: mem_set_value + use SimVariablesModule, only: idm_context ! -- dummy class(GwfDisvType) :: this ! -- locals - character(len=LINELENGTH) :: keyword - integer(I4B) :: n - integer(I4B) :: ierr - logical :: isfound, endOfBlock - integer(I4B), parameter :: nname = 3 - logical, dimension(nname) :: lname - character(len=24), dimension(nname) :: aname - character(len=300) :: ermsg + character(len=LENMEMPATH) :: idmMemoryPath + logical, dimension(3) :: afound ! -- formats - character(len=*), parameter :: fmtdz = & - "('ERROR. CELL (',i0,',',i0,') THICKNESS <= 0. ', & - &'TOP, BOT: ',2(1pg24.15))" - character(len=*), parameter :: fmtnr = & - "(/1x, 'THE SPECIFIED IDOMAIN RESULTS IN A REDUCED NUMBER OF CELLS.',& - &/1x, 'NUMBER OF USER NODES: ',I0,& - &/1X, 'NUMBER OF NODES IN SOLUTION: ', I0, //)" - ! -- data - data aname(1)/'TOP ELEVATION OF LAYER 1'/ - data aname(2)/' MODEL LAYER BOTTOM EL.'/ - data aname(3)/' IDOMAIN'/ ! ------------------------------------------------------------------------------ ! - ! --Read GRIDDATA block - call this%parser%GetBlock('GRIDDATA', isfound, ierr) - lname(:) = .false. - if (isfound) then - write (this%iout, '(/,1x,a)') 'PROCESSING GRIDDATA' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('TOP') - call ReadArray(this%parser%iuactive, this%top2d(:, :), & - aname(1), this%ndim, this%ncpl, 1, this%iout, 0) - lname(1) = .true. - case ('BOTM') - call this%parser%GetStringCaps(keyword) - if (keyword .EQ. 'LAYERED') then - call ReadArray(this%parser%iuactive, & - this%bot3d(:, :, :), aname(2), this%ndim, & - this%ncpl, 1, this%nlay, this%iout, 1, this%nlay) - else - call ReadArray(this%parser%iuactive, & - this%bot3d(:, :, :), aname(2), & - this%ndim, this%nodesuser, 1, 1, this%iout, 0, 0) - end if - lname(2) = .true. - case ('IDOMAIN') - call this%parser%GetStringCaps(keyword) - if (keyword .EQ. 'LAYERED') then - call ReadArray(this%parser%iuactive, this%idomain, aname(3), & - this%ndim, this%ncpl, 1, this%nlay, this%iout, & - 1, this%nlay) - else - call ReadArray(this%parser%iuactive, this%idomain, aname(3), & - this%ndim, this%nodesuser, 1, 1, this%iout, & - 0, 0) - end if - lname(3) = .true. - case default - write (ermsg, '(4x,a,a)') 'Unknown GRIDDATA tag: ', & - trim(keyword) - call store_error(ermsg) - call this%parser%StoreErrorUnit() - end select - end do - write (this%iout, '(1x,a)') 'END PROCESSING GRIDDATA' - else - call store_error('ERROR. REQUIRED GRIDDATA BLOCK NOT FOUND.') - call this%parser%StoreErrorUnit() - end if + ! -- set memory path + idmMemoryPath = create_mem_path(this%name_model, 'DISV', idm_context) ! - ! -- Verify all required items were read (IDOMAIN not required) - do n = 1, nname - 1 - if (.not. lname(n)) then - write (ermsg, '(1x,a,a)') & - 'ERROR. REQUIRED INPUT WAS NOT SPECIFIED: ', aname(n) - call store_error(ermsg) - end if - end do - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() + ! -- update defaults with idm sourced values + call mem_set_value(this%top2d, 'TOP', idmMemoryPath, afound(1)) + call mem_set_value(this%bot3d, 'BOTM', idmMemoryPath, afound(2)) + call mem_set_value(this%idomain, 'IDOMAIN', idmMemoryPath, afound(3)) + ! + ! -- log simulation values + if (this%iout > 0) then + call this%log_griddata(afound) end if ! ! -- Return return - end subroutine read_mf6_griddata + end subroutine source_griddata + + !> @brief Write griddata found to list file + !< + subroutine log_griddata(this, afound) + class(GwfDisvType) :: this + logical, dimension(:), intent(in) :: afound + + write (this%iout, '(1x,a)') 'Setting Discretization Griddata' + + if (afound(1)) then + write (this%iout, '(4x,a)') 'TOP set from input file' + end if + + if (afound(2)) then + write (this%iout, '(4x,a)') 'BOTM set from input file' + end if + + if (afound(3)) then + write (this%iout, '(4x,a)') 'IDOMAIN set from input file' + end if + + write (this%iout, '(1x,a,/)') 'End Setting Discretization Griddata' + + end subroutine log_griddata subroutine grid_finalize(this) ! ****************************************************************************** @@ -583,220 +579,158 @@ subroutine grid_finalize(this) return end subroutine grid_finalize - subroutine read_vertices(this) + subroutine source_vertices(this) ! ****************************************************************************** -! read_vertices -- Read data +! source_vertices -- source vertex data from memory manager input path ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules + use MemoryManagerModule, only: mem_setptr + use MemoryManagerExtModule, only: mem_set_value + use SimVariablesModule, only: idm_context ! -- dummy class(GwfDisvType) :: this + ! -- local integer(I4B) :: i - integer(I4B) :: ierr, ival - logical :: isfound, endOfBlock - real(DP) :: xmin, xmax, ymin, ymax - character(len=300) :: ermsg + character(len=LENMEMPATH) :: idmMemoryPath + real(DP), dimension(:), contiguous, pointer :: vert_x => null() + real(DP), dimension(:), contiguous, pointer :: vert_y => null() ! -- formats - character(len=*), parameter :: fmtvnum = & - "('ERROR. VERTEX NUMBER NOT CONSECUTIVE. LOOKING FOR ',i0,& - &' BUT FOUND ', i0)" - character(len=*), parameter :: fmtnvert = & - &"(3x, 'SUCCESSFULLY READ ',i0,' (X,Y) COORDINATES')" - character(len=*), parameter :: fmtcoord = & - &"(3x, a,' COORDINATE = ', 1(1pg24.15))" ! ------------------------------------------------------------------------------ ! - ! -- Calculates nodesuser - this%nodesuser = this%nlay * this%ncpl + ! -- set memory path + idmMemoryPath = create_mem_path(this%name_model, 'DISV', idm_context) + ! + ! -- set pointers to memory manager input arrays + call mem_setptr(vert_x, 'XV', idmMemoryPath) + call mem_setptr(vert_y, 'YV', idmMemoryPath) ! - ! --Read DISDATA block - call this%parser%GetBlock('VERTICES', isfound, ierr, & - supportOpenClose=.true.) - if (isfound) then - write (this%iout, '(/,1x,a)') 'PROCESSING VERTICES' + ! -- set vertices 2d array + if (associated(vert_x) .and. associated(vert_y)) then do i = 1, this%nvert - call this%parser%GetNextLine(endOfBlock) - ! - ! -- vertex number - ival = this%parser%GetInteger() - if (ival /= i) then - write (ermsg, fmtvnum) i, ival - call store_error(ermsg) - call this%parser%StoreErrorUnit() - end if - ! - ! -- x - this%vertices(1, i) = this%parser%GetDouble() - ! - ! -- y - this%vertices(2, i) = this%parser%GetDouble() - ! - ! -- set min/max coords - if (i == 1) then - xmin = this%vertices(1, i) - xmax = xmin - ymin = this%vertices(2, i) - ymax = ymin - else - xmin = min(xmin, this%vertices(1, i)) - xmax = max(xmax, this%vertices(1, i)) - ymin = min(ymin, this%vertices(2, i)) - ymax = max(ymax, this%vertices(2, i)) - end if + this%vertices(1, i) = vert_x(i) + this%vertices(2, i) = vert_y(i) end do - ! - ! -- Terminate the block - call this%parser%terminateblock() else - call store_error('Required VERTICES block not found.') - call this%parser%StoreErrorUnit() + call store_error('Required Vertex arrays not found.') end if ! - ! -- Write information - write (this%iout, fmtnvert) this%nvert - write (this%iout, fmtcoord) 'MINIMUM X', xmin - write (this%iout, fmtcoord) 'MAXIMUM X', xmax - write (this%iout, fmtcoord) 'MINIMUM Y', ymin - write (this%iout, fmtcoord) 'MAXIMUM Y', ymax - write (this%iout, '(1x,a)') 'END PROCESSING VERTICES' + ! -- log + if (this%iout > 0) then + write (this%iout, '(1x,a)') 'Discretization Vertex data loaded' + end if ! ! -- Return return - end subroutine read_vertices + end subroutine source_vertices - subroutine read_cell2d(this) + subroutine define_cellverts(this, icell2d, ncvert, icvert) + ! -- modules + use SparseModule, only: sparsematrix + ! -- dummy + class(GwfDisvType) :: this + integer(I4B), dimension(:), contiguous, pointer, intent(in) :: icell2d + integer(I4B), dimension(:), contiguous, pointer, intent(in) :: ncvert + integer(I4B), dimension(:), contiguous, pointer, intent(in) :: icvert + ! -- locals + type(sparsematrix) :: vert_spm + integer(I4B) :: i, j, ierr + integer(I4B) :: icv_idx, startvert, maxnnz = 5 +! ------------------------------------------------------------------------------ + ! + ! -- initialize sparse matrix + call vert_spm%init(this%ncpl, this%nvert, maxnnz) + ! + ! -- add sparse matrix connections from input memory paths + icv_idx = 1 + do i = 1, this%ncpl + if (icell2d(i) /= i) call store_error('ICELL2D input sequence violation.') + do j = 1, ncvert(i) + call vert_spm%addconnection(i, icvert(icv_idx), 0) + if (j == 1) then + startvert = icvert(icv_idx) + elseif (j == ncvert(i) .and. (icvert(icv_idx) /= startvert)) then + call vert_spm%addconnection(i, startvert, 0) + end if + icv_idx = icv_idx + 1 + end do + end do + ! + ! -- allocate and fill iavert and javert + call mem_allocate(this%iavert, this%ncpl + 1, 'IAVERT', this%memoryPath) + call mem_allocate(this%javert, vert_spm%nnz, 'JAVERT', this%memoryPath) + call vert_spm%filliaja(this%iavert, this%javert, ierr) + call vert_spm%destroy() + ! + ! -- Return + return + end subroutine define_cellverts + + subroutine source_cell2d(this) ! ****************************************************************************** -! read_cell2d -- Read information describing the two dimensional (x, y) -! configuration of each cell. +! source_cell2d -- source cell2d data from memory manager input path ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use SparseModule, only: sparsematrix - use MemoryManagerModule, only: mem_allocate + use MemoryManagerModule, only: mem_setptr + use MemoryManagerExtModule, only: mem_set_value + use SimVariablesModule, only: idm_context ! -- dummy class(GwfDisvType) :: this - integer(I4B) :: i, j, ivert, ivert1, ncvert - integer(I4B) :: ierr, ival - logical :: isfound, endOfBlock - integer(I4B) :: maxvert, maxvertcell, iuext - real(DP) :: xmin, xmax, ymin, ymax - character(len=300) :: ermsg - integer(I4B), dimension(:), allocatable :: maxnnz - type(sparsematrix) :: vertspm + ! -- locals + character(len=LENMEMPATH) :: idmMemoryPath + integer(I4B), dimension(:), contiguous, pointer :: icell2d => null() + integer(I4B), dimension(:), contiguous, pointer :: ncvert => null() + integer(I4B), dimension(:), contiguous, pointer :: icvert => null() + real(DP), dimension(:), contiguous, pointer :: cell_x => null() + real(DP), dimension(:), contiguous, pointer :: cell_y => null() + integer(I4B) :: i ! -- formats - character(len=*), parameter :: fmtcnum = & - "('ERROR. CELL NUMBER NOT CONSECUTIVE. LOOKING FOR ',i0,& - &' BUT FOUND ', i0)" - character(len=*), parameter :: fmtncpl = & - &"(3x, 'SUCCESSFULLY READ ',i0,' CELL2D INFORMATION ENTRIES')" - character(len=*), parameter :: fmtcoord = & - &"(3x, a,' CELL CENTER = ', 1(1pg24.15))" - character(len=*), parameter :: fmtmaxvert = & - &"(3x, 'MAXIMUM NUMBER OF CELL2D VERTICES IS ',i0,' FOR CELL ', i0)" ! ------------------------------------------------------------------------------ ! - ! -- initialize - maxvert = 0 - maxvertcell = 0 + ! -- set memory path + idmMemoryPath = create_mem_path(this%name_model, 'DISV', idm_context) ! - ! -- Initialize estimate of the max number of vertices for each cell - ! (using 5 as default) and initialize the sparse matrix, which will - ! temporarily store the vertex numbers for each cell. This will - ! be converted to iavert and javert after all cell vertices have - ! been read. - allocate (maxnnz(this%ncpl)) - do i = 1, this%ncpl - maxnnz(i) = 5 - end do - call vertspm%init(this%ncpl, this%nvert, maxnnz) + ! -- set pointers to input path ncvert and icvert + call mem_setptr(icell2d, 'ICELL2D', idmMemoryPath) + call mem_setptr(ncvert, 'NCVERT', idmMemoryPath) + call mem_setptr(icvert, 'ICVERT', idmMemoryPath) ! - ! --Read CELL2D block - call this%parser%GetBlock('CELL2D', isfound, ierr, supportOpenClose=.true.) - if (isfound) then - write (this%iout, '(/,1x,a)') 'PROCESSING CELL2D' + ! -- + if (associated(icell2d) .and. associated(ncvert) & + .and. associated(icvert)) then + call this%define_cellverts(icell2d, ncvert, icvert) + else + call store_error('Required cell vertex array(s) [ICELL2D, NCVERT, ICVERT] & + ¬ found.') + end if + ! + ! -- copy cell center idm sourced values to local arrays + call mem_setptr(cell_x, 'XC', idmMemoryPath) + call mem_setptr(cell_y, 'YC', idmMemoryPath) + ! + ! -- set cell centers + if (associated(cell_x) .and. associated(cell_y)) then do i = 1, this%ncpl - call this%parser%GetNextLine(endOfBlock) - ! - ! -- cell number - ival = this%parser%GetInteger() - if (ival /= i) then - write (ermsg, fmtcnum) i, ival - call store_error(ermsg) - call store_error_unit(iuext) - end if - ! - ! -- Cell x center - this%cellxy(1, i) = this%parser%GetDouble() - ! - ! -- Cell y center - this%cellxy(2, i) = this%parser%GetDouble() - ! - ! -- Number of vertices for this cell - ncvert = this%parser%GetInteger() - if (ncvert > maxvert) then - maxvert = ncvert - maxvertcell = i - end if - ! - ! -- Read each vertex number, and then close the polygon if - ! the last vertex does not equal the first vertex - do j = 1, ncvert - ivert = this%parser%GetInteger() - call vertspm%addconnection(i, ivert, 0) - ! - ! -- If necessary, repeat the last vertex in order to close the cell - if (j == 1) then - ivert1 = ivert - elseif (j == ncvert) then - if (ivert1 /= ivert) then - call vertspm%addconnection(i, ivert1, 0) - end if - end if - end do - ! - ! -- set min/max coords - if (i == 1) then - xmin = this%cellxy(1, i) - xmax = xmin - ymin = this%cellxy(2, i) - ymax = ymin - else - xmin = min(xmin, this%cellxy(1, i)) - xmax = max(xmax, this%cellxy(1, i)) - ymin = min(ymin, this%cellxy(2, i)) - ymax = max(ymax, this%cellxy(2, i)) - end if + this%cellxy(1, i) = cell_x(i) + this%cellxy(2, i) = cell_y(i) end do - ! - ! -- Terminate the block - call this%parser%terminateblock() else - call store_error('Required CELL2D block not found.') - call this%parser%StoreErrorUnit() + call store_error('Required cell center arrays not found.') end if ! - ! -- Convert vertspm into ia/ja form - call mem_allocate(this%iavert, this%ncpl + 1, 'IAVERT', this%memoryPath) - call mem_allocate(this%javert, vertspm%nnz, 'JAVERT', this%memoryPath) - call vertspm%filliaja(this%iavert, this%javert, ierr) - call vertspm%destroy() - ! - ! -- Write information - write (this%iout, fmtncpl) this%ncpl - write (this%iout, fmtcoord) 'MINIMUM X', xmin - write (this%iout, fmtcoord) 'MAXIMUM X', xmax - write (this%iout, fmtcoord) 'MINIMUM Y', ymin - write (this%iout, fmtcoord) 'MAXIMUM Y', ymax - write (this%iout, fmtmaxvert) maxvert, maxvertcell - write (this%iout, '(1x,a)') 'END PROCESSING VERTICES' + ! -- log + if (this%iout > 0) then + write (this%iout, '(1x,a)') 'Discretization Cell2d data loaded' + end if ! ! -- Return return - end subroutine read_cell2d + end subroutine source_cell2d subroutine connect(this) ! ****************************************************************************** diff --git a/src/Model/GroundWaterFlow/gwf3disv8idm.f90 b/src/Model/GroundWaterFlow/gwf3disv8idm.f90 new file mode 100644 index 00000000000..31259ddddf6 --- /dev/null +++ b/src/Model/GroundWaterFlow/gwf3disv8idm.f90 @@ -0,0 +1,406 @@ +module GwfDisvInputModule + use InputDefinitionModule, only: InputParamDefinitionType, & + InputBlockDefinitionType + private + public gwf_disv_param_definitions + public gwf_disv_aggregate_definitions + public gwf_disv_block_definitions + + type(InputParamDefinitionType), parameter :: & + gwfdisv_length_units = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISV', & ! subcomponent + 'OPTIONS', & ! block + 'LENGTH_UNITS', & ! tag name + 'LENGTH_UNITS', & ! fortran variable + 'STRING', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisv_nogrb = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISV', & ! subcomponent + 'OPTIONS', & ! block + 'NOGRB', & ! tag name + 'NOGRB', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisv_xorigin = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISV', & ! subcomponent + 'OPTIONS', & ! block + 'XORIGIN', & ! tag name + 'XORIGIN', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisv_yorigin = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISV', & ! subcomponent + 'OPTIONS', & ! block + 'YORIGIN', & ! tag name + 'YORIGIN', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisv_angrot = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISV', & ! subcomponent + 'OPTIONS', & ! block + 'ANGROT', & ! tag name + 'ANGROT', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisv_nlay = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISV', & ! subcomponent + 'DIMENSIONS', & ! block + 'NLAY', & ! tag name + 'NLAY', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisv_ncpl = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISV', & ! subcomponent + 'DIMENSIONS', & ! block + 'NCPL', & ! tag name + 'NCPL', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisv_nvert = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISV', & ! subcomponent + 'DIMENSIONS', & ! block + 'NVERT', & ! tag name + 'NVERT', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisv_top = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISV', & ! subcomponent + 'GRIDDATA', & ! block + 'TOP', & ! tag name + 'TOP', & ! fortran variable + 'DOUBLE2D', & ! type + 'NCPL, 1', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisv_botm = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISV', & ! subcomponent + 'GRIDDATA', & ! block + 'BOTM', & ! tag name + 'BOTM', & ! fortran variable + 'DOUBLE3D', & ! type + 'NCPL, 1, NLAY', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisv_idomain = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISV', & ! subcomponent + 'GRIDDATA', & ! block + 'IDOMAIN', & ! tag name + 'IDOMAIN', & ! fortran variable + 'INTEGER3D', & ! type + 'NCPL, 1, NLAY', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisv_iv = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISV', & ! subcomponent + 'VERTICES', & ! block + 'IV', & ! tag name + 'IV', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisv_xv = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISV', & ! subcomponent + 'VERTICES', & ! block + 'XV', & ! tag name + 'XV', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisv_yv = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISV', & ! subcomponent + 'VERTICES', & ! block + 'YV', & ! tag name + 'YV', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisv_icell2d = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISV', & ! subcomponent + 'CELL2D', & ! block + 'ICELL2D', & ! tag name + 'ICELL2D', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisv_xc = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISV', & ! subcomponent + 'CELL2D', & ! block + 'XC', & ! tag name + 'XC', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisv_yc = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISV', & ! subcomponent + 'CELL2D', & ! block + 'YC', & ! tag name + 'YC', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisv_ncvert = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISV', & ! subcomponent + 'CELL2D', & ! block + 'NCVERT', & ! tag name + 'NCVERT', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisv_icvert = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISV', & ! subcomponent + 'CELL2D', & ! block + 'ICVERT', & ! tag name + 'ICVERT', & ! fortran variable + 'INTEGER1D', & ! type + 'NCVERT', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwf_disv_param_definitions(*) = & + [ & + gwfdisv_length_units, & + gwfdisv_nogrb, & + gwfdisv_xorigin, & + gwfdisv_yorigin, & + gwfdisv_angrot, & + gwfdisv_nlay, & + gwfdisv_ncpl, & + gwfdisv_nvert, & + gwfdisv_top, & + gwfdisv_botm, & + gwfdisv_idomain, & + gwfdisv_iv, & + gwfdisv_xv, & + gwfdisv_yv, & + gwfdisv_icell2d, & + gwfdisv_xc, & + gwfdisv_yc, & + gwfdisv_ncvert, & + gwfdisv_icvert & + ] + + type(InputParamDefinitionType), parameter :: & + gwfdisv_vertices = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISV', & ! subcomponent + 'VERTICES', & ! block + 'VERTICES', & ! tag name + 'VERTICES', & ! fortran variable + 'RECARRAY IV XV YV', & ! type + 'NVERT', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfdisv_cell2d = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'DISV', & ! subcomponent + 'CELL2D', & ! block + 'CELL2D', & ! tag name + 'CELL2D', & ! fortran variable + 'RECARRAY ICELL2D XC YC NCVERT ICVERT', & ! type + 'NCPL', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwf_disv_aggregate_definitions(*) = & + [ & + gwfdisv_vertices, & + gwfdisv_cell2d & + ] + + type(InputBlockDefinitionType), parameter :: & + gwf_disv_block_definitions(*) = & + [ & + InputBlockDefinitionType( & + 'OPTIONS', & ! blockname + .false., & ! required + .false. & ! aggregate + ), & + InputBlockDefinitionType( & + 'DIMENSIONS', & ! blockname + .true., & ! required + .false. & ! aggregate + ), & + InputBlockDefinitionType( & + 'GRIDDATA', & ! blockname + .true., & ! required + .false. & ! aggregate + ), & + InputBlockDefinitionType( & + 'VERTICES', & ! blockname + .true., & ! required + .true. & ! aggregate + ), & + InputBlockDefinitionType( & + 'CELL2D', & ! blockname + .true., & ! required + .true. & ! aggregate + ) & + ] + +end module GwfDisvInputModule diff --git a/src/Model/GroundWaterFlow/gwf3npf8.f90 b/src/Model/GroundWaterFlow/gwf3npf8.f90 index 886907e15f3..dcfdf99bc31 100644 --- a/src/Model/GroundWaterFlow/gwf3npf8.f90 +++ b/src/Model/GroundWaterFlow/gwf3npf8.f90 @@ -3,7 +3,8 @@ module GwfNpfModule use ConstantsModule, only: DZERO, DEM9, DEM8, DEM7, DEM6, DEM2, & DHALF, DP9, DONE, DTWO, & DLNLOW, DLNHIGH, & - DHNOFLO, DHDRY, DEM10 + DHNOFLO, DHDRY, DEM10, & + LENMEMPATH, LENVARNAME, LINELENGTH use SmoothingModule, only: sQuadraticSaturation, & sQuadraticSaturationDerivative use NumericalPackageModule, only: NumericalPackageType @@ -38,6 +39,7 @@ module GwfNpfModule integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound real(DP), dimension(:), pointer, contiguous :: hnew => null() !< pointer to model xnew integer(I4B), pointer :: ixt3d => null() !< xt3d flag (0 is off, 1 is lhs, 2 is rhs) + integer(I4B), pointer :: ixt3drhs => null() !< xt3d rhs flag, xt3d rhs is set active if 1 integer(I4B), pointer :: iperched => null() !< vertical flow corrections if 1 integer(I4B), pointer :: ivarcv => null() !< CV is function of water table integer(I4B), pointer :: idewatcv => null() !< CV may be a discontinuous function of water table @@ -116,11 +118,12 @@ module GwfNpfModule procedure, private :: wdmsg => sgwf_npf_wdmsg procedure :: allocate_scalars procedure, private :: allocate_arrays - procedure, private :: read_options + procedure, private :: source_options + procedure, private :: source_griddata + procedure, private :: log_options + procedure, private :: log_griddata procedure, private :: set_options - procedure, private :: rewet_options procedure, private :: check_options - procedure, private :: read_grid_data procedure, private :: prepcheck procedure, private :: preprocess_input procedure, private :: calc_condsat @@ -146,11 +149,17 @@ subroutine npf_cr(npfobj, name_model, inunit, iout) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules + use IdmMf6FileLoaderModule, only: input_load + use ConstantsModule, only: LENPACKAGETYPE ! -- dummy type(GwfNpftype), pointer :: npfobj character(len=*), intent(in) :: name_model integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout + ! -- formats + character(len=*), parameter :: fmtheader = & + "(1x, /1x, 'NPF -- NODE PROPERTY FLOW PACKAGE, VERSION 1, 3/30/2015', & + &' INPUT READ FROM UNIT ', i0, /)" ! ------------------------------------------------------------------------------ ! ! -- Create the object @@ -166,6 +175,21 @@ subroutine npf_cr(npfobj, name_model, inunit, iout) npfobj%inunit = inunit npfobj%iout = iout ! + ! -- Check if input file is open + if (inunit > 0) then + ! + ! -- Print a message identifying the node property flow package. + write (iout, fmtheader) inunit + ! + ! -- Initialize block parser and read options + call npfobj%parser%Initialize(inunit, iout) + ! + ! -- Use the input data model routines to load the input data + ! into memory + call input_load(npfobj%parser, 'NPF6', 'GWF', 'NPF', npfobj%name_model, & + 'NPF', [character(len=LENPACKAGETYPE) :: 'TVK6'], iout) + end if + ! ! -- Return return end subroutine npf_cr @@ -194,10 +218,6 @@ subroutine npf_df(this, dis, xt3d, ingnc, npf_options) integer(I4B), intent(in) :: ingnc !< ghostnodes enabled? (>0 means yes) type(GwfNpfOptionsType), optional, intent(in) :: npf_options !< the optional options, for when not constructing from file ! -- local - ! -- formats - character(len=*), parameter :: fmtheader = & - "(1x, /1x, 'NPF -- NODE PROPERTY FLOW PACKAGE, VERSION 1, 3/30/2015', & - &' INPUT READ FROM UNIT ', i0, //)" ! -- data ! ------------------------------------------------------------------------------ ! @@ -205,18 +225,15 @@ subroutine npf_df(this, dis, xt3d, ingnc, npf_options) this%dis => dis ! if (.not. present(npf_options)) then - ! -- Print a message identifying the node property flow package. - write (this%iout, fmtheader) this%inunit ! - ! -- Initialize block parser and read options - call this%parser%Initialize(this%inunit, this%iout) - call this%read_options() + ! -- source options + call this%source_options() ! ! -- allocate arrays call this%allocate_arrays(this%dis%nodes, this%dis%njas) ! - ! -- read from file, set, and convert/check the input - call this%read_grid_data() + ! -- source griddata, set, and convert/check the input + call this%source_griddata() call this%prepcheck() else call this%set_options(npf_options) @@ -1031,9 +1048,14 @@ subroutine npf_da(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules + use MemoryManagerExtModule, only: memorylist_remove + use SimVariablesModule, only: idm_context ! -- dummy class(GwfNpftype) :: this ! ------------------------------------------------------------------------------ + ! + ! -- Deallocate input memory + call memorylist_remove(this%name_model, 'NPF', idm_context) ! ! -- TVK if (this%intvk /= 0) then @@ -1046,6 +1068,7 @@ subroutine npf_da(this) ! -- Scalars call mem_deallocate(this%iname) call mem_deallocate(this%ixt3d) + call mem_deallocate(this%ixt3drhs) call mem_deallocate(this%satomega) call mem_deallocate(this%hnoflo) call mem_deallocate(this%hdry) @@ -1125,6 +1148,7 @@ subroutine allocate_scalars(this) ! -- Allocate scalars call mem_allocate(this%iname, 'INAME', this%memoryPath) call mem_allocate(this%ixt3d, 'IXT3D', this%memoryPath) + call mem_allocate(this%ixt3drhs, 'IXT3DRHS', this%memoryPath) call mem_allocate(this%satomega, 'SATOMEGA', this%memoryPath) call mem_allocate(this%hnoflo, 'HNOFLO', this%memoryPath) call mem_allocate(this%hdry, 'HDRY', this%memoryPath) @@ -1165,6 +1189,7 @@ subroutine allocate_scalars(this) ! -- Initialize value this%iname = 8 this%ixt3d = 0 + this%ixt3drhs = 0 this%satomega = DZERO this%hnoflo = DHNOFLO !1.d30 this%hdry = DHDRY !-1.d30 @@ -1268,181 +1293,200 @@ subroutine allocate_arrays(this, ncells, njas) return end subroutine allocate_arrays - subroutine read_options(this) + subroutine log_options(this, afound) ! ****************************************************************************** -! read_options -- Read the options +! log_options -- log npf options sourced from the input mempath +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use KindModule, only: LGP + ! -- dummy + class(GwfNpftype) :: this + ! -- locals + logical, dimension(:), intent(in) :: afound +! ------------------------------------------------------------------------------ + ! + write (this%iout, '(1x,a)') 'Setting NPF Options' + if (afound(1)) & + write (this%iout, '(4x,a)') 'CELL-BY-CELL FLOW INFORMATION WILL BE PRINTED & + &TO LISTING FILE WHENEVER ICBCFL IS NOT ZERO.' + if (afound(2)) & + write (this%iout, '(4x,a)') 'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED & + &TO BINARY FILE WHENEVER ICBCFL IS NOT ZERO.' + if (afound(3)) & + write (this%iout, '(4x,a,i0)') 'ALTERNATIVE CELL AVERAGING [1=LOGARITHMIC, & + &2=AMT-LMK, 3=AMT-HMK] SET TO: ', & + this%icellavg + if (afound(4)) write (this%iout, '(4x,a)') 'THICKSTRT OPTION HAS BEEN & + &ACTIVATED.' + if (afound(5)) write (this%iout, '(4x,a)') 'VERTICAL FLOW WILL BE ADJUSTED & + &FOR PERCHED CONDITIONS.' + if (afound(6)) write (this%iout, '(4x,a)') 'VERTICAL CONDUCTANCE VARIES WITH & + &WATER TABLE.' + if (afound(7)) write (this%iout, '(4x,a)') 'VERTICAL CONDUCTANCE ACCOUNTS & + &FOR DEWATERED PORTION OF AN & + &UNDERLYING CELL.' + if (afound(8)) write (this%iout, '(4x,a)') 'XT3D FORMULATION IS SELECTED.' + if (afound(9)) write (this%iout, '(4x,a)') 'XT3D RHS FORMULATION IS SELECTED.' + if (afound(10)) & + write (this%iout, '(4x,a)') 'SPECIFIC DISCHARGE WILL BE CALCULATED AT CELL & + &CENTERS AND WRITTEN TO DATA-SPDIS IN BUDGET & + &FILE WHEN REQUESTED.' + if (afound(11)) & + write (this%iout, '(4x,a)') 'SATURATION WILL BE WRITTEN TO DATA-SAT IN & + &BUDGET FILE WHEN REQUESTED.' + if (afound(12)) & + write (this%iout, '(4x,a)') 'VALUES SPECIFIED FOR K22 ARE ANISOTROPY & + &RATIOS AND WILL BE MULTIPLIED BY K BEFORE & + &BEING USED IN CALCULATIONS.' + if (afound(13)) & + write (this%iout, '(4x,a)') 'VALUES SPECIFIED FOR K33 ARE ANISOTROPY & + &RATIOS AND WILL BE MULTIPLIED BY K BEFORE & + &BEING USED IN CALCULATIONS.' + if (afound(15)) write (this%iout, '(4x,a)') 'NEWTON-RAPHSON method disabled & + &for unconfined cells' + if (afound(16)) write (this%iout, '(4x,a)') 'MODFLOW-USG saturation & + &calculation method will be used' + if (afound(17)) write (this%iout, '(4x,a)') 'MODFLOW-NWT upstream weighting & + &method will be used ' + if (afound(18)) & + write (this%iout, '(4x,a,1pg15.6)') 'MINIMUM SATURATED THICKNESS HAS BEEN & + &SET TO: ', this%satmin + if (afound(19)) & + write (this%iout, '(4x,a,1pg15.6)') 'SATURATION OMEGA: ', this%satomega + if (afound(20)) write (this%iout, '(4x,a)') 'REWETTING IS ACTIVE.' + if (afound(21)) write (this%iout, '(4x,a,1pg15.6)') 'WETTING FACTOR HAS BEEN & + &SET TO: ', this%wetfct + if (afound(22)) write (this%iout, '(4x,a,i5)') 'IWETIT HAS BEEN SET TO: ', & + this%iwetit + if (afound(23)) write (this%iout, '(4x,a,i5)') 'IHDWET HAS BEEN SET TO: ', & + this%ihdwet + write (this%iout, '(1x,a,/)') 'End Setting NPF Options' + ! + ! -- Write rewet settings + write (this%iout, '(1x, a)') 'THE FOLLOWING REWET SETTINGS WILL BE USED.' + write (this%iout, '(4x, a,1pg15.6)') ' WETFCT = ', this%wetfct + write (this%iout, '(4x, a,i0)') ' IWETIT = ', this%iwetit + write (this%iout, '(4x, a,i0)') ' IHDWET = ', this%ihdwet + + end subroutine log_options + + subroutine source_options(this) +! ****************************************************************************** +! source_options -- update simulation options from input mempath +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use KindModule, only: LGP + use MemoryHelperModule, only: create_mem_path + use MemoryManagerExtModule, only: mem_set_value + use SimVariablesModule, only: idm_context + ! -- dummy + class(GwfNpftype) :: this + ! -- locals + character(len=LENMEMPATH) :: idmMemoryPath + character(len=LENVARNAME), dimension(3) :: cellavg_method = & + &[character(len=LENVARNAME) :: 'LOGARITHMIC', 'AMT-LMK', 'AMT-HMK'] + logical, dimension(23) :: afound + character(len=LINELENGTH) :: tvk6_filename +! ------------------------------------------------------------------------------ + ! + ! -- set memory path + idmMemoryPath = create_mem_path(this%name_model, 'NPF', idm_context) + ! + ! -- update defaults with idm sourced values + call mem_set_value(this%iprflow, 'IPRFLOW', idmMemoryPath, afound(1)) + call mem_set_value(this%ipakcb, 'IPAKCB', idmMemoryPath, afound(2)) + call mem_set_value(this%icellavg, 'CELLAVG', idmMemoryPath, cellavg_method, & + afound(3)) + call mem_set_value(this%ithickstrt, 'ITHICKSTRT', idmMemoryPath, afound(4)) + call mem_set_value(this%iperched, 'IPERCHED', idmMemoryPath, afound(5)) + call mem_set_value(this%ivarcv, 'IVARCV', idmMemoryPath, afound(6)) + call mem_set_value(this%idewatcv, 'IDEWATCV', idmMemoryPath, afound(7)) + call mem_set_value(this%ixt3d, 'IXT3D', idmMemoryPath, afound(8)) + call mem_set_value(this%ixt3drhs, 'IXT3DRHS', idmMemoryPath, afound(9)) + call mem_set_value(this%isavspdis, 'ISAVSPDIS', idmMemoryPath, afound(10)) + call mem_set_value(this%isavsat, 'ISAVSAT', idmMemoryPath, afound(11)) + call mem_set_value(this%ik22overk, 'IK22OVERK', idmMemoryPath, afound(12)) + call mem_set_value(this%ik33overk, 'IK33OVERK', idmMemoryPath, afound(13)) + call mem_set_value(tvk6_filename, 'TVK6_FILENAME', idmMemoryPath, afound(14)) + call mem_set_value(this%inewton, 'INEWTON', idmMemoryPath, afound(15)) + call mem_set_value(this%iusgnrhc, 'IUSGNRHC', idmMemoryPath, & + afound(16)) + call mem_set_value(this%inwtupw, 'INWTUPW', idmMemoryPath, afound(17)) + call mem_set_value(this%satmin, 'SATMIN', idmMemoryPath, afound(18)) + call mem_set_value(this%satomega, 'SATOMEGA', idmMemoryPath, afound(19)) + call mem_set_value(this%irewet, 'IREWET', idmMemoryPath, afound(20)) + call mem_set_value(this%wetfct, 'WETFCT', idmMemoryPath, afound(21)) + call mem_set_value(this%iwetit, 'IWETIT', idmMemoryPath, afound(22)) + call mem_set_value(this%ihdwet, 'IHDWET', idmMemoryPath, afound(23)) + ! + ! -- save flows option active + if (afound(2)) this%ipakcb = -1 + ! + ! -- xt3d active with rhs + if (afound(8) .and. afound(9)) this%ixt3d = 2 + ! + ! -- save specific discharge active + if (afound(10)) this%icalcspdis = this%isavspdis + ! + ! -- TVK6 subpackage file spec provided + if (afound(14)) then + this%intvk = GetUnit() + call openfile(this%intvk, this%iout, tvk6_filename, 'TVK') + call tvk_cr(this%tvk, this%name_model, this%intvk, this%iout) + end if + ! + ! -- no newton specified + if (afound(15)) then + this%inewton = 0 + this%iasym = 0 + end if + ! + ! -- log options + if (this%iout > 0) then + call this%log_options(afound) + end if + ! + ! -- Return + return + end subroutine source_options + + subroutine set_options(this, options) + class(GwfNpftype) :: this + type(GwfNpfOptionsType), intent(in) :: options + + this%icellavg = options%icellavg + this%ithickstrt = options%ithickstrt + this%iperched = options%iperched + this%ivarcv = options%ivarcv + this%idewatcv = options%idewatcv + this%irewet = options%irewet + this%wetfct = options%wetfct + this%iwetit = options%iwetit + this%ihdwet = options%ihdwet + + end subroutine set_options + + subroutine check_options(this) +! ****************************************************************************** +! check_options -- Check for conflicting NPF options ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, count_errors - implicit none + use ConstantsModule, only: LINELENGTH ! -- dummy class(GwfNpftype) :: this ! -- local - character(len=LINELENGTH) :: errmsg, keyword, fname - integer(I4B) :: ierr - logical :: isfound, endOfBlock - ! -- formats - character(len=*), parameter :: fmtiprflow = & - "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE PRINTED TO LISTING FILE & - &WHENEVER ICBCFL IS NOT ZERO.')" - character(len=*), parameter :: fmtisvflow = & - "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE & - &WHENEVER ICBCFL IS NOT ZERO.')" - character(len=*), parameter :: fmtcellavg = & - &"(4x,'ALTERNATIVE CELL AVERAGING HAS BEEN SET TO ', a)" - character(len=*), parameter :: fmtnct = & - &"(1x, 'Negative cell thickness at cell: ', a)" - ! -- data + character(len=LINELENGTH) :: errmsg ! ------------------------------------------------------------------------------ - ! - ! -- get options block - call this%parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) - ! - ! -- parse options block if detected - if (isfound) then - write (this%iout, '(1x,a)') 'PROCESSING NPF OPTIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('PRINT_FLOWS') - this%iprflow = 1 - write (this%iout, fmtiprflow) - case ('SAVE_FLOWS') - this%ipakcb = -1 - write (this%iout, fmtisvflow) - case ('ALTERNATIVE_CELL_AVERAGING') - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('LOGARITHMIC') - this%icellavg = 1 - write (this%iout, fmtcellavg) 'LOGARITHMIC' - case ('AMT-LMK') - this%icellavg = 2 - write (this%iout, fmtcellavg) 'AMT-LMK' - case ('AMT-HMK') - this%icellavg = 3 - write (this%iout, fmtcellavg) 'AMT-HMK' - case default - write (errmsg, '(4x,a,a)') 'UNKNOWN CELL AVERAGING METHOD: ', & - keyword - call store_error(errmsg) - call this%parser%StoreErrorUnit() - end select - write (this%iout, '(4x,a,a)') & - 'CELL AVERAGING METHOD HAS BEEN SET TO: ', keyword - case ('THICKSTRT') - this%ithickstrt = 1 - write (this%iout, '(4x,a)') 'THICKSTRT OPTION HAS BEEN ACTIVATED.' - case ('PERCHED') - this%iperched = 1 - write (this%iout, '(4x,a)') & - 'VERTICAL FLOW WILL BE ADJUSTED FOR PERCHED CONDITIONS.' - case ('VARIABLECV') - this%ivarcv = 1 - write (this%iout, '(4x,a)') & - 'VERTICAL CONDUCTANCE VARIES WITH WATER TABLE.' - call this%parser%GetStringCaps(keyword) - if (keyword == 'DEWATERED') then - this%idewatcv = 1 - write (this%iout, '(4x,a)') & - 'VERTICAL CONDUCTANCE ACCOUNTS FOR DEWATERED PORTION OF '// & - 'AN UNDERLYING CELL.' - end if - case ('REWET') - call this%rewet_options() - case ('XT3D') - this%ixt3d = 1 - write (this%iout, '(4x,a)') & - 'XT3D FORMULATION IS SELECTED.' - call this%parser%GetStringCaps(keyword) - if (keyword == 'RHS') then - this%ixt3d = 2 - end if - case ('SAVE_SPECIFIC_DISCHARGE') - this%icalcspdis = 1 - this%isavspdis = 1 - write (this%iout, '(4x,a)') & - 'SPECIFIC DISCHARGE WILL BE CALCULATED AT CELL CENTERS '// & - 'AND WRITTEN TO DATA-SPDIS IN BUDGET FILE WHEN REQUESTED.' - case ('SAVE_SATURATION') - this%isavsat = 1 - write (this%iout, '(4x,a)') & - 'SATURATION WILL BE WRITTEN TO DATA-SAT IN BUDGET FILE '// & - 'WHEN REQUESTED.' - case ('K22OVERK') - this%ik22overk = 1 - write (this%iout, '(4x,a)') & - 'VALUES SPECIFIED FOR K22 ARE ANISOTROPY RATIOS AND '// & - 'WILL BE MULTIPLIED BY K BEFORE BEING USED IN CALCULATIONS.' - case ('K33OVERK') - this%ik33overk = 1 - write (this%iout, '(4x,a)') & - 'VALUES SPECIFIED FOR K33 ARE ANISOTROPY RATIOS AND '// & - 'WILL BE MULTIPLIED BY K BEFORE BEING USED IN CALCULATIONS.' - case ('TVK6') - if (this%intvk /= 0) then - errmsg = 'Multiple TVK6 keywords detected in OPTIONS block.'// & - ' Only one TVK6 entry allowed.' - call store_error(errmsg, terminate=.TRUE.) - end if - call this%parser%GetStringCaps(keyword) - if (trim(adjustl(keyword)) /= 'FILEIN') then - errmsg = 'TVK6 keyword must be followed by "FILEIN" '// & - 'then by filename.' - call store_error(errmsg, terminate=.TRUE.) - end if - call this%parser%GetString(fname) - this%intvk = GetUnit() - call openfile(this%intvk, this%iout, fname, 'TVK') - call tvk_cr(this%tvk, this%name_model, this%intvk, this%iout) - ! - ! -- The following are options that are only available in the - ! development version and are not included in the documentation. - ! These options are only available when IDEVELOPMODE in - ! constants module is set to 1 - case ('DEV_NO_NEWTON') - call this%parser%DevOpt() - this%inewton = 0 - write (this%iout, '(4x,a)') & - 'NEWTON-RAPHSON method disabled for unconfined cells' - this%iasym = 0 - case ('DEV_MODFLOWUSG_UPSTREAM_WEIGHTED_SATURATION') - call this%parser%DevOpt() - this%iusgnrhc = 1 - write (this%iout, '(4x,a)') & - 'MODFLOW-USG saturation calculation method will be used ' - case ('DEV_MODFLOWNWT_UPSTREAM_WEIGHTING') - call this%parser%DevOpt() - this%inwtupw = 1 - write (this%iout, '(4x,a)') & - 'MODFLOW-NWT upstream weighting method will be used ' - case ('DEV_MINIMUM_SATURATED_THICKNESS') - call this%parser%DevOpt() - this%satmin = this%parser%GetDouble() - write (this%iout, '(4x,a,1pg15.6)') & - 'MINIMUM SATURATED THICKNESS HAS BEEN SET TO: ', & - this%satmin - case ('DEV_OMEGA') - call this%parser%DevOpt() - this%satomega = this%parser%GetDouble() - write (this%iout, '(4x,a,1pg15.6)') & - 'SATURATION OMEGA: ', this%satomega - - case default - write (errmsg, '(4x,a,a)') 'Unknown NPF option: ', trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - end select - end do - write (this%iout, '(1x,a)') 'END OF NPF OPTIONS' - end if ! -- check if this%iusgnrhc has been enabled for a model that is not using ! the Newton-Raphson formulation if (this%iusgnrhc > 0 .and. this%inewton == 0) then @@ -1488,137 +1532,6 @@ subroutine read_options(this) if (this%inewton > 0) then this%satomega = DEM6 end if - ! - ! -- terminate if errors encountered in options block - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - end if - ! - ! -- Return - return - end subroutine read_options - - subroutine set_options(this, options) - class(GwfNpftype) :: this - type(GwfNpfOptionsType), intent(in) :: options - - this%icellavg = options%icellavg - this%ithickstrt = options%ithickstrt - this%iperched = options%iperched - this%ivarcv = options%ivarcv - this%idewatcv = options%idewatcv - this%irewet = options%irewet - this%wetfct = options%wetfct - this%iwetit = options%iwetit - this%ihdwet = options%ihdwet - - end subroutine set_options - - subroutine rewet_options(this) -! ****************************************************************************** -! rewet_options -- Set rewet options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: store_error - use ConstantsModule, only: LINELENGTH - ! -- dummy - class(GwfNpftype) :: this - ! -- local - integer(I4B) :: ival - character(len=LINELENGTH) :: keyword, errmsg - logical, dimension(3) :: lfound = .false. -! ------------------------------------------------------------------------------ - ! - ! -- If rewet already set, then terminate with error - if (this%irewet == 1) then - write (errmsg, '(a)') 'ERROR WITH NPF REWET OPTION. REWET WAS '// & - 'ALREADY SET. REMOVE DUPLICATE REWET ENTRIES '// & - 'FROM NPF OPTIONS BLOCK.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - end if - this%irewet = 1 - write (this%iout, '(4x,a)') 'REWETTING IS ACTIVE.' - ! - ! -- Parse rewet options - do - call this%parser%GetStringCaps(keyword) - if (keyword == '') exit - select case (keyword) - case ('WETFCT') - this%wetfct = this%parser%GetDouble() - write (this%iout, '(4x,a,1pg15.6)') & - 'WETTING FACTOR HAS BEEN SET TO: ', this%wetfct - lfound(1) = .true. - case ('IWETIT') - if (.not. lfound(1)) then - write (errmsg, '(4x,a)') & - 'NPF rewetting flags must be specified in order. '// & - 'Found iwetit but wetfct not specified.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - end if - ival = this%parser%GetInteger() - if (ival <= 0) ival = 1 - this%iwetit = ival - write (this%iout, '(4x,a,i5)') 'IWETIT HAS BEEN SET TO: ', & - this%iwetit - lfound(2) = .true. - case ('IHDWET') - if (.not. lfound(2)) then - write (errmsg, '(4x,a)') & - 'NPF rewetting flags must be specified in order. '// & - 'Found ihdwet but iwetit not specified.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - end if - this%ihdwet = this%parser%GetInteger() - write (this%iout, '(4x,a,i5)') 'IHDWET HAS BEEN SET TO: ', & - this%ihdwet - lfound(3) = .true. - case default - write (errmsg, '(4x,a,a)') 'Unknown NPF rewet option: ', trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - end select - end do - ! - if (.not. lfound(3)) then - write (errmsg, '(4x,a)') & - '****ERROR. NPF REWETTING FLAGS MUST BE SPECIFIED IN ORDER. '// & - 'DID NOT FIND IHDWET AS LAST REWET SETTING.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - end if - ! - ! -- Write rewet settings - write (this%iout, '(4x, a)') 'THE FOLLOWING REWET SETTINGS WILL BE USED.' - write (this%iout, '(6x, a,1pg15.6)') ' WETFCT = ', this%wetfct - write (this%iout, '(6x, a,i0)') ' IWETIT = ', this%iwetit - write (this%iout, '(6x, a,i0)') ' IHDWET = ', this%ihdwet - ! - ! -- Return - return - end subroutine rewet_options - - subroutine check_options(this) -! ****************************************************************************** -! check_options -- Check for conflicting NPF options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: store_error, count_errors - use ConstantsModule, only: LINELENGTH - ! -- dummy - class(GwfNpftype) :: this - ! -- local - character(len=LINELENGTH) :: errmsg -! ------------------------------------------------------------------------------ ! if (this%inewton > 0) then if (this%iperched > 0) then @@ -1671,148 +1584,149 @@ subroutine check_options(this) return end subroutine check_options - subroutine read_grid_data(this) + !> @brief Write dimensions to list file + !< + subroutine log_griddata(this, afound) + class(GwfNpfType) :: this + logical, dimension(:), intent(in) :: afound + + write (this%iout, '(1x,a)') 'Setting NPF Griddata' + + if (afound(1)) then + write (this%iout, '(4x,a)') 'ICELLTYPE set from input file' + end if + + if (afound(2)) then + write (this%iout, '(4x,a)') 'K set from input file' + end if + + if (afound(3)) then + write (this%iout, '(4x,a)') 'K33 set from input file' + end if + + if (afound(4)) then + write (this%iout, '(4x,a)') 'K22 set from input file' + end if + + if (afound(5)) then + write (this%iout, '(4x,a)') 'WETDRY set from input file' + end if + + if (afound(6)) then + write (this%iout, '(4x,a)') 'ANGLE1 set from input file' + end if + + if (afound(7)) then + write (this%iout, '(4x,a)') 'ANGLE2 set from input file' + end if + + if (afound(8)) then + write (this%iout, '(4x,a)') 'ANGLE3 set from input file' + end if + + write (this%iout, '(1x,a,/)') 'End Setting NPF Griddata' + + end subroutine log_griddata + + subroutine source_griddata(this) ! ****************************************************************************** -! read_grid_data -- read the npf data block +! source_griddata -- update simulation griddata from input mempath ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use ConstantsModule, only: LINELENGTH, DONE, DPIO180 - use SimModule, only: store_error, count_errors + use SimModule, only: count_errors, store_error + use MemoryHelperModule, only: create_mem_path + use MemoryManagerModule, only: mem_reallocate + use MemoryManagerExtModule, only: mem_set_value + use SimVariablesModule, only: idm_context ! -- dummy class(GwfNpftype) :: this - ! -- local + ! -- locals + character(len=LENMEMPATH) :: idmMemoryPath character(len=LINELENGTH) :: errmsg - integer(I4B) :: n, ierr - logical :: isfound - logical, dimension(8) :: lname - character(len=24), dimension(:), pointer :: aname - character(len=24), dimension(8) :: varinames + logical, dimension(10) :: afound + integer(I4B), dimension(:), pointer, contiguous :: map ! -- formats - character(len=*), parameter :: fmtiprflow = & - "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE PRINTED TO LISTING FILE & - &WHENEVER ICBCFL IS NOT ZERO.')" - character(len=*), parameter :: fmtisvflow = & - "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE & - &WHENEVER ICBCFL IS NOT ZERO.')" - character(len=*), parameter :: fmtnct = & - &"(1x, 'Negative cell thickness at cell: ', a)" - ! -- data - !data aname(1) /' ICELLTYPE'/ - !data aname(2) /' K'/ - !data aname(3) /' K33'/ - !data aname(4) /' K22'/ - !data aname(5) /' WETDRY'/ - !data aname(6) /' ANGLE1'/ - !data aname(7) /' ANGLE2'/ - !data aname(8) /' ANGLE3'/ ! ------------------------------------------------------------------------------ ! - ! -- Initialize - aname => this%aname - do n = 1, size(aname) - varinames(n) = adjustl(aname(n)) - lname(n) = .false. - end do - varinames(2) = 'K11 ' - ! - ! -- Read all of the arrays in the GRIDDATA block using the get_block_data - ! method, which is part of NumericalPackageType - call this%parser%GetBlock('GRIDDATA', isfound, ierr) - if (isfound) then - write (this%iout, '(1x,a)') 'PROCESSING GRIDDATA' - call this%get_block_data(aname, lname, varinames) - else - write (errmsg, '(1x,a)') 'Required GRIDDATA block not found.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - end if + ! -- set memory path + idmMemoryPath = create_mem_path(this%name_model, 'NPF', idm_context) + ! + ! -- set map + map => null() + if (this%dis%nodes < this%dis%nodesuser) map => this%dis%nodeuser ! - ! -- Check for ICELLTYPE - if (.not. lname(1)) then - write (errmsg, '(a, a, a)') 'Error in GRIDDATA block: ', & - trim(adjustl(aname(1))), ' not found.' + ! -- update defaults with idm sourced values + call mem_set_value(this%icelltype, 'ICELLTYPE', idmMemoryPath, map, & + afound(1)) + call mem_set_value(this%k11, 'K', idmMemoryPath, map, afound(2)) + call mem_set_value(this%k33, 'K33', idmMemoryPath, map, afound(3)) + call mem_set_value(this%k22, 'K22', idmMemoryPath, map, afound(4)) + call mem_set_value(this%wetdry, 'WETDRY', idmMemoryPath, map, afound(5)) + call mem_set_value(this%angle1, 'ANGLE1', idmMemoryPath, map, afound(6)) + call mem_set_value(this%angle2, 'ANGLE2', idmMemoryPath, map, afound(7)) + call mem_set_value(this%angle3, 'ANGLE3', idmMemoryPath, map, afound(8)) + ! + ! -- ensure ICELLTYPE was found + if (.not. afound(1)) then + write (errmsg, '(a)') 'Error in GRIDDATA block: ICELLTYPE not found.' call store_error(errmsg) end if ! - ! -- Check for K - if (.not. lname(2)) then - write (errmsg, '(a, a, a)') 'Error in GRIDDATA block: ', & - trim(adjustl(aname(2))), ' not found.' + ! -- ensure K was found + if (.not. afound(2)) then + write (errmsg, '(a)') 'Error in GRIDDATA block: K not found.' call store_error(errmsg) end if ! - ! -- set ik33 flag - if (lname(3)) then - this%ik33 = 1 - else - if (this%ik33overk /= 0) then - write (errmsg, '(a)') 'K33OVERK option specified but K33 not specified.' - call store_error(errmsg) - end if - write (this%iout, '(1x, a)') 'K33 not provided. Setting K33 = K.' - do n = 1, size(this%k11) - this%k33(n) = this%k11(n) - end do + ! -- set error if ik33overk set with no k33 + if (.not. afound(3) .and. this%ik33overk /= 0) then + write (errmsg, '(a)') 'K33OVERK option specified but K33 not specified.' + call store_error(errmsg) end if ! - ! -- set ik22 flag - if (lname(4)) then - this%ik22 = 1 - else - if (this%ik22overk /= 0) then - write (errmsg, '(a)') 'K22OVERK option specified but K22 not specified.' - call store_error(errmsg) - end if - write (this%iout, '(1x, a)') 'K22 not provided. Setting K22 = K.' - do n = 1, size(this%k11) - this%k22(n) = this%k11(n) - end do + ! -- set error if ik22overk set with no k22 + if (.not. afound(4) .and. this%ik22overk /= 0) then + write (errmsg, '(a)') 'K22OVERK option specified but K22 not specified.' + call store_error(errmsg) end if ! - ! -- Set WETDRY - if (lname(5)) then - this%iwetdry = 1 - else - call mem_reallocate(this%wetdry, 0, 'WETDRY', trim(this%memoryPath)) - end if + ! -- handle found side effects + if (afound(3)) this%ik33 = 1 + if (afound(4)) this%ik22 = 1 + if (afound(5)) this%iwetdry = 1 + if (afound(6)) this%iangle1 = 1 + if (afound(7)) this%iangle2 = 1 + if (afound(8)) this%iangle3 = 1 ! - ! -- set angle flags - if (lname(6)) then - this%iangle1 = 1 - else - if (this%ixt3d == 0) then - call mem_reallocate(this%angle1, 0, 'ANGLE1', trim(this%memoryPath)) - end if - end if - if (lname(7)) then - this%iangle2 = 1 - else - if (this%ixt3d == 0) then - call mem_reallocate(this%angle2, 0, 'ANGLE2', trim(this%memoryPath)) - end if + ! -- handle not found side effects + if (.not. afound(3)) then + write (this%iout, '(1x, a)') 'K33 not provided. Setting K33 = K.' + call mem_set_value(this%k33, 'K', idmMemoryPath, map, afound(9)) end if - if (lname(8)) then - this%iangle3 = 1 - else - if (this%ixt3d == 0) then - call mem_reallocate(this%angle3, 0, 'ANGLE3', trim(this%memoryPath)) - end if + if (.not. afound(4)) then + write (this%iout, '(1x, a)') 'K22 not provided. Setting K22 = K.' + call mem_set_value(this%k22, 'K', idmMemoryPath, map, afound(10)) end if + if (.not. afound(5)) call mem_reallocate(this%wetdry, 1, 'WETDRY', & + trim(this%memoryPath)) + if (.not. afound(6) .and. this%ixt3d == 0) & + call mem_reallocate(this%angle1, 1, 'ANGLE1', trim(this%memoryPath)) + if (.not. afound(7) .and. this%ixt3d == 0) & + call mem_reallocate(this%angle2, 1, 'ANGLE2', trim(this%memoryPath)) + if (.not. afound(8) .and. this%ixt3d == 0) & + call mem_reallocate(this%angle3, 1, 'ANGLE3', trim(this%memoryPath)) ! - ! -- terminate if read errors encountered - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() + ! -- log griddata + if (this%iout > 0) then + call this%log_griddata(afound) end if ! - ! -- Final NPFDATA message - write (this%iout, '(1x,a)') 'END PROCESSING GRIDDATA' - ! ! -- Return return - end subroutine read_grid_data + end subroutine source_griddata subroutine prepcheck(this) ! ****************************************************************************** diff --git a/src/Model/GroundWaterFlow/gwf3npf8idm.f90 b/src/Model/GroundWaterFlow/gwf3npf8idm.f90 new file mode 100644 index 00000000000..c757278d6b7 --- /dev/null +++ b/src/Model/GroundWaterFlow/gwf3npf8idm.f90 @@ -0,0 +1,664 @@ +module GwfNpfInputModule + use InputDefinitionModule, only: InputParamDefinitionType, & + InputBlockDefinitionType + private + public gwf_npf_param_definitions + public gwf_npf_aggregate_definitions + public gwf_npf_block_definitions + + type(InputParamDefinitionType), parameter :: & + gwfnpf_ipakcb = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'SAVE_FLOWS', & ! tag name + 'IPAKCB', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_iprflow = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'PRINT_FLOWS', & ! tag name + 'IPRFLOW', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_cellavg = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'ALTERNATIVE_CELL_AVERAGING', & ! tag name + 'CELLAVG', & ! fortran variable + 'STRING', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_ithickstrt = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'THICKSTRT', & ! tag name + 'ITHICKSTRT', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_cvoptions = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'CVOPTIONS', & ! tag name + 'CVOPTIONS', & ! fortran variable + 'RECORD VARIABLECV DEWATERED', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_ivarcv = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'VARIABLECV', & ! tag name + 'IVARCV', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_idewatcv = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'DEWATERED', & ! tag name + 'IDEWATCV', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_iperched = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'PERCHED', & ! tag name + 'IPERCHED', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_rewet_record = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'REWET_RECORD', & ! tag name + 'REWET_RECORD', & ! fortran variable + 'RECORD REWET WETFCT IWETIT IHDWET', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_irewet = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'REWET', & ! tag name + 'IREWET', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_wetfct = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'WETFCT', & ! tag name + 'WETFCT', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_iwetit = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'IWETIT', & ! tag name + 'IWETIT', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_ihdwet = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'IHDWET', & ! tag name + 'IHDWET', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_xt3doptions = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'XT3DOPTIONS', & ! tag name + 'XT3DOPTIONS', & ! fortran variable + 'RECORD XT3D RHS', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_ixt3d = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'XT3D', & ! tag name + 'IXT3D', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_ixt3drhs = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'RHS', & ! tag name + 'IXT3DRHS', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_isavspdis = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'SAVE_SPECIFIC_DISCHARGE', & ! tag name + 'ISAVSPDIS', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_isavsat = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'SAVE_SATURATION', & ! tag name + 'ISAVSAT', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_ik22overk = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'K22OVERK', & ! tag name + 'IK22OVERK', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_ik33overk = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'K33OVERK', & ! tag name + 'IK33OVERK', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_tvk_filerecord = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'TVK_FILERECORD', & ! tag name + 'TVK_FILERECORD', & ! fortran variable + 'RECORD TVK6 FILEIN TVK6_FILENAME', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_tvk6 = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'TVK6', & ! tag name + 'TVK6', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_filein = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'FILEIN', & ! tag name + 'FILEIN', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_tvk6_filename = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'TVK6_FILENAME', & ! tag name + 'TVK6_FILENAME', & ! fortran variable + 'STRING', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .true., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_inewton = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'DEV_NO_NEWTON', & ! tag name + 'INEWTON', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_iusgnrhc = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'DEV_MODFLOWUSG_UPSTREAM_WEIGHTED_SATURATION', & ! tag name + 'IUSGNRHC', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_inwtupw = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'DEV_MODFLOWNWT_UPSTREAM_WEIGHTING', & ! tag name + 'INWTUPW', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_satmin = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'DEV_MINIMUM_SATURATED_THICKNESS', & ! tag name + 'SATMIN', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_satomega = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'OPTIONS', & ! block + 'DEV_OMEGA', & ! tag name + 'SATOMEGA', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_icelltype = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'GRIDDATA', & ! block + 'ICELLTYPE', & ! tag name + 'ICELLTYPE', & ! fortran variable + 'INTEGER1D', & ! type + 'NODES', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_k = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'GRIDDATA', & ! block + 'K', & ! tag name + 'K', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_k22 = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'GRIDDATA', & ! block + 'K22', & ! tag name + 'K22', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_k33 = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'GRIDDATA', & ! block + 'K33', & ! tag name + 'K33', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_angle1 = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'GRIDDATA', & ! block + 'ANGLE1', & ! tag name + 'ANGLE1', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_angle2 = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'GRIDDATA', & ! block + 'ANGLE2', & ! tag name + 'ANGLE2', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_angle3 = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'GRIDDATA', & ! block + 'ANGLE3', & ! tag name + 'ANGLE3', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwfnpf_wetdry = InputParamDefinitionType & + ( & + 'GWF', & ! component + 'NPF', & ! subcomponent + 'GRIDDATA', & ! block + 'WETDRY', & ! tag name + 'WETDRY', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwf_npf_param_definitions(*) = & + [ & + gwfnpf_ipakcb, & + gwfnpf_iprflow, & + gwfnpf_cellavg, & + gwfnpf_ithickstrt, & + gwfnpf_cvoptions, & + gwfnpf_ivarcv, & + gwfnpf_idewatcv, & + gwfnpf_iperched, & + gwfnpf_rewet_record, & + gwfnpf_irewet, & + gwfnpf_wetfct, & + gwfnpf_iwetit, & + gwfnpf_ihdwet, & + gwfnpf_xt3doptions, & + gwfnpf_ixt3d, & + gwfnpf_ixt3drhs, & + gwfnpf_isavspdis, & + gwfnpf_isavsat, & + gwfnpf_ik22overk, & + gwfnpf_ik33overk, & + gwfnpf_tvk_filerecord, & + gwfnpf_tvk6, & + gwfnpf_filein, & + gwfnpf_tvk6_filename, & + gwfnpf_inewton, & + gwfnpf_iusgnrhc, & + gwfnpf_inwtupw, & + gwfnpf_satmin, & + gwfnpf_satomega, & + gwfnpf_icelltype, & + gwfnpf_k, & + gwfnpf_k22, & + gwfnpf_k33, & + gwfnpf_angle1, & + gwfnpf_angle2, & + gwfnpf_angle3, & + gwfnpf_wetdry & + ] + + type(InputParamDefinitionType), parameter :: & + gwf_npf_aggregate_definitions(*) = & + [ & + InputParamDefinitionType :: & + ] + + type(InputBlockDefinitionType), parameter :: & + gwf_npf_block_definitions(*) = & + [ & + InputBlockDefinitionType( & + 'OPTIONS', & ! blockname + .true., & ! required + .false. & ! aggregate + ), & + InputBlockDefinitionType( & + 'GRIDDATA', & ! blockname + .true., & ! required + .false. & ! aggregate + ) & + ] + +end module GwfNpfInputModule diff --git a/src/Model/GroundWaterTransport/gwt1dsp.f90 b/src/Model/GroundWaterTransport/gwt1dsp.f90 index 91d04f8ae41..3bff76ec9ec 100644 --- a/src/Model/GroundWaterTransport/gwt1dsp.f90 +++ b/src/Model/GroundWaterTransport/gwt1dsp.f90 @@ -26,6 +26,13 @@ module GwtDspModule real(DP), dimension(:), pointer, contiguous :: atv => null() ! transverse vertical dispersivity integer(I4B), pointer :: idiffc => null() ! flag indicating diffusion is active integer(I4B), pointer :: idisp => null() ! flag indicating mechanical dispersion is active + integer(I4B), pointer :: ialh => null() ! longitudinal horizontal dispersivity data flag + integer(I4B), pointer :: ialv => null() ! longitudinal vertical dispersivity data flag + integer(I4B), pointer :: iath1 => null() ! transverse horizontal dispersivity data flag + integer(I4B), pointer :: iath2 => null() ! transverse horizontal dispersivity data flag + integer(I4B), pointer :: iatv => null() ! transverse vertical dispersivity data flag + integer(I4B), pointer :: ixt3doff => null() ! xt3d off flag, xt3d is set inactive if 1 + integer(I4B), pointer :: ixt3drhs => null() ! xt3d rhs flag, xt3d rhs is set active if 1 integer(I4B), pointer :: ixt3d => null() ! flag indicating xt3d is active type(Xt3dType), pointer :: xt3d => null() ! xt3d object real(DP), dimension(:), pointer, contiguous :: dispcoef => null() ! disp coefficient (only if xt3d not active) @@ -53,8 +60,10 @@ module GwtDspModule procedure :: dsp_da procedure :: allocate_scalars procedure :: allocate_arrays - procedure, private :: read_options - procedure, private :: read_data + procedure, private :: source_options + procedure, private :: source_griddata + procedure, private :: log_options + procedure, private :: log_griddata procedure, private :: calcdispellipse procedure, private :: calcdispcoef @@ -69,12 +78,19 @@ subroutine dsp_cr(dspobj, name_model, inunit, iout, fmi) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ + ! -- modules + use IdmMf6FileLoaderModule, only: input_load + use ConstantsModule, only: LENPACKAGETYPE ! -- dummy type(GwtDspType), pointer :: dspobj character(len=*), intent(in) :: name_model integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout type(GwtFmiType), intent(in), target :: fmi + ! -- formats + character(len=*), parameter :: fmtdsp = & + "(1x,/1x,'DSP-- DISPERSION PACKAGE, VERSION 1, 1/24/2018', & + &' INPUT READ FROM UNIT ', i0, //)" ! ------------------------------------------------------------------------------ ! ! -- Create the object @@ -91,13 +107,30 @@ subroutine dsp_cr(dspobj, name_model, inunit, iout, fmi) dspobj%iout = iout dspobj%fmi => fmi ! + ! -- Check if input file is open + if (dspobj%inunit > 0) then + ! + ! -- Print a message identifying the dispersion package. + if (dspobj%iout > 0) then + write (dspobj%iout, fmtdsp) dspobj%inunit + end if + ! + ! -- Initialize block parser + call dspobj%parser%Initialize(dspobj%inunit, dspobj%iout) + ! + ! -- Use the input data model routines to load the input data + ! into memory + call input_load(dspobj%parser, 'DSP6', 'GWT', 'DSP', dspobj%name_model, & + 'DSP', [character(len=LENPACKAGETYPE) ::], iout) + end if + ! ! -- Return return end subroutine dsp_cr subroutine dsp_df(this, dis, dspOptions) ! ****************************************************************************** -! dsp_df -- Allocate and Read +! dsp_df -- Define ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -109,10 +142,6 @@ subroutine dsp_df(this, dis, dspOptions) type(GwtDspOptionsType), optional, intent(in) :: dspOptions !< the optional DSP options, used when not !! creating DSP from file ! -- local - ! -- formats - character(len=*), parameter :: fmtdsp = & - "(1x,/1x,'DSP-- DISPERSION PACKAGE, VERSION 1, 1/24/2018', & - &' INPUT READ FROM UNIT ', i0, //)" ! ------------------------------------------------------------------------------ ! ! -- Store pointer to dis @@ -130,18 +159,12 @@ subroutine dsp_df(this, dis, dspOptions) call this%allocate_arrays(this%dis%nodes) else ! - ! -- Print a message identifying the dispersion package. - if (this%iout > 0) then - write (this%iout, fmtdsp) this%inunit - end if - ! - ! -- Initialize block parser - call this%parser%Initialize(this%inunit, this%iout) - call this%read_options() + ! -- Source options + call this%source_options() call this%allocate_arrays(this%dis%nodes) ! - ! -- Read dispersion data - call this%read_data() + ! -- Source dispersion data + call this%source_griddata() end if ! ! -- xt3d create @@ -385,6 +408,13 @@ subroutine allocate_scalars(this) ! -- Allocate call mem_allocate(this%idiffc, 'IDIFFC', this%memoryPath) call mem_allocate(this%idisp, 'IDISP', this%memoryPath) + call mem_allocate(this%ialh, 'IALH', this%memoryPath) + call mem_allocate(this%ialv, 'IALV', this%memoryPath) + call mem_allocate(this%iath1, 'IATH1', this%memoryPath) + call mem_allocate(this%iath2, 'IATH2', this%memoryPath) + call mem_allocate(this%iatv, 'IATV', this%memoryPath) + call mem_allocate(this%ixt3doff, 'IXT3DOFF', this%memoryPath) + call mem_allocate(this%ixt3drhs, 'IXT3DRHS', this%memoryPath) call mem_allocate(this%ixt3d, 'IXT3D', this%memoryPath) call mem_allocate(this%id22, 'ID22', this%memoryPath) call mem_allocate(this%id33, 'ID33', this%memoryPath) @@ -395,6 +425,13 @@ subroutine allocate_scalars(this) ! -- Initialize this%idiffc = 0 this%idisp = 0 + this%ialh = 0 + this%ialv = 0 + this%iath1 = 0 + this%iath2 = 0 + this%iatv = 0 + this%ixt3doff = 0 + this%ixt3drhs = 0 this%ixt3d = 0 this%id22 = 1 this%id33 = 1 @@ -423,12 +460,12 @@ subroutine allocate_arrays(this, nodes) ! ------------------------------------------------------------------------------ ! ! -- Allocate - call mem_allocate(this%alh, 0, 'ALH', trim(this%memoryPath)) - call mem_allocate(this%alv, 0, 'ALV', trim(this%memoryPath)) - call mem_allocate(this%ath1, 0, 'ATH1', trim(this%memoryPath)) - call mem_allocate(this%ath2, 0, 'ATH2', trim(this%memoryPath)) - call mem_allocate(this%atv, 0, 'ATV', trim(this%memoryPath)) - call mem_allocate(this%diffc, 0, 'DIFFC', trim(this%memoryPath)) + call mem_allocate(this%alh, nodes, 'ALH', trim(this%memoryPath)) + call mem_allocate(this%alv, nodes, 'ALV', trim(this%memoryPath)) + call mem_allocate(this%ath1, nodes, 'ATH1', trim(this%memoryPath)) + call mem_allocate(this%ath2, nodes, 'ATH2', trim(this%memoryPath)) + call mem_allocate(this%atv, nodes, 'ATV', trim(this%memoryPath)) + call mem_allocate(this%diffc, nodes, 'DIFFC', trim(this%memoryPath)) call mem_allocate(this%d11, nodes, 'D11', trim(this%memoryPath)) call mem_allocate(this%d22, nodes, 'D22', trim(this%memoryPath)) call mem_allocate(this%d33, nodes, 'D33', trim(this%memoryPath)) @@ -457,10 +494,15 @@ subroutine dsp_da(this) ! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate + use MemoryManagerExtModule, only: memorylist_remove + use SimVariablesModule, only: idm_context ! -- dummy class(GwtDspType) :: this ! -- local ! ------------------------------------------------------------------------------ + ! + ! -- Deallocate input memory + call memorylist_remove(this%name_model, 'DSP', idm_context) ! ! -- deallocate arrays if (this%inunit /= 0) then @@ -486,6 +528,13 @@ subroutine dsp_da(this) ! -- deallocate scalars call mem_deallocate(this%idiffc) call mem_deallocate(this%idisp) + call mem_deallocate(this%ialh) + call mem_deallocate(this%ialv) + call mem_deallocate(this%iath1) + call mem_deallocate(this%iath2) + call mem_deallocate(this%iatv) + call mem_deallocate(this%ixt3doff) + call mem_deallocate(this%ixt3drhs) call mem_deallocate(this%ixt3d) call mem_deallocate(this%id22) call mem_deallocate(this%id33) @@ -500,207 +549,188 @@ subroutine dsp_da(this) return end subroutine dsp_da - subroutine read_options(this) + !> @brief Write user options to list file + !< + subroutine log_options(this, afound) + class(GwTDspType) :: this + logical, dimension(:), intent(in) :: afound + + write (this%iout, '(1x,a)') 'Setting DSP Options' + write (this%iout, '(4x,a,i0)') 'XT3D FORMULATION [0=INACTIVE, 1=ACTIVE, & + &3=ACTIVE RHS] SET TO: ', this%ixt3d + write (this%iout, '(1x,a,/)') 'End Setting DSP Options' + end subroutine log_options + + subroutine source_options(this) ! ****************************************************************************** -! read_options -- Allocate and Read +! source_options -- update simulation mempath options ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error + !use KindModule, only: LGP + use MemoryHelperModule, only: create_mem_path + use MemoryTypeModule, only: MemoryType + use MemoryManagerExtModule, only: mem_set_value + use SimVariablesModule, only: idm_context + use ConstantsModule, only: LENMEMPATH ! -- dummy class(GwtDspType) :: this - ! -- local - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock - ! -- formats + ! -- locals + character(len=LENMEMPATH) :: idmMemoryPath + logical, dimension(2) :: afound ! ------------------------------------------------------------------------------ ! - ! -- get options block - call this%parser%GetBlock('OPTIONS', isfound, ierr, blockRequired=.false., & - supportOpenClose=.true.) - ! - ! -- parse options block if detected - if (isfound) then - write (this%iout, '(1x,a)') 'PROCESSING DISPERSION OPTIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('XT3D_OFF') - this%ixt3d = 0 - write (this%iout, '(4x,a)') & - 'XT3D FORMULATION HAS BEEN SHUT OFF.' - case ('XT3D_RHS') - this%ixt3d = 2 - write (this%iout, '(4x,a)') & - 'XT3D RIGHT-HAND SIDE FORMULATION IS SELECTED.' - case default - write (errmsg, '(4x,a,a)') 'UNKNOWN DISPERSION OPTION: ', & - trim(keyword) - call store_error(errmsg, terminate=.TRUE.) - end select - end do - write (this%iout, '(1x,a)') 'END OF DISPERSION OPTIONS' + ! -- set memory path + idmMemoryPath = create_mem_path(this%name_model, 'DSP', idm_context) + ! + ! -- update defaults with idm sourced values + call mem_set_value(this%ixt3doff, 'XT3D_OFF', idmMemoryPath, afound(1)) + call mem_set_value(this%ixt3drhs, 'XT3D_RHS', idmMemoryPath, afound(2)) + ! + ! -- set xt3d state flag + if (afound(1)) this%ixt3d = 0 + if (afound(2)) this%ixt3d = 2 + ! + ! -- log options + if (this%iout > 0) then + call this%log_options(afound) end if ! ! -- Return return - end subroutine read_options + end subroutine source_options + + !> @brief Write dimensions to list file + !< + subroutine log_griddata(this, afound) + class(GwtDspType) :: this + logical, dimension(:), intent(in) :: afound - subroutine read_data(this) + write (this%iout, '(1x,a)') 'Setting DSP Griddata' + + if (afound(1)) then + write (this%iout, '(4x,a)') 'DIFFC set from input file' + end if + + if (afound(2)) then + write (this%iout, '(4x,a)') 'ALH set from input file' + end if + + if (afound(3)) then + write (this%iout, '(4x,a)') 'ALV set from input file' + end if + + if (afound(4)) then + write (this%iout, '(4x,a)') 'ATH1 set from input file' + end if + + if (afound(5)) then + write (this%iout, '(4x,a)') 'ATH2 set from input file' + end if + + if (afound(6)) then + write (this%iout, '(4x,a)') 'ATV set from input file' + end if + + write (this%iout, '(1x,a,/)') 'End Setting DSP Griddata' + + end subroutine log_griddata + + subroutine source_griddata(this) ! ****************************************************************************** -! read_data -- read the dispersion data +! source_griddata -- update dsp simulation data from input mempath ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error, count_errors - use MemoryManagerModule, only: mem_reallocate, mem_copyptr, mem_reassignptr + ! -- modules + use SimModule, only: count_errors, store_error + use MemoryHelperModule, only: create_mem_path + use MemoryManagerModule, only: mem_reallocate, mem_reassignptr + use MemoryManagerExtModule, only: mem_set_value + use SimVariablesModule, only: idm_context + use ConstantsModule, only: LENMEMPATH, LINELENGTH ! -- dummy class(GwtDsptype) :: this - ! -- local - character(len=LINELENGTH) :: errmsg, keyword - character(len=:), allocatable :: line - integer(I4B) :: istart, istop, lloc, ierr - logical :: isfound, endOfBlock - logical, dimension(6) :: lname - character(len=24), dimension(6) :: aname + ! -- locals + character(len=LENMEMPATH) :: idmMemoryPath + character(len=LINELENGTH) :: errmsg + logical, dimension(6) :: afound + integer(I4B), dimension(:), pointer, contiguous :: map + integer(I4B) :: idisp ! -- formats - ! -- data - data aname(1)/' DIFFUSION COEFFICIENT'/ - data aname(2)/' ALH'/ - data aname(3)/' ALV'/ - data aname(4)/' ATH1'/ - data aname(5)/' ATH2'/ - data aname(6)/' ATV'/ ! ------------------------------------------------------------------------------ ! - ! -- initialize - lname(:) = .false. - isfound = .false. - ! - ! -- get griddata block - call this%parser%GetBlock('GRIDDATA', isfound, ierr) - if (isfound) then - write (this%iout, '(1x,a)') 'PROCESSING GRIDDATA' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - call this%parser%GetRemainingLine(line) - lloc = 1 - select case (keyword) - case ('DIFFC') - call mem_reallocate(this%diffc, this%dis%nodes, 'DIFFC', & - trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%diffc, & - aname(1)) - lname(1) = .true. - case ('ALH') - call mem_reallocate(this%alh, this%dis%nodes, 'ALH', & - trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%alh, & - aname(2)) - lname(2) = .true. - case ('ALV') - call mem_reallocate(this%alv, this%dis%nodes, 'ALV', & - trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%alv, & - aname(3)) - lname(3) = .true. - case ('ATH1') - call mem_reallocate(this%ath1, this%dis%nodes, 'ATH1', & - trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%ath1, & - aname(4)) - lname(4) = .true. - case ('ATH2') - call mem_reallocate(this%ath2, this%dis%nodes, 'ATH2', & - trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%ath2, & - aname(5)) - lname(5) = .true. - case ('ATV') - call mem_reallocate(this%atv, this%dis%nodes, 'ATV', & - trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%atv, & - aname(6)) - lname(6) = .true. - case default - write (errmsg, '(4x,a,a)') 'Unknown GRIDDATA tag: ', trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - end select - end do - write (this%iout, '(1x,a)') 'END PROCESSING GRIDDATA' - else - write (errmsg, '(1x,a)') 'Required GRIDDATA block not found.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() + ! -- set memory path + idmMemoryPath = create_mem_path(this%name_model, 'DSP', idm_context) + ! + ! -- set map + map => null() + if (this%dis%nodes < this%dis%nodesuser) map => this%dis%nodeuser + ! + ! -- update defaults with idm sourced values + call mem_set_value(this%diffc, 'DIFFC', idmMemoryPath, map, afound(1)) + call mem_set_value(this%alh, 'ALH', idmMemoryPath, map, afound(2)) + call mem_set_value(this%alv, 'ALV', idmMemoryPath, map, afound(3)) + call mem_set_value(this%ath1, 'ATH1', idmMemoryPath, map, afound(4)) + call mem_set_value(this%ath2, 'ATH2', idmMemoryPath, map, afound(5)) + call mem_set_value(this%atv, 'ATV', idmMemoryPath, map, afound(6)) + ! + ! -- set active flags + if (afound(1)) this%idiffc = 1 + if (afound(2)) this%ialh = 1 + if (afound(3)) this%ialv = 1 + if (afound(4)) this%iath1 = 1 + if (afound(5)) this%iath2 = 1 + if (afound(6)) this%iatv = 1 + ! + ! -- reallocate diffc if not found + if (.not. afound(1)) then + call mem_reallocate(this%diffc, 0, 'DIFFC', trim(this%memoryPath)) end if ! - if (lname(1)) this%idiffc = 1 - if (lname(2)) this%idisp = this%idisp + 1 - if (lname(3)) this%idisp = this%idisp + 1 - if (lname(4)) this%idisp = this%idisp + 1 - if (lname(5)) this%idisp = this%idisp + 1 + ! -- set this%idisp flag + do idisp = 2, 5 ! ALH, ALV, ATH1, ATH2 + if (afound(idisp)) this%idisp = this%idisp + 1 + end do ! - ! -- if dispersivities are specified, then both alh and ath1 must be included + ! -- manage dispersion arrays if (this%idisp > 0) then - ! - ! -- make sure alh was specified - if (.not. lname(2)) then - write (errmsg, '(1x,a)') & - 'IF DISPERSIVITIES ARE SPECIFIED THEN ALH IS REQUIRED.' - call store_error(errmsg) - end if - ! - ! -- make sure ath1 was specified - if (.not. lname(4)) then + if (.not. (afound(2) .and. afound(4))) then write (errmsg, '(1x,a)') & - 'IF DISPERSIVITIES ARE SPECIFIED THEN ATH1 IS REQUIRED.' + 'IF DISPERSIVITIES ARE SPECIFIED THEN ALH AND ATH1 ARE REQUIRED.' call store_error(errmsg) end if - ! ! -- If alv not specified then point it to alh - if (.not. lname(3)) then + if (.not. afound(3)) & call mem_reassignptr(this%alv, 'ALV', trim(this%memoryPath), & 'ALH', trim(this%memoryPath)) - end if - ! - ! -- If ath2 not specified then assign it to ath1 - if (.not. lname(5)) then + ! -- If ath2 not specified then point it to ath1 + if (.not. afound(5)) & call mem_reassignptr(this%ath2, 'ATH2', trim(this%memoryPath), & 'ATH1', trim(this%memoryPath)) - end if - ! - ! -- If atv not specified then assign it to ath2 - if (.not. lname(6)) then + ! -- If atv not specified then point it to ath2 + if (.not. afound(6)) & call mem_reassignptr(this%atv, 'ATV', trim(this%memoryPath), & 'ATH2', trim(this%memoryPath)) - end if + 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)) end if ! - ! -- terminate if errors - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() + ! -- log griddata + if (this%iout > 0) then + call this%log_griddata(afound) end if ! ! -- Return return - end subroutine read_data + end subroutine source_griddata subroutine calcdispellipse(this) ! ****************************************************************************** diff --git a/src/Model/GroundWaterTransport/gwt1dspidm.f90 b/src/Model/GroundWaterTransport/gwt1dspidm.f90 new file mode 100644 index 00000000000..ac857c5dcae --- /dev/null +++ b/src/Model/GroundWaterTransport/gwt1dspidm.f90 @@ -0,0 +1,171 @@ +module GwtDspInputModule + use InputDefinitionModule, only: InputParamDefinitionType, & + InputBlockDefinitionType + private + public gwt_dsp_param_definitions + public gwt_dsp_aggregate_definitions + public gwt_dsp_block_definitions + + type(InputParamDefinitionType), parameter :: & + gwtdsp_xt3d_off = InputParamDefinitionType & + ( & + 'GWT', & ! component + 'DSP', & ! subcomponent + 'OPTIONS', & ! block + 'XT3D_OFF', & ! tag name + 'XT3D_OFF', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwtdsp_xt3d_rhs = InputParamDefinitionType & + ( & + 'GWT', & ! component + 'DSP', & ! subcomponent + 'OPTIONS', & ! block + 'XT3D_RHS', & ! tag name + 'XT3D_RHS', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwtdsp_diffc = InputParamDefinitionType & + ( & + 'GWT', & ! component + 'DSP', & ! subcomponent + 'GRIDDATA', & ! block + 'DIFFC', & ! tag name + 'DIFFC', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwtdsp_alh = InputParamDefinitionType & + ( & + 'GWT', & ! component + 'DSP', & ! subcomponent + 'GRIDDATA', & ! block + 'ALH', & ! tag name + 'ALH', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwtdsp_alv = InputParamDefinitionType & + ( & + 'GWT', & ! component + 'DSP', & ! subcomponent + 'GRIDDATA', & ! block + 'ALV', & ! tag name + 'ALV', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwtdsp_ath1 = InputParamDefinitionType & + ( & + 'GWT', & ! component + 'DSP', & ! subcomponent + 'GRIDDATA', & ! block + 'ATH1', & ! tag name + 'ATH1', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwtdsp_ath2 = InputParamDefinitionType & + ( & + 'GWT', & ! component + 'DSP', & ! subcomponent + 'GRIDDATA', & ! block + 'ATH2', & ! tag name + 'ATH2', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwtdsp_atv = InputParamDefinitionType & + ( & + 'GWT', & ! component + 'DSP', & ! subcomponent + 'GRIDDATA', & ! block + 'ATV', & ! tag name + 'ATV', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwt_dsp_param_definitions(*) = & + [ & + gwtdsp_xt3d_off, & + gwtdsp_xt3d_rhs, & + gwtdsp_diffc, & + gwtdsp_alh, & + gwtdsp_alv, & + gwtdsp_ath1, & + gwtdsp_ath2, & + gwtdsp_atv & + ] + + type(InputParamDefinitionType), parameter :: & + gwt_dsp_aggregate_definitions(*) = & + [ & + InputParamDefinitionType :: & + ] + + type(InputBlockDefinitionType), parameter :: & + gwt_dsp_block_definitions(*) = & + [ & + InputBlockDefinitionType( & + 'OPTIONS', & ! blockname + .false., & ! required + .false. & ! aggregate + ), & + InputBlockDefinitionType( & + 'GRIDDATA', & ! blockname + .false., & ! required + .false. & ! aggregate + ) & + ] + +end module GwtDspInputModule diff --git a/src/Model/ModelUtilities/Connections.f90 b/src/Model/ModelUtilities/Connections.f90 index 88159aa8a5d..de138daabcb 100644 --- a/src/Model/ModelUtilities/Connections.f90 +++ b/src/Model/ModelUtilities/Connections.f90 @@ -1320,7 +1320,7 @@ subroutine set_mask(this, ipos, maskval) return end subroutine set_mask - subroutine iac_to_ia(ia) + subroutine iac_to_ia(iac, ia) ! ****************************************************************************** ! iac_to_ia -- convert an iac array into an ia array ! ****************************************************************************** @@ -1328,15 +1328,21 @@ subroutine iac_to_ia(ia) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy + integer(I4B), dimension(:), contiguous, pointer, intent(in) :: iac integer(I4B), dimension(:), contiguous, intent(inout) :: ia ! -- local integer(I4B) :: n, nodes ! ------------------------------------------------------------------------------ ! ! -- Convert iac to ia - nodes = size(ia) - 1 - do n = 2, nodes + 1 - ia(n) = ia(n) + ia(n - 1) + nodes = size(iac) + ia(1) = iac(1) + do n = 2, size(ia) ! size(ia) == size(iac) + 1 + if (n < size(ia)) then + ia(n) = iac(n) + ia(n - 1) + else + ia(n) = ia(n) + ia(n - 1) + end if end do do n = nodes + 1, 2, -1 ia(n) = ia(n - 1) + 1 diff --git a/src/Model/ModelUtilities/DiscretizationBase.f90 b/src/Model/ModelUtilities/DiscretizationBase.f90 index 1422c30d041..c178a62caf0 100644 --- a/src/Model/ModelUtilities/DiscretizationBase.f90 +++ b/src/Model/ModelUtilities/DiscretizationBase.f90 @@ -33,7 +33,7 @@ module BaseDisModule integer(I4B), pointer :: lenuni => null() !< length unit integer(I4B), pointer :: ndim => null() !< number of spatial model dimensions (1 for disu grid) integer(I4B), pointer :: icondir => null() !< flag indicating if grid has enough info to calculate connection vectors - logical, pointer :: writegrb => null() !< write binary grid file + integer(I4B), pointer :: nogrb => null() !< don't write binary grid file real(DP), dimension(:), pointer, contiguous :: xc => null() !< x-coordinate of the cell center real(DP), dimension(:), pointer, contiguous :: yc => null() !< y-coordinate of the cell center real(DP), pointer :: yorigin => null() !< y-position of the lower-left grid corner (default is 0.) @@ -221,7 +221,7 @@ subroutine dis_ar(this, icelltype) end if end do ! - if (this%writegrb) call this%write_grb(ict) + if (this%nogrb == 0) call this%write_grb(ict) ! ! -- Return return @@ -272,7 +272,7 @@ subroutine dis_da(this) call mem_deallocate(this%nodesuser) call mem_deallocate(this%ndim) call mem_deallocate(this%icondir) - call mem_deallocate(this%writegrb) + call mem_deallocate(this%nogrb) call mem_deallocate(this%xorigin) call mem_deallocate(this%yorigin) call mem_deallocate(this%angrot) @@ -580,7 +580,7 @@ subroutine allocate_scalars(this, name_model) call mem_allocate(this%nodesuser, 'NODESUSER', this%memoryPath) call mem_allocate(this%ndim, 'NDIM', this%memoryPath) call mem_allocate(this%icondir, 'ICONDIR', this%memoryPath) - call mem_allocate(this%writegrb, 'WRITEGRB', this%memoryPath) + call mem_allocate(this%nogrb, 'NOGRB', this%memoryPath) call mem_allocate(this%xorigin, 'XORIGIN', this%memoryPath) call mem_allocate(this%yorigin, 'YORIGIN', this%memoryPath) call mem_allocate(this%angrot, 'ANGROT', this%memoryPath) @@ -596,7 +596,7 @@ subroutine allocate_scalars(this, name_model) this%nodesuser = 0 this%ndim = 1 this%icondir = 1 - this%writegrb = .true. + this%nogrb = 0 this%xorigin = DZERO this%yorigin = DZERO this%angrot = DZERO diff --git a/src/Utilities/Idm/IdmLogger.f90 b/src/Utilities/Idm/IdmLogger.f90 new file mode 100644 index 00000000000..aa7f1f83cca --- /dev/null +++ b/src/Utilities/Idm/IdmLogger.f90 @@ -0,0 +1,209 @@ +!> @brief This module contains the Input Data Model Logger Module +!! +!! This module contains the subroutines for logging messages +!! to the list file as the input data model loads model input. +!! +!< +module IdmLoggerModule + + use KindModule, only: DP, LGP, I4B + + implicit none + private + public :: idm_log_header + public :: idm_log_close + public :: idm_log_var + + interface idm_log_var + module procedure idm_log_var_logical, idm_log_var_int, & + idm_log_var_int1d, idm_log_var_int2d, & + idm_log_var_int3d, idm_log_var_dbl, & + idm_log_var_dbl1d, idm_log_var_dbl2d, & + idm_log_var_dbl3d + end interface idm_log_var + +contains + + !> @ brief log a header message + !< + subroutine idm_log_header(component, subcomponent, iout) + character(len=*), intent(in) :: component !< component name + character(len=*), intent(in) :: subcomponent !< subcomponent name + integer(I4B), intent(in) :: iout + + if (iout > 0) then + write (iout, '(1x,a)') 'Loading input for '//trim(component)//& + &'/'//trim(subcomponent) + end if + end subroutine idm_log_header + + !> @ brief log the closing message + !< + subroutine idm_log_close(component, subcomponent, iout) + character(len=*), intent(in) :: component !< component name + character(len=*), intent(in) :: subcomponent !< subcomponent name + integer(I4B) :: iout + + write (iout, '(1x,a,/)') 'Loading input complete...' + end subroutine idm_log_close + + !> @brief Log type specific information logical + !< + subroutine idm_log_var_logical(p_mem, varname, mempath, iout) + logical(LGP), intent(in) :: p_mem !< logical scalar + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: mempath !< variable memory path + integer(I4B) :: iout + + write (iout, '(3x,a, " = ", l)') trim(varname), p_mem + end subroutine idm_log_var_logical + + !> @brief Log type specific information integer + !< + subroutine idm_log_var_int(p_mem, varname, mempath, iout) + integer(I4B), intent(in) :: p_mem !< int scalar + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: mempath !< variable memory path + integer(I4B) :: iout + + write (iout, '(3x,a, " = ", i0)') trim(varname), p_mem + end subroutine idm_log_var_int + + !> @brief Log type specific information int1d + !< + subroutine idm_log_var_int1d(p_mem, varname, mempath, iout) + integer(I4B), dimension(:), contiguous, intent(in) :: p_mem !< 1d int array + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: mempath !< variable memory path + integer(I4B) :: iout + integer(I4B) :: min_val, max_val + + min_val = minval(p_mem) + max_val = maxval(p_mem) + if (min_val == max_val) then + write (iout, '(3x,a, " = ", i0)') trim(varname), min_val + else + write (iout, '(3x, a, a, i0, a, i0)') & + trim(varname), & + ' = variable 1D integer array ranging from ', & + min_val, ' to ', max_val + end if + end subroutine idm_log_var_int1d + + !> @brief Log type specific information int2d + !< + subroutine idm_log_var_int2d(p_mem, varname, mempath, iout) + integer(I4B), dimension(:, :), contiguous, intent(in) :: p_mem !< 2d int array + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: mempath !< variable memory path + integer(I4B) :: iout + integer(I4B) :: min_val, max_val + + min_val = minval(p_mem) + max_val = maxval(p_mem) + if (min_val == max_val) then + write (iout, '(3x,a, " = ", i0)') trim(varname), min_val + else + write (iout, '(3x, a, a, i0, a, i0)') & + trim(varname), & + ' = variable 2D integer array ranging from ', & + min_val, ' to ', max_val + end if + end subroutine idm_log_var_int2d + + !> @brief Log type specific information int3d + !< + subroutine idm_log_var_int3d(p_mem, varname, mempath, iout) + integer(I4B), dimension(:, :, :), contiguous, intent(in) :: p_mem !< 3d int array + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: mempath !< variable memory path + integer(I4B) :: iout + integer(I4B) :: min_val, max_val + + min_val = minval(p_mem) + max_val = maxval(p_mem) + if (min_val == max_val) then + write (iout, '(3x,a, " = ", i0)') trim(varname), min_val + else + write (iout, '(3x, a, a, i0, a, i0)') & + trim(varname), & + ' = variable 3D integer array ranging from ', & + min_val, ' to ', max_val + end if + end subroutine idm_log_var_int3d + + !> @brief Log type specific information double + !< + subroutine idm_log_var_dbl(p_mem, varname, mempath, iout) + real(DP), intent(in) :: p_mem !< dbl scalar + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: mempath !< variable memory path + integer(I4B) :: iout + + write (iout, '(3x,a, " = ", G0)') trim(varname), p_mem + end subroutine idm_log_var_dbl + + !> @brief Log type specific information dbl1d + !< + subroutine idm_log_var_dbl1d(p_mem, varname, mempath, iout) + real(DP), dimension(:), contiguous, intent(in) :: p_mem !< 1d real array + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: mempath !< variable memory path + integer(I4B) :: iout + real(DP) :: min_val, max_val + + min_val = minval(p_mem) + max_val = maxval(p_mem) + if (min_val == max_val) then + write (iout, '(3x,a, " = ", G0)') trim(varname), min_val + else + write (iout, '(3x, a, a, G0, a, G0)') & + trim(varname), & + ' = variable 1D double precision array ranging from ', & + min_val, ' to ', max_val + end if + end subroutine idm_log_var_dbl1d + + !> @brief Log type specific information dbl2d + !< + subroutine idm_log_var_dbl2d(p_mem, varname, mempath, iout) + real(DP), dimension(:, :), contiguous, intent(in) :: p_mem !< 2d dbl array + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: mempath !< variable memory path + integer(I4B) :: iout + real(DP) :: min_val, max_val + + min_val = minval(p_mem) + max_val = maxval(p_mem) + if (min_val == max_val) then + write (iout, '(3x,a, " = ", G0)') trim(varname), min_val + else + write (iout, '(3x, a, a, G0, a, G0)') & + trim(varname), & + ' = variable 2D double precision array ranging from ', & + min_val, ' to ', max_val + end if + end subroutine idm_log_var_dbl2d + + !> @brief Log type specific information dbl3d + !< + subroutine idm_log_var_dbl3d(p_mem, varname, mempath, iout) + real(DP), dimension(:, :, :), contiguous, intent(in) :: p_mem !< 3d dbl array + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: mempath !< variable memory path + integer(I4B) :: iout + real(DP) :: min_val, max_val + + min_val = minval(p_mem) + max_val = maxval(p_mem) + if (min_val == max_val) then + write (iout, '(3x,a, " = ", G0)') trim(varname), min_val + else + write (iout, '(3x, a, a, G0, a, G0)') & + trim(varname), & + ' = variable 3D double precision array ranging from ', & + min_val, ' to ', max_val + end if + end subroutine idm_log_var_dbl3d + +end module IdmLoggerModule diff --git a/src/Utilities/Idm/IdmMf6FileLoader.f90 b/src/Utilities/Idm/IdmMf6FileLoader.f90 new file mode 100644 index 00000000000..dba8ef7ae0f --- /dev/null +++ b/src/Utilities/Idm/IdmMf6FileLoader.f90 @@ -0,0 +1,92 @@ +!> @brief This module contains the IdmMf6FileLoaderModule +!! +!! This module contains the high-level routines for loading +!! a MODFLOW input file into the __INPUT__ memory manager +!! space. +!! +!< +module IdmMf6FileLoaderModule + + use KindModule, only: DP, I4B, LGP + use BlockParserModule, only: BlockParserType + use ModflowInputModule, only: ModflowInputType, getModflowInput + + implicit none + private + public :: input_load + + !> @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 !< ModflowInputType object that describes the input + integer(I4B), intent(in) :: iout !< unit number for output + end subroutine IPackageLoad + end interface + +contains + + !> @brief generic procedure to MODFLOW 6 load routine + !< + subroutine generic_mf6_load(parser, mf6_input, iout) + use LoadMf6FileTypeModule, only: idm_load + type(BlockParserType), intent(inout) :: parser !< block parser + type(ModflowInputType), intent(in) :: mf6_input !< ModflowInputType object that describes the input + integer(I4B), intent(in) :: iout !< unit number for output + + call idm_load(parser, mf6_input%file_type, & + mf6_input%component_type, mf6_input%subcomponent_type, & + mf6_input%component_name, mf6_input%subcomponent_name, & + mf6_input%subpackages, iout) + + end subroutine generic_mf6_load + + !> @brief main entry to mf6 input load + !< + subroutine input_load(parser, filetype, & + component_type, subcomponent_type, & + component_name, subcomponent_name, & + subpackages, iout) + type(BlockParserType), intent(inout) :: parser !< block parser + character(len=*), intent(in) :: filetype !< file type to load, such as DIS6, DISV6, NPF6 + character(len=*), intent(in) :: component_type !< component type, such as GWF or GWT + character(len=*), intent(in) :: subcomponent_type !< subcomponent type, such as DIS or NPF + character(len=*), intent(in) :: component_name !< component name, such as MYGWFMODEL + character(len=*), intent(in) :: subcomponent_name !< subcomponent name, such as MYWELLPACKAGE + character(len=*), dimension(:), intent(in) :: subpackages !< array of subpackage types, such as ["TVK6", "OBS6"] + integer(I4B), intent(in) :: iout !< unit number for output + type(ModflowInputType) :: mf6_input + type(PackageLoad) :: pkgloader + + mf6_input = getModflowInput(filetype, component_type, & + subcomponent_type, component_name, & + subcomponent_name, subpackages) + ! + ! -- set mf6 parser based package loader by file type + select case (filetype) + case default + pkgloader%load_package => generic_mf6_load + end select + ! + ! -- invoke the selected load routine + call pkgloader%load_package(parser, mf6_input, iout) + ! + ! -- release allocated memory + call mf6_input%destroy() + end subroutine input_load + +end module IdmMf6FileLoaderModule diff --git a/src/Utilities/Idm/InputDefinition.f90 b/src/Utilities/Idm/InputDefinition.f90 new file mode 100644 index 00000000000..01b67416734 --- /dev/null +++ b/src/Utilities/Idm/InputDefinition.f90 @@ -0,0 +1,48 @@ +!> @brief This module contains the InputDefinitionModule +!! +!! This module contains helper objects for storing +!! information about how to read modflow input files. +!! +!< +module InputDefinitionModule + + use KindModule, only: LGP + + implicit none + private + public :: InputParamDefinitionType, & + InputBlockDefinitionType + + !> @brief derived type for storing input definition + !! + !! This derived 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=100) :: mf6varname = '' + character(len=100) :: datatype = '' + character(len=100) :: shape = '' + logical(LGP) :: required = .false. + logical(LGP) :: in_record = .false. + logical(LGP) :: preserve_case = .false. + logical(LGP) :: layered = .false. + end type InputParamDefinitionType + + !> @brief derived type for storing block information + !! + !! This derived 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. + end type InputBlockDefinitionType + +end module InputDefinitionModule diff --git a/src/Utilities/Idm/InputDefinitionSelector.f90 b/src/Utilities/Idm/InputDefinitionSelector.f90 new file mode 100644 index 00000000000..17e030858b2 --- /dev/null +++ b/src/Utilities/Idm/InputDefinitionSelector.f90 @@ -0,0 +1,196 @@ +!> @brief This module contains the InputDefinitionSelectorModule +!! +!! This module contains the routines for getting parameter +!! definitions, aggregate definitions, and block definitions +!! for the different package types. +!! +!< +module InputDefinitionSelectorModule + + use KindModule, only: I4B + use SimVariablesModule, only: errmsg, warnmsg + use SimModule, only: store_error, store_warning + use InputDefinitionModule, only: InputParamDefinitionType, & + InputBlockDefinitionType + use GwfDisInputModule, only: gwf_dis_param_definitions, & + gwf_dis_aggregate_definitions, & + gwf_dis_block_definitions + use GwfDisuInputModule, only: gwf_disu_param_definitions, & + gwf_disu_aggregate_definitions, & + gwf_disu_block_definitions + use GwfDisvInputModule, only: gwf_disv_param_definitions, & + gwf_disv_aggregate_definitions, & + gwf_disv_block_definitions + use GwfNpfInputModule, only: gwf_npf_param_definitions, & + gwf_npf_aggregate_definitions, & + gwf_npf_block_definitions + use GwtDspInputModule, only: gwt_dsp_param_definitions, & + gwt_dsp_aggregate_definitions, & + gwt_dsp_block_definitions + + implicit none + private + public :: block_definitions + public :: aggregate_definitions + public :: param_definitions + public :: get_param_definition_type + public :: get_aggregate_definition_type + +contains + + !> @brief Return the parameter definition for the specified component + !< + function param_definitions(component) result(input_definition) + character(len=*), intent(in) :: component !< component type, such as GWF/DIS + type(InputParamDefinitionType), dimension(:), pointer :: input_definition !< InputParamDefinitionType for specified component + + select case (component) + case ('GWF/DIS') + call set_pointer(input_definition, gwf_dis_param_definitions) + case ('GWF/DISU') + call set_pointer(input_definition, gwf_disu_param_definitions) + case ('GWF/DISV') + call set_pointer(input_definition, gwf_disv_param_definitions) + case ('GWF/NPF') + call set_pointer(input_definition, gwf_npf_param_definitions) + case ('GWT/DSP') + call set_pointer(input_definition, gwt_dsp_param_definitions) + case default + write (warnmsg, '(a,a)') 'IDM Unsupported input type: ', trim(component) + call store_warning(warnmsg) + end select + + return + end function param_definitions + + !> @brief Return the aggregate definition for the specified component + !< + function aggregate_definitions(component) result(input_definition) + character(len=*), intent(in) :: component !< component type, such as GWF/DIS + type(InputParamDefinitionType), dimension(:), pointer :: input_definition !< InputParamDefinitionType for specified component + + select case (component) + case ('GWF/DIS') + call set_pointer(input_definition, gwf_dis_aggregate_definitions) + case ('GWF/DISU') + call set_pointer(input_definition, gwf_disu_aggregate_definitions) + case ('GWF/DISV') + call set_pointer(input_definition, gwf_disv_aggregate_definitions) + case ('GWF/NPF') + call set_pointer(input_definition, gwf_npf_aggregate_definitions) + case ('GWT/DSP') + call set_pointer(input_definition, gwt_dsp_aggregate_definitions) + case default + write (warnmsg, '(a,a)') 'IDM Unsupported input type: ', trim(component) + call store_warning(warnmsg) + end select + + return + end function aggregate_definitions + + !> @brief Return the block definition for the specified component + !< + function block_definitions(component) result(input_definition) + character(len=*), intent(in) :: component !< component type, such as GWF/DIS + type(InputBlockDefinitionType), dimension(:), pointer :: input_definition !< InputParamDefinitionType for specified component + + select case (component) + case ('GWF/DIS') + call set_block_pointer(input_definition, gwf_dis_block_definitions) + case ('GWF/DISU') + call set_block_pointer(input_definition, gwf_disu_block_definitions) + case ('GWF/DISV') + call set_block_pointer(input_definition, gwf_disv_block_definitions) + case ('GWF/NPF') + call set_block_pointer(input_definition, gwf_npf_block_definitions) + case ('GWT/DSP') + call set_block_pointer(input_definition, gwt_dsp_block_definitions) + case default + write (warnmsg, '(a,a)') 'IDM Unsupported input type: ', trim(component) + call store_warning(warnmsg) + end select + + return + end function block_definitions + + !> @brief Set pointer from input_definition to input_definition_target + !< + subroutine set_pointer(input_definition, input_definition_target) + type(InputParamDefinitionType), dimension(:), pointer :: input_definition !< InputParamDefinitionType source + type(InputParamDefinitionType), dimension(:), target :: & + input_definition_target !< InputParamDefinitionType target + input_definition => input_definition_target + end subroutine set_pointer + + !> @brief Set pointer from input_definition to input_definition_target + !< + subroutine set_block_pointer(input_definition, input_definition_target) + type(InputBlockDefinitionType), dimension(:), pointer :: input_definition !< InputParamDefinitionType source + type(InputBlockDefinitionType), dimension(:), target :: & + input_definition_target !< InputParamDefinitionType target + input_definition => input_definition_target + end subroutine set_block_pointer + + !> @brief Return parameter definition + !< + function get_param_definition_type(input_definition_types, component_type, & + subcomponent_type, tagname) result(idt) + type(InputParamDefinitionType), dimension(:), intent(in), target :: & + input_definition_types + character(len=*), intent(in) :: component_type !< component type, such as GWF or GWT + character(len=*), intent(in) :: subcomponent_type !< subcomponent type, such as DIS or NPF + character(len=*), intent(in) :: tagname !< name of the input tag + type(InputParamDefinitionType), pointer :: idt !< corresponding InputParameterDefinitionType for this tag + type(InputParamDefinitionType), pointer :: tmp_ptr + integer(I4B) :: i + + idt => null() + do i = 1, size(input_definition_types) + tmp_ptr => input_definition_types(i) + if (tmp_ptr%component_type == component_type .and. & + tmp_ptr%subcomponent_type == subcomponent_type .and. & + tmp_ptr%tagname == tagname) then + idt => input_definition_types(i) + exit + end if + end do + + if (.not. associated(idt)) then + write (errmsg, '(4x,a,a)') 'parameter definition not found: ', trim(tagname) + call store_error(errmsg) + end if + + end function get_param_definition_type + + !> @brief Return aggregate definition + !< + function get_aggregate_definition_type(input_definition_types, component_type, & + subcomponent_type, blockname) result(idt) + type(InputParamDefinitionType), dimension(:), intent(in), target :: & + input_definition_types + character(len=*), intent(in) :: component_type !< component type, such as GWF or GWT + character(len=*), intent(in) :: subcomponent_type !< subcomponent type, such as DIS or NPF + character(len=*), intent(in) :: blockname !< name of the block + type(InputParamDefinitionType), pointer :: idt !< corresponding InputParameterDefinitionType for this block + type(InputParamDefinitionType), pointer :: tmp_ptr + integer(I4B) :: i + + idt => null() + do i = 1, size(input_definition_types) + tmp_ptr => input_definition_types(i) + if (tmp_ptr%component_type == component_type .and. & + tmp_ptr%subcomponent_type == subcomponent_type .and. & + tmp_ptr%blockname == blockname) then + idt => input_definition_types(i) + exit + end if + end do + + if (.not. associated(idt)) then + write (errmsg, '(4x,a,a)') 'aggregate definition not found: ', & + trim(blockname) + call store_error(errmsg) + end if + end function get_aggregate_definition_type + +end module InputDefinitionSelectorModule diff --git a/src/Utilities/Idm/LoadMf6FileType.f90 b/src/Utilities/Idm/LoadMf6FileType.f90 new file mode 100644 index 00000000000..dd7080482b0 --- /dev/null +++ b/src/Utilities/Idm/LoadMf6FileType.f90 @@ -0,0 +1,704 @@ +!> @brief This module contains the LoadMf6FileTypeModule +!! +!! This module contains the input data model routines for +!! loading the data from a MODFLOW 6 input file using the +!! block parser. +!! +!< +module LoadMf6FileTypeModule + + use KindModule, only: DP, I4B, LGP + use ConstantsModule, only: LINELENGTH, LENMEMPATH + use SimVariablesModule, only: errmsg + use SimModule, only: store_error + use BlockParserModule, only: BlockParserType + use ArrayReadersModule, only: ReadArray + use InputOutputModule, only: parseline + use InputDefinitionModule, only: InputParamDefinitionType + use InputDefinitionSelectorModule, only: get_param_definition_type, & + get_aggregate_definition_type + use ModflowInputModule, only: ModflowInputType, getModflowInput + use MemoryManagerModule, only: mem_allocate, mem_setptr + use MemoryHelperModule, only: create_mem_path + use IdmLoggerModule, only: idm_log_var, idm_log_header, idm_log_close + + implicit none + private + public :: idm_load + + interface idm_load + module procedure idm_load_from_blockparser + end interface idm_load + +contains + + !> @brief procedure to load a file + !! + !! Use parser to load information from an input file into the __INPUT__ + !! memory context location of the memory manager. + !! + !< + subroutine idm_load_from_blockparser(parser, filetype, & + component_type, subcomponent_type, & + component_name, subcomponent_name, & + subpackages, iout) + use SimVariablesModule, only: idm_context + type(BlockParserType), intent(inout) :: parser !< block parser + character(len=*), intent(in) :: filetype !< file type to load, such as DIS6, DISV6, NPF6 + character(len=*), intent(in) :: component_type !< component type, such as GWF or GWT + character(len=*), intent(in) :: subcomponent_type !< subcomponent type, such as DIS or NPF + character(len=*), intent(in) :: component_name !< component name, such as MYGWFMODEL + character(len=*), intent(in) :: subcomponent_name !< subcomponent name, such as MYWELLPACKAGE + character(len=*), dimension(:), intent(in) :: subpackages !< array of subpackage types, such as ["TVK6", "OBS6"] + integer(I4B), intent(in) :: iout !< unit number for output + integer(I4B) :: iblock !< consecutive block number as defined in definition file + type(ModflowInputType) :: mf6_input !< ModflowInputType + character(len=LENMEMPATH) :: componentMemPath + integer(I4B), dimension(:), contiguous, pointer :: mshape => null() + ! + ! -- construct input object + mf6_input = getModflowInput(filetype, component_type, & + subcomponent_type, component_name, & + subcomponent_name, subpackages) + ! + ! -- model shape memory path + componentMemPath = create_mem_path(component=mf6_input%component_name, & + context=idm_context) + ! + ! -- log lst file header + call idm_log_header(mf6_input%component_name, & + mf6_input%subcomponent_name, iout) + ! + ! -- process blocks + do iblock = 1, size(mf6_input%p_block_dfns) + call parse_block(parser, mf6_input, iblock, mshape, iout) + ! + ! -- set model shape if discretion dimensions have been read + if (mf6_input%p_block_dfns(iblock)%blockname == 'DIMENSIONS' .and. & + filetype(1:3) == 'DIS') then + call set_model_shape(mf6_input%file_type, componentMemPath, & + mf6_input%memoryPath, mshape) + end if + end do + ! + ! -- close logging statement + call idm_log_close(mf6_input%component_name, & + mf6_input%subcomponent_name, iout) + ! + ! -- release allocated memory + call mf6_input%destroy() + end subroutine idm_load_from_blockparser + + !> @brief procedure to load a block + !! + !! Use parser to load information from a block into the __INPUT__ + !! memory context location of the memory manager. + !! + !< + subroutine parse_block(parser, mf6_input, iblock, mshape, iout) + 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 + integer(I4B), intent(in) :: iout !< unit number for output + logical(LGP) :: isblockfound + logical(LGP) :: endOfBlock + logical(LGP) :: supportOpenClose + integer(I4B) :: ierr + logical(LGP) :: found + type(MemoryType), pointer :: mt + ! + ! -- disu vertices/cell2d blocks are contingent on NVERT dimension + if (mf6_input%file_type == 'DISU6' .and. & + (mf6_input%p_block_dfns(iblock)%blockname == 'VERTICES' .or. & + mf6_input%p_block_dfns(iblock)%blockname == 'CELL2D')) then + call get_from_memorylist('NVERT', mf6_input%memoryPath, mt, found, .false.) + if (.not. found .or. mt%intsclr == 0) return + end if + ! + ! -- block open/close support + supportOpenClose = (mf6_input%p_block_dfns(iblock)%blockname /= 'GRIDDATA') + ! + ! -- parser search for block + call parser%GetBlock(mf6_input%p_block_dfns(iblock)%blockname, isblockfound, & + ierr, supportOpenClose=supportOpenClose, & + blockRequired=mf6_input%p_block_dfns(iblock)%required) + ! + ! -- process block + if (isblockfound) then + if (mf6_input%p_block_dfns(iblock)%aggregate) then + ! + ! -- process block recarray type, set of variable 1d/2d types + call parse_structarray_block(parser, mf6_input, iblock, mshape, iout) + else + do + ! process each line in block + call parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + ! + ! -- process line as tag(s) + call parse_tag(parser, mf6_input, iblock, mshape, iout, .false.) + end do + end if + end if + + return + end subroutine parse_block + + !> @brief check subpackage + !! + !! Check and make sure that the subpackage is valid for + !! this input file and load the filename of the subpackage + !! into the memory manager. + !! + !< + subroutine subpackage_check(parser, mf6_input, checktag, iout) + type(BlockParserType), intent(inout) :: parser !< block parser + type(ModflowInputType), intent(in) :: mf6_input !< ModflowInputType + character(len=LINELENGTH), intent(in) :: checktag !< subpackage string, such as TVK6 + integer(I4B), intent(in) :: iout !< unit number for output + character(len=LINELENGTH) :: tag, fname_tag + type(InputParamDefinitionType), pointer :: idt !< input data type object describing this record + integer(I4B) :: isubpkg + + do isubpkg = 1, size(mf6_input%subpackages) + if (checktag == mf6_input%subpackages(isubpkg)) then + fname_tag = trim(checktag)//'_FILENAME' + call parser%GetStringCaps(tag) + if (tag == 'FILEIN') then + idt => get_param_definition_type(mf6_input%p_param_dfns, & + mf6_input%component_type, & + mf6_input%subcomponent_type, & + fname_tag) + call load_string_type(parser, idt, mf6_input%memoryPath, iout) + else + errmsg = 'Subpackage keyword must be followed by "FILEIN" '// & + 'then by filename.' + call store_error(errmsg) + end if + end if + end do + end subroutine subpackage_check + + !> @brief load an individual input record into memory + !! + !! Load an individual input record into the memory + !! manager. Allow for recursive calls in the case that multiple + !! tags are on a single line. + !! + !< + recursive subroutine parse_tag(parser, mf6_input, iblock, mshape, 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 + integer(I4B), intent(in) :: iout !< unit number for output + logical(LGP), intent(in) :: recursive_call !< true if recursive call + character(len=LINELENGTH) :: tag + type(InputParamDefinitionType), pointer :: idt !< input data type object describing this record + ! + ! -- read tag name + call parser%GetStringCaps(tag) + if (recursive_call) then + if (tag == '') then + ! no data on line so return + return + end if + end if + ! + ! -- find keyword in input definition + idt => get_param_definition_type(mf6_input%p_param_dfns, & + mf6_input%component_type, & + mf6_input%subcomponent_type, & + tag) + ! + ! -- allocate and load data type + select case (idt%datatype) + case ('KEYWORD') + call load_keyword_type(parser, idt, mf6_input%memoryPath, iout) + ! + ! -- load filename if subpackage tag + call subpackage_check(parser, mf6_input, tag, iout) + ! + ! -- set as dev option + if (mf6_input%p_block_dfns(iblock)%blockname == 'OPTIONS' .and. & + idt%tagname(1:4) == 'DEV_') then + call parser%DevOpt() + end if + case ('STRING') + call load_string_type(parser, idt, mf6_input%memoryPath, iout) + case ('INTEGER') + call load_integer_type(parser, idt, mf6_input%memoryPath, iout) + case ('INTEGER1D') + call load_integer1d_type(parser, idt, mf6_input%memoryPath, mshape, iout) + case ('INTEGER3D') + call load_integer3d_type(parser, idt, mf6_input%memoryPath, mshape, iout) + case ('DOUBLE') + call load_double_type(parser, idt, mf6_input%memoryPath, iout) + case ('DOUBLE1D') + call load_double1d_type(parser, idt, mf6_input%memoryPath, mshape, iout) + case ('DOUBLE2D') + call load_double2d_type(parser, idt, mf6_input%memoryPath, mshape, iout) + case ('DOUBLE3D') + call load_double3d_type(parser, idt, mf6_input%memoryPath, mshape, iout) + case default + write (errmsg, '(4x,a,a)') 'Failure reading data for tag: ', trim(tag) + call store_error(errmsg) + call 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, iout, .true.) + end if + ! + ! -- + return + end subroutine parse_tag + + !> @brief parse a structured array record into memory manager + !! + !! A structarray is similar to a numpy recarray. It it used to + !! load a list of data in which each column in the list may be a + !! different type. Each column in the list is stored as a 1d + !! vector. + !! + !< + subroutine parse_structarray_block(parser, mf6_input, iblock, mshape, 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 + integer(I4B), intent(in) :: iout !< unit number for output + type(InputParamDefinitionType), pointer :: idt !< input data type object describing this record + integer(I4B), pointer :: nrow + 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%p_aggregate_dfns, & + mf6_input%component_type, & + mf6_input%subcomponent_type, & + mf6_input%p_block_dfns(iblock)%blockname) + ! + ! -- identify variable names, ignore first RECARRAY column + parse_str = trim(idt%datatype)//' ' + call parseline(parse_str, nwords, words) + ncol = nwords - 1 + ! + ! -- use shape to set the max num of rows + call mem_setptr(nrow, idt%shape, mf6_input%memoryPath) + ! + ! -- create a structured array + struct_array => constructStructArray(ncol, nrow) + do icol = 1, ncol + ! + ! -- set pointer to input definition for this 1d vector + idt => get_param_definition_type(mf6_input%p_param_dfns, & + mf6_input%component_type, & + mf6_input%subcomponent_type, & + words(icol + 1)) + ! + ! -- allocate variable in memory manager + call struct_array%mem_create_vector(icol, idt%datatype, idt%mf6varname, & + mf6_input%memoryPath, idt%shape, & + idt%preserve_case) + end do + ! + ! -- read the structured array + call struct_array%read_from_parser(parser, iout) + call parser%terminateblock() + ! + ! -- destroy the structured array reader + call destructStructArray(struct_array) + ! + ! -- + return + end subroutine parse_structarray_block + + !> @brief load type keyword + !< + subroutine load_keyword_type(parser, idt, memoryPath, iout) + type(BlockParserType), intent(inout) :: parser !< block parser + type(InputParamDefinitionType), intent(in) :: idt !< input data type object describing this record + character(len=*), intent(in) :: memoryPath !< memorypath to put loaded information + integer(I4B), intent(in) :: iout !< unit number for output + integer(I4B), pointer :: intvar + call mem_allocate(intvar, idt%mf6varname, memoryPath) + intvar = 1 + call idm_log_var(intvar, idt%mf6varname, memoryPath, iout) + return + end subroutine load_keyword_type + + !> @brief load type string + !< + subroutine load_string_type(parser, idt, memoryPath, iout) + type(BlockParserType), intent(inout) :: parser !< block parser + type(InputParamDefinitionType), intent(in) :: idt !< input data type object describing this record + character(len=*), intent(in) :: memoryPath !< memorypath to put loaded information + integer(I4B), intent(in) :: iout !< unit number for output + character(len=LINELENGTH), pointer :: cstr + integer(I4B) :: ilen + ilen = LINELENGTH + call mem_allocate(cstr, ilen, idt%mf6varname, memoryPath) + call parser%GetString(cstr, (.not. idt%preserve_case)) + return + end subroutine load_string_type + + !> @brief load type integer + !< + subroutine load_integer_type(parser, idt, memoryPath, iout) + type(BlockParserType), intent(inout) :: parser !< block parser + type(InputParamDefinitionType), intent(in) :: idt !< input data type object describing this record + character(len=*), intent(in) :: memoryPath !< memorypath to put loaded information + integer(I4B), intent(in) :: iout !< unit number for output + integer(I4B), pointer :: intvar + call mem_allocate(intvar, idt%mf6varname, memoryPath) + intvar = parser%GetInteger() + call idm_log_var(intvar, idt%mf6varname, memoryPath, iout) + return + end subroutine load_integer_type + + !> @brief load type 1d integer + !< + subroutine load_integer1d_type(parser, idt, memoryPath, mshape, iout) + type(BlockParserType), intent(inout) :: parser !< block parser + type(InputParamDefinitionType), intent(in) :: idt !< input data type object describing this record + character(len=*), intent(in) :: memoryPath !< memorypath to put loaded information + integer(I4B), dimension(:), contiguous, pointer, intent(in) :: mshape !< model shape + integer(I4B), intent(in) :: iout !< unit number for output + integer(I4B), dimension(:), pointer, contiguous :: int1d + integer(I4B), pointer :: nsize1 + integer(I4B) :: nvals + + if (idt%shape == 'NODES') then + nvals = product(mshape) + call mem_allocate(int1d, nvals, idt%mf6varname, memoryPath) + else + call mem_setptr(nsize1, idt%shape, memoryPath) + call mem_allocate(int1d, nsize1, idt%mf6varname, memoryPath) + end if + + call read_grid_array(parser, mshape, idt%tagname, idt%layered, intarray=int1d) + + call idm_log_var(int1d, idt%mf6varname, memoryPath, iout) + return + end subroutine load_integer1d_type + + !> @brief load type 3d integer + !< + subroutine load_integer3d_type(parser, idt, memoryPath, mshape, iout) + type(BlockParserType), intent(inout) :: parser !< block parser + type(InputParamDefinitionType), intent(in) :: idt !< input data type object describing this record + character(len=*), intent(in) :: memoryPath !< memorypath to put loaded information + integer(I4B), dimension(:), contiguous, pointer, intent(in) :: mshape !< model shape + integer(I4B), intent(in) :: iout !< unit number for output + integer(I4B), dimension(:, :, :), pointer, contiguous :: int3d + integer(I4B) :: ndim + integer(I4B) :: nsize1, nsize2, nsize3 + character(len=LINELENGTH) :: keyword + + ndim = size(mshape) + + ! set sizes + if (ndim == 2) then + nsize1 = mshape(2) ! NCPL + nsize2 = 1 + nsize3 = mshape(1) + elseif (ndim == 3) then + nsize1 = mshape(3) ! NCOL + nsize2 = mshape(2) ! NROW + nsize3 = mshape(1) ! NLAY + end if + + ! allocate the array using the memory manager + call mem_allocate(int3d, nsize1, nsize2, nsize3, idt%mf6varname, memoryPath) + + ! fill the array from the file + if (idt%blockname == 'GRIDDATA') then + call parser%GetStringCaps(keyword) + if (keyword == 'LAYERED') then + ! read by layer + call ReadArray(parser%iuactive, int3d(:, :, :), & + idt%mf6varname, ndim, nsize1, nsize2, & + nsize3, iout, 1, nsize3) + else + ! read full 3d array + call ReadArray(parser%iuactive, int3d(:, :, :), idt%mf6varname, & + ndim, nsize1 * nsize2 * nsize3, iout) + end if + else + ! read full 3d array + call ReadArray(parser%iuactive, int3d(:, :, :), idt%mf6varname, & + ndim, nsize1 * nsize2 * nsize3, iout) + end if + + call idm_log_var(int3d, idt%mf6varname, memoryPath, iout) + return + end subroutine load_integer3d_type + + !> @brief load type double + !< + subroutine load_double_type(parser, idt, memoryPath, iout) + type(BlockParserType), intent(inout) :: parser !< block parser + type(InputParamDefinitionType), intent(in) :: idt !< input data type object describing this record + character(len=*), intent(in) :: memoryPath !< memorypath to put loaded information + integer(I4B), intent(in) :: iout !< unit number for output + real(DP), pointer :: dblvar + call mem_allocate(dblvar, idt%mf6varname, memoryPath) + dblvar = parser%GetDouble() + call idm_log_var(dblvar, idt%mf6varname, memoryPath, iout) + return + end subroutine load_double_type + + !> @brief load type 1d double + !< + subroutine load_double1d_type(parser, idt, memoryPath, mshape, iout) + type(BlockParserType), intent(inout) :: parser !< block parser + type(InputParamDefinitionType), intent(in) :: idt !< input data type object describing this record + character(len=*), intent(in) :: memoryPath !< memorypath to put loaded information + integer(I4B), dimension(:), contiguous, pointer, intent(in) :: mshape !< model shape + integer(I4B), intent(in) :: iout !< unit number for output + real(DP), dimension(:), pointer, contiguous :: dbl1d + integer(I4B), pointer :: nsize1 + integer(I4B) :: nvals + + if (idt%shape == 'NODES') then + nvals = product(mshape) + call mem_allocate(dbl1d, nvals, idt%mf6varname, memoryPath) + else + call mem_setptr(nsize1, idt%shape, memoryPath) + call mem_allocate(dbl1d, nsize1, idt%mf6varname, memoryPath) + end if + + call read_grid_array(parser, mshape, idt%tagname, idt%layered, dbl1d) + call idm_log_var(dbl1d, idt%mf6varname, memoryPath, iout) + return + end subroutine load_double1d_type + + !> @brief load type 2d double + !< + subroutine load_double2d_type(parser, idt, memoryPath, mshape, iout) + type(BlockParserType), intent(inout) :: parser !< block parser + type(InputParamDefinitionType), intent(in) :: idt !< input data type object describing this record + character(len=*), intent(in) :: memoryPath !< memorypath to put loaded information + integer(I4B), dimension(:), contiguous, pointer, intent(in) :: mshape !< model shape + integer(I4B), intent(in) :: iout !< unit number for output + real(DP), dimension(:, :), pointer, contiguous :: dbl2d + integer(I4B) :: ndim + integer(I4B) :: nsize1, nsize2 + + ndim = size(mshape) + + ! set sizes + if (ndim == 2) then + nsize1 = mshape(2) ! NCPL + nsize2 = 1 + elseif (ndim == 3) then + nsize1 = mshape(3) ! NCOL + nsize2 = mshape(2) ! NROW + end if + + ! allocate the array using the memory manager + call mem_allocate(dbl2d, nsize1, nsize2, idt%mf6varname, memoryPath) + + ! fill the array from the file + call ReadArray(parser%iuactive, dbl2d, idt%mf6varname, & + ndim, nsize1, nsize2, iout, 0) + + call idm_log_var(dbl2d, idt%mf6varname, memoryPath, iout) + return + end subroutine load_double2d_type + + !> @brief load type 3d double + !< + subroutine load_double3d_type(parser, idt, memoryPath, mshape, iout) + type(BlockParserType), intent(inout) :: parser !< block parser + type(InputParamDefinitionType), intent(in) :: idt !< input data type object describing this record + character(len=*), intent(in) :: memoryPath !< memorypath to put loaded information + integer(I4B), dimension(:), contiguous, pointer, intent(in) :: mshape !< model shape + integer(I4B), intent(in) :: iout !< unit number for output + real(DP), dimension(:, :, :), pointer, contiguous :: dbl3d + integer(I4B) :: ndim + integer(I4B) :: nsize1, nsize2, nsize3 + character(len=LINELENGTH) :: keyword + + ndim = size(mshape) + + ! set sizes + if (ndim == 2) then + nsize1 = mshape(2) ! NCPL + nsize2 = 1 + nsize3 = mshape(1) + elseif (ndim == 3) then + nsize1 = mshape(3) ! NCOL + nsize2 = mshape(2) ! NROW + nsize3 = mshape(1) ! NLAY + end if + + ! allocate the array using the memory manager + call mem_allocate(dbl3d, nsize1, nsize2, nsize3, idt%mf6varname, memoryPath) + + ! fill the array from the file + if (idt%blockname == 'GRIDDATA') then + call parser%GetStringCaps(keyword) + if (keyword == 'LAYERED') then + ! read by layer + call ReadArray(parser%iuactive, dbl3d(:, :, :), & + idt%mf6varname, ndim, nsize1, nsize2, & + nsize3, iout, 1, nsize3) + else + ! read full 3d array + call ReadArray(parser%iuactive, dbl3d(:, :, :), idt%mf6varname, & + ndim, nsize1 * nsize2 * nsize3, iout) + end if + else + ! read full 3d array + call ReadArray(parser%iuactive, dbl3d(:, :, :), idt%mf6varname, & + ndim, nsize1 * nsize2 * nsize3, iout) + end if + + call idm_log_var(dbl3d, idt%mf6varname, memoryPath, iout) + return + end subroutine load_double3d_type + + !> @brief routine for setting the model shape + !! + !! The model shape must be set in the memory manager because + !! individual packages need to know the shape of the arrays + !! to read. + !! + !< + subroutine set_model_shape(ftype, model_mempath, dis_mempath, model_shape) + use MemoryTypeModule, only: MemoryType + use MemoryManagerModule, only: get_from_memorylist + character(len=*), intent(in) :: ftype + character(len=*), intent(in) :: model_mempath + character(len=*), intent(in) :: dis_mempath + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: model_shape + integer(I4B), pointer :: ndim1 + integer(I4B), pointer :: ndim2 + integer(I4B), pointer :: ndim3 + + select case (ftype) + case ('DIS6') + call mem_allocate(model_shape, 3, 'MODEL_SHAPE', model_mempath) + call mem_setptr(ndim1, 'NLAY', dis_mempath) + call mem_setptr(ndim2, 'NROW', dis_mempath) + call mem_setptr(ndim3, 'NCOL', dis_mempath) + model_shape = [ndim1, ndim2, ndim3] + case ('DISV6') + call mem_allocate(model_shape, 2, 'MODEL_SHAPE', model_mempath) + call mem_setptr(ndim1, 'NLAY', dis_mempath) + call mem_setptr(ndim2, 'NCPL', dis_mempath) + model_shape = [ndim1, ndim2] + case ('DISU6') + call mem_allocate(model_shape, 1, 'MODEL_SHAPE', model_mempath) + call mem_setptr(ndim1, 'NODES', dis_mempath) + model_shape = [ndim1] + end select + + return + end subroutine set_model_shape + + !> @brief read an array that is the size of the model grid + !< + subroutine read_grid_array(parser, mshape, array_name, layered, dblarray, & + intarray) + type(BlockParserType), intent(inout) :: parser !< block parser + integer(I4B), dimension(:), intent(in) :: mshape !< model shape + character(len=*), intent(in) :: array_name + logical(LGP), intent(in) :: layered + real(DP), dimension(:), optional, intent(inout) :: dblarray + integer(I4B), dimension(:), optional, intent(inout) :: intarray + integer(I4B) :: nvals + integer(I4B) :: ndim + integer(I4B) :: ndim1 + integer(I4B) :: ndim2 + integer(I4B) :: ndim3 + integer(I4B) :: k1 + integer(I4B) :: k2 + integer(I4B) :: iout !< unit number for output + character(len=LINELENGTH) :: keyword + + ndim = size(mshape) + if (present(dblarray)) then + nvals = size(dblarray) + end if + if (present(intarray)) then + nvals = size(intarray) + end if + iout = 0 + + ! disu + if (ndim == 1) then + ndim1 = mshape(1) ! nodesuser + ndim2 = 1 ! none + ndim3 = 1 ! none + k1 = 0 + k2 = 0 + + ! disv + else if (ndim == 2) then + ndim1 = mshape(1) ! nlay + ndim2 = 1 ! none + ndim3 = mshape(2) ! ncpl + k1 = 1 + k2 = ndim1 + + ! dis + else if (ndim == 3) then + ndim1 = mshape(1) ! nlay + ndim2 = mshape(2) ! nrow + ndim3 = mshape(3) ! ncol + k1 = 1 + k2 = ndim1 + end if + + call parser%GetStringCaps(keyword) + if (keyword == 'LAYERED' .and. layered) then + + ! float array + if (present(dblarray)) then + call ReadArray(parser%iuactive, dblarray, & + array_name, ndim, ndim3, ndim2, & + ndim1, nvals, iout, k1, k2) + end if + + ! integer array + if (present(intarray)) then + call ReadArray(parser%iuactive, intarray, & + array_name, ndim, ndim3, ndim2, & + ndim1, nvals, iout, k1, k2) + end if + + else + + ! float array + if (present(dblarray)) then + call ReadArray(parser%iuactive, dblarray, array_name, & + ndim, nvals, iout, 0) + end if + + ! integer array + if (present(intarray)) then + call ReadArray(parser%iuactive, intarray, array_name, & + ndim, nvals, iout, 0) + end if + + end if + + return + end subroutine read_grid_array + +end module LoadMf6FileTypeModule diff --git a/src/Utilities/Idm/ModflowInput.f90 b/src/Utilities/Idm/ModflowInput.f90 new file mode 100644 index 00000000000..5ed0aaba08a --- /dev/null +++ b/src/Utilities/Idm/ModflowInput.f90 @@ -0,0 +1,93 @@ +!> @brief This module contains the ModflowInputModule +!! +!! This module contains a helper object and function +!! for accessing the ModflowInput, which is a +!! description of the structure of a modflow input +!! file. +!! +!< +module ModflowInputModule + + use KindModule, only: I4B, LGP + use ConstantsModule, only: LENMEMPATH, LENCOMPONENTNAME, & + LENPACKAGETYPE, LENFTYPE + use MemoryHelperModule, only: create_mem_path + use InputDefinitionModule, only: InputParamDefinitionType, & + InputBlockDefinitionType + use InputDefinitionSelectorModule, only: block_definitions, & + aggregate_definitions, & + param_definitions + use SimVariablesModule, only: idm_context + + implicit none + private + public :: ModflowInputType, getModflowInput + + !> @brief derived type for storing input definition for a file + !! + !! This derived type contains the information needed to read + !! a specific modflow input file, including block definitions, + !! aggregate definitions (structarrays), and individual + !! parameter definitions. + !! + !< + type ModflowInputType + character(len=LENFTYPE) :: file_type + character(len=LENCOMPONENTNAME) :: component_type + character(len=LENCOMPONENTNAME) :: subcomponent_type + character(len=LENCOMPONENTNAME) :: component_name + character(len=LENCOMPONENTNAME) :: subcomponent_name + character(len=LENMEMPATH) :: memoryPath + character(len=LENMEMPATH) :: component + character(len=LENPACKAGETYPE), allocatable, dimension(:) :: subpackages + type(InputBlockDefinitionType), dimension(:), pointer :: p_block_dfns + type(InputParamDefinitionType), dimension(:), pointer :: p_aggregate_dfns + type(InputParamDefinitionType), dimension(:), pointer :: p_param_dfns + contains + procedure :: destroy + end type ModflowInputType + +contains + + !> @brief function to return ModflowInputType + !< + function getModflowInput(ftype, component_type, & + subcomponent_type, component_name, subcomponent_name, & + subpackages) & + result(mf6_input) + character(len=*), intent(in) :: ftype !< file type to load, such as DIS6, DISV6, NPF6 + character(len=*), intent(in) :: component_type !< component type, such as GWF or GWT + character(len=*), intent(in) :: subcomponent_type !< subcomponent type, such as DIS or NPF + character(len=*), intent(in) :: component_name !< component name, such as MYGWFMODEL + character(len=*), intent(in) :: subcomponent_name !< subcomponent name, such as MYWELLPACKAGE + character(len=*), dimension(:), intent(in) :: subpackages !< array of subpackage types, such as ["TVK6", "OBS6"] + type(ModflowInputType) :: mf6_input + + mf6_input%file_type = trim(ftype) + mf6_input%component_type = trim(component_type) + mf6_input%subcomponent_type = trim(subcomponent_type) + mf6_input%component_name = trim(component_name) + mf6_input%subcomponent_name = trim(subcomponent_name) + allocate (mf6_input%subpackages(size(subpackages))) + mf6_input%subpackages = subpackages + + mf6_input%memoryPath = create_mem_path(component_name, subcomponent_name, & + idm_context) + mf6_input%component = trim(component_type)//'/'//trim(subcomponent_type) + + mf6_input%p_block_dfns => block_definitions(mf6_input%component) + mf6_input%p_aggregate_dfns => aggregate_definitions(mf6_input%component) + mf6_input%p_param_dfns => param_definitions(mf6_input%component) + end function getModflowInput + + !> @brief function to release ModflowInputType allocated memory + !< + subroutine destroy(this) + class(ModflowInputType) :: this !< ModflowInputType + + if (allocated(this%subpackages)) then + deallocate (this%subpackages) + end if + end subroutine destroy + +end module ModflowInputModule diff --git a/src/Utilities/Idm/StructArray.f90 b/src/Utilities/Idm/StructArray.f90 new file mode 100644 index 00000000000..a57a2e211a0 --- /dev/null +++ b/src/Utilities/Idm/StructArray.f90 @@ -0,0 +1,289 @@ +!> @brief This module contains the StructArrayModule +!! +!! This module contains the routines for reading a +!! structured list, which consists of a separate vector +!! for each column in the list. +!! +!< +module StructArrayModule + + use KindModule, only: I4B, DP, LGP + use ConstantsModule, only: DNODATA, LINELENGTH + use StructVectorModule, only: StructVectorType + use MemoryManagerModule, only: mem_allocate + use CharacterStringModule, only: CharacterStringType + use VectorIntModule, only: VectorInt + use IdmLoggerModule, only: idm_log_var + use MemoryManagerModule, only: mem_setptr + use BlockParserModule, only: BlockParserType + + implicit none + private + public :: StructArrayType + public :: constructStructArray, destructStructArray + + !> @brief derived type for structured array + !! + !! This derived type is used to read and store a + !! list that consists of multiple one-dimensional + !! vectors. + !! + !< + type StructArrayType + integer(I4B) :: ncol + integer(I4B) :: nrow + type(StructVectorType), dimension(:), allocatable :: struct_vector_1d + contains + procedure :: mem_create_vector + procedure :: add_vector_int1d + procedure :: add_vector_dbl1d + procedure :: add_vector_str1d + procedure :: add_vector_intvector + procedure :: read_from_parser + procedure :: load_intvector + procedure :: log_structarray_vars + + end type StructArrayType + +contains + + !> @brief constructor for a struct_array + !< + function constructStructArray(ncol, nrow) result(struct_array) + integer(I4B), intent(in) :: ncol !< number of columns in the StructArrayType + integer(I4B), intent(in) :: nrow !< number of rows in the StructArrayType + type(StructArrayType), pointer :: struct_array !< new StructArrayType + + allocate (struct_array) + struct_array%ncol = ncol + struct_array%nrow = nrow + allocate (struct_array%struct_vector_1d(ncol)) + end function constructStructArray + + !> @brief destructor for a struct_array + !< + subroutine destructStructArray(struct_array) + type(StructArrayType), pointer, intent(inout) :: struct_array !< StructArrayType to destroy + + deallocate (struct_array%struct_vector_1d) + deallocate (struct_array) + nullify (struct_array) + end subroutine destructStructArray + + !> @brief create new vector in StructArrayType + !< + subroutine mem_create_vector(this, icol, vartype, name, memoryPath, & + varname_shape, preserve_case) + class(StructArrayType) :: this !< StructArrayType + integer(I4B), intent(in) :: icol !< column to create + character(len=*), intent(in) :: vartype !< type of column to create + character(len=*), intent(in) :: name !< name of the column to create + character(len=*), intent(in) :: memoryPath !< memory path for storing the vector + character(len=*), intent(in) :: varname_shape !< shape + logical(LGP), optional, intent(in) :: preserve_case !< flag indicating whether or not to preserve case + integer(I4B), dimension(:), pointer, contiguous :: int1d + real(DP), dimension(:), pointer, contiguous :: dbl1d + type(CharacterStringType), dimension(:), pointer, contiguous :: cstr1d + type(VectorInt), pointer :: intvector + integer(I4B) :: j + integer(I4B) :: inodata = 999 !todo: create INODATA in constants? + + select case (vartype) + case ('INTEGER1D') + allocate (intvector) + call this%add_vector_intvector(name, memoryPath, varname_shape, icol, & + intvector) + case ('INTEGER') + call mem_allocate(int1d, this%nrow, name, memoryPath) + do j = 1, this%nrow + int1d(j) = inodata + end do + call this%add_vector_int1d(name, memoryPath, icol, int1d) + case ('DOUBLE') + call mem_allocate(dbl1d, this%nrow, name, memoryPath) + do j = 1, this%nrow + dbl1d(j) = DNODATA + end do + call this%add_vector_dbl1d(name, memoryPath, icol, dbl1d) + case ('STRING') + call mem_allocate(cstr1d, LINELENGTH, this%nrow, name, memoryPath) + do j = 1, this%nrow + cstr1d(j) = '' + end do + call this%add_vector_str1d(icol, cstr1d, preserve_case) + end select + + return + end subroutine mem_create_vector + + !> @brief add int1d to StructArrayType + !< + subroutine add_vector_int1d(this, varname, memoryPath, icol, int1d) + class(StructArrayType) :: this !< StructArrayType + character(len=*), intent(in) :: varname !< name of the variable + character(len=*), intent(in) :: memoryPath !< memory path to vector + integer(I4B), intent(in) :: icol !< column of the vector + integer(I4B), dimension(:), pointer, contiguous, intent(in) :: int1d !< vector to add + type(StructVectorType) :: sv + sv%varname = varname + sv%memoryPath = memoryPath + sv%memtype = 1 + sv%int1d => int1d + this%struct_vector_1d(icol) = sv + return + end subroutine add_vector_int1d + + !> @brief add dbl1d to StructArrayType + !< + subroutine add_vector_dbl1d(this, varname, memoryPath, icol, dbl1d) + class(StructArrayType) :: this !< StructArrayType + character(len=*), intent(in) :: varname !< name of the variable + character(len=*), intent(in) :: memoryPath !< memory path to vector + integer(I4B), intent(in) :: icol !< column of the vector + real(DP), dimension(:), pointer, contiguous, intent(in) :: dbl1d !< vector to add + type(StructVectorType) :: sv + sv%varname = varname + sv%memoryPath = memoryPath + sv%memtype = 2 + sv%dbl1d => dbl1d + this%struct_vector_1d(icol) = sv + return + end subroutine add_vector_dbl1d + + !> @brief add str1d to StructArrayType + !< + subroutine add_vector_str1d(this, icol, str1d, preserve_case) + class(StructArrayType) :: this !< StructArrayType + integer(I4B), intent(in) :: icol !< column of the vector + type(CharacterStringType), dimension(:), pointer, contiguous, intent(in) :: & + str1d !< vector to add + logical(LGP), intent(in) :: preserve_case + type(StructVectorType) :: sv + sv%memtype = 3 + sv%preserve_case = preserve_case + sv%str1d => str1d + this%struct_vector_1d(icol) = sv + return + end subroutine add_vector_str1d + + !> @brief add VectorInt to StructArrayType + !< + subroutine add_vector_intvector(this, varname, memoryPath, varname_shape, & + icol, intvector) + class(StructArrayType) :: this !< StructArrayType + character(len=*), intent(in) :: varname !< name of the variable + character(len=*), intent(in) :: memoryPath !< memory path to vector + character(len=*), intent(in) :: varname_shape !< shape of variable + integer(I4B), intent(in) :: icol !< column of the vector + type(VectorInt), pointer, intent(in) :: intvector !< vector to add + type(StructVectorType) :: sv + + call intvector%init() + call mem_setptr(sv%intvector_shape, varname_shape, memoryPath) + + sv%varname = varname + sv%memoryPath = memoryPath + sv%memtype = 4 + sv%intvector => intvector + this%struct_vector_1d(icol) = sv + return + end subroutine add_vector_intvector + + !> @brief load integer vector into StructArrayType + !< + subroutine load_intvector(this) + class(StructArrayType) :: this !< StructArrayType + integer(I4B) :: i, j + integer(I4B), dimension(:), pointer, contiguous :: p_intvector + ! -- if an allocatable vector has been read, add to MemoryManager + do i = 1, this%ncol + if (this%struct_vector_1d(i)%memtype == 4) then + call this%struct_vector_1d(i)%intvector%shrink_to_fit() + call mem_allocate(p_intvector, this%struct_vector_1d(i)%intvector%size, & + this%struct_vector_1d(i)%varname, & + this%struct_vector_1d(i)%memoryPath) + do j = 1, this%struct_vector_1d(i)%intvector%size + p_intvector(j) = this%struct_vector_1d(i)%intvector%at(j) + end do + call this%struct_vector_1d(i)%intvector%destroy() + deallocate (this%struct_vector_1d(i)%intvector) + nullify (this%struct_vector_1d(i)%intvector_shape) + end if + end do + return + end subroutine load_intvector + + !> @brief log information about the StructArrayType + !< + subroutine log_structarray_vars(this, iout) + class(StructArrayType) :: this !< StructArrayType + integer(I4B), intent(in) :: iout !< unit number for output + integer(I4B) :: j + integer(I4B), dimension(:), pointer, contiguous :: int1d + ! + ! -- idm variable logging + do j = 1, this%ncol + select case (this%struct_vector_1d(j)%memtype) + case (1) + call idm_log_var(this%struct_vector_1d(j)%int1d, & + this%struct_vector_1d(j)%varname, & + this%struct_vector_1d(j)%memoryPath, iout) + case (2) + call idm_log_var(this%struct_vector_1d(j)%dbl1d, & + this%struct_vector_1d(j)%varname, & + this%struct_vector_1d(j)%memoryPath, iout) + case (4) + call mem_setptr(int1d, this%struct_vector_1d(j)%varname, & + this%struct_vector_1d(j)%memoryPath) + call idm_log_var(int1d, this%struct_vector_1d(j)%varname, & + this%struct_vector_1d(j)%memoryPath, iout) + + end select + end do + return + end subroutine log_structarray_vars + + !> @brief read from the block parser to fill the StructArrayType + !< + subroutine read_from_parser(this, parser, iout) + class(StructArrayType) :: this !< StructArrayType + type(BlockParserType) :: parser !< block parser to read from + integer(I4B), intent(in) :: iout !< unit number for output + logical(LGP) :: endOfBlock + integer(I4B) :: i, j, k + integer(I4B) :: intval, numval + character(len=LINELENGTH) :: str1d + ! + ! -- read block + do i = 1, this%nrow + call parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + do j = 1, this%ncol + select case (this%struct_vector_1d(j)%memtype) + case (1) + this%struct_vector_1d(j)%int1d(i) = parser%GetInteger() + case (2) + this%struct_vector_1d(j)%dbl1d(i) = parser%GetDouble() + case (3) + call parser%GetString(str1d, & + (.not. this%struct_vector_1d(j)%preserve_case)) + this%struct_vector_1d(j)%str1d(i) = str1d + case (4) + numval = this%struct_vector_1d(j)%intvector_shape(i) + do k = 1, numval + intval = parser%GetInteger() + call this%struct_vector_1d(j)%intvector%push_back(intval) + end do + end select + end do + end do + ! + ! -- if jagged array was read, load to input path + call this%load_intvector() + ! + ! -- log loaded variables + call this%log_structarray_vars(iout) + + end subroutine read_from_parser + +end module StructArrayModule diff --git a/src/Utilities/Idm/StructVector.f90 b/src/Utilities/Idm/StructVector.f90 new file mode 100644 index 00000000000..60aa546255f --- /dev/null +++ b/src/Utilities/Idm/StructVector.f90 @@ -0,0 +1,38 @@ +!> @brief This module contains the StructVectorModule +!! +!! This module contains a generic type for storing +!! different types of vectors. +!! +!< +module StructVectorModule + + use KindModule, only: I4B, DP, LGP + use ConstantsModule, only: LENMEMPATH, LENVARNAME + use CharacterStringModule, only: CharacterStringType + use VectorIntModule, only: VectorInt + + implicit none + private + public :: StructVectorType + + !> @brief derived type for generic vector + !! + !! This derived type is used in the StructArrayType to + !! store any type of vector. + !! + !< + type StructVectorType + character(len=LENVARNAME) :: varname + character(len=LENMEMPATH) :: memoryPath + integer(I4B) :: memtype = 0 + logical(LGP) :: preserve_case = .false. + integer(I4B), dimension(:), pointer, contiguous :: int1d => null() + real(DP), dimension(:), pointer, contiguous :: dbl1d => null() + type(CharacterStringType), dimension(:), pointer, contiguous :: & + str1d => null() + type(VectorInt), pointer :: intvector => null() + integer(I4B), dimension(:), pointer, contiguous :: intvector_shape => null() + + end type StructVectorType + +end module StructVectorModule diff --git a/src/Utilities/Memory/Memory.f90 b/src/Utilities/Memory/Memory.f90 index 9015ec4127f..00597edf1fc 100644 --- a/src/Utilities/Memory/Memory.f90 +++ b/src/Utilities/Memory/Memory.f90 @@ -41,6 +41,7 @@ module MemoryTypeModule contains procedure :: table_entry procedure :: mt_associated + procedure :: mt_deallocate end type contains @@ -99,4 +100,68 @@ function mt_associated(this) result(al) if (associated(this%acharstr1d)) al = .true. end function mt_associated + subroutine mt_deallocate(this) + class(MemoryType) :: this + + if (associated(this%strsclr)) then + if (this%master) deallocate (this%strsclr) + nullify (this%strsclr) + end if + + if (associated(this%logicalsclr)) then + if (this%master) deallocate (this%logicalsclr) + nullify (this%logicalsclr) + end if + + if (associated(this%intsclr)) then + if (this%master) deallocate (this%intsclr) + nullify (this%intsclr) + end if + + if (associated(this%dblsclr)) then + if (this%master) deallocate (this%dblsclr) + nullify (this%dblsclr) + end if + + if (associated(this%astr1d)) then + if (this%master) deallocate (this%astr1d) + nullify (this%astr1d) + end if + + if (associated(this%aint1d)) then + if (this%master) deallocate (this%aint1d) + nullify (this%aint1d) + end if + + if (associated(this%aint2d)) then + if (this%master) deallocate (this%aint2d) + nullify (this%aint2d) + end if + + if (associated(this%aint3d)) then + if (this%master) deallocate (this%aint3d) + nullify (this%aint3d) + end if + + if (associated(this%adbl1d)) then + if (this%master) deallocate (this%adbl1d) + nullify (this%adbl1d) + end if + + if (associated(this%adbl2d)) then + if (this%master) deallocate (this%adbl2d) + nullify (this%adbl2d) + end if + + if (associated(this%adbl3d)) then + if (this%master) deallocate (this%adbl3d) + nullify (this%adbl3d) + end if + + if (associated(this%acharstr1d)) then + if (this%master) deallocate (this%acharstr1d) + nullify (this%acharstr1d) + end if + end subroutine mt_deallocate + end module MemoryTypeModule diff --git a/src/Utilities/Memory/MemoryList.f90 b/src/Utilities/Memory/MemoryList.f90 index 94e5045398a..badafb519fd 100644 --- a/src/Utilities/Memory/MemoryList.f90 +++ b/src/Utilities/Memory/MemoryList.f90 @@ -12,6 +12,7 @@ module MemoryListModule procedure :: get procedure :: count procedure :: clear + procedure :: remove end type MemoryListType contains @@ -49,4 +50,11 @@ subroutine clear(this) call this%list%Clear() end subroutine clear + subroutine remove(this, ipos, destroyValue) + class(MemoryListType) :: this + integer(I4B), intent(in) :: ipos + logical, intent(in) :: destroyValue + call this%list%RemoveNode(ipos, destroyValue) + end subroutine remove + end module MemoryListModule diff --git a/src/Utilities/Memory/MemoryManagerExt.f90 b/src/Utilities/Memory/MemoryManagerExt.f90 new file mode 100644 index 00000000000..d169449466b --- /dev/null +++ b/src/Utilities/Memory/MemoryManagerExt.f90 @@ -0,0 +1,369 @@ +module MemoryManagerExtModule + + use KindModule, only: DP, LGP, I4B, I8B + use SimModule, only: store_error + use MemoryTypeModule, only: MemoryType + use MemoryManagerModule, only: memorylist, get_from_memorylist + + implicit none + private + public :: mem_set_value + public :: memorylist_remove + + interface mem_set_value + module procedure mem_set_value_logical, mem_set_value_int, & + mem_set_value_int_setval, mem_set_value_str_mapped_int, & + mem_set_value_int1d, mem_set_value_int1d_mapped, & + mem_set_value_int2d, mem_set_value_int3d, mem_set_value_dbl, & + mem_set_value_dbl1d, mem_set_value_dbl1d_mapped, & + mem_set_value_dbl2d, mem_set_value_dbl3d, mem_set_value_str + end interface mem_set_value + +contains + + subroutine memorylist_remove(component, subcomponent, context) + use MemoryHelperModule, only: create_mem_path + use ConstantsModule, only: LENMEMPATH + character(len=*), intent(in) :: component !< name of the solution, model, or exchange + character(len=*), intent(in), optional :: subcomponent !< name of the package (optional) + character(len=*), intent(in), optional :: context !< name of the context (optional) + character(len=LENMEMPATH) :: memory_path !< the memory path + type(MemoryType), pointer :: mt + integer(I4B) :: ipos + logical(LGP) :: removed + + memory_path = create_mem_path(component, subcomponent, context) + removed = .true. !< initialize the loop + + do while (removed) + removed = .false. + do ipos = 1, memorylist%count() + mt => memorylist%Get(ipos) + if (mt%path == memory_path .and. mt%mt_associated()) then + call mt%mt_deallocate() + deallocate (mt) + call memorylist%remove(ipos, .false.) + removed = .true. + exit + end if + end do + end do + end subroutine memorylist_remove + + !> @brief Set pointer to value of memory list logical variable + !< + subroutine mem_set_value_logical(p_mem, varname, memory_path, found) + logical(LGP), pointer, intent(inout) :: p_mem !< pointer to logical scalar + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: memory_path !< path where variable is stored + logical(LGP), intent(inout) :: found + type(MemoryType), pointer :: mt + logical(LGP) :: checkfail = .false. + + call get_from_memorylist(varname, memory_path, mt, found, checkfail) + if (found .and. mt%memtype(1:index(mt%memtype, ' ')) == 'LOGICAL') then + p_mem = mt%logicalsclr + end if + end subroutine mem_set_value_logical + + !> @brief Set pointer to value of memory list int variable + !< + subroutine mem_set_value_int(p_mem, varname, memory_path, found) + integer(I4B), pointer, intent(inout) :: p_mem !< pointer to int scalar + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: memory_path !< path where variable is stored + logical(LGP), intent(inout) :: found + type(MemoryType), pointer :: mt + logical(LGP) :: checkfail = .false. + + call get_from_memorylist(varname, memory_path, mt, found, checkfail) + if (found .and. mt%memtype(1:index(mt%memtype, ' ')) == 'INTEGER') then + p_mem = mt%intsclr + end if + end subroutine mem_set_value_int + + subroutine mem_set_value_int_setval(p_mem, varname, memory_path, setval, found) + integer(I4B), pointer, intent(inout) :: p_mem !< pointer to int scalar + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: memory_path !< path where variable is stored + integer(I4B), intent(in) :: setval !< set p_mem to setval if varname found + logical(LGP), intent(inout) :: found + type(MemoryType), pointer :: mt + logical(LGP) :: checkfail = .false. + + call get_from_memorylist(varname, memory_path, mt, found, checkfail) + if (found) then + p_mem = setval + end if + end subroutine mem_set_value_int_setval + + subroutine mem_set_value_str_mapped_int(p_mem, varname, memory_path, str_list, & + found) + integer(I4B), pointer, intent(inout) :: p_mem !< pointer to int scalar + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: memory_path !< path where variable is stored + character(len=*), dimension(:), intent(in) :: str_list + logical(LGP), intent(inout) :: found + type(MemoryType), pointer :: mt + logical(LGP) :: checkfail = .false. + integer(I4B) :: i + + call get_from_memorylist(varname, memory_path, mt, found, checkfail) + if (found .and. mt%memtype(1:index(mt%memtype, ' ')) == 'STRING') then + do i = 1, size(str_list) + if (mt%strsclr == str_list(i)) then + p_mem = i + end if + end do + end if + end subroutine mem_set_value_str_mapped_int + + !> @brief Set pointer to value of memory list 1d int array variable + !< + subroutine mem_set_value_int1d(p_mem, varname, memory_path, found) + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: p_mem !< pointer to 1d int array + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: memory_path !< path where variable is stored + logical(LGP), intent(inout) :: found + type(MemoryType), pointer :: mt + logical(LGP) :: checkfail = .false. + integer(I4B) :: n + + call get_from_memorylist(varname, memory_path, mt, found, checkfail) + if (found .and. mt%memtype(1:index(mt%memtype, ' ')) == 'INTEGER') then + if (size(mt%aint1d) /= size(p_mem)) then + call store_error('mem_set_value() size mismatch int1d, varname='//& + &trim(varname), terminate=.TRUE.) + end if + do n = 1, size(mt%aint1d) + p_mem(n) = mt%aint1d(n) + end do + end if + end subroutine mem_set_value_int1d + + !> @brief Set pointer to value of memory list 1d int array variable with mapping + !< + subroutine mem_set_value_int1d_mapped(p_mem, varname, memory_path, map, & + found) + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: p_mem !< pointer to 1d int array + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: memory_path !< path where variable is stored + integer(I4B), dimension(:), pointer, contiguous, intent(in) :: map !< pointer to 1d int mapping array + logical(LGP), intent(inout) :: found + type(MemoryType), pointer :: mt + logical(LGP) :: checkfail = .false. + integer(I4B) :: n + + call get_from_memorylist(varname, memory_path, mt, found, checkfail) + if (found .and. mt%memtype(1:index(mt%memtype, ' ')) == 'INTEGER') then + if (associated(map)) then + do n = 1, size(p_mem) + p_mem(n) = mt%aint1d(map(n)) + end do + else + if (size(mt%aint1d) /= size(p_mem)) then + call store_error('mem_set_value() size mismatch int1d, varname='//& + &trim(varname), terminate=.TRUE.) + end if + do n = 1, size(mt%aint1d) + p_mem(n) = mt%aint1d(n) + end do + end if + end if + end subroutine mem_set_value_int1d_mapped + + !> @brief Set pointer to value of memory list 2d int array variable + !< + subroutine mem_set_value_int2d(p_mem, varname, memory_path, found) + integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: p_mem !< pointer to 2d int array + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: memory_path !< path where variable is stored + logical(LGP), intent(inout) :: found + type(MemoryType), pointer :: mt + logical(LGP) :: checkfail = .false. + integer(I4B) :: i, j + + call get_from_memorylist(varname, memory_path, mt, found, checkfail) + if (found .and. mt%memtype(1:index(mt%memtype, ' ')) == 'INTEGER') then + if (size(mt%aint2d, dim=1) /= size(p_mem, dim=1) .or. & + size(mt%aint2d, dim=2) /= size(p_mem, dim=2)) then + call store_error('mem_set_value() size mismatch int2d, varname='//& + &trim(varname), terminate=.TRUE.) + end if + do j = 1, size(mt%aint2d, dim=2) + do i = 1, size(mt%aint2d, dim=1) + p_mem(i, j) = mt%aint2d(i, j) + end do + end do + end if + end subroutine mem_set_value_int2d + + !> @brief Set pointer to value of memory list 3d int array variable + !< + subroutine mem_set_value_int3d(p_mem, varname, memory_path, found) + integer(I4B), dimension(:, :, :), pointer, contiguous, intent(inout) :: p_mem !< pointer to 3d int array + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: memory_path !< path where variable is stored + logical(LGP), intent(inout) :: found + type(MemoryType), pointer :: mt + logical(LGP) :: checkfail = .false. + integer(I4B) :: i, j, k + + call get_from_memorylist(varname, memory_path, mt, found, checkfail) + if (found .and. mt%memtype(1:index(mt%memtype, ' ')) == 'INTEGER') then + if (size(mt%aint3d, dim=1) /= size(p_mem, dim=1) .or. & + size(mt%aint3d, dim=2) /= size(p_mem, dim=2) .or. & + size(mt%aint3d, dim=3) /= size(p_mem, dim=3)) then + call store_error('mem_set_value() size mismatch int3d, varname='//& + &trim(varname), terminate=.TRUE.) + end if + do k = 1, size(mt%aint3d, dim=3) + do j = 1, size(mt%aint3d, dim=2) + do i = 1, size(mt%aint3d, dim=1) + p_mem(i, j, k) = mt%aint3d(i, j, k) + end do + end do + end do + end if + end subroutine mem_set_value_int3d + + !> @brief Set pointer to value of memory list double variable + !< + subroutine mem_set_value_dbl(p_mem, varname, memory_path, found) + real(DP), pointer, intent(inout) :: p_mem !< pointer to dbl scalar + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: memory_path !< path where variable is stored + logical(LGP), intent(inout) :: found + type(MemoryType), pointer :: mt + logical(LGP) :: checkfail = .false. + + call get_from_memorylist(varname, memory_path, mt, found, checkfail) + if (found .and. mt%memtype(1:index(mt%memtype, ' ')) == 'DOUBLE') then + p_mem = mt%dblsclr + end if + end subroutine mem_set_value_dbl + + !> @brief Set pointer to value of memory list 1d dbl array variable + !< + subroutine mem_set_value_dbl1d(p_mem, varname, memory_path, found) + real(DP), dimension(:), pointer, contiguous, intent(inout) :: p_mem !< pointer to 1d dbl array + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: memory_path !< path where variable is stored + logical(LGP), intent(inout) :: found + type(MemoryType), pointer :: mt + logical(LGP) :: checkfail = .false. + integer(I4B) :: n + + call get_from_memorylist(varname, memory_path, mt, found, checkfail) + if (found .and. mt%memtype(1:index(mt%memtype, ' ')) == 'DOUBLE') then + if (size(mt%adbl1d) /= size(p_mem)) then + call store_error('mem_set_value() size mismatch dbl1d, varname='//& + &trim(varname), terminate=.TRUE.) + end if + do n = 1, size(mt%adbl1d) + p_mem(n) = mt%adbl1d(n) + end do + end if + end subroutine mem_set_value_dbl1d + + !> @brief Set pointer to value of memory list 1d dbl array variable with mapping + !< + subroutine mem_set_value_dbl1d_mapped(p_mem, varname, memory_path, map, & + found) + real(DP), dimension(:), pointer, contiguous, intent(inout) :: p_mem !< pointer to 1d dbl array + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: memory_path !< path where variable is stored + integer(I4B), dimension(:), pointer, contiguous, intent(in) :: map !< pointer to 1d int mapping array + logical(LGP), intent(inout) :: found + type(MemoryType), pointer :: mt + logical(LGP) :: checkfail = .false. + integer(I4B) :: n + + call get_from_memorylist(varname, memory_path, mt, found, checkfail) + if (found .and. mt%memtype(1:index(mt%memtype, ' ')) == 'DOUBLE') then + if (associated(map)) then + do n = 1, size(p_mem) + p_mem(n) = mt%adbl1d(map(n)) + end do + else + if (size(mt%adbl1d) /= size(p_mem)) then + call store_error('mem_set_value() size mismatch dbl1d, varname='//& + &trim(varname), terminate=.TRUE.) + end if + do n = 1, size(mt%adbl1d) + p_mem(n) = mt%adbl1d(n) + end do + end if + end if + end subroutine mem_set_value_dbl1d_mapped + + !> @brief Set pointer to value of memory list 2d dbl array variable + !< + subroutine mem_set_value_dbl2d(p_mem, varname, memory_path, found) + real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: p_mem !< pointer to 2d dbl array + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: memory_path !< path where variable is stored + logical(LGP), intent(inout) :: found + type(MemoryType), pointer :: mt + logical(LGP) :: checkfail = .false. + integer(I4B) :: i, j + + call get_from_memorylist(varname, memory_path, mt, found, checkfail) + if (found .and. mt%memtype(1:index(mt%memtype, ' ')) == 'DOUBLE') then + if (size(mt%adbl2d, dim=1) /= size(p_mem, dim=1) .or. & + size(mt%adbl2d, dim=2) /= size(p_mem, dim=2)) then + call store_error('mem_set_value() size mismatch dbl2d, varname='//& + &trim(varname), terminate=.TRUE.) + end if + do j = 1, size(mt%adbl2d, dim=2) + do i = 1, size(mt%adbl2d, dim=1) + p_mem(i, j) = mt%adbl2d(i, j) + end do + end do + end if + end subroutine mem_set_value_dbl2d + + !> @brief Set pointer to value of memory list 3d dbl array variable + !< + subroutine mem_set_value_dbl3d(p_mem, varname, memory_path, found) + real(DP), dimension(:, :, :), pointer, contiguous, intent(inout) :: p_mem !< pointer to 3d dbl array + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: memory_path !< path where variable is stored + logical(LGP), intent(inout) :: found + type(MemoryType), pointer :: mt + logical(LGP) :: checkfail = .false. + integer(I4B) :: i, j, k + + call get_from_memorylist(varname, memory_path, mt, found, checkfail) + if (found .and. mt%memtype(1:index(mt%memtype, ' ')) == 'DOUBLE') then + if (size(mt%adbl3d, dim=1) /= size(p_mem, dim=1) .or. & + size(mt%adbl3d, dim=2) /= size(p_mem, dim=2) .or. & + size(mt%adbl3d, dim=3) /= size(p_mem, dim=3)) then + call store_error('mem_set_value() size mismatch dbl3d, varname='//& + &trim(varname), terminate=.TRUE.) + end if + do k = 1, size(mt%adbl3d, dim=3) + do j = 1, size(mt%adbl3d, dim=2) + do i = 1, size(mt%adbl3d, dim=1) + p_mem(i, j, k) = mt%adbl3d(i, j, k) + end do + end do + end do + end if + end subroutine mem_set_value_dbl3d + + subroutine mem_set_value_str(p_mem, varname, memory_path, found) + character(len=*), intent(inout) :: p_mem !< pointer to str scalar + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: memory_path !< path where variable is stored + logical(LGP), intent(inout) :: found + type(MemoryType), pointer :: mt + logical(LGP) :: checkfail = .false. + + call get_from_memorylist(varname, memory_path, mt, found, checkfail) + if (found .and. mt%memtype(1:index(mt%memtype, ' ')) == 'STRING') then + p_mem = mt%strsclr + end if + end subroutine mem_set_value_str + +end module MemoryManagerExtModule diff --git a/src/Utilities/SimVariables.f90 b/src/Utilities/SimVariables.f90 index a86853f27c5..6847d8376c1 100644 --- a/src/Utilities/SimVariables.f90 +++ b/src/Utilities/SimVariables.f90 @@ -14,6 +14,7 @@ module SimVariablesModule character(len=LINELENGTH) :: simfile = 'mfsim.nam' !< simulation name file character(len=LINELENGTH) :: simlstfile = 'mfsim.lst' !< simulation listing file name character(len=LINELENGTH) :: simstdout = 'mfsim.stdout' !< name of standard out file if screen output is piped to a file + character(len=LINELENGTH) :: idm_context = '__INPUT__' character(len=MAXCHARLEN) :: errmsg !< error message string character(len=MAXCHARLEN) :: warnmsg !< warning message string integer(I4B) :: istdout = output_unit !< unit number for stdout diff --git a/src/meson.build b/src/meson.build index 83238eaacb0..f5df942650a 100644 --- a/src/meson.build +++ b/src/meson.build @@ -37,8 +37,11 @@ modflow_sources = files( 'Model' / 'GroundWaterFlow' / 'gwf3chd8.f90', 'Model' / 'GroundWaterFlow' / 'gwf3csub8.f90', 'Model' / 'GroundWaterFlow' / 'gwf3dis8.f90', + 'Model' / 'GroundWaterFlow' / 'gwf3dis8idm.f90', 'Model' / 'GroundWaterFlow' / 'gwf3disu8.f90', + 'Model' / 'GroundWaterFlow' / 'gwf3disu8idm.f90', 'Model' / 'GroundWaterFlow' / 'gwf3disv8.f90', + 'Model' / 'GroundWaterFlow' / 'gwf3disv8idm.f90', 'Model' / 'GroundWaterFlow' / 'gwf3drn8.f90', 'Model' / 'GroundWaterFlow' / 'gwf3evt8.f90', 'Model' / 'GroundWaterFlow' / 'gwf3ghb8.f90', @@ -48,6 +51,7 @@ modflow_sources = files( 'Model' / 'GroundWaterFlow' / 'gwf3maw8.f90', 'Model' / 'GroundWaterFlow' / 'gwf3mvr8.f90', 'Model' / 'GroundWaterFlow' / 'gwf3npf8.f90', + 'Model' / 'GroundWaterFlow' / 'gwf3npf8idm.f90', 'Model' / 'GroundWaterFlow' / 'gwf3obs8.f90', 'Model' / 'GroundWaterFlow' / 'gwf3oc8.f90', 'Model' / 'GroundWaterFlow' / 'gwf3rch8.f90', @@ -64,6 +68,7 @@ modflow_sources = files( 'Model' / 'GroundWaterTransport' / 'gwt1apt1.f90', 'Model' / 'GroundWaterTransport' / 'gwt1cnc1.f90', 'Model' / 'GroundWaterTransport' / 'gwt1dsp.f90', + 'Model' / 'GroundWaterTransport' / 'gwt1dspidm.f90', 'Model' / 'GroundWaterTransport' / 'gwt1fmi1.f90', 'Model' / 'GroundWaterTransport' / 'gwt1ic1.f90', 'Model' / 'GroundWaterTransport' / 'gwt1ist1.f90', @@ -108,10 +113,19 @@ modflow_sources = files( 'Solution' / 'SolutionGroup.f90', 'Timing' / 'ats.f90', 'Timing' / 'tdis.f90', + 'Utilities' / 'Idm' / 'IdmLogger.f90', + 'Utilities' / 'Idm' / 'IdmMf6FileLoader.f90', + 'Utilities' / 'Idm' / 'ModflowInput.f90', + 'Utilities' / 'Idm' / 'InputDefinition.f90', + 'Utilities' / 'Idm' / 'InputDefinitionSelector.f90', + 'Utilities' / 'Idm' / 'LoadMf6FileType.f90', + 'Utilities' / 'Idm' / 'StructArray.f90', + 'Utilities' / 'Idm' / 'StructVector.f90', 'Utilities' / 'Memory' / 'Memory.f90', 'Utilities' / 'Memory' / 'MemoryHelper.f90', 'Utilities' / 'Memory' / 'MemoryList.f90', 'Utilities' / 'Memory' / 'MemoryManager.f90', + 'Utilities' / 'Memory' / 'MemoryManagerExt.f90', 'Utilities' / 'Memory' / 'MemorySetHandler.f90', 'Utilities' / 'Observation' / 'Obs3.f90', 'Utilities' / 'Observation' / 'ObsContainer.f90', diff --git a/utils/idmloader/README.md b/utils/idmloader/README.md new file mode 100644 index 00000000000..300d55e9811 --- /dev/null +++ b/utils/idmloader/README.md @@ -0,0 +1,3 @@ +# idmloader + +This is a placeholder for the idmloader utility, a standalone tool that populates input memory paths from a supported input source. diff --git a/utils/idmloader/scripts/dfn2f90.py b/utils/idmloader/scripts/dfn2f90.py new file mode 100644 index 00000000000..eb063e89fff --- /dev/null +++ b/utils/idmloader/scripts/dfn2f90.py @@ -0,0 +1,411 @@ +import os +import sys +import json +import yaml +from pathlib import Path +from enum import Enum + +MF6_LENVARNAME = 16 +F90_LINELEN = 82 + + +class Dfn2F90: + """generate idm f90 file from dfn file""" + + def __init__( + self, + dfnfspec: str = None, + ): + """Dfn290 init""" + + self._dfnfspec = dfnfspec + self._var_d = {} + self.component = "" + self.subcomponent = "" + self._param_str = "" + self._aggregate_str = "" + self._block_str = "" + self._param_varnames = [] + self._aggregate_varnames = [] + self._warnings = [] + + self.component, self.subcomponent = self._dfnfspec.stem.upper().split("-") + + print(f"\nprocessing dfn => {self._dfnfspec}") + self._set_var_d() + self._set_param_strs() + + def write_f90(self, odspec=None, gwt_name=False): + if gwt_name: + fname = Path(odspec, f"{self.component.lower()}1{self.subcomponent.lower()}idm.f90") + else: + fname = Path(odspec, f"{self.component.lower()}3{self.subcomponent.lower()}8idm.f90") + with open(fname, "w") as f: + + # file header + f.write(self._source_file_header(self.component, self.subcomponent)) + + # params + if len(self._param_varnames): + f.write(self._param_str) + f.write(self._source_params_header(self.component, self.subcomponent)) + f.write(" " + ", &\n ".join(self._param_varnames) + " &\n") + f.write(self._source_list_footer(self.component, self.subcomponent) + "\n") + else: + f.write(self._source_params_header(self.component, self.subcomponent)) + f.write(self._param_str.rsplit(",", 1)[0] + " &\n") + f.write(self._source_list_footer(self.component, self.subcomponent) + "\n") + + # aggregate types + if len(self._aggregate_varnames): + f.write(self._aggregate_str) + f.write(self._source_aggregates_header(self.component, self.subcomponent)) + f.write(" " + ", &\n ".join(self._aggregate_varnames) + " &\n") + f.write(self._source_list_footer(self.component, self.subcomponent) + "\n") + else: + f.write(self._source_aggregates_header(self.component, self.subcomponent)) + f.write(self._aggregate_str.rsplit(",", 1)[0] + " &\n") + f.write(self._source_list_footer(self.component, self.subcomponent) + "\n") + + # blocks + f.write(self._source_blocks_header(self.component, self.subcomponent)) + f.write(self._block_str.rsplit(",", 1)[0] + " &\n") + f.write(self._source_list_footer(self.component, self.subcomponent) + "\n") + + # file footer + f.write(self._source_file_footer(self.component, self.subcomponent)) + + def get_blocknames(self): + blocknames = [] + for var, bname in self._var_d: + if bname not in blocknames: + blocknames.append(bname) + return blocknames + + def warn(self): + if len(self._warnings): + sys.stderr.write("Warnings:\n") + for warn in self._warnings: + sys.stderr.write(" " + warn + "\n") + + def _set_var_d(self): + f = open(self._dfnfspec, "r") + lines = f.readlines() + f.close() + + vardict = {} + vd = {} + + for line in lines: + + # skip blank lines + if len(line.strip()) == 0: + if len(vd) > 0: + name = vd["name"] + if "block" in vd: + block = vd["block"] + key = (name, block) + else: + key = name + if name in vardict: + raise Exception( + "Variable already exists in dictionary: " + name + ) + vardict[key] = vd + vd = {} + continue + + # skip comments + if "#" in line.strip()[0]: + continue + + ll = line.strip().split() + if len(ll) > 1: + k = ll[0] + istart = line.index(" ") + v = line[istart:].strip() + if k in vd: + raise Exception("Attribute already exists in dictionary: " + k) + vd[k] = v + + if len(vd) > 0: + name = vd["name"] + if "block" in vd: + block = vd["block"] + key = (name, block) + else: + key = name + if name in vardict: + raise Exception("Variable already exists in dictionary: " + name) + vardict[key] = vd + + self._var_d = vardict + + def _construct_f90_block_statement( + self, blockname, required=False, aggregate=False + ): + f90statement = f" InputBlockDefinitionType( &\n" + f90statement += f" '{blockname}', & ! blockname\n" + if required: + f90statement += f" .true., & ! required\n" + else: + f90statement += f" .false., & ! required\n" + if aggregate: + f90statement += f" .true. & ! aggregate\n" + else: + f90statement += f" .false. & ! aggregate\n" + f90statement += f" ), &" + + return f90statement + + def _construct_f90_param_statement(self, tuple_list, basename, varname, aggregate=False): + vname = f"{basename.lower()}_{varname.lower()}" + if aggregate: + self._aggregate_varnames.append(vname) + else: + self._param_varnames.append(vname) + f90statement = f" type(InputParamDefinitionType), parameter :: &\n" + f90statement += f" {vname} = InputParamDefinitionType &\n" + f90statement += f" ( &\n" + for i, (value, varname) in enumerate(tuple_list): + comma = "," + if i + 1 == len(tuple_list): + comma = "" + v = f"'{value}'" + if value in [".false.", ".true."]: + v = f"{value}" + f90statement += f" {v}{comma} & ! {varname}\n" + f90statement += f" )\n" + + return f90statement + + def _set_param_strs(self): + blocknames = self.get_blocknames() + for b in blocknames: + self._set_blk_param_strs(b, self.component, self.subcomponent) + + if not self._param_str: + self._param_str += " InputParamDefinitionType ::, &" + + if not self._aggregate_str: + self._aggregate_str += " InputParamDefinitionType ::, &" + + if not self._block_str: + self._aggregate_str += " InputBlockDefinitionType ::, &" + + def _set_blk_param_strs(self, blockname, component, subcomponent): + print(" processing block params => ", blockname) + + required_l = None + required_l = [] + is_aggregate_blk = False + + # comment + s = f" ! {component} {subcomponent} {blockname.upper()}\n" + + r = ".true." + if blockname.upper() == "OPTIONS": + r = ".false." + + for k in self._var_d: + + varname, bname = k + if bname != blockname: + continue + + v = self._var_d[k] + + if "block_variable" in v and v["block_variable"].upper() == "TRUE": + # TODO: add to block defn type + continue + + c = component + sc = subcomponent + b = v["block"].upper() + + # variable name + vn = v["name"].upper() + mf6vn = vn + if "mf6internal" in v: + mf6vn = v["mf6internal"].upper() + + if len(mf6vn) > MF6_LENVARNAME: + self._warnings.append( + f"MF6_LENVARNAME({MF6_LENVARNAME}) exceeded: {component}-{subcomponent}-{blockname}: {mf6vn}" + ) + + t = v["type"].upper() + aggregate_t = t and t.startswith("RECARRAY") + + shape = "" + shapelist = [] + if "shape" in v: + shape = v["shape"] + shape = shape.replace("(", "") + shape = shape.replace(")", "") + shape = shape.upper() + shapelist = shape.strip().split() + ndim = len(shapelist) + + if t == "DOUBLE PRECISION": + t = "DOUBLE" + if shape != "" and not aggregate_t and (t == "DOUBLE" or t == "INTEGER"): + t = f"{t}{ndim}D" + + r = ".true." + if "optional" in v: + if v["optional"] == "true": + r = ".false." + else: + r = ".true." + is_required_blk = True + + inrec = ".false." + if "in_record" in v: + if v["in_record"] == "true": + inrec = ".true." + else: + inrec = ".false." + + preserve_case = ".false." + if "preserve_case" in v: + if v["preserve_case"] == "true": + preserve_case = ".true." + else: + preserve_case = ".false." + + layered = ".false." + if "layered" in v: + if v["layered"] == "true": + layered = ".true." + else: + layered = ".false." + + required_l.append(r) + tuple_list = [ + (c, "component"), + (sc, "subcomponent"), + (b, "block"), + (vn, "tag name"), + (mf6vn, "fortran variable"), + (t, "type"), + (shape, "shape"), + (r, "required"), + (inrec, "multi-record"), + (preserve_case, "preserve case"), + (layered, "layered"), + ] + + # assumes recarray type appears before and member + # parameter descriptions in dfn file, adjust + # if necessary + if aggregate_t: + self._aggregate_str += ( + self._construct_f90_param_statement(tuple_list, f"{component}{subcomponent}", mf6vn, True) + "\n" + ) + is_aggregate_blk = True + if not shape: + self._warnings.append( + f"Aggregate type found with no shape: {component}-{subcomponent}-{blockname}: {mf6vn}" + ) + + else: + self._param_str += ( + self._construct_f90_param_statement(tuple_list, f"{component}{subcomponent}", mf6vn) + "\n" + ) + + self._block_str += ( + self._construct_f90_block_statement( + blockname.upper(), + required=(".true." in required_l), + aggregate=is_aggregate_blk, + ) + + "\n" + ) + + def _source_file_header(self, component, subcomponent): + s = f"module {component.title()}{subcomponent.title()}InputModule" + "\n" + s += ( + " use InputDefinitionModule, only: InputParamDefinitionType, &" + + "\n" + + " InputBlockDefinitionType" + + "\n" + ) + s += " private" + "\n" + s += ( + f" public {component.lower()}_{subcomponent.lower()}_param_definitions" + + "\n" + ) + s += ( + f" public {component.lower()}_{subcomponent.lower()}_aggregate_definitions" + + "\n" + ) + s += ( + f" public {component.lower()}_{subcomponent.lower()}_block_definitions" + + "\n\n" + ) + return s + + def _source_params_header(self, component, subcomponent): + s = ( + f" type(InputParamDefinitionType), parameter :: &" + + "\n" + + f" {component.lower()}_{subcomponent.lower()}_param_definitions(*) = &" + + "\n" + ) + s += " [ &" + "\n" + return s + + def _source_aggregates_header(self, component, subcomponent): + s = ( + f" type(InputParamDefinitionType), parameter :: &" + + "\n" + + f" {component.lower()}_{subcomponent.lower()}_aggregate_definitions(*) = &" + + "\n" + ) + s += " [ &" + "\n" + return s + + def _source_blocks_header(self, component, subcomponent): + s = ( + f" type(InputBlockDefinitionType), parameter :: &" + + "\n" + + f" {component.lower()}_{subcomponent.lower()}_block_definitions(*) = &" + + "\n" + ) + s += " [ &" + "\n" + return s + + def _source_list_footer(self, component, subcomponent): + s = " ]" + "\n" + return s + + def _source_file_footer(self, component, subcomponent): + s = f"end module {component.title()}{subcomponent.title()}InputModule" + "\n" + return s + + +if __name__ == "__main__": + + gwf_dfns = [ + Path("../../../doc/mf6io/mf6ivar/dfn", "gwf-dis.dfn"), + Path("../../../doc/mf6io/mf6ivar/dfn", "gwf-disu.dfn"), + Path("../../../doc/mf6io/mf6ivar/dfn", "gwf-disv.dfn"), + Path("../../../doc/mf6io/mf6ivar/dfn", "gwf-npf.dfn"), + ] + + for dfn in gwf_dfns: + converter = Dfn2F90(dfnfspec=dfn) + converter.write_f90(odspec=os.path.join("..", "..", "..", "src", "Model", "GroundWaterFlow")) + converter.warn() + + gwt_dfns = [ + Path("../../../doc/mf6io/mf6ivar/dfn", "gwt-dsp.dfn"), + ] + + for dfn in gwt_dfns: + converter = Dfn2F90(dfnfspec=dfn) + converter.write_f90(odspec=os.path.join("..", "..", "..", "src", "Model", "GroundWaterTransport"), gwt_name=True) + converter.warn() + + print("\n...done.") diff --git a/utils/mf5to6/make/makefile b/utils/mf5to6/make/makefile index 161a83f072d..9708dc02d99 100644 --- a/utils/mf5to6/make/makefile +++ b/utils/mf5to6/make/makefile @@ -5,10 +5,10 @@ include ./makedefaults # Define the source file directories SOURCEDIR1=../src -SOURCEDIR2=../src/NWT -SOURCEDIR3=../src/LGR -SOURCEDIR4=../src/Preproc -SOURCEDIR5=../src/MF2005 +SOURCEDIR2=../src/LGR +SOURCEDIR3=../src/MF2005 +SOURCEDIR4=../src/NWT +SOURCEDIR5=../src/Preproc SOURCEDIR6=../../../src/Utilities/Memory SOURCEDIR7=../../../src/Utilities/TimeSeries SOURCEDIR8=../../../src/Utilities