From ea5920a4e6e1505f0bc7352525298d14b8fe8377 Mon Sep 17 00:00:00 2001 From: langevin-usgs Date: Thu, 9 Apr 2020 12:58:11 -0500 Subject: [PATCH] Introduce end-of-line normalization (#386) --- .gitattributes | 15 + distribution/make-release.py | 740 +- doc/mf6io/mf6ivar/dfn/utl-tas.dfn | 230 +- doc/mf6io/mf6ivar/dfn/utl-ts.dfn | 346 +- .../mf6ivar/examples/sim-tdis-example.dat | 28 +- .../mf6ivar/examples/sln-ims-example.dat | 56 +- msvs/mf6.sln | 108 +- msvs/mf6.vfproj | 144 +- msvs/mf6bmi.sln | 104 +- msvs/mf6bmi.vfproj | 66 +- msvs/mf6core.vfproj | 324 +- pymake/excludefiles.txt | 8 +- src/Exchange/BaseExchange.f90 | 354 +- src/Exchange/GhostNode.f90 | 2116 +-- src/Exchange/GwfGwfExchange.f90 | 4346 ++--- src/Exchange/NumericalExchange.f90 | 1310 +- src/Model/BaseModel.f90 | 12 +- src/Model/Geometry/BaseGeometry.f90 | 200 +- src/Model/Geometry/CircularGeometry.f90 | 420 +- src/Model/Geometry/RectangularChGeometry.f90 | 506 +- src/Model/Geometry/RectangularGeometry.f90 | 404 +- src/Model/GroundWaterFlow/gwf3.f90 | 3070 ++-- src/Model/GroundWaterFlow/gwf3chd8.f90 | 942 +- src/Model/GroundWaterFlow/gwf3csub8.f90 | 14238 ++++++++-------- src/Model/GroundWaterFlow/gwf3dis8.f90 | 3834 ++--- src/Model/GroundWaterFlow/gwf3disu8.f90 | 3938 ++--- src/Model/GroundWaterFlow/gwf3disv8.f90 | 4398 ++--- src/Model/GroundWaterFlow/gwf3drn8.f90 | 724 +- src/Model/GroundWaterFlow/gwf3evt8.f90 | 2458 +-- src/Model/GroundWaterFlow/gwf3ghb8.f90 | 698 +- src/Model/GroundWaterFlow/gwf3hfb8.f90 | 1744 +- src/Model/GroundWaterFlow/gwf3ic8.f90 | 504 +- src/Model/GroundWaterFlow/gwf3lak8.f90 | 12444 +++++++------- src/Model/GroundWaterFlow/gwf3maw8.f90 | 8752 +++++----- src/Model/GroundWaterFlow/gwf3mvr8.f90 | 2484 +-- src/Model/GroundWaterFlow/gwf3npf8.f90 | 6958 ++++---- src/Model/GroundWaterFlow/gwf3oc8.f90 | 196 +- src/Model/GroundWaterFlow/gwf3rch8.f90 | 1810 +- src/Model/GroundWaterFlow/gwf3riv8.f90 | 762 +- src/Model/GroundWaterFlow/gwf3sfr8.f90 | 9688 +++++------ src/Model/GroundWaterFlow/gwf3sto8.f90 | 1890 +- src/Model/GroundWaterFlow/gwf3uzf8.f90 | 6976 ++++---- src/Model/GroundWaterFlow/gwf3wel8.f90 | 900 +- src/Model/ModelUtilities/BoundaryPackage.f90 | 3410 ++-- src/Model/ModelUtilities/Connections.f90 | 2712 +-- .../ModelUtilities/DiscretizationBase.f90 | 3092 ++-- src/Model/ModelUtilities/DisvGeom.f90 | 986 +- src/Model/ModelUtilities/Mover.f90 | 810 +- src/Model/ModelUtilities/PackageMover.f90 | 396 +- src/Model/ModelUtilities/UzfCellGroup.f90 | 4854 +++--- src/Model/ModelUtilities/Xt3dAlgorithm.f90 | 1064 +- src/Model/ModelUtilities/Xt3dInterface.f90 | 3526 ++-- src/Model/NumericalModel.f90 | 852 +- src/Model/NumericalPackage.f90 | 550 +- src/SimulationCreate.f90 | 1368 +- src/Solution/NumericalSolution.f90 | 5906 +++---- src/Solution/SolutionGroup.f90 | 454 +- .../SparseMatrixSolver/ims8linear.f90 | 5766 +++---- .../SparseMatrixSolver/ims8reordering.f90 | 3316 ++-- src/Timing/tdis.f90 | 1460 +- src/Utilities/ArrayHandlers.f90 | 748 +- src/Utilities/ArrayReaders.f90 | 128 +- src/Utilities/BlockParser.f90 | 866 +- src/Utilities/BudgetFileReader.f90 | 524 +- src/Utilities/BudgetObject.f90 | 1452 +- src/Utilities/BudgetTerm.f90 | 962 +- src/Utilities/Constants.f90 | 252 +- src/Utilities/DeferredStringObject.f90 | 20 +- src/Utilities/InputOutput.f90 | 4432 ++--- src/Utilities/Iunit.f90 | 344 +- src/Utilities/List.f90 | 14 +- src/Utilities/ListReader.f90 | 1546 +- src/Utilities/Memory/Memory.f90 | 12 +- src/Utilities/Memory/MemoryList.f90 | 102 +- src/Utilities/Memory/MemoryManager.f90 | 1044 +- src/Utilities/NameFile.f90 | 768 +- src/Utilities/Observation/Obs3.f90 | 2428 +-- src/Utilities/Observation/ObsContainer.f90 | 2 +- src/Utilities/Observation/ObsOutput.f90 | 2 +- src/Utilities/Observation/ObsUtility.f90 | 8 +- src/Utilities/Observation/Observe.f90 | 74 +- src/Utilities/OpenSpec.f90 | 102 +- src/Utilities/OutputControl/OutputControl.f90 | 962 +- .../OutputControl/OutputControlData.f90 | 686 +- .../OutputControl/PrintSaveManager.f90 | 562 +- src/Utilities/Sim.f90 | 1408 +- src/Utilities/SmoothingFunctions.f90 | 294 +- src/Utilities/Sparse.f90 | 6 +- src/Utilities/Table.f90 | 1870 +- src/Utilities/TableTerm.f90 | 648 +- src/Utilities/TimeSeries/TimeArraySeries.f90 | 1752 +- .../TimeSeries/TimeArraySeriesManager.f90 | 904 +- src/Utilities/TimeSeries/TimeSeries.f90 | 2930 ++-- .../TimeSeries/TimeSeriesManager.f90 | 1494 +- src/Utilities/Timer.f90 | 388 +- src/Utilities/comarg.f90 | 512 +- src/Utilities/compilerversion.fpp | 8 +- src/Utilities/genericutils.f90 | 522 +- src/Utilities/kind.f90 | 78 +- src/Utilities/sort.f90 | 242 +- src/mf6core.f90 | 652 +- src/mf6lists.f90 | 42 +- srcbmi/mf6bmi.f90 | 22 +- utils/mf5to6/msvs/mf5to6.sln | 44 +- utils/mf5to6/msvs/mf5to6.vfproj | 374 +- utils/mf5to6/src/Lake.f90 | 4 +- utils/mf5to6/src/MF2005/GwfLakSubs.f | 4250 ++--- utils/mf5to6/src/Model.f90 | 28 +- utils/mf5to6/src/ModelConverter.f90 | 2 +- utils/mf5to6/src/MultiLayerObsModule.f90 | 2 +- utils/mf5to6/src/NpfWriter.f90 | 1444 +- utils/mf5to6/src/Preproc/Global.f90 | 26 +- utils/mf5to6/src/Preproc/GlobalVariables.f90 | 2 +- utils/mf5to6/src/Preproc/ObsBlock.f90 | 2 +- utils/mf5to6/src/Preproc/SimListVariables.f90 | 4 +- utils/mf5to6/src/UzfPackageWriter.f90 | 1488 +- utils/zonebudget/msvs/zonebudget.sln | 44 +- utils/zonebudget/msvs/zonebudget.vfproj | 98 +- utils/zonebudget/pymake/extrafiles.txt | 28 +- utils/zonebudget/src/budgetdata.f90 | 402 +- utils/zonebudget/src/grb.f90 | 332 +- utils/zonebudget/src/zbud6.f90 | 762 +- utils/zonebudget/src/zone.f90 | 1010 +- utils/zonebudget/src/zoneoutput.f90 | 486 +- 124 files changed, 92213 insertions(+), 92198 deletions(-) create mode 100644 .gitattributes diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 00000000000..e5e837d1e7f --- /dev/null +++ b/.gitattributes @@ -0,0 +1,15 @@ +############################################################################### +# Set default behavior to automatically normalize line endings. +############################################################################### +* text=auto + +############################################################################### +# Set the merge driver for project and solution files +# +*.sln text eol=crlf +*.vfproj text eol=crlf + +# Denote all files that are truly binary and should not be modified. +*.png binary +*.jpg binary +*.pdf binary diff --git a/distribution/make-release.py b/distribution/make-release.py index 6192f3def28..0d57e26c3f1 100644 --- a/distribution/make-release.py +++ b/distribution/make-release.py @@ -1,370 +1,370 @@ -#!/usr/bin/python - -from __future__ import print_function -import subprocess -import os -import sys -import datetime -import json -from collections import OrderedDict - -# update files and paths so that there are the same number of -# path and file entries in the paths and files list. Enter '.' -# as the path if the file is in the root repository directory -paths = ['../', '../doc', '../', '../', - '../', '../src/Utilities'] -files = ['version.txt', 'version.tex', 'README.md', 'DISCLAIMER.md', - 'code.json', 'version.f90'] - -# check that there are the same number of entries in files and paths -if len(paths) != len(files): - msg = 'The number of entries in paths ' + \ - '({}) must equal '.format(len(paths)) + \ - 'the number of entries in files ({})'.format(len(files)) - assert False, msg - -prod = 'MODFLOW 6' -repo = 'MODFLOW-USGS/modflow6.git' - -now = datetime.datetime.now() - -approved = '''Disclaimer ----------- - -This software has been approved for release by the U.S. Geological Survey -(USGS). Although the software has been subjected to rigorous review, the USGS -reserves the right to update the software as needed pursuant to further analysis -and review. No warranty, expressed or implied, is made by the USGS or the U.S. -Government as to the functionality of the software and related material nor -shall the fact of release constitute any such warranty. Furthermore, the -software is released on condition that neither the USGS nor the U.S. Government -shall be held liable for any damages resulting from its authorized or -unauthorized use. -''' - -preliminary = '''Disclaimer ----------- - -This software is preliminary or provisional and is subject to revision. It is -being provided to meet the need for timely best science. The software has not -received final approval by the U.S. Geological Survey (USGS). No warranty, -expressed or implied, is made by the USGS or the U.S. Government as to the -functionality of the software and related material nor shall the fact of release -constitute any such warranty. The software is provided on the condition that -neither the USGS nor the U.S. Government shall be held liable for any damages -resulting from the authorized or unauthorized use of the software. -''' - -approvedfmt = ''' character(len=*), parameter :: FMTDISCLAIMER = & - "(/, & - &'This software has been approved for release by the U.S. Geological ',/, & - &'Survey (USGS). Although the software has been subjected to rigorous ',/, & - &'review, the USGS reserves the right to update the software as needed ',/, & - &'pursuant to further analysis and review. No warranty, expressed or ',/, & - &'implied, is made by the USGS or the U.S. Government as to the ',/, & - &'functionality of the software and related material nor shall the ',/, & - &'fact of release constitute any such warranty. Furthermore, the ',/, & - &'software is released on condition that neither the USGS nor the U.S. ',/, & - &'Government shall be held liable for any damages resulting from its ',/, & - &'authorized or unauthorized use. Also refer to the USGS Water ',/, & - &'Resources Software User Rights Notice for complete use, copyright, ',/, & - &'and distribution information.',/)"''' - -preliminaryfmt = ''' character(len=*), parameter :: FMTDISCLAIMER = & - "(/, & - &'This software is preliminary or provisional and is subject to ',/, & - &'revision. It is being provided to meet the need for timely best ',/, & - &'science. The software has not received final approval by the U.S. ',/, & - &'Geological Survey (USGS). No warranty, expressed or implied, is made ',/, & - &'by the USGS or the U.S. Government as to the functionality of the ',/, & - &'software and related material nor shall the fact of release ',/, & - &'constitute any such warranty. The software is provided on the ',/, & - &'condition that neither the USGS nor the U.S. Government shall be held ',/,& - &'liable for any damages resulting from the authorized or unauthorized ',/, & - &'use of the software.',/)"''' - - -def get_disclaimer(): - # get current branch - branch = get_branch() - - if 'release' in branch.lower() or 'master' in branch.lower(): - disclaimer = approved - is_approved = True - else: - disclaimer = preliminary - is_approved = False - - return is_approved, disclaimer - - -def get_disclaimerfmt(): - # get current branch - branch = get_branch() - - if 'release' in branch.lower() or 'master' in branch.lower(): - disclaimer = approvedfmt - is_approved = True - else: - disclaimer = preliminaryfmt - is_approved = False - - return is_approved, disclaimer - - -def get_branch(): - branch = None - - # determine if branch defined on command line - for argv in sys.argv: - if 'master' in argv: - branch = 'master' - elif 'develop' in argv.lower(): - branch = 'develop' - - if branch is None: - try: - # determine current branch - b = subprocess.Popen(("git", "status"), - stdout=subprocess.PIPE, - stderr=subprocess.STDOUT).communicate()[0] - if isinstance(b, bytes): - b = b.decode('utf-8') - - for line in b.splitlines(): - if 'On branch' in line: - branch = line.replace('On branch ', '').rstrip() - - if branch is not None: - if 'master' in branch or 'release' in branch: - branch = 'master' - else: - branch = 'develop' - - except: - msg = 'Could not determine current branch. Is git installed?' - raise ValueError(msg) - - return branch - - -def get_version_str(v0, v1, v2): - version_type = ('{}'.format(v0), - '{}'.format(v1), - '{}'.format(v2)) - version = '.'.join(version_type) - return version - - -def get_tag(v0, v1, v2): - tag_type = ('{}'.format(v0), - '{}'.format(v1), - '{}'.format(v2)) - tag = '.'.join(tag_type) - return tag - - -def update_version(): - try: - fpth = os.path.join(paths[0], files[0]) - - vmajor = 0 - vminor = 0 - vmicro = 0 - lines = [line.rstrip('\n') for line in open(fpth, 'r')] - for line in lines: - t = line.split() - if 'major =' in line: - vmajor = int(t[2]) - elif 'minor =' in line: - vminor = int(t[2]) - elif 'micro =' in line: - vmicro = int(t[2]) - except: - msg = 'There was a problem updating the version file' - raise IOError(msg) - - try: - # write new version file - f = open(fpth, 'w') - f.write('# {} version file automatically '.format(prod) + - 'created using...{}\n'.format(os.path.basename(__file__))) - f.write('# created on...' + - '{}\n'.format(now.strftime("%B %d, %Y %H:%M:%S"))) - f.write('\n') - f.write('major = {}\n'.format(vmajor)) - f.write('minor = {}\n'.format(vminor)) - f.write('micro = {}\n'.format(vmicro)) - f.write("__version__ = '{:d}.{:d}.{:d}'.format(major, minor, micro)\n") - f.close() - print('Successfully updated version.py') - - # update latex version file - version = get_version_str(vmajor, vminor, vmicro) - pth = os.path.join(paths[1], files[1]) - f = open(pth, 'w') - line = '\\newcommand{\\modflowversion}{mf' + \ - '{}'.format(version) + '}' - f.write('{}\n'.format(line)) - line = '\\newcommand{\\modflowdate}{' + \ - '{}'.format(now.strftime('%B %d, %Y')) + \ - '}' - f.write('{}\n'.format(line)) - line = '\\newcommand{\\currentmodflowversion}' + \ - '{Version \\modflowversion---\\modflowdate}' - f.write('{}\n'.format(line)) - f.close() - print('Succesfully updated {}'.format(files[1])) - except: - msg = 'There was a problem updating the version file' - raise IOError(msg) - - # update version.f90 - update_mf6_version(vmajor, vminor, vmicro) - - # update README.md with new version information - update_readme_markdown(vmajor, vminor, vmicro) - - # update code.json - update_codejson(vmajor, vminor, vmicro) - - -def update_mf6_version(vmajor, vminor, vmicro): - branch = get_branch() - - # create version - version = get_tag(vmajor, vminor, vmicro) - idevelopmode = 0 - if 'release' not in branch.lower() and 'master' not in branch.lower(): - idevelopmode = 1 - - # develop date text - sdate = now.strftime('%m/%d/%Y') - - # create disclaimer text - is_approved, disclaimerfmt = get_disclaimerfmt() - - # read version.f90 into memory - fpth = os.path.join(paths[5], files[5]) - with open(fpth, 'r') as file: - lines = [line.rstrip() for line in file] - - # rewrite version.f90 - skip = False - f = open(fpth, 'w') - for line in lines: - # skip all of the disclaimer text - if skip: - if ',/)"' in line: - skip = False - continue - elif 'IDEVELOPMODE' in line: - line = ' integer(I4B), parameter :: ' + \ - 'IDEVELOPMODE = {}'.format(idevelopmode) - elif 'VERSION' in line: - line = " character(len=40), parameter :: " + \ - "VERSION = '{} {}'".format(version, sdate) - elif 'FMTDISCLAIMER' in line: - line = disclaimerfmt - skip = True - f.write('{}\n'.format(line)) - f.close() - - return - - -def update_readme_markdown(vmajor, vminor, vmicro): - - # get branch - branch = get_branch() - - # create version - version = get_tag(vmajor, vminor, vmicro) - - # create disclaimer text - is_approved, disclaimer = get_disclaimer() - - if is_approved: - sb = '' - else: - sb = ' release candidate' - - # read README.md into memory - fpth = os.path.join(paths[2], files[2]) - with open(fpth, 'r') as file: - lines = [line.rstrip() for line in file] - - # rewrite README.md - terminate = False - f = open(fpth, 'w') - for line in lines: - if '### Version ' in line: - line = '### Version {}'.format(version) - if 'develop' in branch: - line += sb - elif '[Build Status]' in line: - line = '[![Build Status](https://travis-ci.org/MODFLOW-USGS/' + \ - 'modflow6.svg?branch={})]'.format(branch) + \ - '(https://travis-ci.org/MODFLOW-USGS/modflow6)' - elif 'https://doi.org/10.5066/F76Q1VQV' in line: - line = '[Langevin, C.D., Hughes, J.D., ' + \ - 'Banta, E.R., Provost, A.M., ' + \ - 'Niswonger, R.G., and Panday, Sorab, ' + \ - '{}, '.format(now.year) + \ - 'MODFLOW 6 Modular Hydrologic Model ' + \ - 'version {}{}: '.format(version, sb) + \ - 'U.S. Geological Survey Software Release, ' + \ - '{}, '.format(now.strftime('%d %B %Y')) + \ - 'https://doi.org/10.5066/F76Q1VQV]' + \ - '(https://doi.org/10.5066/F76Q1VQV)' - elif 'Disclaimer' in line: - line = disclaimer - terminate = True - f.write('{}\n'.format(line)) - if terminate: - break - f.close() - - # write disclaimer markdown file - fpth = os.path.join(paths[3], files[3]) - f = open(fpth, 'w') - f.write(disclaimer) - f.close() - - return - - -def update_codejson(vmajor, vminor, vmicro): - # define json filename - json_fname = os.path.join(paths[4], files[4]) - - # get branch - branch = get_branch() - - # create version - version = get_tag(vmajor, vminor, vmicro) - - # load and modify json file - with open(json_fname, 'r') as f: - data = json.load(f, object_pairs_hook=OrderedDict) - - # modify the json file data - sdate = now.strftime('%Y-%m-%d') - data[0]['date']['metadataLastUpdated'] = sdate - if 'release' in branch.lower() or 'master' in branch.lower(): - data[0]['version'] = version - data[0]['status'] = 'Production' - else: - data[0]['version'] = version - data[0]['status'] = 'Release Candidate' - - # rewrite the json file - with open(json_fname, 'w') as f: - json.dump(data, f, indent=4) - f.write('\n') - - return - - -if __name__ == "__main__": - update_version() +#!/usr/bin/python + +from __future__ import print_function +import subprocess +import os +import sys +import datetime +import json +from collections import OrderedDict + +# update files and paths so that there are the same number of +# path and file entries in the paths and files list. Enter '.' +# as the path if the file is in the root repository directory +paths = ['../', '../doc', '../', '../', + '../', '../src/Utilities'] +files = ['version.txt', 'version.tex', 'README.md', 'DISCLAIMER.md', + 'code.json', 'version.f90'] + +# check that there are the same number of entries in files and paths +if len(paths) != len(files): + msg = 'The number of entries in paths ' + \ + '({}) must equal '.format(len(paths)) + \ + 'the number of entries in files ({})'.format(len(files)) + assert False, msg + +prod = 'MODFLOW 6' +repo = 'MODFLOW-USGS/modflow6.git' + +now = datetime.datetime.now() + +approved = '''Disclaimer +---------- + +This software has been approved for release by the U.S. Geological Survey +(USGS). Although the software has been subjected to rigorous review, the USGS +reserves the right to update the software as needed pursuant to further analysis +and review. No warranty, expressed or implied, is made by the USGS or the U.S. +Government as to the functionality of the software and related material nor +shall the fact of release constitute any such warranty. Furthermore, the +software is released on condition that neither the USGS nor the U.S. Government +shall be held liable for any damages resulting from its authorized or +unauthorized use. +''' + +preliminary = '''Disclaimer +---------- + +This software is preliminary or provisional and is subject to revision. It is +being provided to meet the need for timely best science. The software has not +received final approval by the U.S. Geological Survey (USGS). No warranty, +expressed or implied, is made by the USGS or the U.S. Government as to the +functionality of the software and related material nor shall the fact of release +constitute any such warranty. The software is provided on the condition that +neither the USGS nor the U.S. Government shall be held liable for any damages +resulting from the authorized or unauthorized use of the software. +''' + +approvedfmt = ''' character(len=*), parameter :: FMTDISCLAIMER = & + "(/, & + &'This software has been approved for release by the U.S. Geological ',/, & + &'Survey (USGS). Although the software has been subjected to rigorous ',/, & + &'review, the USGS reserves the right to update the software as needed ',/, & + &'pursuant to further analysis and review. No warranty, expressed or ',/, & + &'implied, is made by the USGS or the U.S. Government as to the ',/, & + &'functionality of the software and related material nor shall the ',/, & + &'fact of release constitute any such warranty. Furthermore, the ',/, & + &'software is released on condition that neither the USGS nor the U.S. ',/, & + &'Government shall be held liable for any damages resulting from its ',/, & + &'authorized or unauthorized use. Also refer to the USGS Water ',/, & + &'Resources Software User Rights Notice for complete use, copyright, ',/, & + &'and distribution information.',/)"''' + +preliminaryfmt = ''' character(len=*), parameter :: FMTDISCLAIMER = & + "(/, & + &'This software is preliminary or provisional and is subject to ',/, & + &'revision. It is being provided to meet the need for timely best ',/, & + &'science. The software has not received final approval by the U.S. ',/, & + &'Geological Survey (USGS). No warranty, expressed or implied, is made ',/, & + &'by the USGS or the U.S. Government as to the functionality of the ',/, & + &'software and related material nor shall the fact of release ',/, & + &'constitute any such warranty. The software is provided on the ',/, & + &'condition that neither the USGS nor the U.S. Government shall be held ',/,& + &'liable for any damages resulting from the authorized or unauthorized ',/, & + &'use of the software.',/)"''' + + +def get_disclaimer(): + # get current branch + branch = get_branch() + + if 'release' in branch.lower() or 'master' in branch.lower(): + disclaimer = approved + is_approved = True + else: + disclaimer = preliminary + is_approved = False + + return is_approved, disclaimer + + +def get_disclaimerfmt(): + # get current branch + branch = get_branch() + + if 'release' in branch.lower() or 'master' in branch.lower(): + disclaimer = approvedfmt + is_approved = True + else: + disclaimer = preliminaryfmt + is_approved = False + + return is_approved, disclaimer + + +def get_branch(): + branch = None + + # determine if branch defined on command line + for argv in sys.argv: + if 'master' in argv: + branch = 'master' + elif 'develop' in argv.lower(): + branch = 'develop' + + if branch is None: + try: + # determine current branch + b = subprocess.Popen(("git", "status"), + stdout=subprocess.PIPE, + stderr=subprocess.STDOUT).communicate()[0] + if isinstance(b, bytes): + b = b.decode('utf-8') + + for line in b.splitlines(): + if 'On branch' in line: + branch = line.replace('On branch ', '').rstrip() + + if branch is not None: + if 'master' in branch or 'release' in branch: + branch = 'master' + else: + branch = 'develop' + + except: + msg = 'Could not determine current branch. Is git installed?' + raise ValueError(msg) + + return branch + + +def get_version_str(v0, v1, v2): + version_type = ('{}'.format(v0), + '{}'.format(v1), + '{}'.format(v2)) + version = '.'.join(version_type) + return version + + +def get_tag(v0, v1, v2): + tag_type = ('{}'.format(v0), + '{}'.format(v1), + '{}'.format(v2)) + tag = '.'.join(tag_type) + return tag + + +def update_version(): + try: + fpth = os.path.join(paths[0], files[0]) + + vmajor = 0 + vminor = 0 + vmicro = 0 + lines = [line.rstrip('\n') for line in open(fpth, 'r')] + for line in lines: + t = line.split() + if 'major =' in line: + vmajor = int(t[2]) + elif 'minor =' in line: + vminor = int(t[2]) + elif 'micro =' in line: + vmicro = int(t[2]) + except: + msg = 'There was a problem updating the version file' + raise IOError(msg) + + try: + # write new version file + f = open(fpth, 'w') + f.write('# {} version file automatically '.format(prod) + + 'created using...{}\n'.format(os.path.basename(__file__))) + f.write('# created on...' + + '{}\n'.format(now.strftime("%B %d, %Y %H:%M:%S"))) + f.write('\n') + f.write('major = {}\n'.format(vmajor)) + f.write('minor = {}\n'.format(vminor)) + f.write('micro = {}\n'.format(vmicro)) + f.write("__version__ = '{:d}.{:d}.{:d}'.format(major, minor, micro)\n") + f.close() + print('Successfully updated version.py') + + # update latex version file + version = get_version_str(vmajor, vminor, vmicro) + pth = os.path.join(paths[1], files[1]) + f = open(pth, 'w') + line = '\\newcommand{\\modflowversion}{mf' + \ + '{}'.format(version) + '}' + f.write('{}\n'.format(line)) + line = '\\newcommand{\\modflowdate}{' + \ + '{}'.format(now.strftime('%B %d, %Y')) + \ + '}' + f.write('{}\n'.format(line)) + line = '\\newcommand{\\currentmodflowversion}' + \ + '{Version \\modflowversion---\\modflowdate}' + f.write('{}\n'.format(line)) + f.close() + print('Succesfully updated {}'.format(files[1])) + except: + msg = 'There was a problem updating the version file' + raise IOError(msg) + + # update version.f90 + update_mf6_version(vmajor, vminor, vmicro) + + # update README.md with new version information + update_readme_markdown(vmajor, vminor, vmicro) + + # update code.json + update_codejson(vmajor, vminor, vmicro) + + +def update_mf6_version(vmajor, vminor, vmicro): + branch = get_branch() + + # create version + version = get_tag(vmajor, vminor, vmicro) + idevelopmode = 0 + if 'release' not in branch.lower() and 'master' not in branch.lower(): + idevelopmode = 1 + + # develop date text + sdate = now.strftime('%m/%d/%Y') + + # create disclaimer text + is_approved, disclaimerfmt = get_disclaimerfmt() + + # read version.f90 into memory + fpth = os.path.join(paths[5], files[5]) + with open(fpth, 'r') as file: + lines = [line.rstrip() for line in file] + + # rewrite version.f90 + skip = False + f = open(fpth, 'w') + for line in lines: + # skip all of the disclaimer text + if skip: + if ',/)"' in line: + skip = False + continue + elif 'IDEVELOPMODE' in line: + line = ' integer(I4B), parameter :: ' + \ + 'IDEVELOPMODE = {}'.format(idevelopmode) + elif 'VERSION' in line: + line = " character(len=40), parameter :: " + \ + "VERSION = '{} {}'".format(version, sdate) + elif 'FMTDISCLAIMER' in line: + line = disclaimerfmt + skip = True + f.write('{}\n'.format(line)) + f.close() + + return + + +def update_readme_markdown(vmajor, vminor, vmicro): + + # get branch + branch = get_branch() + + # create version + version = get_tag(vmajor, vminor, vmicro) + + # create disclaimer text + is_approved, disclaimer = get_disclaimer() + + if is_approved: + sb = '' + else: + sb = ' release candidate' + + # read README.md into memory + fpth = os.path.join(paths[2], files[2]) + with open(fpth, 'r') as file: + lines = [line.rstrip() for line in file] + + # rewrite README.md + terminate = False + f = open(fpth, 'w') + for line in lines: + if '### Version ' in line: + line = '### Version {}'.format(version) + if 'develop' in branch: + line += sb + elif '[Build Status]' in line: + line = '[![Build Status](https://travis-ci.org/MODFLOW-USGS/' + \ + 'modflow6.svg?branch={})]'.format(branch) + \ + '(https://travis-ci.org/MODFLOW-USGS/modflow6)' + elif 'https://doi.org/10.5066/F76Q1VQV' in line: + line = '[Langevin, C.D., Hughes, J.D., ' + \ + 'Banta, E.R., Provost, A.M., ' + \ + 'Niswonger, R.G., and Panday, Sorab, ' + \ + '{}, '.format(now.year) + \ + 'MODFLOW 6 Modular Hydrologic Model ' + \ + 'version {}{}: '.format(version, sb) + \ + 'U.S. Geological Survey Software Release, ' + \ + '{}, '.format(now.strftime('%d %B %Y')) + \ + 'https://doi.org/10.5066/F76Q1VQV]' + \ + '(https://doi.org/10.5066/F76Q1VQV)' + elif 'Disclaimer' in line: + line = disclaimer + terminate = True + f.write('{}\n'.format(line)) + if terminate: + break + f.close() + + # write disclaimer markdown file + fpth = os.path.join(paths[3], files[3]) + f = open(fpth, 'w') + f.write(disclaimer) + f.close() + + return + + +def update_codejson(vmajor, vminor, vmicro): + # define json filename + json_fname = os.path.join(paths[4], files[4]) + + # get branch + branch = get_branch() + + # create version + version = get_tag(vmajor, vminor, vmicro) + + # load and modify json file + with open(json_fname, 'r') as f: + data = json.load(f, object_pairs_hook=OrderedDict) + + # modify the json file data + sdate = now.strftime('%Y-%m-%d') + data[0]['date']['metadataLastUpdated'] = sdate + if 'release' in branch.lower() or 'master' in branch.lower(): + data[0]['version'] = version + data[0]['status'] = 'Production' + else: + data[0]['version'] = version + data[0]['status'] = 'Release Candidate' + + # rewrite the json file + with open(json_fname, 'w') as f: + json.dump(data, f, indent=4) + f.write('\n') + + return + + +if __name__ == "__main__": + update_version() diff --git a/doc/mf6io/mf6ivar/dfn/utl-tas.dfn b/doc/mf6io/mf6ivar/dfn/utl-tas.dfn index 2a90f1c4684..b3c734c6387 100644 --- a/doc/mf6io/mf6ivar/dfn/utl-tas.dfn +++ b/doc/mf6io/mf6ivar/dfn/utl-tas.dfn @@ -1,116 +1,116 @@ -# --------------------- gwf ts attributes --------------------- - -block attributes -name time_series_namerecord -type record name time_series_name -shape -reader urword -tagged false -optional false -longname -description xxx - -block attributes -name name -type keyword -shape -reader urword -optional false -longname -description xxx - -block attributes -name time_series_name -type string -shape any1d -tagged false -reader urword -optional false -longname -description Name by which a package references a particular time-array series. The name must be unique among all time-array series used in a package. - -block attributes -name interpolation_methodrecord -type record method interpolation_method -shape -reader urword -tagged false -optional true -longname -description xxx - -block attributes -name method -type keyword -shape -reader urword -optional false -longname -description xxx - -block attributes -name interpolation_method -type string -valid stepwise linear linearend -shape -tagged false -reader urword -optional false -longname -description Interpolation method, which is either STEPWISE or LINEAR. - -block attributes -name sfacrecord -type record sfac sfacval -shape -reader urword -tagged true -optional true -longname -description xxx - -block attributes -name sfac -type keyword -shape -reader urword -optional false -longname -description xxx - -block attributes -name sfacval -type double precision -shape time_series_name -tagged false -reader urword -optional false -longname -description Scale factor, which will multiply all array values in time series. SFAC is an optional attribute; if omitted, SFAC = 1.0. - -# --------------------- gwf ts time --------------------- - -block time -name time_from_model_start -type double precision -block_variable True -in_record true -shape -tagged false -valid -reader urword -optional false -longname -description A numeric time relative to the start of the simulation, in the time unit used in the simulation. Times must be strictly increasing. - -block time -name tas_array -type double precision -tagged false -just_data true -shape (unknown) -reader readarray -optional false -repeating true -longname +# --------------------- gwf ts attributes --------------------- + +block attributes +name time_series_namerecord +type record name time_series_name +shape +reader urword +tagged false +optional false +longname +description xxx + +block attributes +name name +type keyword +shape +reader urword +optional false +longname +description xxx + +block attributes +name time_series_name +type string +shape any1d +tagged false +reader urword +optional false +longname +description Name by which a package references a particular time-array series. The name must be unique among all time-array series used in a package. + +block attributes +name interpolation_methodrecord +type record method interpolation_method +shape +reader urword +tagged false +optional true +longname +description xxx + +block attributes +name method +type keyword +shape +reader urword +optional false +longname +description xxx + +block attributes +name interpolation_method +type string +valid stepwise linear linearend +shape +tagged false +reader urword +optional false +longname +description Interpolation method, which is either STEPWISE or LINEAR. + +block attributes +name sfacrecord +type record sfac sfacval +shape +reader urword +tagged true +optional true +longname +description xxx + +block attributes +name sfac +type keyword +shape +reader urword +optional false +longname +description xxx + +block attributes +name sfacval +type double precision +shape time_series_name +tagged false +reader urword +optional false +longname +description Scale factor, which will multiply all array values in time series. SFAC is an optional attribute; if omitted, SFAC = 1.0. + +# --------------------- gwf ts time --------------------- + +block time +name time_from_model_start +type double precision +block_variable True +in_record true +shape +tagged false +valid +reader urword +optional false +longname +description A numeric time relative to the start of the simulation, in the time unit used in the simulation. Times must be strictly increasing. + +block time +name tas_array +type double precision +tagged false +just_data true +shape (unknown) +reader readarray +optional false +repeating true +longname description An array of numeric, floating-point values, or a constant value, readable by the U2DREL array-reading utility. \ No newline at end of file diff --git a/doc/mf6io/mf6ivar/dfn/utl-ts.dfn b/doc/mf6io/mf6ivar/dfn/utl-ts.dfn index 69316d7a17b..5f584c59b34 100644 --- a/doc/mf6io/mf6ivar/dfn/utl-ts.dfn +++ b/doc/mf6io/mf6ivar/dfn/utl-ts.dfn @@ -1,173 +1,173 @@ -# --------------------- gwf ts attributes --------------------- - -block attributes -name time_series_namerecord -type record names time_series_names -shape -reader urword -tagged false -optional false -longname -description xxx - -block attributes -name names -other_names name -type keyword -shape -reader urword -optional false -longname -description xxx - -block attributes -name time_series_names -type string -shape any1d -tagged false -reader urword -optional false -longname -description Name by which a package references a particular time-array series. The name must be unique among all time-array series used in a package. - -block attributes -name interpolation_methodrecord -type record methods interpolation_method -shape -reader urword -tagged false -optional true -longname -description xxx - -block attributes -name methods -type keyword -shape -reader urword -optional false -longname -description xxx - -block attributes -name interpolation_method -type string -valid stepwise linear linearend -shape time_series_names -tagged false -reader urword -optional false -longname -description Interpolation method, which is either STEPWISE or LINEAR. - -block attributes -name interpolation_methodrecord_single -type record method interpolation_method_single -shape -reader urword -tagged false -optional true -longname -description xxx - -block attributes -name method -type keyword -shape -reader urword -optional false -longname -description xxx - -block attributes -name interpolation_method_single -type string -valid stepwise linear linearend -shape -tagged false -reader urword -optional false -longname -description Interpolation method, which is either STEPWISE or LINEAR. - -block attributes -name sfacrecord -type record sfacs sfacval -shape -reader urword -tagged true -optional true -longname -description xxx - -block attributes -name sfacs -type keyword -shape -reader urword -optional false -longname -description xxx - -block attributes -name sfacval -type double precision -shape - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/msvs/mf6bmi.sln b/msvs/mf6bmi.sln index 175f9500db2..3056cb4478e 100644 --- a/msvs/mf6bmi.sln +++ b/msvs/mf6bmi.sln @@ -1,52 +1,52 @@ - -Microsoft Visual Studio Solution File, Format Version 12.00 -# Visual Studio 15 -VisualStudioVersion = 15.0.27130.2024 -MinimumVisualStudioVersion = 10.0.40219.1 -Project("{6989167D-11E4-40FE-8C1A-2192A86A7E90}") = "mf6core", "mf6core.vfproj", "{380139B4-29CE-4CF3-BD74-5AA979FD0F43}" -EndProject -Project("{6989167D-11E4-40FE-8C1A-2192A86A7E90}") = "mf6bmi", "mf6bmi.vfproj", "{63FE82B0-6FA8-43FC-9B31-C1D6478CB4BC}" - ProjectSection(ProjectDependencies) = postProject - {380139B4-29CE-4CF3-BD74-5AA979FD0F43} = {380139B4-29CE-4CF3-BD74-5AA979FD0F43} - EndProjectSection -EndProject -Global - GlobalSection(SolutionConfigurationPlatforms) = preSolution - Debug|Win32 = Debug|Win32 - Debug|x64 = Debug|x64 - Profile|Win32 = Profile|Win32 - Profile|x64 = Profile|x64 - Release|Win32 = Release|Win32 - Release|x64 = Release|x64 - EndGlobalSection - GlobalSection(ProjectConfigurationPlatforms) = postSolution - {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Debug|Win32.ActiveCfg = Debug|Win32 - {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Debug|Win32.Build.0 = Debug|Win32 - {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Debug|x64.ActiveCfg = Debug|x64 - {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Debug|x64.Build.0 = Debug|x64 - {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Profile|Win32.ActiveCfg = Release|Win32 - {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Profile|Win32.Build.0 = Release|Win32 - {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Profile|x64.ActiveCfg = Release|x64 - {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Profile|x64.Build.0 = Release|x64 - {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Release|Win32.ActiveCfg = Release|Win32 - {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Release|Win32.Build.0 = Release|Win32 - {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Release|x64.ActiveCfg = Release|x64 - {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Release|x64.Build.0 = Release|x64 - {63FE82B0-6FA8-43FC-9B31-C1D6478CB4BC}.Debug|Win32.ActiveCfg = Debug|x64 - {63FE82B0-6FA8-43FC-9B31-C1D6478CB4BC}.Debug|x64.ActiveCfg = Debug|x64 - {63FE82B0-6FA8-43FC-9B31-C1D6478CB4BC}.Debug|x64.Build.0 = Debug|x64 - {63FE82B0-6FA8-43FC-9B31-C1D6478CB4BC}.Profile|Win32.ActiveCfg = Release|x64 - {63FE82B0-6FA8-43FC-9B31-C1D6478CB4BC}.Profile|Win32.Build.0 = Release|x64 - {63FE82B0-6FA8-43FC-9B31-C1D6478CB4BC}.Profile|x64.ActiveCfg = Release|x64 - {63FE82B0-6FA8-43FC-9B31-C1D6478CB4BC}.Profile|x64.Build.0 = Release|x64 - {63FE82B0-6FA8-43FC-9B31-C1D6478CB4BC}.Release|Win32.ActiveCfg = Release|x64 - {63FE82B0-6FA8-43FC-9B31-C1D6478CB4BC}.Release|x64.ActiveCfg = Release|x64 - {63FE82B0-6FA8-43FC-9B31-C1D6478CB4BC}.Release|x64.Build.0 = Release|x64 - EndGlobalSection - GlobalSection(SolutionProperties) = preSolution - HideSolutionNode = FALSE - EndGlobalSection - GlobalSection(ExtensibilityGlobals) = postSolution - SolutionGuid = {A077BEB2-AC7C-4B3D-AC89-2F6B4A677AF2} - EndGlobalSection -EndGlobal + +Microsoft Visual Studio Solution File, Format Version 12.00 +# Visual Studio 15 +VisualStudioVersion = 15.0.27130.2024 +MinimumVisualStudioVersion = 10.0.40219.1 +Project("{6989167D-11E4-40FE-8C1A-2192A86A7E90}") = "mf6core", "mf6core.vfproj", "{380139B4-29CE-4CF3-BD74-5AA979FD0F43}" +EndProject +Project("{6989167D-11E4-40FE-8C1A-2192A86A7E90}") = "mf6bmi", "mf6bmi.vfproj", "{63FE82B0-6FA8-43FC-9B31-C1D6478CB4BC}" + ProjectSection(ProjectDependencies) = postProject + {380139B4-29CE-4CF3-BD74-5AA979FD0F43} = {380139B4-29CE-4CF3-BD74-5AA979FD0F43} + EndProjectSection +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|Win32 = Debug|Win32 + Debug|x64 = Debug|x64 + Profile|Win32 = Profile|Win32 + Profile|x64 = Profile|x64 + Release|Win32 = Release|Win32 + Release|x64 = Release|x64 + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Debug|Win32.ActiveCfg = Debug|Win32 + {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Debug|Win32.Build.0 = Debug|Win32 + {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Debug|x64.ActiveCfg = Debug|x64 + {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Debug|x64.Build.0 = Debug|x64 + {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Profile|Win32.ActiveCfg = Release|Win32 + {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Profile|Win32.Build.0 = Release|Win32 + {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Profile|x64.ActiveCfg = Release|x64 + {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Profile|x64.Build.0 = Release|x64 + {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Release|Win32.ActiveCfg = Release|Win32 + {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Release|Win32.Build.0 = Release|Win32 + {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Release|x64.ActiveCfg = Release|x64 + {380139B4-29CE-4CF3-BD74-5AA979FD0F43}.Release|x64.Build.0 = Release|x64 + {63FE82B0-6FA8-43FC-9B31-C1D6478CB4BC}.Debug|Win32.ActiveCfg = Debug|x64 + {63FE82B0-6FA8-43FC-9B31-C1D6478CB4BC}.Debug|x64.ActiveCfg = Debug|x64 + {63FE82B0-6FA8-43FC-9B31-C1D6478CB4BC}.Debug|x64.Build.0 = Debug|x64 + {63FE82B0-6FA8-43FC-9B31-C1D6478CB4BC}.Profile|Win32.ActiveCfg = Release|x64 + {63FE82B0-6FA8-43FC-9B31-C1D6478CB4BC}.Profile|Win32.Build.0 = Release|x64 + {63FE82B0-6FA8-43FC-9B31-C1D6478CB4BC}.Profile|x64.ActiveCfg = Release|x64 + {63FE82B0-6FA8-43FC-9B31-C1D6478CB4BC}.Profile|x64.Build.0 = Release|x64 + {63FE82B0-6FA8-43FC-9B31-C1D6478CB4BC}.Release|Win32.ActiveCfg = Release|x64 + {63FE82B0-6FA8-43FC-9B31-C1D6478CB4BC}.Release|x64.ActiveCfg = Release|x64 + {63FE82B0-6FA8-43FC-9B31-C1D6478CB4BC}.Release|x64.Build.0 = Release|x64 + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection + GlobalSection(ExtensibilityGlobals) = postSolution + SolutionGuid = {A077BEB2-AC7C-4B3D-AC89-2F6B4A677AF2} + EndGlobalSection +EndGlobal diff --git a/msvs/mf6bmi.vfproj b/msvs/mf6bmi.vfproj index 40a07d75c7e..f21120a60de 100644 --- a/msvs/mf6bmi.vfproj +++ b/msvs/mf6bmi.vfproj @@ -1,33 +1,33 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index 521333c77fd..7420bd48c9c 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -1,162 +1,162 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/pymake/excludefiles.txt b/pymake/excludefiles.txt index db5f7279c52..0b5171d2e2b 100644 --- a/pymake/excludefiles.txt +++ b/pymake/excludefiles.txt @@ -1,4 +1,4 @@ -../src/mf6_duplicate.f90 -../src/bibbab.f90 - - +../src/mf6_duplicate.f90 +../src/bibbab.f90 + + diff --git a/src/Exchange/BaseExchange.f90 b/src/Exchange/BaseExchange.f90 index 15450f7a051..45b7d3a26bd 100644 --- a/src/Exchange/BaseExchange.f90 +++ b/src/Exchange/BaseExchange.f90 @@ -1,177 +1,177 @@ -module BaseExchangeModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LENPACKAGENAME - use BaseSolutionModule, only: BaseSolutionType - use ListModule, only: ListType - - implicit none - - private - public :: BaseExchangeType, AddBaseExchangeToList, GetBaseExchangeFromList - private :: CastAsBaseExchangeClass - - type, abstract :: BaseExchangeType - character(len=LENPACKAGENAME) :: name - class(BaseSolutionType), pointer :: solution => null() - integer(I4B) :: id - contains - procedure(exg_df), deferred :: exg_df - procedure(exg_ar), deferred :: exg_ar - procedure :: exg_rp - procedure :: exg_ot - procedure :: exg_fp - procedure :: exg_da - end type BaseExchangeType - - abstract interface - - subroutine exg_df(this) - import BaseExchangeType - class(BaseExchangeType) :: this - end subroutine - - subroutine exg_ar(this) - import BaseExchangeType - class(BaseExchangeType) :: this - end subroutine - - end interface - - contains - - subroutine exg_rp(this) -! ****************************************************************************** -! exg_rp -- Read and prepare -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: readnewdata - ! -- dummy - class(BaseExchangeType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Check with TDIS on whether or not it is time to RP - if (.not. readnewdata) return - ! - ! -- Nothing to do for RP - ! - ! -- Return - return - end subroutine exg_rp - - subroutine exg_ot(this) -! ****************************************************************************** -! exg_ot -- Output -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(BaseExchangeType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Return - return - end subroutine exg_ot - - subroutine exg_fp(this) -! ****************************************************************************** -! exg_fp -- Final processing -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(BaseExchangeType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Return - return - end subroutine exg_fp - - subroutine exg_da(this) -! ****************************************************************************** -! exg_da -- Deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(BaseExchangeType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Return - return - end subroutine exg_da - - function CastAsBaseExchangeClass(obj) result (res) -! ****************************************************************************** -! CastAsBaseExchangeClass -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(*), pointer, intent(inout) :: obj - ! -- return - class(BaseExchangeType), pointer :: res -! ------------------------------------------------------------------------------ - ! - res => null() - if (.not. associated(obj)) return - ! - select type (obj) - class is (BaseExchangeType) - res => obj - end select - return - end function CastAsBaseExchangeClass - - subroutine AddBaseExchangeToList(list, exchange) -! ****************************************************************************** -! AddBaseExchangeToList -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - type(ListType), intent(inout) :: list - class(BaseExchangeType), pointer, intent(inout) :: exchange - ! -- local - class(*), pointer :: obj -! ------------------------------------------------------------------------------ - ! - obj => exchange - call list%Add(obj) - ! - return - end subroutine AddBaseExchangeToList - - function GetBaseExchangeFromList(list, idx) result (res) -! ****************************************************************************** -! GetBaseExchangeFromList -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx - class(BaseExchangeType), pointer :: res - ! -- local - class(*), pointer :: obj -! ------------------------------------------------------------------------------ - ! - obj => list%GetItem(idx) - res => CastAsBaseExchangeClass(obj) - ! - return - end function GetBaseExchangeFromList - -end module BaseExchangeModule +module BaseExchangeModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: LENPACKAGENAME + use BaseSolutionModule, only: BaseSolutionType + use ListModule, only: ListType + + implicit none + + private + public :: BaseExchangeType, AddBaseExchangeToList, GetBaseExchangeFromList + private :: CastAsBaseExchangeClass + + type, abstract :: BaseExchangeType + character(len=LENPACKAGENAME) :: name + class(BaseSolutionType), pointer :: solution => null() + integer(I4B) :: id + contains + procedure(exg_df), deferred :: exg_df + procedure(exg_ar), deferred :: exg_ar + procedure :: exg_rp + procedure :: exg_ot + procedure :: exg_fp + procedure :: exg_da + end type BaseExchangeType + + abstract interface + + subroutine exg_df(this) + import BaseExchangeType + class(BaseExchangeType) :: this + end subroutine + + subroutine exg_ar(this) + import BaseExchangeType + class(BaseExchangeType) :: this + end subroutine + + end interface + + contains + + subroutine exg_rp(this) +! ****************************************************************************** +! exg_rp -- Read and prepare +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: readnewdata + ! -- dummy + class(BaseExchangeType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Check with TDIS on whether or not it is time to RP + if (.not. readnewdata) return + ! + ! -- Nothing to do for RP + ! + ! -- Return + return + end subroutine exg_rp + + subroutine exg_ot(this) +! ****************************************************************************** +! exg_ot -- Output +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(BaseExchangeType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Return + return + end subroutine exg_ot + + subroutine exg_fp(this) +! ****************************************************************************** +! exg_fp -- Final processing +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(BaseExchangeType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Return + return + end subroutine exg_fp + + subroutine exg_da(this) +! ****************************************************************************** +! exg_da -- Deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(BaseExchangeType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Return + return + end subroutine exg_da + + function CastAsBaseExchangeClass(obj) result (res) +! ****************************************************************************** +! CastAsBaseExchangeClass +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(*), pointer, intent(inout) :: obj + ! -- return + class(BaseExchangeType), pointer :: res +! ------------------------------------------------------------------------------ + ! + res => null() + if (.not. associated(obj)) return + ! + select type (obj) + class is (BaseExchangeType) + res => obj + end select + return + end function CastAsBaseExchangeClass + + subroutine AddBaseExchangeToList(list, exchange) +! ****************************************************************************** +! AddBaseExchangeToList +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + type(ListType), intent(inout) :: list + class(BaseExchangeType), pointer, intent(inout) :: exchange + ! -- local + class(*), pointer :: obj +! ------------------------------------------------------------------------------ + ! + obj => exchange + call list%Add(obj) + ! + return + end subroutine AddBaseExchangeToList + + function GetBaseExchangeFromList(list, idx) result (res) +! ****************************************************************************** +! GetBaseExchangeFromList +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + type(ListType), intent(inout) :: list + integer(I4B), intent(in) :: idx + class(BaseExchangeType), pointer :: res + ! -- local + class(*), pointer :: obj +! ------------------------------------------------------------------------------ + ! + obj => list%GetItem(idx) + res => CastAsBaseExchangeClass(obj) + ! + return + end function GetBaseExchangeFromList + +end module BaseExchangeModule diff --git a/src/Exchange/GhostNode.f90 b/src/Exchange/GhostNode.f90 index d248496a40d..28d62b7dabe 100644 --- a/src/Exchange/GhostNode.f90 +++ b/src/Exchange/GhostNode.f90 @@ -1,1058 +1,1058 @@ -module GhostNodeModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH, LENORIGIN - use NumericalModelModule, only: NumericalModelType - use NumericalPackageModule, only: NumericalPackageType - use BlockParserModule, only: BlockParserType - - implicit none - - private - public :: GhostNodeType - public :: gnc_cr - - type, extends(NumericalPackageType) :: GhostNodeType - logical, pointer :: smgnc => null() ! single model gnc - logical, pointer :: implicit => null() ! lhs or rhs - logical, pointer :: i2kn => null() ! not used - integer(I4B), pointer :: nexg => null() ! number of gncs - integer(I4B), pointer :: numjs => null() ! number of connecting nodes - class(NumericalModelType), pointer :: m1 => null() ! pointer to model 1 - class(NumericalModelType), pointer :: m2 => null() ! pointer to model 2 - integer(I4B), dimension(:), pointer, contiguous :: nodem1 => null() ! array of nodes in model 1 - integer(I4B), dimension(:), pointer, contiguous :: nodem2 => null() ! array of nodes in model 2 - integer(I4B), dimension(:, :), pointer, contiguous :: nodesj => null() ! array of interpolation nodes - real(DP), dimension(:), pointer, contiguous :: cond => null() ! array of conductance - integer(I4B), dimension(:), pointer, contiguous :: idxglo => null() ! connection position in amat - integer(I4B), dimension(:), pointer, contiguous :: idxsymglo => null() ! symmetric position in amat - real(DP), dimension(:, :), pointer, contiguous :: alphasj => null() ! interpolation factors - integer(I4B), dimension(:), pointer, contiguous :: idiagn => null() ! amat diagonal position of n - integer(I4B), dimension(:), pointer, contiguous :: idiagm => null() ! amat diagonal position of m - integer(I4B), dimension(:,:), pointer, contiguous :: jposinrown => null() ! amat j position in row n - integer(I4B), dimension(:,:), pointer, contiguous :: jposinrowm => null() ! amat j position in row m - contains - procedure :: gnc_df - procedure :: gnc_ac - procedure :: gnc_mc - procedure, private :: gnc_fmsav - procedure :: gnc_fc - procedure :: gnc_fn - procedure :: gnc_ot - procedure :: gnc_da - procedure :: flowja => gncflowja - procedure :: deltaQgnc - procedure :: allocate_scalars - procedure, private :: allocate_arrays - procedure, private :: read_options - procedure, private :: read_dimensions - procedure, private :: read_data - procedure, private :: nodeu_to_noder - end type GhostNodeType - - contains - - subroutine gnc_cr(gncobj, name_parent, inunit, iout) -! ****************************************************************************** -! gnc_cr -- Create new GNC exchange object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - type(GhostNodeType), pointer, intent(inout) :: gncobj - character(len=*), intent(in) :: name_parent - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout -! ------------------------------------------------------------------------------ - ! - ! -- Allocate the gnc exchange object - allocate(gncobj) - ! - ! -- create name and origin. name_parent will either be model name or the - ! exchange name. - call gncobj%set_names(1, name_parent, 'GNC', 'GNC') - ! - ! -- allocate scalars - call gncobj%allocate_scalars() - ! - ! -- Set variables - gncobj%inunit = inunit - gncobj%iout = iout - ! - ! -- return - return - end subroutine gnc_cr - - subroutine gnc_df(this, m1, m2) -! ****************************************************************************** -! gnc_df -- Initialize a gnc object. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use NumericalModelModule, only: NumericalModelType - use SimModule, only: store_error, store_error_unit, ustop - ! -- dummy - class(GhostNodeType) :: this - class(NumericalModelType), target :: m1 - class(NumericalModelType), target, optional :: m2 - ! -- local - character(len=LINELENGTH) :: errmsg -! ------------------------------------------------------------------------------ - ! - ! -- Point or set attributes - this%m1 => m1 - this%m2 => m1 - ! - ! -- If m2 is present, then GNC spans two models - if (present(m2)) then - this%m2 => m2 - this%smgnc = .false. - endif - ! - ! -- Initialize block parser - call this%parser%Initialize(this%inunit, this%iout) - ! - ! -- read gnc options - call this%read_options() - ! - ! -- read gnc dimensions - call this%read_dimensions() - ! - ! -- allocate arrays - call this%allocate_arrays() - ! - ! -- Allocate and read the gnc entries - call this%read_data() - ! - ! -- Trap for implicit gnc but models are in different solutions - if(this%m1%idsoln /= this%m2%idsoln) then - if(this%implicit) then - write(errmsg, '(a)') 'Error. GNC is implicit but models are in ' // & - 'different solutions.' - call store_error(errmsg) - call store_error_unit(this%inunit) - call ustop() - endif - endif - ! - ! -- return - return - end subroutine gnc_df - - subroutine gnc_ac(this, sparse) -! ****************************************************************************** -! gnc_ac -- Single or Two-Model GNC Add Connections -! Subroutine: (1) For implicit GNC, expand the sparse solution matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SparseModule, only: sparsematrix - ! -- dummy - class(GhostNodeType) :: this - type(sparsematrix), intent(inout) :: sparse - ! -- local - integer(I4B) :: ignc, jidx, noden, nodem, nodej -! ------------------------------------------------------------------------------ - ! - ! -- Expand the sparse matrix for ghost node connections. No need to add - ! connection between n and m as they must be connected some other way - ! that will calculate the conductance. - if(this%implicit) then - do ignc = 1, this%nexg - noden = this%nodem1(ignc) + this%m1%moffset - nodem = this%nodem2(ignc) + this%m2%moffset - jloop: do jidx = 1, this%numjs - nodej = this%nodesj(jidx, ignc) - if(nodej == 0) cycle - nodej = nodej + this%m1%moffset - call sparse%addconnection(nodem, nodej, 1) - call sparse%addconnection(nodej, nodem, 1) - call sparse%addconnection(noden, nodej, 1) - call sparse%addconnection(nodej, noden, 1) - enddo jloop - enddo - endif - ! - ! -- return - return - end subroutine gnc_ac - - subroutine gnc_mc(this, iasln, jasln) -! ****************************************************************************** -! gnc_mc -- Single or Two-Model GNC Map Connections -! Subroutine: (1) Fill the following mapping arrays: -! this%idiagn, this%idiagm (diagonal positions in solution amat) -! this%idxglo (nm connection in solution amat) -! this%idxsymglo (mn connection in solution amat) -! this%jposinrown (position of j in row n of solution amat) -! this%jposinrowm (position of j in row m of solution amat) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: ustop, store_error, store_error_unit, count_errors - ! -- dummy - class(GhostNodeType) :: this - integer(I4B), dimension(:), intent(in) :: iasln - integer(I4B), dimension(:), intent(in) :: jasln - ! -- local - character(len=LINELENGTH) :: errmsg - integer(I4B) :: noden, nodem, ipos, j, ignc, jidx, nodej - ! -- formats - character(len=*),parameter :: fmterr = & - "('GHOST NODE ERROR. Cell ', i0, ' in model ', a, & - &' is not connected to cell ', i0, ' in model ', a)" -! ------------------------------------------------------------------------------ - ! - ! -- Find the location of Cnm in the global solution and store it in - ! this%idxglo - do ignc = 1, this%nexg - noden = this%nodem1(ignc) + this%m1%moffset - nodem = this%nodem2(ignc) + this%m2%moffset - ! - ! -- store diagonal positions in idiagn and idiagm - this%idiagn(ignc) = iasln(noden) - this%idiagm(ignc) = iasln(nodem) - !if(this%implicit) then - ! this%idiagn(ignc) = iasln(noden) - ! this%idiagm(ignc) = iasln(nodem) - !endif - ! - ! -- find location of m in row n of global solution - this%idxglo(ignc) = 0 - searchloopnm: do ipos = iasln(noden) + 1, iasln(noden + 1) - 1 - j = jasln(ipos) - if(j == nodem) then - this%idxglo(ignc) = ipos - exit searchloopnm - endif - enddo searchloopnm - ! - ! -- find location of n in row m of global solution and store in idxsymglo - !if(this%implicit) then - this%idxsymglo(ignc) = 0 - searchloopmn: do ipos = iasln(nodem), iasln(nodem + 1) - 1 - j = jasln(ipos) - if(j == noden) then - this%idxsymglo(ignc) = ipos - exit searchloopmn - endif - enddo searchloopmn - !endif - ! - ! -- Check to make sure idxglo is non-zero - if(this%idxglo(ignc) == 0) then - write(errmsg, fmterr) this%nodem1(ignc), trim(this%m1%name), & - this%nodem2(ignc), trim(this%m2%name) - call store_error(errmsg) - endif - ! - enddo - ! - ! -- Stop if errors - if(count_errors() > 0) then - call store_error_unit(this%inunit) - call ustop() - endif - ! - ! -- find locations of j in rows n and row m of global solution - if(this%implicit) then - do ignc = 1, this%nexg - noden = this%nodem1(ignc) + this%m1%moffset - nodem = this%nodem2(ignc) + this%m2%moffset - ! - do jidx = 1, this%numjs - nodej = this%nodesj(jidx, ignc) - if(nodej > 0) nodej = nodej + this%m1%moffset - ! - ! -- search for nodej in row n, unless it is 0 - if(nodej == 0) then - ipos = 0 - this%jposinrown(jidx, ignc) = ipos - else - searchloopn: do ipos = iasln(noden), iasln(noden + 1) - 1 - j = jasln(ipos) - if(j == nodej) then - this%jposinrown(jidx, ignc) = ipos - exit searchloopn - endif - enddo searchloopn - endif - ! - ! -- search for nodej in row m - if(nodej == 0) then - ipos = 0 - this%jposinrowm(jidx, ignc) = ipos - else - searchloopm: do ipos = iasln(nodem) + 1, iasln(nodem + 1) - 1 - j = jasln(ipos) - if(j == nodej) then - this%jposinrowm(jidx, ignc) = ipos - exit searchloopm - endif - enddo searchloopm - endif - enddo - enddo - endif - ! - ! -- return - return - end subroutine gnc_mc - - subroutine gnc_fmsav(this, kiter, amatsln) -! ****************************************************************************** -! gnc_fmsav -- Store the n-m Picard conductance in cond prior to the Newton -! terms being added. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DZERO - ! -- dummy - class(GhostNodeType) :: this - integer(I4B), intent(in) :: kiter - real(DP), dimension(:), intent(inout) :: amatsln - ! -- local - integer(I4B) :: ignc, ipos - real(DP) :: cond -! ------------------------------------------------------------------------------ - ! - ! -- An ipos value of zero indicates that noden is not connected to - ! nodem, and therefore the conductance is zero. - gncloop: do ignc = 1, this%nexg - ipos = this%idxglo(ignc) - if(ipos > 0) then - cond = amatsln(ipos) - else - cond = DZERO - endif - this%cond(ignc) = cond - enddo gncloop - ! - ! -- return - return - end subroutine gnc_fmsav - - subroutine gnc_fc(this, kiter, amatsln) -! ****************************************************************************** -! gnc_fc -- Fill matrix terms -! Subroutine: (1) Add the GNC terms to the solution amat or model rhs depending -! on whether GNC is implicit or explicit -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DZERO - ! -- dummy - class(GhostNodeType) :: this - integer(I4B), intent(in) :: kiter - real(DP), dimension(:), intent(inout) :: amatsln - ! -- local - integer(I4B) :: ignc, j, noden, nodem, ipos, jidx, iposjn, iposjm - real(DP) :: cond, alpha, aterm, rterm -! ------------------------------------------------------------------------------ - ! - ! -- If this is a single model gnc (not an exchange across models), then - ! pull conductances out of amatsln and store them in this%cond - if(this%smgnc) call this%gnc_fmsav(kiter, amatsln) - ! - ! -- Add gnc terms to rhs or to amat depending on whether gnc is implicit - ! or explicit - gncloop: do ignc = 1, this%nexg - noden = this%nodem1(ignc) - nodem = this%nodem2(ignc) - if(this%m1%ibound(noden) == 0 .or. & - this%m2%ibound(nodem) == 0) cycle gncloop - ipos = this%idxglo(ignc) - cond = this%cond(ignc) - jloop: do jidx = 1, this%numjs - j = this%nodesj(jidx, ignc) - if(j == 0) cycle - alpha = this%alphasj(jidx, ignc) - if (alpha == DZERO) cycle - aterm = alpha * cond - if(this%implicit) then - iposjn = this%jposinrown(jidx, ignc) - iposjm = this%jposinrowm(jidx, ignc) - amatsln(this%idiagn(ignc)) = amatsln(this%idiagn(ignc)) + aterm - amatsln(iposjn) = amatsln(iposjn) - aterm - amatsln(this%idxsymglo(ignc)) = amatsln(this%idxsymglo(ignc)) - aterm - amatsln(iposjm) = amatsln(iposjm) + aterm - else - rterm = aterm * (this%m1%x(noden) - this%m1%x(j)) - this%m1%rhs(noden) = this%m1%rhs(noden) - rterm - this%m2%rhs(nodem) = this%m2%rhs(nodem) + rterm - endif - enddo jloop - enddo gncloop - ! - ! -- return - return - end subroutine gnc_fc - - subroutine gnc_fn(this, kiter, njasln, amatsln, condsat, ihc_opt, & - ivarcv_opt, ictm1_opt, ictm2_opt) -! ****************************************************************************** -! gnc_fn -- Fill GNC Newton terms -! -! Required arguments: -! kiter : outer iteration number -! njasln : size of amatsln -! amatsln : coefficient matrix for the solution -! condsat is of size(njas) if single model, otherwise nexg -! -! Optional arguments: -! ihc_opt : an optional vector of size(nexg), which contains a horizontal -! connection code (0=vertical, 1=horizontal, 2=vertically staggered) -! ivarcv_opt : variable vertical conductance flag (default is 0) -! ictm1_opt : icelltype for model 1 integer vector (default is 1) -! ictm2_opt : icelltype for model 2 integer vector (default is 1) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DZERO - use SmoothingModule, only: sQuadraticSaturationDerivative - ! -- dummy - class(GhostNodeType) :: this - integer(I4B) :: kiter - integer(I4B), intent(in) :: njasln - real(DP), dimension(njasln), intent(inout) :: amatsln - real(DP), dimension(:), intent(in) :: condsat - integer(I4B), dimension(:), optional :: ihc_opt - integer(I4B), optional :: ivarcv_opt - integer(I4B), dimension(:), optional :: ictm1_opt - integer(I4B), dimension(:), optional :: ictm2_opt - ! -- local - integer(I4B) :: ignc, jidx, ipos, isympos, ihc, ivarcv - integer(I4B) :: nodej, noden, nodem - integer(I4B) :: iups, ictup - real(DP) :: csat, alpha, consterm, term, derv - real(DP) :: xup, topup, botup -! ------------------------------------------------------------------------------ - ! - ! -- Set the ivarcv to indicate whether or not the vertical conductance - ! is a function of water table - ivarcv = 0 - if (present(ivarcv_opt)) ivarcv = ivarcv_opt - ! - gncloop: do ignc = 1, this%nexg - noden = this%nodem1(ignc) - nodem = this%nodem2(ignc) - if(this%m1%ibound(noden) == 0 .or. & - this%m2%ibound(nodem) == 0) cycle gncloop - ! - ! -- Assign variables depending on whether single model gnc or exchange - ! gnc - if(this%smgnc) then - ipos = this%m1%dis%con%getjaindex(noden, nodem) - isympos = this%m1%dis%con%jas(ipos) - ihc = this%m1%dis%con%ihc(isympos) - csat = condsat(isympos) - else - ihc = ihc_opt(ignc) - csat = condsat(ignc) - endif - ! - ! If vertical connection and not variable cv, then cycle - if(ihc == 0 .and. ivarcv == 0) cycle - ! - ! determine upstream node (0 is noden, 1 is nodem) - iups = 0 - if (this%m2%x(nodem) > this%m1%x(noden)) iups = 1 - ! - ! -- Set the upstream top and bot, and then recalculate for a - ! vertically staggered horizontal connection - if(iups == 0) then - topup = this%m1%dis%top(noden) - botup = this%m1%dis%bot(noden) - ictup = 1 - if (present(ictm1_opt)) ictup = ictm1_opt(noden) - xup = this%m1%x(noden) - else - topup = this%m2%dis%top(nodem) - botup = this%m2%dis%bot(nodem) - ictup = 1 - if (present(ictm2_opt)) ictup = ictm2_opt(nodem) - xup = this%m2%x(nodem) - endif - ! - ! -- No newton terms if upstream cell is confined - if (ictup == 0) cycle - ! - ! -- Handle vertically staggered horizontal connection - if(ihc == 2) then - topup = min(this%m1%dis%top(noden), this%m2%dis%top(nodem)) - botup = max(this%m1%dis%bot(noden), this%m2%dis%bot(nodem)) - endif - ! - ! -- Process each contributing node - jloop: do jidx = 1, this%numjs - nodej = this%nodesj(jidx, ignc) - if(nodej == 0) cycle - if(this%m1%ibound(nodej) == 0) cycle - alpha = this%alphasj(jidx, ignc) - if (alpha == DZERO) cycle - consterm = csat * alpha * (this%m1%x(noden) - this%m1%x(nodej)) - derv = sQuadraticSaturationDerivative(topup, botup, xup) - term = consterm * derv - if(iups == 0) then - amatsln(this%idiagn(ignc)) = amatsln(this%idiagn(ignc)) + term - if(this%m2%ibound(nodem) > 0) then - amatsln(this%idxsymglo(ignc)) = amatsln(this%idxsymglo(ignc)) - & - term - endif - this%m1%rhs(noden) = this%m1%rhs(noden) + term * this%m1%x(noden) - this%m2%rhs(nodem) = this%m2%rhs(nodem) - term * this%m1%x(noden) - else - amatsln(this%idiagm(ignc)) = amatsln(this%idiagm(ignc)) - term - if(this%m1%ibound(noden) > 0) then - amatsln(this%idxglo(ignc)) = amatsln(this%idxglo(ignc)) + term - endif - this%m1%rhs(noden) = this%m1%rhs(noden) + term * this%m2%x(nodem) - this%m2%rhs(nodem) = this%m2%rhs(nodem) - term * this%m2%x(nodem) - endif - enddo jloop - enddo gncloop - ! - ! -- return - return - end subroutine gnc_fn - - subroutine gnc_ot(this) -! ****************************************************************************** -! gnc_ot -- Single Model GNC Output -! Subroutine: (1) Output GNC deltaQgnc values -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GhostNodeType) :: this - ! -- local - integer(I4B) :: ignc - real(DP) :: deltaQgnc - character(len=LINELENGTH) :: nodenstr, nodemstr - ! -- format - character(len=*), parameter :: fmtgnc = "(i10, 2a10, 2(1pg15.6))" -! ------------------------------------------------------------------------------ - ! - ! -- Process each gnc and output deltaQgnc - if(this%iprflow /= 0) then - write(this%iout, '(//, a)') 'GHOST NODE CORRECTION RESULTS' - write(this%iout, '(3a10, 2a15)') 'GNC NUM', 'NODEN', 'NODEM', & - 'DELTAQGNC', 'CONDNM' - do ignc = 1, this%nexg - deltaQgnc = this%deltaQgnc(ignc) - call this%m1%dis%noder_to_string(this%nodem1(ignc), nodenstr) - call this%m2%dis%noder_to_string(this%nodem2(ignc), nodemstr) - write(this%iout, fmtgnc) ignc, trim(adjustl(nodenstr)), & - trim(adjustl(nodemstr)), & - deltaQgnc, this%cond(ignc) - enddo - endif - ! - ! -- return - return - end subroutine gnc_ot - - subroutine gncflowja(this, flowja) -! ****************************************************************************** -! gncflowja -- Add GNC to flowja -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GhostNodeType) :: this - real(DP), dimension(:), intent(inout) :: flowja - ! -- local - integer(I4B) :: ignc, n1, n2, ipos, isympos - real(DP) :: deltaQgnc - ! -- format -! ------------------------------------------------------------------------------ - ! - ! -- go through each gnc and add deltagnc to flowja - do ignc = 1, this%nexg - ! - ! -- calculate correction term between n1 and n2 connection - n1 = this%nodem1(ignc) - n2 = this%nodem2(ignc) - deltaQgnc = this%deltaQgnc(ignc) - ! - ! -- find the positions of this connection in the csr array - ipos = this%m1%dis%con%getjaindex(n1, n2) - isympos = this%m1%dis%con%isym(ipos) - ! - ! -- add/subtract the corrections - flowja(ipos) = flowja(ipos) + deltaQgnc - flowja(isympos) = flowja(isympos) - deltaQgnc - ! - enddo - ! - ! -- return - return - end subroutine gncflowja - - function deltaQgnc(this, ignc) -! ****************************************************************************** -! deltaQgnc -- Single Model deltaQgnc (ghost node correction flux) -! Subroutine: (1) Calculate the deltaQgnc value for any GNC in the GNC list -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DZERO - ! -- return - real(DP) :: deltaQgnc - ! -- dummy - class(GhostNodeType) :: this - integer(I4B), intent(in) :: ignc - ! -- local - integer(I4B) :: noden, nodem, nodej, jidx - real(DP) :: sigalj, alpha, hd, aterm, cond -! ------------------------------------------------------------------------------ - ! - ! -- initialize values - deltaQgnc = DZERO - sigalj = DZERO - hd = DZERO - noden = this%nodem1(ignc) - nodem = this%nodem2(ignc) - ! - ! -- calculate deltaQgnc - if(this%m1%ibound(noden) /= 0 .and. this%m2%ibound(nodem) /= 0) then - jloop: do jidx = 1, this%numjs - nodej = this%nodesj(jidx, ignc) - if(nodej == 0) cycle jloop - if(this%m1%ibound(nodej) == 0) cycle jloop - alpha = this%alphasj(jidx, ignc) - sigalj = sigalj + alpha - hd = hd + alpha * this%m1%x(nodej) - enddo jloop - aterm = sigalj * this%m1%x(noden) - hd - cond = this%cond(ignc) - deltaQgnc = aterm * cond - endif - ! - ! -- return - return - end function deltaQgnc - - subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -- allocate gnc scalar variables -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(GhostNodeType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- allocate scalars in NumericalPackageType - call this%NumericalPackageType%allocate_scalars() - ! - call mem_allocate(this%smgnc, 'SMGNC', this%origin) - call mem_allocate(this%implicit, 'IMPLICIT', this%origin) - call mem_allocate(this%i2kn, 'I2KN', this%origin) - call mem_allocate(this%nexg, 'NEXG', this%origin) - call mem_allocate(this%numjs, 'NUMJS', this%origin) - ! - ! -- Initialize values - this%smgnc = .true. - this%implicit = .true. - this%i2kn = .false. - this%nexg = 0 - this%numjs = 0 - ! - return - end subroutine allocate_scalars - - subroutine allocate_arrays(this) -! ****************************************************************************** -! allocate_arrays -- allocate gnc scalar variables -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - use ConstantsModule, only: LENORIGIN - ! -- dummy - class(GhostNodeType) :: this - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- allocate memory for arrays - call mem_allocate(this%nodem1, this%nexg, 'NODEM1', this%origin) - call mem_allocate(this%nodem2, this%nexg, 'NODEM2', this%origin) - call mem_allocate(this%nodesj, this%numjs, this%nexg, 'NODESJ', & - this%origin) - call mem_allocate(this%alphasj, this%numjs, this%nexg, 'ALPHASJ', & - this%origin) - call mem_allocate(this%cond, this%nexg, 'COND', this%origin) - call mem_allocate(this%idxglo, this%nexg, 'IDXGLO', this%origin) - call mem_allocate(this%idiagn, this%nexg, 'IDIAGN', this%origin) - call mem_allocate(this%idiagm, this%nexg, 'IDIAGM', this%origin) - call mem_allocate(this%idxsymglo, this%nexg, 'IDXSYMGLO', this%origin) - if(this%implicit) then - call mem_allocate(this%jposinrown, this%numjs, this%nexg, 'JPOSINROWN', & - this%origin) - call mem_allocate(this%jposinrowm, this%numjs, this%nexg, 'JPOSINROWM', & - this%origin) - else - call mem_allocate(this%jposinrown, 0, 0, 'JPOSINROWN', this%origin) - call mem_allocate(this%jposinrowm, 0, 0, 'JPOSINROWM', this%origin) - endif - ! - ! -- Return - return - end subroutine allocate_arrays - - subroutine gnc_da(this) -! ****************************************************************************** -! gnc_da -- deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(GhostNodeType) :: this -! ------------------------------------------------------------------------------ - ! - call mem_deallocate(this%smgnc) - call mem_deallocate(this%implicit) - call mem_deallocate(this%i2kn) - call mem_deallocate(this%nexg) - call mem_deallocate(this%numjs) - ! - ! -- Arrays - if (this%inunit > 0) then - call mem_deallocate(this%nodem1) - call mem_deallocate(this%nodem2) - call mem_deallocate(this%nodesj) - call mem_deallocate(this%alphasj) - call mem_deallocate(this%cond) - call mem_deallocate(this%idxglo) - call mem_deallocate(this%idiagn) - call mem_deallocate(this%idiagm) - call mem_deallocate(this%idxsymglo) - call mem_deallocate(this%jposinrown) - call mem_deallocate(this%jposinrowm) - endif - ! - ! -- deallocate NumericalPackageType - call this%NumericalPackageType%da() - ! - ! -- Return - return - end subroutine gnc_da - - subroutine read_options(this) -! ****************************************************************************** -! read_options -- read a gnc options block -! Subroutine: (1) read options from input file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: ustop, store_error - ! -- dummy - class(GhostNodeType) :: this - ! -- local - 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.) - ! - ! -- parse options block if detected - if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING GNC OPTIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('PRINT_INPUT') - this%iprpak = 1 - write(this%iout,'(4x,a)') & - 'THE LIST OF GHOST-NODE CORRECTIONS WILL BE PRINTED.' - case ('PRINT_FLOWS') - this%iprflow = 1 - write(this%iout,'(4x,a)') & - 'DELTAQGNC VALUES WILL BE PRINTED TO THE LIST FILE.' - case ('I2KN') - this%i2kn = .true. - write(this%iout,'(4x,a)') & - 'SECOND ORDER CORRECTION WILL BE APPLIED.' - case ('EXPLICIT') - this%implicit = .false. - write(this%iout,'(4x,a)')'GHOST NODE CORRECTION IS EXPLICIT.' - case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN GNC OPTION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - end do - write(this%iout,'(1x,a)')'END OF GNC OPTIONS' - end if - ! - ! -- Set the iasym flag if the correction is implicit - if (this%implicit) this%iasym = 1 - ! - ! -- return - return - end subroutine read_options - - subroutine read_dimensions(this) -! ****************************************************************************** -! read_dimensions -- Single Model GNC Read Dimensions -! Subroutine: (1) read dimensions (size of gnc list) from input file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: ustop, store_error - ! -- dummy - class(GhostNodeType) :: this - ! -- local - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock -! ------------------------------------------------------------------------------ - ! - ! -- 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 GNC DIMENSIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('NUMGNC') - this%nexg = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)')'NUMGNC = ', this%nexg - case ('NUMALPHAJ') - this%numjs = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)')'NUMAPHAJ = ', this%numjs - case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN GNC DIMENSION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - end do - write(this%iout,'(1x,a)')'END OF GNC DIMENSIONS' - else - call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') - call ustop() - end if - ! - ! -- return - return - end subroutine read_dimensions - - subroutine read_data(this) -! ****************************************************************************** -! read_data -- Read a GNCDATA block -! Subroutine: (1) read list of GNCs from input file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: ustop, store_error, count_errors - ! -- dummy - class(GhostNodeType) :: this - ! -- local - character(len=LINELENGTH) :: line, errmsg, nodestr, fmtgnc, cellid, & - cellidm, cellidn - integer(I4B) :: lloc,ierr,ival - integer(I4B) :: ignc, jidx, nodeun, nodeum, nerr - integer(I4B), dimension(:), allocatable :: nodesuj - logical :: isfound, endOfBlock - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- Construct the fmtgnc format - write(fmtgnc, '("(2i10,",i0,"i10,",i0, "(1pg15.6))")') this%numjs, & - this%numjs - ! - ! -- Allocate the temporary nodesuj, which stores the user-based nodej - ! node numbers - allocate(nodesuj(this%numjs)) - ! - ! -- get GNCDATA block - call this%parser%GetBlock('GNCDATA', isfound, ierr, supportOpenClose=.true.) - ! - ! -- process GNC data - if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING GNCDATA' - do ignc = 1, this%nexg - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetCurrentLine(line) - lloc = 1 - ! - ! -- cellidn (read as cellid and convert to user node) - call this%parser%GetCellid(this%m1%dis%ndim, cellidn) - nodeun = this%m1%dis%nodeu_from_cellid(cellidn, this%parser%iuactive, & - this%iout) - ! - ! -- convert user node to reduced node number - call this%nodeu_to_noder(nodeun, this%nodem1(ignc), this%m1) - ! - ! -- cellidm (read as cellid and convert to user node) - call this%parser%GetCellid(this%m2%dis%ndim, cellidm) - nodeum = this%m2%dis%nodeu_from_cellid(cellidm, this%parser%iuactive, & - this%iout) - ! - ! -- convert user node to reduced node number - call this%nodeu_to_noder(nodeum, this%nodem2(ignc), this%m2) - ! - ! -- cellidsj (read as cellid) - do jidx=1, this%numjs - ! read cellidj as cellid of model 1 - call this%parser%GetCellid(this%m1%dis%ndim, cellid) - ival = this%m1%dis%nodeu_from_cellid(cellid, this%parser%iuactive, & - this%iout, allow_zero=.true.) - nodesuj(jidx) = ival - if(ival > 0) then - call this%nodeu_to_noder(ival, this%nodesj(jidx, ignc), this%m1) - else - this%nodesj(jidx, ignc) = 0 - endif - enddo - ! - ! -- alphaj - do jidx=1, this%numjs - this%alphasj(jidx, ignc) = this%parser%GetDouble() - enddo - ! - ! -- Echo if requested - if(this%iprpak /= 0) & - write(this%iout, fmtgnc) nodeun, nodeum, & - (nodesuj(jidx), jidx = 1, this%numjs), & - (this%alphasj(jidx, ignc), jidx = 1, this%numjs) - ! - ! -- Check to see if noden is outside of active domain - if(this%nodem1(ignc) <= 0) then - call this%m1%dis%nodeu_to_string(nodeun, nodestr) - write(errmsg, *) & - trim(adjustl(this%m1%name)) // & - ' Cell is outside active grid domain: ' // & - trim(adjustl(nodestr)) - call store_error(errmsg) - endif - ! - ! -- Check to see if nodem is outside of active domain - if(this%nodem2(ignc) <= 0) then - call this%m2%dis%nodeu_to_string(nodeum, nodestr) - write(errmsg, *) & - trim(adjustl(this%m2%name)) // & - ' Cell is outside active grid domain: ' // & - trim(adjustl(nodestr)) - call store_error(errmsg) - endif - ! - ! -- Check to see if any nodejs are outside of active domain - do jidx = 1, this%numjs - if(this%nodesj(jidx, ignc) < 0) then - call this%m1%dis%nodeu_to_string(nodesuj(jidx), nodestr) - write(errmsg, *) & - trim(adjustl(this%m1%name)) // & - ' Cell is outside active grid domain: ' // & - trim(adjustl(nodestr)) - call store_error(errmsg) - endif - enddo - ! - enddo - ! - ! -- Stop if errors - nerr = count_errors() - if(nerr > 0) then - call store_error('Errors encountered in GNC input file.') - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - write(this%iout,'(1x,a)')'END OF GNCDATA' - else - write(errmsg, '(1x,a)')'ERROR. REQUIRED GNCDATA BLOCK NOT FOUND.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- deallocate nodesuj array - deallocate(nodesuj) - ! - ! -- return - return - end subroutine read_data - - subroutine nodeu_to_noder(this, nodeu, noder, model) -! ****************************************************************************** -! nodeu_to_noder -- Convert the user-based node number into a reduced number -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use NumericalModelModule, only: NumericalModelType - use SimModule, only: store_error - ! -- dummy - class(GhostNodeType) :: this - integer(I4B), intent(in) :: nodeu - integer(I4B), intent(inout) :: noder - class(NumericalModelType), intent(in) :: model - ! -- local - character(len=LINELENGTH) :: errmsg -! ------------------------------------------------------------------------------ - ! - if(nodeu < 1 .or. nodeu > model%dis%nodesuser) then - write(errmsg, *) & - trim(adjustl(model%name)) // & - ' node number < 0 or > model nodes: ', nodeu - call store_error(errmsg) - else - noder = model%dis%get_nodenumber(nodeu, 0) - endif - ! - ! -- Return - return - end subroutine nodeu_to_noder - - -end module GhostNodeModule +module GhostNodeModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: LINELENGTH, LENORIGIN + use NumericalModelModule, only: NumericalModelType + use NumericalPackageModule, only: NumericalPackageType + use BlockParserModule, only: BlockParserType + + implicit none + + private + public :: GhostNodeType + public :: gnc_cr + + type, extends(NumericalPackageType) :: GhostNodeType + logical, pointer :: smgnc => null() ! single model gnc + logical, pointer :: implicit => null() ! lhs or rhs + logical, pointer :: i2kn => null() ! not used + integer(I4B), pointer :: nexg => null() ! number of gncs + integer(I4B), pointer :: numjs => null() ! number of connecting nodes + class(NumericalModelType), pointer :: m1 => null() ! pointer to model 1 + class(NumericalModelType), pointer :: m2 => null() ! pointer to model 2 + integer(I4B), dimension(:), pointer, contiguous :: nodem1 => null() ! array of nodes in model 1 + integer(I4B), dimension(:), pointer, contiguous :: nodem2 => null() ! array of nodes in model 2 + integer(I4B), dimension(:, :), pointer, contiguous :: nodesj => null() ! array of interpolation nodes + real(DP), dimension(:), pointer, contiguous :: cond => null() ! array of conductance + integer(I4B), dimension(:), pointer, contiguous :: idxglo => null() ! connection position in amat + integer(I4B), dimension(:), pointer, contiguous :: idxsymglo => null() ! symmetric position in amat + real(DP), dimension(:, :), pointer, contiguous :: alphasj => null() ! interpolation factors + integer(I4B), dimension(:), pointer, contiguous :: idiagn => null() ! amat diagonal position of n + integer(I4B), dimension(:), pointer, contiguous :: idiagm => null() ! amat diagonal position of m + integer(I4B), dimension(:,:), pointer, contiguous :: jposinrown => null() ! amat j position in row n + integer(I4B), dimension(:,:), pointer, contiguous :: jposinrowm => null() ! amat j position in row m + contains + procedure :: gnc_df + procedure :: gnc_ac + procedure :: gnc_mc + procedure, private :: gnc_fmsav + procedure :: gnc_fc + procedure :: gnc_fn + procedure :: gnc_ot + procedure :: gnc_da + procedure :: flowja => gncflowja + procedure :: deltaQgnc + procedure :: allocate_scalars + procedure, private :: allocate_arrays + procedure, private :: read_options + procedure, private :: read_dimensions + procedure, private :: read_data + procedure, private :: nodeu_to_noder + end type GhostNodeType + + contains + + subroutine gnc_cr(gncobj, name_parent, inunit, iout) +! ****************************************************************************** +! gnc_cr -- Create new GNC exchange object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + type(GhostNodeType), pointer, intent(inout) :: gncobj + character(len=*), intent(in) :: name_parent + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout +! ------------------------------------------------------------------------------ + ! + ! -- Allocate the gnc exchange object + allocate(gncobj) + ! + ! -- create name and origin. name_parent will either be model name or the + ! exchange name. + call gncobj%set_names(1, name_parent, 'GNC', 'GNC') + ! + ! -- allocate scalars + call gncobj%allocate_scalars() + ! + ! -- Set variables + gncobj%inunit = inunit + gncobj%iout = iout + ! + ! -- return + return + end subroutine gnc_cr + + subroutine gnc_df(this, m1, m2) +! ****************************************************************************** +! gnc_df -- Initialize a gnc object. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use NumericalModelModule, only: NumericalModelType + use SimModule, only: store_error, store_error_unit, ustop + ! -- dummy + class(GhostNodeType) :: this + class(NumericalModelType), target :: m1 + class(NumericalModelType), target, optional :: m2 + ! -- local + character(len=LINELENGTH) :: errmsg +! ------------------------------------------------------------------------------ + ! + ! -- Point or set attributes + this%m1 => m1 + this%m2 => m1 + ! + ! -- If m2 is present, then GNC spans two models + if (present(m2)) then + this%m2 => m2 + this%smgnc = .false. + endif + ! + ! -- Initialize block parser + call this%parser%Initialize(this%inunit, this%iout) + ! + ! -- read gnc options + call this%read_options() + ! + ! -- read gnc dimensions + call this%read_dimensions() + ! + ! -- allocate arrays + call this%allocate_arrays() + ! + ! -- Allocate and read the gnc entries + call this%read_data() + ! + ! -- Trap for implicit gnc but models are in different solutions + if(this%m1%idsoln /= this%m2%idsoln) then + if(this%implicit) then + write(errmsg, '(a)') 'Error. GNC is implicit but models are in ' // & + 'different solutions.' + call store_error(errmsg) + call store_error_unit(this%inunit) + call ustop() + endif + endif + ! + ! -- return + return + end subroutine gnc_df + + subroutine gnc_ac(this, sparse) +! ****************************************************************************** +! gnc_ac -- Single or Two-Model GNC Add Connections +! Subroutine: (1) For implicit GNC, expand the sparse solution matrix +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SparseModule, only: sparsematrix + ! -- dummy + class(GhostNodeType) :: this + type(sparsematrix), intent(inout) :: sparse + ! -- local + integer(I4B) :: ignc, jidx, noden, nodem, nodej +! ------------------------------------------------------------------------------ + ! + ! -- Expand the sparse matrix for ghost node connections. No need to add + ! connection between n and m as they must be connected some other way + ! that will calculate the conductance. + if(this%implicit) then + do ignc = 1, this%nexg + noden = this%nodem1(ignc) + this%m1%moffset + nodem = this%nodem2(ignc) + this%m2%moffset + jloop: do jidx = 1, this%numjs + nodej = this%nodesj(jidx, ignc) + if(nodej == 0) cycle + nodej = nodej + this%m1%moffset + call sparse%addconnection(nodem, nodej, 1) + call sparse%addconnection(nodej, nodem, 1) + call sparse%addconnection(noden, nodej, 1) + call sparse%addconnection(nodej, noden, 1) + enddo jloop + enddo + endif + ! + ! -- return + return + end subroutine gnc_ac + + subroutine gnc_mc(this, iasln, jasln) +! ****************************************************************************** +! gnc_mc -- Single or Two-Model GNC Map Connections +! Subroutine: (1) Fill the following mapping arrays: +! this%idiagn, this%idiagm (diagonal positions in solution amat) +! this%idxglo (nm connection in solution amat) +! this%idxsymglo (mn connection in solution amat) +! this%jposinrown (position of j in row n of solution amat) +! this%jposinrowm (position of j in row m of solution amat) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: ustop, store_error, store_error_unit, count_errors + ! -- dummy + class(GhostNodeType) :: this + integer(I4B), dimension(:), intent(in) :: iasln + integer(I4B), dimension(:), intent(in) :: jasln + ! -- local + character(len=LINELENGTH) :: errmsg + integer(I4B) :: noden, nodem, ipos, j, ignc, jidx, nodej + ! -- formats + character(len=*),parameter :: fmterr = & + "('GHOST NODE ERROR. Cell ', i0, ' in model ', a, & + &' is not connected to cell ', i0, ' in model ', a)" +! ------------------------------------------------------------------------------ + ! + ! -- Find the location of Cnm in the global solution and store it in + ! this%idxglo + do ignc = 1, this%nexg + noden = this%nodem1(ignc) + this%m1%moffset + nodem = this%nodem2(ignc) + this%m2%moffset + ! + ! -- store diagonal positions in idiagn and idiagm + this%idiagn(ignc) = iasln(noden) + this%idiagm(ignc) = iasln(nodem) + !if(this%implicit) then + ! this%idiagn(ignc) = iasln(noden) + ! this%idiagm(ignc) = iasln(nodem) + !endif + ! + ! -- find location of m in row n of global solution + this%idxglo(ignc) = 0 + searchloopnm: do ipos = iasln(noden) + 1, iasln(noden + 1) - 1 + j = jasln(ipos) + if(j == nodem) then + this%idxglo(ignc) = ipos + exit searchloopnm + endif + enddo searchloopnm + ! + ! -- find location of n in row m of global solution and store in idxsymglo + !if(this%implicit) then + this%idxsymglo(ignc) = 0 + searchloopmn: do ipos = iasln(nodem), iasln(nodem + 1) - 1 + j = jasln(ipos) + if(j == noden) then + this%idxsymglo(ignc) = ipos + exit searchloopmn + endif + enddo searchloopmn + !endif + ! + ! -- Check to make sure idxglo is non-zero + if(this%idxglo(ignc) == 0) then + write(errmsg, fmterr) this%nodem1(ignc), trim(this%m1%name), & + this%nodem2(ignc), trim(this%m2%name) + call store_error(errmsg) + endif + ! + enddo + ! + ! -- Stop if errors + if(count_errors() > 0) then + call store_error_unit(this%inunit) + call ustop() + endif + ! + ! -- find locations of j in rows n and row m of global solution + if(this%implicit) then + do ignc = 1, this%nexg + noden = this%nodem1(ignc) + this%m1%moffset + nodem = this%nodem2(ignc) + this%m2%moffset + ! + do jidx = 1, this%numjs + nodej = this%nodesj(jidx, ignc) + if(nodej > 0) nodej = nodej + this%m1%moffset + ! + ! -- search for nodej in row n, unless it is 0 + if(nodej == 0) then + ipos = 0 + this%jposinrown(jidx, ignc) = ipos + else + searchloopn: do ipos = iasln(noden), iasln(noden + 1) - 1 + j = jasln(ipos) + if(j == nodej) then + this%jposinrown(jidx, ignc) = ipos + exit searchloopn + endif + enddo searchloopn + endif + ! + ! -- search for nodej in row m + if(nodej == 0) then + ipos = 0 + this%jposinrowm(jidx, ignc) = ipos + else + searchloopm: do ipos = iasln(nodem) + 1, iasln(nodem + 1) - 1 + j = jasln(ipos) + if(j == nodej) then + this%jposinrowm(jidx, ignc) = ipos + exit searchloopm + endif + enddo searchloopm + endif + enddo + enddo + endif + ! + ! -- return + return + end subroutine gnc_mc + + subroutine gnc_fmsav(this, kiter, amatsln) +! ****************************************************************************** +! gnc_fmsav -- Store the n-m Picard conductance in cond prior to the Newton +! terms being added. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DZERO + ! -- dummy + class(GhostNodeType) :: this + integer(I4B), intent(in) :: kiter + real(DP), dimension(:), intent(inout) :: amatsln + ! -- local + integer(I4B) :: ignc, ipos + real(DP) :: cond +! ------------------------------------------------------------------------------ + ! + ! -- An ipos value of zero indicates that noden is not connected to + ! nodem, and therefore the conductance is zero. + gncloop: do ignc = 1, this%nexg + ipos = this%idxglo(ignc) + if(ipos > 0) then + cond = amatsln(ipos) + else + cond = DZERO + endif + this%cond(ignc) = cond + enddo gncloop + ! + ! -- return + return + end subroutine gnc_fmsav + + subroutine gnc_fc(this, kiter, amatsln) +! ****************************************************************************** +! gnc_fc -- Fill matrix terms +! Subroutine: (1) Add the GNC terms to the solution amat or model rhs depending +! on whether GNC is implicit or explicit +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DZERO + ! -- dummy + class(GhostNodeType) :: this + integer(I4B), intent(in) :: kiter + real(DP), dimension(:), intent(inout) :: amatsln + ! -- local + integer(I4B) :: ignc, j, noden, nodem, ipos, jidx, iposjn, iposjm + real(DP) :: cond, alpha, aterm, rterm +! ------------------------------------------------------------------------------ + ! + ! -- If this is a single model gnc (not an exchange across models), then + ! pull conductances out of amatsln and store them in this%cond + if(this%smgnc) call this%gnc_fmsav(kiter, amatsln) + ! + ! -- Add gnc terms to rhs or to amat depending on whether gnc is implicit + ! or explicit + gncloop: do ignc = 1, this%nexg + noden = this%nodem1(ignc) + nodem = this%nodem2(ignc) + if(this%m1%ibound(noden) == 0 .or. & + this%m2%ibound(nodem) == 0) cycle gncloop + ipos = this%idxglo(ignc) + cond = this%cond(ignc) + jloop: do jidx = 1, this%numjs + j = this%nodesj(jidx, ignc) + if(j == 0) cycle + alpha = this%alphasj(jidx, ignc) + if (alpha == DZERO) cycle + aterm = alpha * cond + if(this%implicit) then + iposjn = this%jposinrown(jidx, ignc) + iposjm = this%jposinrowm(jidx, ignc) + amatsln(this%idiagn(ignc)) = amatsln(this%idiagn(ignc)) + aterm + amatsln(iposjn) = amatsln(iposjn) - aterm + amatsln(this%idxsymglo(ignc)) = amatsln(this%idxsymglo(ignc)) - aterm + amatsln(iposjm) = amatsln(iposjm) + aterm + else + rterm = aterm * (this%m1%x(noden) - this%m1%x(j)) + this%m1%rhs(noden) = this%m1%rhs(noden) - rterm + this%m2%rhs(nodem) = this%m2%rhs(nodem) + rterm + endif + enddo jloop + enddo gncloop + ! + ! -- return + return + end subroutine gnc_fc + + subroutine gnc_fn(this, kiter, njasln, amatsln, condsat, ihc_opt, & + ivarcv_opt, ictm1_opt, ictm2_opt) +! ****************************************************************************** +! gnc_fn -- Fill GNC Newton terms +! +! Required arguments: +! kiter : outer iteration number +! njasln : size of amatsln +! amatsln : coefficient matrix for the solution +! condsat is of size(njas) if single model, otherwise nexg +! +! Optional arguments: +! ihc_opt : an optional vector of size(nexg), which contains a horizontal +! connection code (0=vertical, 1=horizontal, 2=vertically staggered) +! ivarcv_opt : variable vertical conductance flag (default is 0) +! ictm1_opt : icelltype for model 1 integer vector (default is 1) +! ictm2_opt : icelltype for model 2 integer vector (default is 1) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DZERO + use SmoothingModule, only: sQuadraticSaturationDerivative + ! -- dummy + class(GhostNodeType) :: this + integer(I4B) :: kiter + integer(I4B), intent(in) :: njasln + real(DP), dimension(njasln), intent(inout) :: amatsln + real(DP), dimension(:), intent(in) :: condsat + integer(I4B), dimension(:), optional :: ihc_opt + integer(I4B), optional :: ivarcv_opt + integer(I4B), dimension(:), optional :: ictm1_opt + integer(I4B), dimension(:), optional :: ictm2_opt + ! -- local + integer(I4B) :: ignc, jidx, ipos, isympos, ihc, ivarcv + integer(I4B) :: nodej, noden, nodem + integer(I4B) :: iups, ictup + real(DP) :: csat, alpha, consterm, term, derv + real(DP) :: xup, topup, botup +! ------------------------------------------------------------------------------ + ! + ! -- Set the ivarcv to indicate whether or not the vertical conductance + ! is a function of water table + ivarcv = 0 + if (present(ivarcv_opt)) ivarcv = ivarcv_opt + ! + gncloop: do ignc = 1, this%nexg + noden = this%nodem1(ignc) + nodem = this%nodem2(ignc) + if(this%m1%ibound(noden) == 0 .or. & + this%m2%ibound(nodem) == 0) cycle gncloop + ! + ! -- Assign variables depending on whether single model gnc or exchange + ! gnc + if(this%smgnc) then + ipos = this%m1%dis%con%getjaindex(noden, nodem) + isympos = this%m1%dis%con%jas(ipos) + ihc = this%m1%dis%con%ihc(isympos) + csat = condsat(isympos) + else + ihc = ihc_opt(ignc) + csat = condsat(ignc) + endif + ! + ! If vertical connection and not variable cv, then cycle + if(ihc == 0 .and. ivarcv == 0) cycle + ! + ! determine upstream node (0 is noden, 1 is nodem) + iups = 0 + if (this%m2%x(nodem) > this%m1%x(noden)) iups = 1 + ! + ! -- Set the upstream top and bot, and then recalculate for a + ! vertically staggered horizontal connection + if(iups == 0) then + topup = this%m1%dis%top(noden) + botup = this%m1%dis%bot(noden) + ictup = 1 + if (present(ictm1_opt)) ictup = ictm1_opt(noden) + xup = this%m1%x(noden) + else + topup = this%m2%dis%top(nodem) + botup = this%m2%dis%bot(nodem) + ictup = 1 + if (present(ictm2_opt)) ictup = ictm2_opt(nodem) + xup = this%m2%x(nodem) + endif + ! + ! -- No newton terms if upstream cell is confined + if (ictup == 0) cycle + ! + ! -- Handle vertically staggered horizontal connection + if(ihc == 2) then + topup = min(this%m1%dis%top(noden), this%m2%dis%top(nodem)) + botup = max(this%m1%dis%bot(noden), this%m2%dis%bot(nodem)) + endif + ! + ! -- Process each contributing node + jloop: do jidx = 1, this%numjs + nodej = this%nodesj(jidx, ignc) + if(nodej == 0) cycle + if(this%m1%ibound(nodej) == 0) cycle + alpha = this%alphasj(jidx, ignc) + if (alpha == DZERO) cycle + consterm = csat * alpha * (this%m1%x(noden) - this%m1%x(nodej)) + derv = sQuadraticSaturationDerivative(topup, botup, xup) + term = consterm * derv + if(iups == 0) then + amatsln(this%idiagn(ignc)) = amatsln(this%idiagn(ignc)) + term + if(this%m2%ibound(nodem) > 0) then + amatsln(this%idxsymglo(ignc)) = amatsln(this%idxsymglo(ignc)) - & + term + endif + this%m1%rhs(noden) = this%m1%rhs(noden) + term * this%m1%x(noden) + this%m2%rhs(nodem) = this%m2%rhs(nodem) - term * this%m1%x(noden) + else + amatsln(this%idiagm(ignc)) = amatsln(this%idiagm(ignc)) - term + if(this%m1%ibound(noden) > 0) then + amatsln(this%idxglo(ignc)) = amatsln(this%idxglo(ignc)) + term + endif + this%m1%rhs(noden) = this%m1%rhs(noden) + term * this%m2%x(nodem) + this%m2%rhs(nodem) = this%m2%rhs(nodem) - term * this%m2%x(nodem) + endif + enddo jloop + enddo gncloop + ! + ! -- return + return + end subroutine gnc_fn + + subroutine gnc_ot(this) +! ****************************************************************************** +! gnc_ot -- Single Model GNC Output +! Subroutine: (1) Output GNC deltaQgnc values +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GhostNodeType) :: this + ! -- local + integer(I4B) :: ignc + real(DP) :: deltaQgnc + character(len=LINELENGTH) :: nodenstr, nodemstr + ! -- format + character(len=*), parameter :: fmtgnc = "(i10, 2a10, 2(1pg15.6))" +! ------------------------------------------------------------------------------ + ! + ! -- Process each gnc and output deltaQgnc + if(this%iprflow /= 0) then + write(this%iout, '(//, a)') 'GHOST NODE CORRECTION RESULTS' + write(this%iout, '(3a10, 2a15)') 'GNC NUM', 'NODEN', 'NODEM', & + 'DELTAQGNC', 'CONDNM' + do ignc = 1, this%nexg + deltaQgnc = this%deltaQgnc(ignc) + call this%m1%dis%noder_to_string(this%nodem1(ignc), nodenstr) + call this%m2%dis%noder_to_string(this%nodem2(ignc), nodemstr) + write(this%iout, fmtgnc) ignc, trim(adjustl(nodenstr)), & + trim(adjustl(nodemstr)), & + deltaQgnc, this%cond(ignc) + enddo + endif + ! + ! -- return + return + end subroutine gnc_ot + + subroutine gncflowja(this, flowja) +! ****************************************************************************** +! gncflowja -- Add GNC to flowja +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GhostNodeType) :: this + real(DP), dimension(:), intent(inout) :: flowja + ! -- local + integer(I4B) :: ignc, n1, n2, ipos, isympos + real(DP) :: deltaQgnc + ! -- format +! ------------------------------------------------------------------------------ + ! + ! -- go through each gnc and add deltagnc to flowja + do ignc = 1, this%nexg + ! + ! -- calculate correction term between n1 and n2 connection + n1 = this%nodem1(ignc) + n2 = this%nodem2(ignc) + deltaQgnc = this%deltaQgnc(ignc) + ! + ! -- find the positions of this connection in the csr array + ipos = this%m1%dis%con%getjaindex(n1, n2) + isympos = this%m1%dis%con%isym(ipos) + ! + ! -- add/subtract the corrections + flowja(ipos) = flowja(ipos) + deltaQgnc + flowja(isympos) = flowja(isympos) - deltaQgnc + ! + enddo + ! + ! -- return + return + end subroutine gncflowja + + function deltaQgnc(this, ignc) +! ****************************************************************************** +! deltaQgnc -- Single Model deltaQgnc (ghost node correction flux) +! Subroutine: (1) Calculate the deltaQgnc value for any GNC in the GNC list +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DZERO + ! -- return + real(DP) :: deltaQgnc + ! -- dummy + class(GhostNodeType) :: this + integer(I4B), intent(in) :: ignc + ! -- local + integer(I4B) :: noden, nodem, nodej, jidx + real(DP) :: sigalj, alpha, hd, aterm, cond +! ------------------------------------------------------------------------------ + ! + ! -- initialize values + deltaQgnc = DZERO + sigalj = DZERO + hd = DZERO + noden = this%nodem1(ignc) + nodem = this%nodem2(ignc) + ! + ! -- calculate deltaQgnc + if(this%m1%ibound(noden) /= 0 .and. this%m2%ibound(nodem) /= 0) then + jloop: do jidx = 1, this%numjs + nodej = this%nodesj(jidx, ignc) + if(nodej == 0) cycle jloop + if(this%m1%ibound(nodej) == 0) cycle jloop + alpha = this%alphasj(jidx, ignc) + sigalj = sigalj + alpha + hd = hd + alpha * this%m1%x(nodej) + enddo jloop + aterm = sigalj * this%m1%x(noden) - hd + cond = this%cond(ignc) + deltaQgnc = aterm * cond + endif + ! + ! -- return + return + end function deltaQgnc + + subroutine allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars -- allocate gnc scalar variables +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GhostNodeType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- allocate scalars in NumericalPackageType + call this%NumericalPackageType%allocate_scalars() + ! + call mem_allocate(this%smgnc, 'SMGNC', this%origin) + call mem_allocate(this%implicit, 'IMPLICIT', this%origin) + call mem_allocate(this%i2kn, 'I2KN', this%origin) + call mem_allocate(this%nexg, 'NEXG', this%origin) + call mem_allocate(this%numjs, 'NUMJS', this%origin) + ! + ! -- Initialize values + this%smgnc = .true. + this%implicit = .true. + this%i2kn = .false. + this%nexg = 0 + this%numjs = 0 + ! + return + end subroutine allocate_scalars + + subroutine allocate_arrays(this) +! ****************************************************************************** +! allocate_arrays -- allocate gnc scalar variables +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + use ConstantsModule, only: LENORIGIN + ! -- dummy + class(GhostNodeType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- allocate memory for arrays + call mem_allocate(this%nodem1, this%nexg, 'NODEM1', this%origin) + call mem_allocate(this%nodem2, this%nexg, 'NODEM2', this%origin) + call mem_allocate(this%nodesj, this%numjs, this%nexg, 'NODESJ', & + this%origin) + call mem_allocate(this%alphasj, this%numjs, this%nexg, 'ALPHASJ', & + this%origin) + call mem_allocate(this%cond, this%nexg, 'COND', this%origin) + call mem_allocate(this%idxglo, this%nexg, 'IDXGLO', this%origin) + call mem_allocate(this%idiagn, this%nexg, 'IDIAGN', this%origin) + call mem_allocate(this%idiagm, this%nexg, 'IDIAGM', this%origin) + call mem_allocate(this%idxsymglo, this%nexg, 'IDXSYMGLO', this%origin) + if(this%implicit) then + call mem_allocate(this%jposinrown, this%numjs, this%nexg, 'JPOSINROWN', & + this%origin) + call mem_allocate(this%jposinrowm, this%numjs, this%nexg, 'JPOSINROWM', & + this%origin) + else + call mem_allocate(this%jposinrown, 0, 0, 'JPOSINROWN', this%origin) + call mem_allocate(this%jposinrowm, 0, 0, 'JPOSINROWM', this%origin) + endif + ! + ! -- Return + return + end subroutine allocate_arrays + + subroutine gnc_da(this) +! ****************************************************************************** +! gnc_da -- deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(GhostNodeType) :: this +! ------------------------------------------------------------------------------ + ! + call mem_deallocate(this%smgnc) + call mem_deallocate(this%implicit) + call mem_deallocate(this%i2kn) + call mem_deallocate(this%nexg) + call mem_deallocate(this%numjs) + ! + ! -- Arrays + if (this%inunit > 0) then + call mem_deallocate(this%nodem1) + call mem_deallocate(this%nodem2) + call mem_deallocate(this%nodesj) + call mem_deallocate(this%alphasj) + call mem_deallocate(this%cond) + call mem_deallocate(this%idxglo) + call mem_deallocate(this%idiagn) + call mem_deallocate(this%idiagm) + call mem_deallocate(this%idxsymglo) + call mem_deallocate(this%jposinrown) + call mem_deallocate(this%jposinrowm) + endif + ! + ! -- deallocate NumericalPackageType + call this%NumericalPackageType%da() + ! + ! -- Return + return + end subroutine gnc_da + + subroutine read_options(this) +! ****************************************************************************** +! read_options -- read a gnc options block +! Subroutine: (1) read options from input file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: ustop, store_error + ! -- dummy + class(GhostNodeType) :: this + ! -- local + 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.) + ! + ! -- parse options block if detected + if (isfound) then + write(this%iout,'(1x,a)')'PROCESSING GNC OPTIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('PRINT_INPUT') + this%iprpak = 1 + write(this%iout,'(4x,a)') & + 'THE LIST OF GHOST-NODE CORRECTIONS WILL BE PRINTED.' + case ('PRINT_FLOWS') + this%iprflow = 1 + write(this%iout,'(4x,a)') & + 'DELTAQGNC VALUES WILL BE PRINTED TO THE LIST FILE.' + case ('I2KN') + this%i2kn = .true. + write(this%iout,'(4x,a)') & + 'SECOND ORDER CORRECTION WILL BE APPLIED.' + case ('EXPLICIT') + this%implicit = .false. + write(this%iout,'(4x,a)')'GHOST NODE CORRECTION IS EXPLICIT.' + case default + write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN GNC OPTION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + end do + write(this%iout,'(1x,a)')'END OF GNC OPTIONS' + end if + ! + ! -- Set the iasym flag if the correction is implicit + if (this%implicit) this%iasym = 1 + ! + ! -- return + return + end subroutine read_options + + subroutine read_dimensions(this) +! ****************************************************************************** +! read_dimensions -- Single Model GNC Read Dimensions +! Subroutine: (1) read dimensions (size of gnc list) from input file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: ustop, store_error + ! -- dummy + class(GhostNodeType) :: this + ! -- local + character(len=LINELENGTH) :: errmsg, keyword + integer(I4B) :: ierr + logical :: isfound, endOfBlock +! ------------------------------------------------------------------------------ + ! + ! -- 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 GNC DIMENSIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('NUMGNC') + this%nexg = this%parser%GetInteger() + write(this%iout,'(4x,a,i7)')'NUMGNC = ', this%nexg + case ('NUMALPHAJ') + this%numjs = this%parser%GetInteger() + write(this%iout,'(4x,a,i7)')'NUMAPHAJ = ', this%numjs + case default + write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN GNC DIMENSION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + end do + write(this%iout,'(1x,a)')'END OF GNC DIMENSIONS' + else + call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') + call ustop() + end if + ! + ! -- return + return + end subroutine read_dimensions + + subroutine read_data(this) +! ****************************************************************************** +! read_data -- Read a GNCDATA block +! Subroutine: (1) read list of GNCs from input file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: ustop, store_error, count_errors + ! -- dummy + class(GhostNodeType) :: this + ! -- local + character(len=LINELENGTH) :: line, errmsg, nodestr, fmtgnc, cellid, & + cellidm, cellidn + integer(I4B) :: lloc,ierr,ival + integer(I4B) :: ignc, jidx, nodeun, nodeum, nerr + integer(I4B), dimension(:), allocatable :: nodesuj + logical :: isfound, endOfBlock + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- Construct the fmtgnc format + write(fmtgnc, '("(2i10,",i0,"i10,",i0, "(1pg15.6))")') this%numjs, & + this%numjs + ! + ! -- Allocate the temporary nodesuj, which stores the user-based nodej + ! node numbers + allocate(nodesuj(this%numjs)) + ! + ! -- get GNCDATA block + call this%parser%GetBlock('GNCDATA', isfound, ierr, supportOpenClose=.true.) + ! + ! -- process GNC data + if (isfound) then + write(this%iout,'(1x,a)')'PROCESSING GNCDATA' + do ignc = 1, this%nexg + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetCurrentLine(line) + lloc = 1 + ! + ! -- cellidn (read as cellid and convert to user node) + call this%parser%GetCellid(this%m1%dis%ndim, cellidn) + nodeun = this%m1%dis%nodeu_from_cellid(cellidn, this%parser%iuactive, & + this%iout) + ! + ! -- convert user node to reduced node number + call this%nodeu_to_noder(nodeun, this%nodem1(ignc), this%m1) + ! + ! -- cellidm (read as cellid and convert to user node) + call this%parser%GetCellid(this%m2%dis%ndim, cellidm) + nodeum = this%m2%dis%nodeu_from_cellid(cellidm, this%parser%iuactive, & + this%iout) + ! + ! -- convert user node to reduced node number + call this%nodeu_to_noder(nodeum, this%nodem2(ignc), this%m2) + ! + ! -- cellidsj (read as cellid) + do jidx=1, this%numjs + ! read cellidj as cellid of model 1 + call this%parser%GetCellid(this%m1%dis%ndim, cellid) + ival = this%m1%dis%nodeu_from_cellid(cellid, this%parser%iuactive, & + this%iout, allow_zero=.true.) + nodesuj(jidx) = ival + if(ival > 0) then + call this%nodeu_to_noder(ival, this%nodesj(jidx, ignc), this%m1) + else + this%nodesj(jidx, ignc) = 0 + endif + enddo + ! + ! -- alphaj + do jidx=1, this%numjs + this%alphasj(jidx, ignc) = this%parser%GetDouble() + enddo + ! + ! -- Echo if requested + if(this%iprpak /= 0) & + write(this%iout, fmtgnc) nodeun, nodeum, & + (nodesuj(jidx), jidx = 1, this%numjs), & + (this%alphasj(jidx, ignc), jidx = 1, this%numjs) + ! + ! -- Check to see if noden is outside of active domain + if(this%nodem1(ignc) <= 0) then + call this%m1%dis%nodeu_to_string(nodeun, nodestr) + write(errmsg, *) & + trim(adjustl(this%m1%name)) // & + ' Cell is outside active grid domain: ' // & + trim(adjustl(nodestr)) + call store_error(errmsg) + endif + ! + ! -- Check to see if nodem is outside of active domain + if(this%nodem2(ignc) <= 0) then + call this%m2%dis%nodeu_to_string(nodeum, nodestr) + write(errmsg, *) & + trim(adjustl(this%m2%name)) // & + ' Cell is outside active grid domain: ' // & + trim(adjustl(nodestr)) + call store_error(errmsg) + endif + ! + ! -- Check to see if any nodejs are outside of active domain + do jidx = 1, this%numjs + if(this%nodesj(jidx, ignc) < 0) then + call this%m1%dis%nodeu_to_string(nodesuj(jidx), nodestr) + write(errmsg, *) & + trim(adjustl(this%m1%name)) // & + ' Cell is outside active grid domain: ' // & + trim(adjustl(nodestr)) + call store_error(errmsg) + endif + enddo + ! + enddo + ! + ! -- Stop if errors + nerr = count_errors() + if(nerr > 0) then + call store_error('Errors encountered in GNC input file.') + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + write(this%iout,'(1x,a)')'END OF GNCDATA' + else + write(errmsg, '(1x,a)')'ERROR. REQUIRED GNCDATA BLOCK NOT FOUND.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- deallocate nodesuj array + deallocate(nodesuj) + ! + ! -- return + return + end subroutine read_data + + subroutine nodeu_to_noder(this, nodeu, noder, model) +! ****************************************************************************** +! nodeu_to_noder -- Convert the user-based node number into a reduced number +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use NumericalModelModule, only: NumericalModelType + use SimModule, only: store_error + ! -- dummy + class(GhostNodeType) :: this + integer(I4B), intent(in) :: nodeu + integer(I4B), intent(inout) :: noder + class(NumericalModelType), intent(in) :: model + ! -- local + character(len=LINELENGTH) :: errmsg +! ------------------------------------------------------------------------------ + ! + if(nodeu < 1 .or. nodeu > model%dis%nodesuser) then + write(errmsg, *) & + trim(adjustl(model%name)) // & + ' node number < 0 or > model nodes: ', nodeu + call store_error(errmsg) + else + noder = model%dis%get_nodenumber(nodeu, 0) + endif + ! + ! -- Return + return + end subroutine nodeu_to_noder + + +end module GhostNodeModule diff --git a/src/Exchange/GwfGwfExchange.f90 b/src/Exchange/GwfGwfExchange.f90 index db967e60698..a96719d569d 100644 --- a/src/Exchange/GwfGwfExchange.f90 +++ b/src/Exchange/GwfGwfExchange.f90 @@ -1,2173 +1,2173 @@ -module GwfGwfExchangeModule - - use KindModule, only: DP, I4B - use ArrayHandlersModule, only: ExpandArray - use BaseModelModule, only: GetBaseModelFromList - use BaseExchangeModule, only: BaseExchangeType, AddBaseExchangeToList - use ConstantsModule, only: LENBOUNDNAME, NAMEDBOUNDFLAG, LINELENGTH, & - TABCENTER, TABLEFT - use ListsModule, only: basemodellist - use NumericalExchangeModule, only: NumericalExchangeType - use NumericalModelModule, only: NumericalModelType - use GwfModule, only: GwfModelType - use GhostNodeModule, only: GhostNodeType - use GwfMvrModule, only: GwfMvrType - use ObserveModule, only: ObserveType - use ObsModule, only: ObsType - use SimModule, only: count_errors, store_error, & - store_error_unit, ustop - use BlockParserModule, only: BlockParserType - use TableModule, only: TableType, table_cr - - implicit none - - private - public :: gwfexchange_create - - type, extends(NumericalExchangeType) :: GwfExchangeType - type(GwfModelType), pointer :: gwfmodel1 => null() ! pointer to GWF Model 1 - type(GwfModelType), pointer :: gwfmodel2 => null() ! pointer to GWF Model 2 - integer(I4B), pointer :: inewton => null() ! newton flag (1 newton is on) - integer(I4B), pointer :: icellavg => null() ! cell averaging - integer(I4B), pointer :: ivarcv => null() ! variable cv - integer(I4B), pointer :: idewatcv => null() ! dewatered cv - integer(I4B), pointer :: ianglex => null() ! flag indicating anglex was read, if read, ianglex is index in auxvar - integer(I4B), pointer :: icdist => null() ! flag indicating cdist was read, if read, icdist is index in auxvar - integer(I4B), pointer :: inamedbound => null() ! flag to read boundnames - real(DP), pointer :: satomega => null() ! saturation smoothing - integer(I4B), dimension(:), pointer, contiguous :: ihc => null() ! horizontal connection indicator array - real(DP), dimension(:), pointer, contiguous :: condsat => null() ! saturated conductance - real(DP), dimension(:), pointer, contiguous :: cl1 => null() ! connection length 1 - real(DP), dimension(:), pointer, contiguous :: cl2 => null() ! connection length 2 - real(DP), dimension(:), pointer, contiguous :: hwva => null() ! horizontal widths, vertical flow areas - integer(I4B), pointer :: ingnc => null() ! unit number for gnc (0 if off) - type(GhostNodeType), pointer :: gnc => null() ! gnc object - integer(I4B), pointer :: inmvr => null() ! unit number for mover (0 if off) - type(GwfMvrType), pointer :: mvr => null() ! water mover object - integer(I4B), pointer :: inobs => null() ! unit number for GWF-GWF observations - type(ObsType), pointer :: obs => null() ! observation object - character(len=LENBOUNDNAME), dimension(:), & - pointer, contiguous :: boundname => null() ! boundnames - ! - ! -- table objects - type(TableType), pointer :: outputtab1 => null() - type(TableType), pointer :: outputtab2 => null() - - contains - - procedure :: exg_df => gwf_gwf_df - procedure :: exg_ac => gwf_gwf_ac - procedure :: exg_mc => gwf_gwf_mc - procedure :: exg_ar => gwf_gwf_ar - procedure :: exg_rp => gwf_gwf_rp - procedure :: exg_ad => gwf_gwf_ad - procedure :: exg_cf => gwf_gwf_cf - procedure :: exg_fc => gwf_gwf_fc - procedure :: exg_fn => gwf_gwf_fn - procedure :: exg_cq => gwf_gwf_cq - procedure :: exg_bd => gwf_gwf_bd - procedure :: exg_ot => gwf_gwf_ot - procedure :: exg_da => gwf_gwf_da - procedure :: exg_fp => gwf_gwf_fp - procedure :: get_iasym => gwf_gwf_get_iasym - procedure :: allocate_scalars - procedure :: allocate_arrays - procedure :: read_options - procedure :: read_data - procedure :: read_gnc - procedure :: read_mvr - procedure, private :: condcalc - procedure, private :: rewet - procedure, private :: qcalc - procedure, private :: gwf_gwf_df_obs - procedure, private :: gwf_gwf_rp_obs - procedure, public :: gwf_gwf_save_simvals - end type GwfExchangeType - -contains - - subroutine gwfexchange_create(filename, id, m1id, m2id) -! ****************************************************************************** -! Create a new GWF to GWF exchange object. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use BaseModelModule, only: BaseModelType - use ListsModule, only: baseexchangelist - use ObsModule, only: obs_cr - ! -- dummy - character(len=*),intent(in) :: filename - integer(I4B), intent(in) :: id, m1id, m2id - ! -- local - type(GwfExchangeType), pointer :: exchange - class(BaseModelType), pointer :: mb - class(BaseExchangeType), pointer :: baseexchange - character(len=20) :: cint -! ------------------------------------------------------------------------------ - ! - ! -- Create a new exchange and add it to the baseexchangelist container - allocate(exchange) - baseexchange => exchange - call AddBaseExchangeToList(baseexchangelist, baseexchange) - ! - ! -- Assign id and name - exchange%id = id - write(cint, '(i0)') id - exchange%name = 'GWF-GWF_' // trim(adjustl(cint)) - ! - ! -- allocate scalars and set defaults - call exchange%allocate_scalars() - exchange%filename = filename - exchange%typename = 'GWF-GWF' - exchange%implicit = .true. - ! - ! -- set exchange%m1 - mb => GetBaseModelFromList(basemodellist, m1id) - select type (mb) - class is (NumericalModelType) - exchange%m1=>mb - end select - ! - ! -- set exchange%m2 - mb => GetBaseModelFromList(basemodellist, m2id) - select type (mb) - class is (NumericalModelType) - exchange%m2=>mb - end select - ! - ! -- set gwfmodel1 - mb => GetBaseModelFromList(basemodellist, m1id) - select type (mb) - type is (GwfModelType) - exchange%gwfmodel1 => mb - end select - ! - ! -- set gwfmodel2 - mb => GetBaseModelFromList(basemodellist, m2id) - select type (mb) - type is (GwfModelType) - exchange%gwfmodel2 => mb - end select - ! - ! -- Create the obs package - call obs_cr(exchange%obs, exchange%inobs) - ! - ! -- return - return - end subroutine gwfexchange_create - - subroutine gwf_gwf_df(this) -! ****************************************************************************** -! gwf_gwf_df -- Define GWF to GWF exchange object. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimVariablesModule, only: iout - use InputOutputModule, only: getunit, openfile - use GhostNodeModule, only: gnc_cr - ! -- dummy - class(GwfExchangeType) :: this - ! -- local - integer(I4B) :: inunit -! ------------------------------------------------------------------------------ - ! - ! -- open the file - inunit = getunit() - write(iout,'(/a,a)') ' Creating exchange: ', this%name - call openfile(inunit, iout, this%filename, 'GWF-GWF') - ! - call this%parser%Initialize(inunit, iout) - ! - ! -- Ensure models are in same solution - if(this%gwfmodel1%idsoln /= this%gwfmodel2%idsoln) then - call store_error('ERROR. TWO MODELS ARE CONNECTED ' // & - 'IN A GWF EXCHANGE BUT THEY ARE IN DIFFERENT SOLUTIONS. ' // & - 'GWF MODELS MUST BE IN SAME SOLUTION: ' // & - trim(this%gwfmodel1%name) // ' ' // trim(this%gwfmodel2%name) ) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- read options - call this%read_options(iout) - ! - ! -- read dimensions - call this%read_dimensions(iout) - ! - ! -- allocate arrays - call this%allocate_arrays() - ! - ! -- read exchange data - call this%read_data(iout) - ! - ! -- call each model and increase the edge count - call this%gwfmodel1%npf%increase_edge_count(this%nexg) - call this%gwfmodel2%npf%increase_edge_count(this%nexg) - ! - ! -- Create and read ghost node information - if(this%ingnc > 0) then - call gnc_cr(this%gnc, this%name, this%ingnc, iout) - call this%read_gnc(iout) - endif - ! - ! -- Read mover information - if(this%inmvr > 0) then - call this%read_mvr(iout) - endif - ! - ! -- close the file - close(inunit) - ! - ! -- Store obs - call this%gwf_gwf_df_obs() - call this%obs%obs_df(iout, this%name, 'GWF-GWF', this%gwfmodel1%dis) - ! - ! -- return - return - end subroutine gwf_gwf_df - - subroutine gwf_gwf_ac(this, sparse) -! ****************************************************************************** -! gwf_gwf_ac -- override parent exg_ac so that gnc can add -! connections here. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SparseModule, only:sparsematrix - ! -- dummy - class(GwfExchangeType) :: this - type(sparsematrix), intent(inout) :: sparse - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- call parent model to add exchange connections - call this%NumericalExchangeType%exg_ac(sparse) - ! - ! -- add gnc connections - if(this%ingnc > 0) then - call this%gnc%gnc_ac(sparse) - endif - ! - ! -- Return - return - end subroutine gwf_gwf_ac - - subroutine gwf_gwf_mc(this, iasln, jasln) -! ****************************************************************************** -! gwf_gwf_mc -- Map the connections in the global matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SparseModule, only:sparsematrix - ! -- dummy - class(GwfExchangeType) :: this - integer(I4B), dimension(:), intent(in) :: iasln - integer(I4B), dimension(:), intent(in) :: jasln - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- call parent model to map exchange connections - call this%NumericalExchangeType%exg_mc(iasln, jasln) - ! - ! -- map gnc connections - if(this%ingnc > 0) then - call this%gnc%gnc_mc(iasln, jasln) - endif - ! - ! -- Return - return - end subroutine gwf_gwf_mc - - subroutine gwf_gwf_ar(this) -! ****************************************************************************** -! gwf_gwf_ar -- Calculate the saturated conductance. Must be called after -! npf_ar for both GWF models. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH, DZERO, DHALF, DONE, DPIO180 - use SimModule, only: store_error, ustop - use GwfNpfModule, only: condmean, vcond, hcond - ! -- dummy - class(GwfExchangeType) :: this - ! -- local - integer(I4B) :: iexg - integer(I4B) :: n, m, ihc - real(DP) :: topn, topm - real(DP) :: botn, botm - real(DP) :: satn, satm - real(DP) :: thickn, thickm - real(DP) :: angle, hyn, hym - real(DP) :: csat - real(DP) :: fawidth - real(DP), dimension(3) :: vg - character(len=LINELENGTH) :: errmsg -! ------------------------------------------------------------------------------ - ! - ! -- If mover is active, then call ar routine - if(this%inmvr > 0) call this%mvr%mvr_ar() - ! - ! -- Check to see if horizontal anisotropy is in either model1 or model2. - ! If so, then ANGLDEGX must be provided as an auxiliary variable for this - ! GWF-GWF exchange (this%ianglex > 0). - if(this%gwfmodel1%npf%ik22 /= 0 .or. this%gwfmodel2%npf%ik22 /= 0) then - if(this%ianglex == 0) then - write(errmsg, '(a)') 'Error. GWF-GWF requires that ANGLDEGX be ' // & - 'specified as an auxiliary variable because ' // & - 'K22 was specified in one or both ' // & - 'groundwater models.' - call store_error(errmsg) - call ustop() - endif - endif - ! - ! -- Check to see if specific discharge is needed for model1 or model2. - ! If so, then ANGLDEGX must be provided as an auxiliary variable for this - ! GWF-GWF exchange (this%ianglex > 0). - if(this%gwfmodel1%npf%icalcspdis /= 0 .or. & - this%gwfmodel2%npf%icalcspdis /= 0) then - if(this%ianglex == 0) then - write(errmsg, '(a)') 'Error. GWF-GWF requires that ANGLDEGX be ' // & - 'specified as an auxiliary variable because ' // & - 'specific discharge is being calculated in' // & - ' one or both groundwater models.' - call store_error(errmsg) - call ustop() - endif - if(this%icdist == 0) then - write(errmsg, '(a)') 'Error. GWF-GWF requires that CDIST be ' // & - 'specified as an auxiliary variable because ' // & - 'specific discharge is being calculated in' // & - ' one or both groundwater models.' - call store_error(errmsg) - call ustop() - endif - endif - ! - ! -- Go through each connection and calculate the saturated conductance - do iexg = 1, this%nexg - ! - ihc = this%ihc(iexg) - n = this%nodem1(iexg) - m = this%nodem2(iexg) - topn = this%gwfmodel1%dis%top(n) - topm = this%gwfmodel2%dis%top(m) - botn = this%gwfmodel1%dis%bot(n) - botm = this%gwfmodel2%dis%bot(m) - satn = this%gwfmodel1%npf%sat(n) - satm = this%gwfmodel2%npf%sat(m) - thickn = (topn - botn) * satn - thickm = (topm - botm) * satm - ! - ! -- Calculate conductance depending on connection orientation - if(ihc == 0) then - ! - ! -- Vertical conductance for fully saturated conditions - vg(1) = DZERO - vg(2) = DZERO - vg(3) = DONE - hyn = this%gwfmodel1%npf%hy_eff(n, 0, ihc, vg=vg) - hym = this%gwfmodel2%npf%hy_eff(m, 0, ihc, vg=vg) - csat = vcond(1, 1, 1, 1, 0, 1, 1, DONE, & - botn, botm, & - hyn, hym, & - satn, satm, & - topn, topm, & - botn, botm, & - this%hwva(iexg)) - else - ! - ! -- Calculate horizontal conductance - hyn = this%gwfmodel1%npf%k11(n) - hym = this%gwfmodel2%npf%k11(m) - ! - ! -- Check for anisotropy in models, and recalculate hyn and hym - if(this%ianglex > 0) then - angle = this%auxvar(this%ianglex, iexg) * DPIO180 - vg(1) = abs(cos(angle)) - vg(2) = abs(sin(angle)) - vg(3) = DZERO - ! - ! -- anisotropy in model 1 - if(this%gwfmodel1%npf%ik22 /= 0) then - hyn = this%gwfmodel1%npf%hy_eff(n, 0, ihc, vg=vg) - endif - ! - ! -- anisotropy in model 2 - if(this%gwfmodel2%npf%ik22 /= 0) then - hym = this%gwfmodel2%npf%hy_eff(m, 0, ihc, vg=vg) - endif - endif - ! - fawidth = this%hwva(iexg) - csat = hcond(1, 1, 1, 1, this%inewton, 0, ihc, & - this%icellavg, 0, 0, DONE, & - topn, topm, satn, satm, hyn, hym, & - topn, topm, & - botn, botm, & - this%cl1(iexg), this%cl2(iexg), & - fawidth, this%satomega) - endif - ! - ! -- store csat in condsat - this%condsat(iexg) = csat - enddo - ! - ! -- Observation AR - call this%obs%obs_ar() - ! - ! -- Return - return - end subroutine gwf_gwf_ar - - subroutine gwf_gwf_rp(this) -! ****************************************************************************** -! gwf_gwf_rp -- Read and prepare -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: readnewdata - ! -- dummy - class(GwfExchangeType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Check with TDIS on whether or not it is time to RP - if (.not. readnewdata) return - ! - ! -- Read and prepare for mover - if(this%inmvr > 0) call this%mvr%mvr_rp() - ! - ! -- Read and prepare for observations - call this%gwf_gwf_rp_obs() - ! - ! -- Return - return - end subroutine gwf_gwf_rp - - subroutine gwf_gwf_ad(this, isolnid, kpicard, isubtime) -! ****************************************************************************** -! gwf_gwf_ad -- Initialize package x values to zero for explicit exchanges -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(GwfExchangeType) :: this - integer(I4B), intent(in) :: isolnid - integer(I4B), intent(in) :: kpicard - integer(I4B), intent(in) :: isubtime - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- Advance mover - if(this%inmvr > 0) call this%mvr%mvr_ad() - ! - ! -- Push simulated values to preceding time/subtime step - call this%obs%obs_ad() - ! - ! -- Return - return - end subroutine gwf_gwf_ad - - subroutine gwf_gwf_cf(this, kiter) -! ****************************************************************************** -! gwf_gwf_cf -- Calculate the conductance term. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfExchangeType) :: this - integer(I4B), intent(in) :: kiter - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- Rewet cells across models using the wetdry parameters in each model's - ! npf package, and the head in the connected model. - call this%rewet(kiter) - ! - ! -- Return - return - end subroutine gwf_gwf_cf - - subroutine gwf_gwf_fc(this, kiter, iasln, amatsln, inwtflag) -! ****************************************************************************** -! gwf_gwf_fc -- Fill the matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DHALF - use GwfNpfModule, only: hcond, vcond - ! -- dummy - class(GwfExchangeType) :: this - integer(I4B), intent(in) :: kiter - integer(I4B), dimension(:), intent(in) :: iasln - real(DP), dimension(:), intent(inout) :: amatsln - integer(I4B), optional, intent(in) :: inwtflag - ! -- local - integer(I4B) :: inwt, iexg - integer(I4B) :: njasln -! ------------------------------------------------------------------------------ - ! - ! -- calculate the conductance for each exchange connection - call this%condcalc() - ! - ! -- if gnc is active, then copy cond into gnc cond (might consider a - ! pointer here in the future) - if(this%ingnc > 0) then - do iexg = 1, this%nexg - this%gnc%cond(iexg) = this%cond(iexg) - enddo - endif - ! - ! -- Call fill method of parent to put this%cond into amatsln - call this%NumericalExchangeType%exg_fc(kiter, iasln, amatsln) - ! - ! -- Fill the gnc terms in the solution matrix - if(this%ingnc > 0) then - call this%gnc%gnc_fc(kiter, amatsln) - endif - ! - ! -- Call mvr fc routine - if(this%inmvr > 0) call this%mvr%mvr_fc() - ! - ! -- Set inwt to exchange newton, but shut off if requested by caller - inwt = this%inewton - if(present(inwtflag)) then - if (inwtflag == 0) inwt = 0 - endif - if (inwt /= 0) then - call this%exg_fn(kiter, iasln, amatsln) - endif - ! - ! -- Ghost node Newton-Raphson - if (this%ingnc > 0) then - if (inwt /= 0) then - njasln = size(amatsln) - call this%gnc%gnc_fn(kiter, njasln, amatsln, this%condsat, & - ihc_opt=this%ihc, ivarcv_opt=this%ivarcv, & - ictm1_opt=this%gwfmodel1%npf%icelltype, & - ictm2_opt=this%gwfmodel2%npf%icelltype) - endif - endif - ! - ! -- Return - return - end subroutine gwf_gwf_fc - - subroutine gwf_gwf_fn(this, kiter, iasln, amatsln) -! ****************************************************************************** -! gwf_gwf_fn -- Fill amatsln with Newton terms -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SmoothingModule, only: sQuadraticSaturationDerivative - ! -- dummy - class(GwfExchangeType) :: this - integer(I4B), intent(in) :: kiter - integer(I4B), dimension(:), intent(in) :: iasln - real(DP), dimension(:), intent(inout) :: amatsln - ! -- local - logical :: nisup - integer(I4B) :: iexg - integer(I4B) :: n, m - integer(I4B) :: nodensln, nodemsln - integer(I4B) :: ibdn, ibdm - integer(I4B) :: idiagnsln, idiagmsln - real(DP) :: topn, topm - real(DP) :: botn, botm - real(DP) :: topup, botup - real(DP) :: hn, hm - real(DP) :: hup, hdn - real(DP) :: cond - real(DP) :: term - real(DP) :: consterm - real(DP) :: derv -! ------------------------------------------------------------------------------ - ! - do iexg = 1, this%nexg - n = this%nodem1(iexg) - m = this%nodem2(iexg) - nodensln = this%nodem1(iexg) + this%m1%moffset - nodemsln = this%nodem2(iexg) + this%m2%moffset - ibdn = this%gwfmodel1%ibound(n) - ibdm = this%gwfmodel2%ibound(m) - topn = this%gwfmodel1%dis%top(n) - topm = this%gwfmodel2%dis%top(m) - botn = this%gwfmodel1%dis%bot(n) - botm = this%gwfmodel2%dis%bot(m) - hn = this%gwfmodel1%x(n) - hm = this%gwfmodel2%x(m) - if(this%ihc(iexg) == 0) then - ! -- vertical connection, newton not supported - else - ! -- determine upstream node - nisup = .false. - if(hm < hn) nisup = .true. - ! - ! -- set upstream top and bot - if(nisup) then - topup = topn - botup = botn - hup = hn - hdn = hm - else - topup = topm - botup = botm - hup = hm - hdn = hn - endif - ! - ! -- no newton terms if upstream cell is confined - if (nisup) then - if (this%gwfmodel1%npf%icelltype(n) == 0) cycle - else - if (this%gwfmodel2%npf%icelltype(m) == 0) cycle - end if - ! - ! -- set topup and botup - if(this%ihc(iexg) == 2) then - topup = min(topn, topm) - botup = max(botn, botm) - endif - ! - ! get saturated conductivity for derivative - cond = this%condsat(iexg) - ! - ! -- TO DO deal with MODFLOW-NWT upstream weighting option - ! - ! -- compute terms - consterm = -cond * (hup - hdn) - derv = sQuadraticSaturationDerivative(topup, botup, hup) - idiagnsln = iasln(nodensln) - idiagmsln = iasln(nodemsln) - if(nisup) then - ! - ! -- fill jacobian with n being upstream - term = consterm * derv - this%gwfmodel1%rhs(n) = this%gwfmodel1%rhs(n) + term * hn - this%gwfmodel2%rhs(m) = this%gwfmodel2%rhs(m) - term * hn - amatsln(idiagnsln) = amatsln(idiagnsln) + term - if(ibdm > 0) then - amatsln(this%idxsymglo(iexg)) = amatsln(this%idxsymglo(iexg)) - term - endif - else - ! - ! -- fill jacobian with m being upstream - term = -consterm * derv - this%gwfmodel1%rhs(n) = this%gwfmodel1%rhs(n) + term * hm - this%gwfmodel2%rhs(m) = this%gwfmodel2%rhs(m) - term * hm - amatsln(idiagmsln) = amatsln(idiagmsln) - term - if(ibdn > 0) then - amatsln(this%idxglo(iexg)) = amatsln(this%idxglo(iexg)) + term - endif - endif - endif - enddo - ! - ! -- Return - return - end subroutine gwf_gwf_fn - - subroutine gwf_gwf_cq(this, icnvg, isuppress_output, isolnid) -! ****************************************************************************** -! gwf_gwf_cq -- Calculate flow between two cells -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DZERO, DPIO180 - use GwfNpfModule, only: thksatnm - ! -- dummy - class(GwfExchangeType) :: this - integer(I4B), intent(inout) :: icnvg - integer(I4B), intent(in) :: isuppress_output - integer(I4B), intent(in) :: isolnid - ! -- local - integer(I4B) :: i - integer(I4B) :: n1 - integer(I4B) :: n2 - integer(I4B) :: ihc - integer(I4B) :: ibdn1 - integer(I4B) :: ibdn2 - integer(I4B) :: ictn1 - integer(I4B) :: ictn2 - integer(I4B) :: iusg - real(DP) :: topn1 - real(DP) :: topn2 - real(DP) :: botn1 - real(DP) :: botn2 - real(DP) :: satn1 - real(DP) :: satn2 - real(DP) :: hn1 - real(DP) :: hn2 - real(DP) :: rrate - real(DP) :: thksat - real(DP) :: angle - real(DP) :: nx - real(DP) :: ny - real(DP) :: distance - real(DP) :: dltot - real(DP) :: hwva - real(DP) :: area -! ------------------------------------------------------------------------------ - ! - ! -- Return if there neither model needs to calculate specific discharge - if (this%gwfmodel1%npf%icalcspdis == 0 .and. & - this%gwfmodel2%npf%icalcspdis == 0) return - ! - ! -- initialize - iusg = 0 - ! - ! -- Loop through all exchanges - do i = 1, this%nexg - rrate = DZERO - n1 = this%nodem1(i) - n2 = this%nodem2(i) - ihc = this%ihc(i) - hwva = this%hwva(i) - ibdn1 = this%gwfmodel1%ibound(n1) - ibdn2 = this%gwfmodel2%ibound(n2) - ictn1 = this%gwfmodel1%npf%icelltype(n1) - ictn2 = this%gwfmodel2%npf%icelltype(n2) - topn1 = this%gwfmodel1%dis%top(n1) - topn2 = this%gwfmodel2%dis%top(n2) - botn1 = this%gwfmodel1%dis%bot(n1) - botn2 = this%gwfmodel2%dis%bot(n2) - satn1 = this%gwfmodel1%npf%sat(n1) - satn2 = this%gwfmodel2%npf%sat(n2) - hn1 = this%gwfmodel1%x(n1) - hn2 = this%gwfmodel2%x(n2) - ! - ! -- If both cells are active then calculate flow rate, and add ghost - ! node contribution - if(ibdn1 /= 0 .and. ibdn2 /= 0) then - rrate = this%qcalc(i, n1, n2) - if(this%ingnc > 0) then - rrate = rrate + this%gnc%deltaqgnc(i) - endif - endif - ! - ! -- Calculate face normal components - if(ihc == 0) then - nx = DZERO - ny = DZERO - area = hwva - if (botn1 < botn2) then - ! -- n1 is beneath n2, so rate is positive downward. Flip rate - ! upward so that points in positive z direction - rrate = - rrate - endif - else - if(this%ianglex > 0) then - angle = this%auxvar(this%ianglex, i) * DPIO180 - nx = cos(angle) - ny = sin(angle) - else - ! error? - call ustop('error in gwf_gwf_cq') - endif - ! - ! -- Calculate the saturated thickness at interface between n1 and n2 - thksat = thksatnm(ibdn1, ibdn2, ictn1, ictn2, this%inewton, ihc, & - iusg, hn1, hn2, satn1, satn2, & - topn1, topn2, botn1, botn2, this%satomega) - area = hwva * thksat - endif - ! - ! -- Submit this connection and flow information to the npf - ! package of gwfmodel1 - if(this%icdist > 0) then - dltot = this%auxvar(this%icdist, i) - else - call ustop('error in gwf_gwf_cq') - endif - distance = dltot * this%cl1(i) / (this%cl1(i) + this%cl2(i)) - if (this%gwfmodel1%npf%icalcspdis == 1) then - call this%gwfmodel1%npf%set_edge_properties(n1, ihc, rrate, area, & - nx, ny, distance) - endif - ! - ! -- Submit this connection and flow information to the npf - ! package of gwfmodel2 - if(this%icdist > 0) then - dltot = this%auxvar(this%icdist, i) - else - call ustop('error in gwf_gwf_cq') - endif - if (this%gwfmodel2%npf%icalcspdis == 1) then - distance = dltot * this%cl2(i) / (this%cl1(i) + this%cl2(i)) - if (ihc /= 0) rrate = -rrate - call this%gwfmodel2%npf%set_edge_properties(n2, ihc, rrate, area, & - -nx, -ny, distance) - endif - ! - enddo - ! - ! -- return - return - end subroutine gwf_gwf_cq - - subroutine gwf_gwf_bd(this, icnvg, isuppress_output, isolnid) -! ****************************************************************************** -! gwf_gwf_bd -- Budget for implicit gwf to gwf exchange; the budget for the -! explicit exchange connections is handled for each model by -! the exchange boundary package. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DZERO, LENBUDTXT, LENPACKAGENAME - !use TdisModule, only: kstp, kper - ! -- dummy - class(GwfExchangeType) :: this - integer(I4B), intent(inout) :: icnvg - integer(I4B), intent(in) :: isuppress_output - integer(I4B), intent(in) :: isolnid - ! -- local - character(len=LENBOUNDNAME) :: bname - character(len=LENPACKAGENAME+4) :: packname1 - character(len=LENPACKAGENAME+4) :: packname2 - character(len=LENBUDTXT), dimension(1) :: budtxt - character(len=20) :: nodestr - integer(I4B) :: ntabrows - integer(I4B) :: nodeu - real(DP), dimension(2, 1) :: budterm - integer(I4B) :: i, n1, n2, n1u, n2u - integer(I4B) :: ibinun1, ibinun2 - integer(I4B) :: icbcfl, ibudfl - real(DP) :: ratin, ratout, rrate, deltaqgnc - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- initialize local variables - budtxt(1) = ' FLOW-JA-FACE' - packname1 = 'EXG '//this%name - packname1 = adjustr(packname1) - packname2 = 'EXG '//this%name - packname2 = adjustr(packname2) - ! - ! -- update output tables - if (this%iprflow /= 0) then - ! - ! -- update titles - if (this%gwfmodel1%oc%oc_save('BUDGET')) then - call this%outputtab1%set_title(packname1) - end if - if (this%gwfmodel2%oc%oc_save('BUDGET')) then - call this%outputtab2%set_title(packname2) - end if - ! - ! -- update maxbound of tables - ntabrows = 0 - do i = 1, this%nexg - n1 = this%nodem1(i) - n2 = this%nodem2(i) - ! - ! -- If both cells are active then calculate flow rate - if (this%gwfmodel1%ibound(n1) /= 0 .and. & - this%gwfmodel2%ibound(n2) /= 0) then - ntabrows = ntabrows + 1 - end if - end do - if (ntabrows > 0) then - call this%outputtab1%set_maxbound(ntabrows) - call this%outputtab2%set_maxbound(ntabrows) - end if - end if - ! - ! -- Print and write budget terms for model 1 - ! - ! -- Set binary unit numbers for saving flows - if(this%ipakcb /= 0) then - ibinun1 = this%gwfmodel1%oc%oc_save_unit('BUDGET') - else - ibinun1 = 0 - endif - ! - ! -- If save budget flag is zero for this stress period, then - ! shut off saving - if(.not. this%gwfmodel1%oc%oc_save('BUDGET')) ibinun1 = 0 - if(isuppress_output /= 0) then - ibinun1 = 0 - endif - ! - ! -- If cell-by-cell flows will be saved as a list, write header. - if(ibinun1 /= 0) then - call this%gwfmodel1%dis%record_srcdst_list_header(budtxt(1), & - this%m1%name, this%name, & - this%m2%name, this%name, & - this%naux, this%auxname, & - ibinun1, this%nexg, this%gwfmodel1%iout) - endif - ! - ! Initialize accumulators - ratin = DZERO - ratout = DZERO - ! - ! -- Loop through all exchanges - do i = 1, this%nexg - ! - ! -- Assign boundary name - if (this%inamedbound>0) then - bname = this%boundname(i) - else - bname = '' - endif - ! - ! -- Calculate the flow rate between n1 and n2 - rrate = DZERO - n1 = this%nodem1(i) - n2 = this%nodem2(i) - ! - ! -- If both cells are active then calculate flow rate - if(this%gwfmodel1%ibound(n1) /= 0 .and. & - this%gwfmodel2%ibound(n2) /= 0) then - rrate = this%qcalc(i, n1, n2) - ! - ! -- add ghost node contribution - if(this%ingnc > 0) then - deltaqgnc = this%gnc%deltaqgnc(i) - rrate = rrate + deltaqgnc - endif - ! - ! -- Print the individual rates to model list files if requested - if(this%iprflow /= 0) then - if(this%gwfmodel1%oc%oc_save('BUDGET')) then - ! - ! -- set nodestr and write outputtab table - nodeu = this%gwfmodel1%dis%get_nodeuser(n1) - call this%gwfmodel1%dis%nodeu_to_string(nodeu, nodestr) - call this%outputtab1%print_list_entry(i, trim(adjustl(nodestr)), & - rrate, bname) - end if - endif - if(rrate < DZERO) then - ratout = ratout - rrate - else - ratin = ratin + rrate - endif - endif - ! - ! -- If saving cell-by-cell flows in list, write flow - n1u = this%gwfmodel1%dis%get_nodeuser(n1) - n2u = this%gwfmodel2%dis%get_nodeuser(n2) - if(ibinun1 /= 0) & - call this%gwfmodel1%dis%record_mf6_list_entry( & - ibinun1, n1u, n2u, rrate, this%naux, this%auxvar(:, i), & - .false., .false.) - ! - enddo - ! - ! -- Add the budget terms to model 1 - budterm(1, 1) = ratin - budterm(2, 1) = ratout - call this%m1%model_bdentry(budterm, budtxt, this%name) - ! - ! -- Print and write budget terms for model 2 - ! - ! -- Set binary unit numbers for saving flows - if(this%ipakcb /= 0) then - ibinun2 = this%gwfmodel2%oc%oc_save_unit('BUDGET') - else - ibinun2 = 0 - endif - ! - ! -- If save budget flag is zero for this stress period, then - ! shut off saving - if(.not. this%gwfmodel2%oc%oc_save('BUDGET')) ibinun2 = 0 - if(isuppress_output /= 0) then - ibinun2 = 0 - endif - ! - ! -- If cell-by-cell flows will be saved as a list, write header. - if(ibinun2 /= 0) then - call this%gwfmodel2%dis%record_srcdst_list_header(budtxt(1), & - this%m2%name, this%name, & - this%m1%name, this%name, & - this%naux, this%auxname, & - ibinun2, this%nexg, this%gwfmodel2%iout) - endif - ! - ! Initialize accumulators - ratin = DZERO - ratout = DZERO - ! - ! -- Loop through all exchanges - do i = 1, this%nexg - ! - ! -- Assign boundary name - if (this%inamedbound>0) then - bname = this%boundname(i) - else - bname = '' - endif - ! - ! -- Calculate the flow rate between n1 and n2 - rrate = DZERO - n1 = this%nodem1(i) - n2 = this%nodem2(i) - ! - ! -- If both cells are active then calculate flow rate - if(this%gwfmodel1%ibound(n1) /= 0 .and. & - this%gwfmodel2%ibound(n2) /= 0) then - rrate = this%cond(i) * this%m2%x(n2) - this%cond(i) * this%m1%x(n1) - ! - ! -- add ghost node contribution - if(this%ingnc > 0) then - deltaqgnc = this%gnc%deltaqgnc(i) - rrate = rrate + deltaqgnc - endif - ! - ! -- Print the individual rates to model list files if requested - if(this%iprflow /= 0) then - if(this%gwfmodel2%oc%oc_save('BUDGET')) then - ! - ! -- set nodestr and write outputtab table - nodeu = this%gwfmodel2%dis%get_nodeuser(n2) - call this%gwfmodel2%dis%nodeu_to_string(nodeu, nodestr) - call this%outputtab2%print_list_entry(i, trim(adjustl(nodestr)), & - -rrate, bname) - end if - endif - if(rrate < DZERO) then - ratout = ratout - rrate - else - ratin = ratin + rrate - endif - endif - ! - ! -- If saving cell-by-cell flows in list, write flow - n1u = this%gwfmodel1%dis%get_nodeuser(n1) - n2u = this%gwfmodel2%dis%get_nodeuser(n2) - if(ibinun2 /= 0) & - call this%gwfmodel2%dis%record_mf6_list_entry( & - ibinun2, n2u, n1u, -rrate, this%naux, this%auxvar(:, i), & - .false., .false.) - ! - enddo - ! - ! -- Add the budget terms to model 2 - budterm(1, 1) = ratout - budterm(2, 1) = ratin - call this%m2%model_bdentry(budterm, budtxt, this%name) - ! - ! -- Set icbcfl, ibudfl to zero so that flows will be printed and - ! saved, if the options were set in the MVR package - icbcfl = 1 - ibudfl = 1 - ! - ! -- Call mvr bd routine - if(this%inmvr > 0) call this%mvr%mvr_bd(icbcfl, ibudfl, isuppress_output) - ! - ! -- Calculate and write simulated values for observations - if(this%inobs /= 0) then - call this%gwf_gwf_save_simvals() - endif - ! - ! -- return - return - end subroutine gwf_gwf_bd - - subroutine gwf_gwf_ot(this) -! ****************************************************************************** -! gwf_gwf_ot -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimVariablesModule, only: iout - use ConstantsModule, only: DZERO, LINELENGTH - ! -- dummy - class(GwfExchangeType) :: this - ! -- local - integer(I4B) :: iexg, n1, n2 - real(DP) :: flow, deltaqgnc - character(len=LINELENGTH) :: node1str, node2str - ! -- format - character(len=*), parameter :: fmtheader = & - "(/1x, 'SUMMARY OF EXCHANGE RATES FOR EXCHANGE ', a, ' WITH ID ', i0, /, & - &2a16, 5a16, /, 112('-'))" - character(len=*), parameter :: fmtheader2 = & - "(/1x, 'SUMMARY OF EXCHANGE RATES FOR EXCHANGE ', a, ' WITH ID ', i0, /, & - &2a16, 4a16, /, 96('-'))" - character(len=*), parameter :: fmtdata = & - "(2a16, 5(1pg16.6))" -! ------------------------------------------------------------------------------ - ! - ! -- Initialize - deltaqgnc = DZERO - ! - ! -- Write a table of exchanges - if(this%iprflow /= 0) then - if(this%ingnc > 0) then - write(iout, fmtheader) trim(adjustl(this%name)), this%id, 'NODEM1', & - 'NODEM2', 'COND', 'X_M1', 'X_M2', 'DELTAQGNC', & - 'FLOW' - else - write(iout, fmtheader2) trim(adjustl(this%name)), this%id, 'NODEM1', & - 'NODEM2', 'COND', 'X_M1', 'X_M2', 'FLOW' - endif - do iexg = 1, this%nexg - n1 = this%nodem1(iexg) - n2 = this%nodem2(iexg) - flow = this%cond(iexg) * (this%m2%x(n2) - this%m1%x(n1)) - call this%m1%dis%noder_to_string(n1, node1str) - call this%m2%dis%noder_to_string(n2, node2str) - if(this%ingnc > 0) then - deltaqgnc = this%gnc%deltaqgnc(iexg) - write(iout, fmtdata) trim(adjustl(node1str)), & - trim(adjustl(node2str)), & - this%cond(iexg), this%m1%x(n1), this%m2%x(n2), & - deltaqgnc, flow + deltaqgnc - else - write(iout, fmtdata) trim(adjustl(node1str)), & - trim(adjustl(node2str)), & - this%cond(iexg), this%m1%x(n1), this%m2%x(n2), & - flow - endif - enddo - endif - ! - ! -- Mover budget output - if(this%inmvr > 0) call this%mvr%mvr_ot() - ! - ! -- OBS output - call this%obs%obs_ot() - ! - ! -- return - return - end subroutine gwf_gwf_ot - - subroutine read_options(this, iout) -! ****************************************************************************** -! read_options -- Read Options -! Subroutine: (1) read options from input file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ArrayHandlersModule, only: ifind - use ConstantsModule, only: LINELENGTH, DEM6 - use InputOutputModule, only: getunit, openfile, urdaux - use SimModule, only: store_error, store_error_unit, ustop - ! -- dummy - class(GwfExchangeType) :: this - integer(I4B), intent(in) :: iout - ! -- local - character(len=LINELENGTH) :: line, errmsg, keyword, fname - integer(I4B) :: istart,istop,lloc,ierr,ival - integer(I4B) :: inobs - logical :: isfound, endOfBlock -! ------------------------------------------------------------------------------ - ! - ! -- get options block - call this%parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) - ! - ! -- parse options block if detected - if (isfound) then - write(iout,'(1x,a)')'PROCESSING GWF EXCHANGE OPTIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case('AUXILIARY') - call this%parser%GetRemainingLine(line) - lloc = 1 - call urdaux(this%naux, this%parser%iuactive, iout, lloc, istart, & - istop, this%auxname, line, 'GWF_GWF_Exchange') - ! - ! -- If ANGLDEGX is an auxiliary variable, then anisotropy can be - ! used in either model. Store ANGLDEGX position in this%ianglex - ival = ifind(this%auxname, 'ANGLDEGX') - if(ival > 0) this%ianglex = ival - ival = ifind(this%auxname, 'CDIST') - if(ival > 0) this%icdist = ival - case ('PRINT_INPUT') - this%iprpak = 1 - write(iout,'(4x,a)') & - 'THE LIST OF EXCHANGES WILL BE PRINTED.' - case ('PRINT_FLOWS') - this%iprflow = 1 - write(iout,'(4x,a)') & - 'EXCHANGE FLOWS WILL BE PRINTED TO LIST FILES.' - case ('SAVE_FLOWS') - this%ipakcb = -1 - write(iout,'(4x,a)') & - 'EXCHANGE FLOWS WILL BE SAVED TO BINARY BUDGET FILES.' - case ('ALTERNATIVE_CELL_AVERAGING') - call this%parser%GetStringCaps(keyword) - select case(keyword) - case('LOGARITHMIC') - this%icellavg = 1 - case('AMT-LMK') - this%icellavg = 2 - case default - write(errmsg,'(4x,a,a)')'UNKNOWN CELL AVERAGING METHOD: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - write(iout,'(4x,a,a)') & - 'CELL AVERAGING METHOD HAS BEEN SET TO: ', trim(keyword) - case ('VARIABLECV') - this%ivarcv = 1 - write(iout,'(4x,a)') & - 'VERTICAL CONDUCTANCE VARIES WITH WATER TABLE.' - call this%parser%GetStringCaps(keyword) - if(keyword == 'DEWATERED') then - this%idewatcv = 1 - write(iout,'(4x,a)') & - 'VERTICAL CONDUCTANCE ACCOUNTS FOR DEWATERED PORTION OF ' // & - 'AN UNDERLYING CELL.' - endif - case ('NEWTON') - this%inewton = 1 - write(iout, '(4x,a)') & - 'NEWTON-RAPHSON method used for unconfined cells' - case ('GNC6') - call this%parser%GetStringCaps(keyword) - if(keyword /= 'FILEIN') then - call store_error('GNC6 KEYWORD MUST BE FOLLOWED BY ' // & - '"FILEIN" then by filename.') - call this%parser%StoreErrorUnit() - call ustop() - endif - call this%parser%GetString(fname) - if(fname == '') then - call store_error('NO GNC6 FILE SPECIFIED.') - call this%parser%StoreErrorUnit() - call ustop() - endif - this%ingnc = getunit() - call openfile(this%ingnc, iout, fname, 'GNC') - write(iout,'(4x,a)') & - 'GHOST NODES WILL BE READ FROM ', trim(fname) - case ('MVR6') - call this%parser%GetStringCaps(keyword) - if(keyword /= 'FILEIN') then - call store_error('MVR6 KEYWORD MUST BE FOLLOWED BY ' // & - '"FILEIN" then by filename.') - call this%parser%StoreErrorUnit() - call ustop() - endif - call this%parser%GetString(fname) - if(fname == '') then - call store_error('NO MVR6 FILE SPECIFIED.') - call this%parser%StoreErrorUnit() - call ustop() - endif - this%inmvr = getunit() - call openfile(this%inmvr, iout, fname, 'MVR') - write(iout,'(4x,a)') & - 'WATER MOVER INFORMATION WILL BE READ FROM ', trim(fname) - case ('BOUNDNAMES') - this%inamedbound = 1 - write(iout,'(4x,a)') 'EXCHANGE BOUNDARIES HAVE NAMES' // & - ' IN LAST COLUMN.' - case ('OBS6') - call this%parser%GetStringCaps(keyword) - if(keyword /= 'FILEIN') then - call store_error('OBS8 KEYWORD MUST BE FOLLOWED BY ' // & - '"FILEIN" then by filename.') - call this%parser%StoreErrorUnit() - call ustop() - endif - this%obs%active = .true. - call this%parser%GetString(this%obs%inputFilename) - inobs = GetUnit() - call openfile(inobs, iout, this%obs%inputFilename, 'OBS') - this%obs%inUnitObs = inobs - case default - write(errmsg,'(4x,a,a)')'***ERROR. UNKNOWN GWF EXCHANGE OPTION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - end do - write(iout,'(1x,a)')'END OF GWF EXCHANGE OPTIONS' - end if - ! - ! -- set omega value used for saturation calculations - if (this%inewton > 0) then - this%satomega = DEM6 - end if - ! - ! -- return - return - end subroutine read_options - - subroutine read_data(this, iout) -! ****************************************************************************** -! read_data -- Read EXGDATA block -! Subroutine: (1) read list of EXGs from input file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, store_error_unit, count_errors - ! -- dummy - class(GwfExchangeType) :: this - integer(I4B), intent(in) :: iout - ! -- local - character(len=LINELENGTH) :: errmsg, nodestr, node1str, node2str, cellid - character(len=2) :: cnfloat - integer(I4B) :: lloc, ierr, nerr, iaux - integer(I4B) :: iexg, nodem1, nodem2, nodeum1, nodeum2 - logical :: isfound, endOfBlock - ! -- format - character(len=*), parameter :: fmtexglabel = "(5x, 3a10, 50(a16))" - character(len=*), parameter :: fmtexgdata = & - "(5x, a, 1x, a ,I10, 50(1pg16.6))" - character(len=40) :: fmtexgdata2 -! ------------------------------------------------------------------------------ - ! - ! -- get ExchangeData block - call this%parser%GetBlock('EXCHANGEDATA', isfound, ierr, & - supportOpenClose=.true.) - ! - ! -- parse ExchangeData block if detected - if (isfound) then - write(iout,'(1x,a)')'PROCESSING EXCHANGEDATA' - if(this%iprpak /= 0) then - if (this%inamedbound==0) then - write(iout, fmtexglabel) 'NODEM1', 'NODEM2', 'IHC', & - 'CL1', 'CL2', 'HWVA', (adjustr(this%auxname(iaux)), & - iaux = 1, this%naux) - else - write(iout, fmtexglabel) 'NODEM1', 'NODEM2', 'IHC', 'CL1', 'CL2', & - 'HWVA', (adjustr(this%auxname(iaux)),iaux=1,this%naux), & - ' BOUNDNAME ' - ! Define format suitable for writing input data, - ! any auxiliary variables, and boundname. - write(cnfloat,'(i0)') 3+this%naux - fmtexgdata2 = '(5x, a, 1x, a, i10, ' // trim(cnfloat) // & - '(1pg16.6), 1x, a)' - endif - endif - do iexg = 1, this%nexg - call this%parser%GetNextLine(endOfBlock) - lloc = 1 - ! - ! -- Read and check node 1 - call this%parser%GetCellid(this%m1%dis%ndim, cellid, flag_string=.true.) - nodem1 = this%m1%dis%noder_from_cellid(cellid, this%parser%iuactive, & - iout, flag_string=.true.) - this%nodem1(iexg) = nodem1 - ! - ! -- Read and check node 2 - call this%parser%GetCellid(this%m2%dis%ndim, cellid, flag_string=.true.) - nodem2 = this%m2%dis%noder_from_cellid(cellid, this%parser%iuactive, & - iout, flag_string=.true.) - this%nodem2(iexg) = nodem2 - ! - ! -- Read rest of input line - this%ihc(iexg) = this%parser%GetInteger() - this%cl1(iexg) = this%parser%GetDouble() - this%cl2(iexg) = this%parser%GetDouble() - this%hwva(iexg) = this%parser%GetDouble() - do iaux = 1, this%naux - this%auxvar(iaux, iexg) = this%parser%GetDouble() - enddo - if (this%inamedbound==1) then - call this%parser%GetStringCaps(this%boundname(iexg)) - endif - ! - ! -- Write the data to listing file if requested - if(this%iprpak /= 0) then - nodeum1 = this%m1%dis%get_nodeuser(nodem1) - call this%m1%dis%nodeu_to_string(nodeum1, node1str) - nodeum2 = this%m2%dis%get_nodeuser(nodem2) - call this%m2%dis%nodeu_to_string(nodeum2, node2str) - if (this%inamedbound == 0) then - write(iout, fmtexgdata) trim(node1str), trim(node2str), & - this%ihc(iexg), this%cl1(iexg), this%cl2(iexg), & - this%hwva(iexg), & - (this%auxvar(iaux, iexg), iaux=1,this%naux) - else - write(iout, fmtexgdata2) trim(node1str), trim(node2str), & - this%ihc(iexg), this%cl1(iexg), this%cl2(iexg), & - this%hwva(iexg), & - (this%auxvar(iaux, iexg), iaux=1,this%naux), & - trim(this%boundname(iexg)) - endif - endif - ! - ! -- Check to see if nodem1 is outside of active domain - if(nodem1 <= 0) then - call this%gwfmodel1%dis%nodeu_to_string(nodeum1, nodestr) - write(errmsg, *) & - trim(adjustl(this%gwfmodel1%name)) // & - ' Cell is outside active grid domain: ' // & - trim(adjustl(nodestr)) - call store_error(errmsg) - endif - ! - ! -- Check to see if nodem2 is outside of active domain - if(nodem2 <= 0) then - call this%gwfmodel2%dis%nodeu_to_string(nodeum2, nodestr) - write(errmsg, *) & - trim(adjustl(this%gwfmodel2%name)) // & - ' Cell is outside active grid domain: ' // & - trim(adjustl(nodestr)) - call store_error(errmsg) - endif - enddo - ! - ! -- Stop if errors - nerr = count_errors() - if(nerr > 0) then - call store_error('Errors encountered in exchange input file.') - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - write(iout,'(1x,a)')'END OF EXCHANGEDATA' - else - write(errmsg, '(1x,a)')'ERROR. REQUIRED EXCHANGEDATA BLOCK NOT FOUND.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- return - return - end subroutine read_data - - subroutine read_gnc(this, iout) -! ****************************************************************************** -! read_gnc -- Read ghost node information. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: store_error, store_error_unit, count_errors, ustop - use ConstantsModule, only: LINELENGTH - ! -- dummy - class(GwfExchangeType) :: this - integer(I4B), intent(in) :: iout - ! -- local - integer(I4B) :: i, nm1, nm2, nmgnc1, nmgnc2 - character(len=LINELENGTH) :: errmsg - character(len=*), parameter :: fmterr = & - "('EXCHANGE NODES ', i0, ' AND ', i0," // & - "' NOT CONSISTENT WITH GNC NODES ', i0, ' AND ', i0)" -! ------------------------------------------------------------------------------ - ! - ! -- If exchange has ghost nodes, then initialize ghost node object - ! This will read the ghost node blocks from the gnc input file. - call this%gnc%gnc_df(this%m1, m2=this%m2) - ! - ! -- Verify gnc is implicit if exchange has Newton Terms - if(.not. this%gnc%implicit .and. this%inewton /= 0) then - call store_error('GNC IS EXPLICIT, BUT GWF EXCHANGE HAS ACTIVE NEWTON.') - call store_error('ADD IMPLICIT OPTION TO GNC OR REMOVE NEWTON FROM ' // & - 'GWF EXCHANGE.') - call store_error_unit(this%ingnc) - call ustop() - endif - ! - ! -- Perform checks to ensure GNCs match with GWF-GWF nodes - if(this%nexg /= this%gnc%nexg) then - call store_error('NUMBER OF EXCHANGES DOES NOT MATCH NUMBER OF GNCs') - call store_error_unit(this%ingnc) - call ustop() - endif - ! - ! -- Go through each entry and confirm - do i = 1, this%nexg - if(this%nodem1(i) /= this%gnc%nodem1(i) .or. & - this%nodem2(i) /= this%gnc%nodem2(i) ) then - nm1 = this%gwfmodel1%dis%get_nodeuser(this%nodem1(i)) - nm2 = this%gwfmodel2%dis%get_nodeuser(this%nodem2(i)) - nmgnc1 = this%gwfmodel1%dis%get_nodeuser(this%gnc%nodem1(i)) - nmgnc2 = this%gwfmodel2%dis%get_nodeuser(this%gnc%nodem2(i)) - write(errmsg, fmterr) nm1, nm2, nmgnc1, nmgnc2 - call store_error(errmsg) - endif - enddo - if(count_errors() > 0) then - call store_error_unit(this%ingnc) - call ustop() - endif - ! - ! -- close the file - close(this%ingnc) - ! - ! -- return - return - end subroutine read_gnc - - subroutine read_mvr(this, iout) -! ****************************************************************************** -! read_mvr -- Read water mover information. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use GwfMvrModule, only: mvr_cr - ! -- dummy - class(GwfExchangeType) :: this - integer(I4B), intent(in) :: iout - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- Create and initialize the mover object - call mvr_cr(this%mvr, this%name, this%inmvr, iout, iexgmvr=1) - ! - ! -- Return - return - end subroutine read_mvr - - subroutine rewet(this, kiter) -! ****************************************************************************** -! rewet -- Check for rewetting across models -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: kper, kstp - ! -- dummy - class(GwfExchangeType) :: this - integer(I4B), intent(in) :: kiter - ! -- local - integer(I4B) :: iexg - integer(I4B) :: n, m - integer(I4B) :: ibdn, ibdm - integer(I4B) :: ihc - real(DP) :: hn, hm - integer(I4B) :: irewet - character(len=30) :: nodestrn, nodestrm - character(len=*),parameter :: fmtrwt = & - "(1x, 'CELL ',A,' REWET FROM GWF MODEL ',A,' CELL ',A, & - &' FOR ITER. ',I0, ' STEP ',I0, ' PERIOD ', I0)" -! ------------------------------------------------------------------------------ - ! - ! -- Use model 1 to rewet model 2 and vice versa - do iexg = 1, this%nexg - n = this%nodem1(iexg) - m = this%nodem2(iexg) - hn = this%gwfmodel1%x(n) - hm = this%gwfmodel2%x(m) - ibdn = this%gwfmodel1%ibound(n) - ibdm = this%gwfmodel2%ibound(m) - ihc = this%ihc(iexg) - call this%gwfmodel1%npf%rewet_check(kiter, n, hm, ibdm, ihc, & - this%gwfmodel1%x, irewet) - if(irewet == 1) then - call this%gwfmodel1%dis%noder_to_string(n, nodestrn) - call this%gwfmodel2%dis%noder_to_string(m, nodestrm) - write(this%gwfmodel1%iout, fmtrwt) trim(nodestrn), & - trim(this%gwfmodel2%name), trim(nodestrm), kiter, kstp, kper - endif - call this%gwfmodel2%npf%rewet_check(kiter, m, hn, ibdn, ihc, & - this%gwfmodel2%x, irewet) - if(irewet == 1) then - call this%gwfmodel1%dis%noder_to_string(n, nodestrm) - call this%gwfmodel2%dis%noder_to_string(m, nodestrn) - write(this%gwfmodel2%iout, fmtrwt) trim(nodestrn), & - trim(this%gwfmodel1%name), trim(nodestrm), kiter, kstp, kper - endif - ! - enddo - ! - ! -- Return - return - end subroutine rewet - - subroutine condcalc(this) -! ****************************************************************************** -! condcalc -- Calculate the conductance -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DHALF, DZERO, DONE - use GwfNpfModule, only: hcond, vcond - ! -- dummy - class(GwfExchangeType) :: this - ! -- local - integer(I4B) :: iexg - integer(I4B) :: n, m, ihc - integer(I4B) :: ibdn, ibdm - integer(I4B) :: ictn, ictm - real(DP) :: topn, topm - real(DP) :: botn, botm - real(DP) :: satn, satm - real(DP) :: hyn, hym - real(DP) :: angle - real(DP) :: hn, hm - real(DP) :: cond - real(DP) :: fawidth - real(DP), dimension(3) :: vg -! ------------------------------------------------------------------------------ - ! - ! -- Calculate conductance and put into amat - do iexg = 1, this%nexg - ihc = this%ihc(iexg) - n = this%nodem1(iexg) - m = this%nodem2(iexg) - ibdn = this%gwfmodel1%ibound(n) - ibdm = this%gwfmodel2%ibound(m) - ictn = this%gwfmodel1%npf%icelltype(n) - ictm = this%gwfmodel2%npf%icelltype(m) - topn = this%gwfmodel1%dis%top(n) - topm = this%gwfmodel2%dis%top(m) - botn = this%gwfmodel1%dis%bot(n) - botm = this%gwfmodel2%dis%bot(m) - satn = this%gwfmodel1%npf%sat(n) - satm = this%gwfmodel2%npf%sat(m) - hn = this%gwfmodel1%x(n) - hm = this%gwfmodel2%x(m) - ! - ! -- Calculate conductance depending on connection orientation - if(ihc == 0) then - ! - ! -- Vertical connection - vg(1) = DZERO - vg(2) = DZERO - vg(3) = DONE - hyn = this%gwfmodel1%npf%hy_eff(n, 0, ihc, vg=vg) - hym = this%gwfmodel2%npf%hy_eff(m, 0, ihc, vg=vg) - cond = vcond(ibdn, ibdm, ictn, ictm, this%inewton, this%ivarcv, & - this%idewatcv, this%condsat(iexg), hn, hm, hyn, hym, & - satn, satm, topn, topm, botn, botm, this%hwva(iexg)) - else - ! - ! -- Horizontal Connection - hyn = this%gwfmodel1%npf%k11(n) - hym = this%gwfmodel2%npf%k11(m) - ! - ! -- Check for anisotropy in models, and recalculate hyn and hym - if(this%ianglex > 0) then - angle = this%auxvar(this%ianglex, iexg) - vg(1) = abs(cos(angle)) - vg(2) = abs(sin(angle)) - vg(3) = DZERO - ! - ! -- anisotropy in model 1 - if(this%gwfmodel1%npf%ik22 /= 0) then - hyn = this%gwfmodel1%npf%hy_eff(n, 0, ihc, vg=vg) - endif - ! - ! -- anisotropy in model 2 - if(this%gwfmodel2%npf%ik22 /= 0) then - hym = this%gwfmodel2%npf%hy_eff(m, 0, ihc, vg=vg) - endif - endif - ! - fawidth = this%hwva(iexg) - cond = hcond(ibdn, ibdm, ictn, ictm, this%inewton, this%inewton, & - this%ihc(iexg), this%icellavg, 0, 0, this%condsat(iexg), & - hn, hm, satn, satm, hyn, hym, topn, topm, botn, botm, & - this%cl1(iexg), this%cl2(iexg), fawidth, this%satomega) - endif - ! - this%cond(iexg) = cond - ! - enddo - ! - ! -- Return - return - end subroutine condcalc - - subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - use ConstantsModule, only: LENORIGIN, DZERO - ! -- dummy - class(GwfExchangeType) :: this - ! -- local - character(len=LENORIGIN) :: origin -! ------------------------------------------------------------------------------ - ! - ! -- create the origin name - origin = trim(this%name) - ! - ! -- Call parent type allocate_scalars - call this%NumericalExchangeType%allocate_scalars() - ! - call mem_allocate(this%icellavg, 'ICELLAVG', origin) - call mem_allocate(this%ivarcv, 'IVARCV', origin) - call mem_allocate(this%idewatcv, 'IDEWATCV', origin) - call mem_allocate(this%inewton, 'INEWTON', origin) - call mem_allocate(this%ianglex, 'IANGLEX', origin) - call mem_allocate(this%icdist, 'ICDIST', origin) - call mem_allocate(this%ingnc, 'INGNC', origin) - call mem_allocate(this%inmvr, 'INMVR', origin) - call mem_allocate(this%inobs, 'INOBS', origin) - call mem_allocate(this%inamedbound, 'INAMEDBOUND', origin) - call mem_allocate(this%satomega, 'SATOMEGA', origin) - this%icellavg = 0 - this%ivarcv = 0 - this%idewatcv = 0 - this%inewton = 0 - this%ianglex = 0 - this%icdist = 0 - this%ingnc = 0 - this%inmvr = 0 - this%inobs = 0 - this%inamedbound = 0 - this%satomega = DZERO - ! - ! -- return - return - end subroutine allocate_scalars - - subroutine gwf_gwf_da(this) -! ****************************************************************************** -! gwf_gwf_da -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(GwfExchangeType) :: this - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- Call parent type allocate_scalars - call this%NumericalExchangeType%exg_da() - ! - ! -- objects - if(this%ingnc > 0) then - call this%gnc%gnc_da() - deallocate(this%gnc) - endif - if (this%inmvr > 0) then - call this%mvr%mvr_da() - deallocate(this%mvr) - endif - call this%obs%obs_da() - deallocate(this%obs) - ! - ! -- arrays - call mem_deallocate(this%ihc) - call mem_deallocate(this%cl1) - call mem_deallocate(this%cl2) - call mem_deallocate(this%hwva) - call mem_deallocate(this%condsat) - deallocate(this%boundname) - ! - ! -- output table objects - if (associated(this%outputtab1)) then - call this%outputtab1%table_da() - deallocate(this%outputtab1) - nullify(this%outputtab1) - end if - if (associated(this%outputtab2)) then - call this%outputtab2%table_da() - deallocate(this%outputtab2) - nullify(this%outputtab2) - end if - ! - ! -- scalars - call mem_deallocate(this%icellavg) - call mem_deallocate(this%ivarcv) - call mem_deallocate(this%idewatcv) - call mem_deallocate(this%inewton) - call mem_deallocate(this%ianglex) - call mem_deallocate(this%icdist) - call mem_deallocate(this%ingnc) - call mem_deallocate(this%inmvr) - call mem_deallocate(this%inobs) - call mem_deallocate(this%inamedbound) - call mem_deallocate(this%satomega) - ! - ! -- return - return - end subroutine gwf_gwf_da - - subroutine allocate_arrays(this) -! ****************************************************************************** -! allocate_scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - use ConstantsModule, only: LENORIGIN - ! -- dummy - class(GwfExchangeType) :: this - ! -- local - character(len=LINELENGTH) :: text - character(len=LENORIGIN) :: origin - integer(I4B) :: ntabcol -! ------------------------------------------------------------------------------ - ! - ! -- create the origin name - origin = trim(this%name) - ! - ! -- Call parent type allocate_scalars - call this%NumericalExchangeType%allocate_arrays() - ! - call mem_allocate(this%ihc, this%nexg, 'IHC', origin) - call mem_allocate(this%cl1, this%nexg, 'CL1', origin) - call mem_allocate(this%cl2, this%nexg, 'CL2', origin) - call mem_allocate(this%hwva, this%nexg, 'HWVA', origin) - call mem_allocate(this%condsat, this%nexg, 'CONDSAT', origin) - ! - ! -- Allocate boundname - if(this%inamedbound==1) then - allocate(this%boundname(this%nexg)) - else - allocate(this%boundname(1)) - endif - this%boundname(:) = '' - ! - ! -- allocate and initialize the output table - if (this%iprflow /= 0) then - ! - ! -- dimension table - ntabcol = 3 - if (this%inamedbound > 0) then - ntabcol = ntabcol + 1 - end if - ! - ! -- initialize the output table objects - ! outouttab1 - call table_cr(this%outputtab1, this%name, ' ') - call this%outputtab1%table_df(this%nexg, ntabcol, this%gwfmodel1%iout, & - transient=.TRUE.) - text = 'NUMBER' - call this%outputtab1%initialize_column(text, 10, alignment=TABCENTER) - text = 'CELLID' - call this%outputtab1%initialize_column(text, 20, alignment=TABLEFT) - text = 'RATE' - call this%outputtab1%initialize_column(text, 15, alignment=TABCENTER) - if (this%inamedbound > 0) then - text = 'NAME' - call this%outputtab1%initialize_column(text, 20, alignment=TABLEFT) - end if - ! outouttab2 - call table_cr(this%outputtab2, this%name, ' ') - call this%outputtab2%table_df(this%nexg, ntabcol, this%gwfmodel2%iout, & - transient=.TRUE.) - text = 'NUMBER' - call this%outputtab2%initialize_column(text, 10, alignment=TABCENTER) - text = 'CELLID' - call this%outputtab2%initialize_column(text, 20, alignment=TABLEFT) - text = 'RATE' - call this%outputtab2%initialize_column(text, 15, alignment=TABCENTER) - if (this%inamedbound > 0) then - text = 'NAME' - call this%outputtab2%initialize_column(text, 20, alignment=TABLEFT) - end if - end if - ! - ! -- return - return - end subroutine allocate_arrays - - subroutine gwf_gwf_df_obs(this) -! ****************************************************************************** -! gwf_gwf_df_obs -! -- Store observation type supported by GWF-GWF exchange. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfExchangeType) :: this - ! -- local - integer(I4B) :: indx -! ------------------------------------------------------------------------------ - ! - ! -- Store obs type and assign procedure pointer - ! for gwf-gwf observation type. - call this%obs%StoreObsType('flow-ja-face', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => gwf_gwf_process_obsID - ! - ! -- return - return - end subroutine gwf_gwf_df_obs - - subroutine gwf_gwf_rp_obs(this) -! ****************************************************************************** -! gwf_gwf_rp_obs -! -- Handle observation IDs that are exchange-boundary names. -! Store exchange numbers included in observation. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DZERO - ! -- dummy - class(GwfExchangeType) :: this - ! -- local - integer(I4B) :: i, j, n - class(ObserveType), pointer :: obsrv => null() - character(len=LENBOUNDNAME) :: bname - character(len=1000) :: ermsg - logical :: jfound - ! -- formats -10 format('Error: Boundary "',a,'" for observation "',a, & - '" is invalid in package "',a,'"') -! ------------------------------------------------------------------------------ - ! - do i=1,this%obs%npakobs - obsrv => this%obs%pakobs(i)%obsrv - ! - ! -- indxbnds needs to be deallocated and reallocated (using - ! ExpandArray) each stress period because list of boundaries - ! can change each stress period. - ! -- Not true for exchanges, but leave this in for now anyway. - if (allocated(obsrv%indxbnds)) then - deallocate(obsrv%indxbnds) - endif - obsrv%BndFound = .false. - ! - bname = obsrv%FeatureName - if (bname /= '') then - ! -- Observation location(s) is(are) based on a boundary name. - ! Iterate through all boundaries to identify and store - ! corresponding index(indices) in bound array. - jfound = .false. - do j=1,this%nexg - if (this%boundname(j) == bname) then - jfound = .true. - obsrv%BndFound = .true. - obsrv%CurrentTimeStepEndValue = DZERO - call ExpandArray(obsrv%indxbnds) - n = size(obsrv%indxbnds) - obsrv%indxbnds(n) = j - endif - enddo - if (.not. jfound) then - write(ermsg,10)trim(bname) - call store_error(ermsg) - endif - else - ! -- Observation location is a single exchange number - if (obsrv%intPak1 <= this%nexg) then - jfound = .true. - obsrv%BndFound = .true. - obsrv%CurrentTimeStepEndValue = DZERO - call ExpandArray(obsrv%indxbnds) - n = size(obsrv%indxbnds) - obsrv%indxbnds(n) = obsrv%intPak1 - else - jfound = .false. - endif - endif - enddo - ! - if (count_errors() > 0) then - call store_error_unit(this%inobs) - call ustop() - endif - ! - ! -- Return - return - end subroutine gwf_gwf_rp_obs - - subroutine gwf_gwf_fp(this) -! ****************************************************************************** -! gwf_gwf_fp -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfExchangeType) :: this -! ------------------------------------------------------------------------------ - ! - return - end subroutine gwf_gwf_fp - - function qcalc(this, iexg, n1, n2) -! ****************************************************************************** -! qcalc -- calculate flow between two cells, positive into n1 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - real(DP) :: qcalc - ! -- dummy - class(GwfExchangeType) :: this - integer(I4B), intent(in) :: iexg - integer(I4B), intent(in) :: n1 - integer(I4B), intent(in) :: n2 - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- Calculate flow between nodes in the two models - qcalc = this%cond(iexg) * (this%m2%x(n2) - this%m1%x(n1)) - ! - ! -- return - return - end function qcalc - - function gwf_gwf_get_iasym(this) result (iasym) -! ****************************************************************************** -! gwf_gwf_get_iasym -- return 1 if any option causes the matrix to be asymmetric. -! Otherwise return 0. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfExchangeType) :: this - ! -- local - integer(I4B) :: iasym -! ------------------------------------------------------------------------------ - ! - ! -- Start by setting iasym to zero - iasym = 0 - ! - ! -- Groundwater flow - if (this%inewton /= 0) iasym = 1 - ! - ! -- GNC - if (this%ingnc > 0) then - if (this%gnc%iasym /= 0) iasym = 1 - endif - ! - ! -- return - return - end function gwf_gwf_get_iasym - - subroutine gwf_gwf_save_simvals(this) -! ****************************************************************************** -! gwf_gwf_save_simvals -! -- Calculate observations this time step and call -! ObsType%SaveOneSimval for each GWF-GWF Type observation. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - use SimModule, only: store_error, store_error_unit, ustop - use ConstantsModule, only: DZERO - use ObserveModule, only: ObserveType - class(GwfExchangeType), intent(inout) :: this - ! -- local - integer(I4B) :: i, j, n1, n2, nbndobs - integer(I4B) :: iexg - real(DP) :: v - character(len=100) :: msg - type(ObserveType), pointer :: obsrv => null() -! ------------------------------------------------------------------------------ - ! - ! -- Write simulated values for all gwf-gwf observations - if (this%obs%npakobs > 0) then - call this%obs%obs_bd_clear() - do i = 1, this%obs%npakobs - obsrv => this%obs%pakobs(i)%obsrv - nbndobs = size(obsrv%indxbnds) - do j = 1, nbndobs - iexg = obsrv%indxbnds(j) - v = DZERO - select case (obsrv%ObsTypeId) - case ('FLOW-JA-FACE') - n1 = this%nodem1(iexg) - n2 = this%nodem2(iexg) - v = this%cond(iexg) * (this%m2%x(n2) - this%m1%x(n1)) - if(this%ingnc > 0) then - v = v + this%gnc%deltaqgnc(iexg) - endif - case default - msg = 'Error: Unrecognized observation type: ' // & - trim(obsrv%ObsTypeId) - call store_error(msg) - call store_error_unit(this%inobs) - call ustop() - end select - call this%obs%SaveOneSimval(obsrv, v) - enddo - enddo - endif - ! - return - end subroutine gwf_gwf_save_simvals - - subroutine gwf_gwf_process_obsID(obsrv, dis, inunitobs, iout) -! ****************************************************************************** -! -- This procedure is pointed to by ObsDataType%ProcesssIdPtr. It processes -! the ID string of an observation definition for GWF-GWF-package observations -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use InputOutputModule, only: urword - use ObserveModule, only: ObserveType - use BaseDisModule, only: DisBaseType - ! -- dummy - type(ObserveType), intent(inout) :: obsrv - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: inunitobs - integer(I4B), intent(in) :: iout - ! -- local - integer(I4B) :: n, iexg, istat - integer(I4B) :: icol, istart, istop - real(DP) :: r - character(len=LINELENGTH) :: strng -! ------------------------------------------------------------------------------ - ! - strng = obsrv%IDstring - icol = 1 - ! -- get exchange index - call urword(strng, icol, istart, istop, 0, n, r, iout, inunitobs) - read (strng(istart:istop), '(i10)', iostat=istat) iexg - if (istat == 0) then - obsrv%intPak1 = iexg - else - ! Integer can't be read from strng; it's presumed to be an exchange - ! boundary name (already converted to uppercase) - obsrv%FeatureName = strng(istart:istop) - ! -- Observation may require summing rates from multiple exchange - ! boundaries, so assign intPak1 as a value that indicates observation - ! is for a named exchange boundary or group of exchange boundaries. - obsrv%intPak1 = NAMEDBOUNDFLAG - endif - ! - return - end subroutine gwf_gwf_process_obsID - -end module GwfGwfExchangeModule - +module GwfGwfExchangeModule + + use KindModule, only: DP, I4B + use ArrayHandlersModule, only: ExpandArray + use BaseModelModule, only: GetBaseModelFromList + use BaseExchangeModule, only: BaseExchangeType, AddBaseExchangeToList + use ConstantsModule, only: LENBOUNDNAME, NAMEDBOUNDFLAG, LINELENGTH, & + TABCENTER, TABLEFT + use ListsModule, only: basemodellist + use NumericalExchangeModule, only: NumericalExchangeType + use NumericalModelModule, only: NumericalModelType + use GwfModule, only: GwfModelType + use GhostNodeModule, only: GhostNodeType + use GwfMvrModule, only: GwfMvrType + use ObserveModule, only: ObserveType + use ObsModule, only: ObsType + use SimModule, only: count_errors, store_error, & + store_error_unit, ustop + use BlockParserModule, only: BlockParserType + use TableModule, only: TableType, table_cr + + implicit none + + private + public :: gwfexchange_create + + type, extends(NumericalExchangeType) :: GwfExchangeType + type(GwfModelType), pointer :: gwfmodel1 => null() ! pointer to GWF Model 1 + type(GwfModelType), pointer :: gwfmodel2 => null() ! pointer to GWF Model 2 + integer(I4B), pointer :: inewton => null() ! newton flag (1 newton is on) + integer(I4B), pointer :: icellavg => null() ! cell averaging + integer(I4B), pointer :: ivarcv => null() ! variable cv + integer(I4B), pointer :: idewatcv => null() ! dewatered cv + integer(I4B), pointer :: ianglex => null() ! flag indicating anglex was read, if read, ianglex is index in auxvar + integer(I4B), pointer :: icdist => null() ! flag indicating cdist was read, if read, icdist is index in auxvar + integer(I4B), pointer :: inamedbound => null() ! flag to read boundnames + real(DP), pointer :: satomega => null() ! saturation smoothing + integer(I4B), dimension(:), pointer, contiguous :: ihc => null() ! horizontal connection indicator array + real(DP), dimension(:), pointer, contiguous :: condsat => null() ! saturated conductance + real(DP), dimension(:), pointer, contiguous :: cl1 => null() ! connection length 1 + real(DP), dimension(:), pointer, contiguous :: cl2 => null() ! connection length 2 + real(DP), dimension(:), pointer, contiguous :: hwva => null() ! horizontal widths, vertical flow areas + integer(I4B), pointer :: ingnc => null() ! unit number for gnc (0 if off) + type(GhostNodeType), pointer :: gnc => null() ! gnc object + integer(I4B), pointer :: inmvr => null() ! unit number for mover (0 if off) + type(GwfMvrType), pointer :: mvr => null() ! water mover object + integer(I4B), pointer :: inobs => null() ! unit number for GWF-GWF observations + type(ObsType), pointer :: obs => null() ! observation object + character(len=LENBOUNDNAME), dimension(:), & + pointer, contiguous :: boundname => null() ! boundnames + ! + ! -- table objects + type(TableType), pointer :: outputtab1 => null() + type(TableType), pointer :: outputtab2 => null() + + contains + + procedure :: exg_df => gwf_gwf_df + procedure :: exg_ac => gwf_gwf_ac + procedure :: exg_mc => gwf_gwf_mc + procedure :: exg_ar => gwf_gwf_ar + procedure :: exg_rp => gwf_gwf_rp + procedure :: exg_ad => gwf_gwf_ad + procedure :: exg_cf => gwf_gwf_cf + procedure :: exg_fc => gwf_gwf_fc + procedure :: exg_fn => gwf_gwf_fn + procedure :: exg_cq => gwf_gwf_cq + procedure :: exg_bd => gwf_gwf_bd + procedure :: exg_ot => gwf_gwf_ot + procedure :: exg_da => gwf_gwf_da + procedure :: exg_fp => gwf_gwf_fp + procedure :: get_iasym => gwf_gwf_get_iasym + procedure :: allocate_scalars + procedure :: allocate_arrays + procedure :: read_options + procedure :: read_data + procedure :: read_gnc + procedure :: read_mvr + procedure, private :: condcalc + procedure, private :: rewet + procedure, private :: qcalc + procedure, private :: gwf_gwf_df_obs + procedure, private :: gwf_gwf_rp_obs + procedure, public :: gwf_gwf_save_simvals + end type GwfExchangeType + +contains + + subroutine gwfexchange_create(filename, id, m1id, m2id) +! ****************************************************************************** +! Create a new GWF to GWF exchange object. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use BaseModelModule, only: BaseModelType + use ListsModule, only: baseexchangelist + use ObsModule, only: obs_cr + ! -- dummy + character(len=*),intent(in) :: filename + integer(I4B), intent(in) :: id, m1id, m2id + ! -- local + type(GwfExchangeType), pointer :: exchange + class(BaseModelType), pointer :: mb + class(BaseExchangeType), pointer :: baseexchange + character(len=20) :: cint +! ------------------------------------------------------------------------------ + ! + ! -- Create a new exchange and add it to the baseexchangelist container + allocate(exchange) + baseexchange => exchange + call AddBaseExchangeToList(baseexchangelist, baseexchange) + ! + ! -- Assign id and name + exchange%id = id + write(cint, '(i0)') id + exchange%name = 'GWF-GWF_' // trim(adjustl(cint)) + ! + ! -- allocate scalars and set defaults + call exchange%allocate_scalars() + exchange%filename = filename + exchange%typename = 'GWF-GWF' + exchange%implicit = .true. + ! + ! -- set exchange%m1 + mb => GetBaseModelFromList(basemodellist, m1id) + select type (mb) + class is (NumericalModelType) + exchange%m1=>mb + end select + ! + ! -- set exchange%m2 + mb => GetBaseModelFromList(basemodellist, m2id) + select type (mb) + class is (NumericalModelType) + exchange%m2=>mb + end select + ! + ! -- set gwfmodel1 + mb => GetBaseModelFromList(basemodellist, m1id) + select type (mb) + type is (GwfModelType) + exchange%gwfmodel1 => mb + end select + ! + ! -- set gwfmodel2 + mb => GetBaseModelFromList(basemodellist, m2id) + select type (mb) + type is (GwfModelType) + exchange%gwfmodel2 => mb + end select + ! + ! -- Create the obs package + call obs_cr(exchange%obs, exchange%inobs) + ! + ! -- return + return + end subroutine gwfexchange_create + + subroutine gwf_gwf_df(this) +! ****************************************************************************** +! gwf_gwf_df -- Define GWF to GWF exchange object. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimVariablesModule, only: iout + use InputOutputModule, only: getunit, openfile + use GhostNodeModule, only: gnc_cr + ! -- dummy + class(GwfExchangeType) :: this + ! -- local + integer(I4B) :: inunit +! ------------------------------------------------------------------------------ + ! + ! -- open the file + inunit = getunit() + write(iout,'(/a,a)') ' Creating exchange: ', this%name + call openfile(inunit, iout, this%filename, 'GWF-GWF') + ! + call this%parser%Initialize(inunit, iout) + ! + ! -- Ensure models are in same solution + if(this%gwfmodel1%idsoln /= this%gwfmodel2%idsoln) then + call store_error('ERROR. TWO MODELS ARE CONNECTED ' // & + 'IN A GWF EXCHANGE BUT THEY ARE IN DIFFERENT SOLUTIONS. ' // & + 'GWF MODELS MUST BE IN SAME SOLUTION: ' // & + trim(this%gwfmodel1%name) // ' ' // trim(this%gwfmodel2%name) ) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- read options + call this%read_options(iout) + ! + ! -- read dimensions + call this%read_dimensions(iout) + ! + ! -- allocate arrays + call this%allocate_arrays() + ! + ! -- read exchange data + call this%read_data(iout) + ! + ! -- call each model and increase the edge count + call this%gwfmodel1%npf%increase_edge_count(this%nexg) + call this%gwfmodel2%npf%increase_edge_count(this%nexg) + ! + ! -- Create and read ghost node information + if(this%ingnc > 0) then + call gnc_cr(this%gnc, this%name, this%ingnc, iout) + call this%read_gnc(iout) + endif + ! + ! -- Read mover information + if(this%inmvr > 0) then + call this%read_mvr(iout) + endif + ! + ! -- close the file + close(inunit) + ! + ! -- Store obs + call this%gwf_gwf_df_obs() + call this%obs%obs_df(iout, this%name, 'GWF-GWF', this%gwfmodel1%dis) + ! + ! -- return + return + end subroutine gwf_gwf_df + + subroutine gwf_gwf_ac(this, sparse) +! ****************************************************************************** +! gwf_gwf_ac -- override parent exg_ac so that gnc can add +! connections here. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SparseModule, only:sparsematrix + ! -- dummy + class(GwfExchangeType) :: this + type(sparsematrix), intent(inout) :: sparse + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- call parent model to add exchange connections + call this%NumericalExchangeType%exg_ac(sparse) + ! + ! -- add gnc connections + if(this%ingnc > 0) then + call this%gnc%gnc_ac(sparse) + endif + ! + ! -- Return + return + end subroutine gwf_gwf_ac + + subroutine gwf_gwf_mc(this, iasln, jasln) +! ****************************************************************************** +! gwf_gwf_mc -- Map the connections in the global matrix +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SparseModule, only:sparsematrix + ! -- dummy + class(GwfExchangeType) :: this + integer(I4B), dimension(:), intent(in) :: iasln + integer(I4B), dimension(:), intent(in) :: jasln + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- call parent model to map exchange connections + call this%NumericalExchangeType%exg_mc(iasln, jasln) + ! + ! -- map gnc connections + if(this%ingnc > 0) then + call this%gnc%gnc_mc(iasln, jasln) + endif + ! + ! -- Return + return + end subroutine gwf_gwf_mc + + subroutine gwf_gwf_ar(this) +! ****************************************************************************** +! gwf_gwf_ar -- Calculate the saturated conductance. Must be called after +! npf_ar for both GWF models. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH, DZERO, DHALF, DONE, DPIO180 + use SimModule, only: store_error, ustop + use GwfNpfModule, only: condmean, vcond, hcond + ! -- dummy + class(GwfExchangeType) :: this + ! -- local + integer(I4B) :: iexg + integer(I4B) :: n, m, ihc + real(DP) :: topn, topm + real(DP) :: botn, botm + real(DP) :: satn, satm + real(DP) :: thickn, thickm + real(DP) :: angle, hyn, hym + real(DP) :: csat + real(DP) :: fawidth + real(DP), dimension(3) :: vg + character(len=LINELENGTH) :: errmsg +! ------------------------------------------------------------------------------ + ! + ! -- If mover is active, then call ar routine + if(this%inmvr > 0) call this%mvr%mvr_ar() + ! + ! -- Check to see if horizontal anisotropy is in either model1 or model2. + ! If so, then ANGLDEGX must be provided as an auxiliary variable for this + ! GWF-GWF exchange (this%ianglex > 0). + if(this%gwfmodel1%npf%ik22 /= 0 .or. this%gwfmodel2%npf%ik22 /= 0) then + if(this%ianglex == 0) then + write(errmsg, '(a)') 'Error. GWF-GWF requires that ANGLDEGX be ' // & + 'specified as an auxiliary variable because ' // & + 'K22 was specified in one or both ' // & + 'groundwater models.' + call store_error(errmsg) + call ustop() + endif + endif + ! + ! -- Check to see if specific discharge is needed for model1 or model2. + ! If so, then ANGLDEGX must be provided as an auxiliary variable for this + ! GWF-GWF exchange (this%ianglex > 0). + if(this%gwfmodel1%npf%icalcspdis /= 0 .or. & + this%gwfmodel2%npf%icalcspdis /= 0) then + if(this%ianglex == 0) then + write(errmsg, '(a)') 'Error. GWF-GWF requires that ANGLDEGX be ' // & + 'specified as an auxiliary variable because ' // & + 'specific discharge is being calculated in' // & + ' one or both groundwater models.' + call store_error(errmsg) + call ustop() + endif + if(this%icdist == 0) then + write(errmsg, '(a)') 'Error. GWF-GWF requires that CDIST be ' // & + 'specified as an auxiliary variable because ' // & + 'specific discharge is being calculated in' // & + ' one or both groundwater models.' + call store_error(errmsg) + call ustop() + endif + endif + ! + ! -- Go through each connection and calculate the saturated conductance + do iexg = 1, this%nexg + ! + ihc = this%ihc(iexg) + n = this%nodem1(iexg) + m = this%nodem2(iexg) + topn = this%gwfmodel1%dis%top(n) + topm = this%gwfmodel2%dis%top(m) + botn = this%gwfmodel1%dis%bot(n) + botm = this%gwfmodel2%dis%bot(m) + satn = this%gwfmodel1%npf%sat(n) + satm = this%gwfmodel2%npf%sat(m) + thickn = (topn - botn) * satn + thickm = (topm - botm) * satm + ! + ! -- Calculate conductance depending on connection orientation + if(ihc == 0) then + ! + ! -- Vertical conductance for fully saturated conditions + vg(1) = DZERO + vg(2) = DZERO + vg(3) = DONE + hyn = this%gwfmodel1%npf%hy_eff(n, 0, ihc, vg=vg) + hym = this%gwfmodel2%npf%hy_eff(m, 0, ihc, vg=vg) + csat = vcond(1, 1, 1, 1, 0, 1, 1, DONE, & + botn, botm, & + hyn, hym, & + satn, satm, & + topn, topm, & + botn, botm, & + this%hwva(iexg)) + else + ! + ! -- Calculate horizontal conductance + hyn = this%gwfmodel1%npf%k11(n) + hym = this%gwfmodel2%npf%k11(m) + ! + ! -- Check for anisotropy in models, and recalculate hyn and hym + if(this%ianglex > 0) then + angle = this%auxvar(this%ianglex, iexg) * DPIO180 + vg(1) = abs(cos(angle)) + vg(2) = abs(sin(angle)) + vg(3) = DZERO + ! + ! -- anisotropy in model 1 + if(this%gwfmodel1%npf%ik22 /= 0) then + hyn = this%gwfmodel1%npf%hy_eff(n, 0, ihc, vg=vg) + endif + ! + ! -- anisotropy in model 2 + if(this%gwfmodel2%npf%ik22 /= 0) then + hym = this%gwfmodel2%npf%hy_eff(m, 0, ihc, vg=vg) + endif + endif + ! + fawidth = this%hwva(iexg) + csat = hcond(1, 1, 1, 1, this%inewton, 0, ihc, & + this%icellavg, 0, 0, DONE, & + topn, topm, satn, satm, hyn, hym, & + topn, topm, & + botn, botm, & + this%cl1(iexg), this%cl2(iexg), & + fawidth, this%satomega) + endif + ! + ! -- store csat in condsat + this%condsat(iexg) = csat + enddo + ! + ! -- Observation AR + call this%obs%obs_ar() + ! + ! -- Return + return + end subroutine gwf_gwf_ar + + subroutine gwf_gwf_rp(this) +! ****************************************************************************** +! gwf_gwf_rp -- Read and prepare +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: readnewdata + ! -- dummy + class(GwfExchangeType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Check with TDIS on whether or not it is time to RP + if (.not. readnewdata) return + ! + ! -- Read and prepare for mover + if(this%inmvr > 0) call this%mvr%mvr_rp() + ! + ! -- Read and prepare for observations + call this%gwf_gwf_rp_obs() + ! + ! -- Return + return + end subroutine gwf_gwf_rp + + subroutine gwf_gwf_ad(this, isolnid, kpicard, isubtime) +! ****************************************************************************** +! gwf_gwf_ad -- Initialize package x values to zero for explicit exchanges +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfExchangeType) :: this + integer(I4B), intent(in) :: isolnid + integer(I4B), intent(in) :: kpicard + integer(I4B), intent(in) :: isubtime + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Advance mover + if(this%inmvr > 0) call this%mvr%mvr_ad() + ! + ! -- Push simulated values to preceding time/subtime step + call this%obs%obs_ad() + ! + ! -- Return + return + end subroutine gwf_gwf_ad + + subroutine gwf_gwf_cf(this, kiter) +! ****************************************************************************** +! gwf_gwf_cf -- Calculate the conductance term. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfExchangeType) :: this + integer(I4B), intent(in) :: kiter + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Rewet cells across models using the wetdry parameters in each model's + ! npf package, and the head in the connected model. + call this%rewet(kiter) + ! + ! -- Return + return + end subroutine gwf_gwf_cf + + subroutine gwf_gwf_fc(this, kiter, iasln, amatsln, inwtflag) +! ****************************************************************************** +! gwf_gwf_fc -- Fill the matrix +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DHALF + use GwfNpfModule, only: hcond, vcond + ! -- dummy + class(GwfExchangeType) :: this + integer(I4B), intent(in) :: kiter + integer(I4B), dimension(:), intent(in) :: iasln + real(DP), dimension(:), intent(inout) :: amatsln + integer(I4B), optional, intent(in) :: inwtflag + ! -- local + integer(I4B) :: inwt, iexg + integer(I4B) :: njasln +! ------------------------------------------------------------------------------ + ! + ! -- calculate the conductance for each exchange connection + call this%condcalc() + ! + ! -- if gnc is active, then copy cond into gnc cond (might consider a + ! pointer here in the future) + if(this%ingnc > 0) then + do iexg = 1, this%nexg + this%gnc%cond(iexg) = this%cond(iexg) + enddo + endif + ! + ! -- Call fill method of parent to put this%cond into amatsln + call this%NumericalExchangeType%exg_fc(kiter, iasln, amatsln) + ! + ! -- Fill the gnc terms in the solution matrix + if(this%ingnc > 0) then + call this%gnc%gnc_fc(kiter, amatsln) + endif + ! + ! -- Call mvr fc routine + if(this%inmvr > 0) call this%mvr%mvr_fc() + ! + ! -- Set inwt to exchange newton, but shut off if requested by caller + inwt = this%inewton + if(present(inwtflag)) then + if (inwtflag == 0) inwt = 0 + endif + if (inwt /= 0) then + call this%exg_fn(kiter, iasln, amatsln) + endif + ! + ! -- Ghost node Newton-Raphson + if (this%ingnc > 0) then + if (inwt /= 0) then + njasln = size(amatsln) + call this%gnc%gnc_fn(kiter, njasln, amatsln, this%condsat, & + ihc_opt=this%ihc, ivarcv_opt=this%ivarcv, & + ictm1_opt=this%gwfmodel1%npf%icelltype, & + ictm2_opt=this%gwfmodel2%npf%icelltype) + endif + endif + ! + ! -- Return + return + end subroutine gwf_gwf_fc + + subroutine gwf_gwf_fn(this, kiter, iasln, amatsln) +! ****************************************************************************** +! gwf_gwf_fn -- Fill amatsln with Newton terms +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SmoothingModule, only: sQuadraticSaturationDerivative + ! -- dummy + class(GwfExchangeType) :: this + integer(I4B), intent(in) :: kiter + integer(I4B), dimension(:), intent(in) :: iasln + real(DP), dimension(:), intent(inout) :: amatsln + ! -- local + logical :: nisup + integer(I4B) :: iexg + integer(I4B) :: n, m + integer(I4B) :: nodensln, nodemsln + integer(I4B) :: ibdn, ibdm + integer(I4B) :: idiagnsln, idiagmsln + real(DP) :: topn, topm + real(DP) :: botn, botm + real(DP) :: topup, botup + real(DP) :: hn, hm + real(DP) :: hup, hdn + real(DP) :: cond + real(DP) :: term + real(DP) :: consterm + real(DP) :: derv +! ------------------------------------------------------------------------------ + ! + do iexg = 1, this%nexg + n = this%nodem1(iexg) + m = this%nodem2(iexg) + nodensln = this%nodem1(iexg) + this%m1%moffset + nodemsln = this%nodem2(iexg) + this%m2%moffset + ibdn = this%gwfmodel1%ibound(n) + ibdm = this%gwfmodel2%ibound(m) + topn = this%gwfmodel1%dis%top(n) + topm = this%gwfmodel2%dis%top(m) + botn = this%gwfmodel1%dis%bot(n) + botm = this%gwfmodel2%dis%bot(m) + hn = this%gwfmodel1%x(n) + hm = this%gwfmodel2%x(m) + if(this%ihc(iexg) == 0) then + ! -- vertical connection, newton not supported + else + ! -- determine upstream node + nisup = .false. + if(hm < hn) nisup = .true. + ! + ! -- set upstream top and bot + if(nisup) then + topup = topn + botup = botn + hup = hn + hdn = hm + else + topup = topm + botup = botm + hup = hm + hdn = hn + endif + ! + ! -- no newton terms if upstream cell is confined + if (nisup) then + if (this%gwfmodel1%npf%icelltype(n) == 0) cycle + else + if (this%gwfmodel2%npf%icelltype(m) == 0) cycle + end if + ! + ! -- set topup and botup + if(this%ihc(iexg) == 2) then + topup = min(topn, topm) + botup = max(botn, botm) + endif + ! + ! get saturated conductivity for derivative + cond = this%condsat(iexg) + ! + ! -- TO DO deal with MODFLOW-NWT upstream weighting option + ! + ! -- compute terms + consterm = -cond * (hup - hdn) + derv = sQuadraticSaturationDerivative(topup, botup, hup) + idiagnsln = iasln(nodensln) + idiagmsln = iasln(nodemsln) + if(nisup) then + ! + ! -- fill jacobian with n being upstream + term = consterm * derv + this%gwfmodel1%rhs(n) = this%gwfmodel1%rhs(n) + term * hn + this%gwfmodel2%rhs(m) = this%gwfmodel2%rhs(m) - term * hn + amatsln(idiagnsln) = amatsln(idiagnsln) + term + if(ibdm > 0) then + amatsln(this%idxsymglo(iexg)) = amatsln(this%idxsymglo(iexg)) - term + endif + else + ! + ! -- fill jacobian with m being upstream + term = -consterm * derv + this%gwfmodel1%rhs(n) = this%gwfmodel1%rhs(n) + term * hm + this%gwfmodel2%rhs(m) = this%gwfmodel2%rhs(m) - term * hm + amatsln(idiagmsln) = amatsln(idiagmsln) - term + if(ibdn > 0) then + amatsln(this%idxglo(iexg)) = amatsln(this%idxglo(iexg)) + term + endif + endif + endif + enddo + ! + ! -- Return + return + end subroutine gwf_gwf_fn + + subroutine gwf_gwf_cq(this, icnvg, isuppress_output, isolnid) +! ****************************************************************************** +! gwf_gwf_cq -- Calculate flow between two cells +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DZERO, DPIO180 + use GwfNpfModule, only: thksatnm + ! -- dummy + class(GwfExchangeType) :: this + integer(I4B), intent(inout) :: icnvg + integer(I4B), intent(in) :: isuppress_output + integer(I4B), intent(in) :: isolnid + ! -- local + integer(I4B) :: i + integer(I4B) :: n1 + integer(I4B) :: n2 + integer(I4B) :: ihc + integer(I4B) :: ibdn1 + integer(I4B) :: ibdn2 + integer(I4B) :: ictn1 + integer(I4B) :: ictn2 + integer(I4B) :: iusg + real(DP) :: topn1 + real(DP) :: topn2 + real(DP) :: botn1 + real(DP) :: botn2 + real(DP) :: satn1 + real(DP) :: satn2 + real(DP) :: hn1 + real(DP) :: hn2 + real(DP) :: rrate + real(DP) :: thksat + real(DP) :: angle + real(DP) :: nx + real(DP) :: ny + real(DP) :: distance + real(DP) :: dltot + real(DP) :: hwva + real(DP) :: area +! ------------------------------------------------------------------------------ + ! + ! -- Return if there neither model needs to calculate specific discharge + if (this%gwfmodel1%npf%icalcspdis == 0 .and. & + this%gwfmodel2%npf%icalcspdis == 0) return + ! + ! -- initialize + iusg = 0 + ! + ! -- Loop through all exchanges + do i = 1, this%nexg + rrate = DZERO + n1 = this%nodem1(i) + n2 = this%nodem2(i) + ihc = this%ihc(i) + hwva = this%hwva(i) + ibdn1 = this%gwfmodel1%ibound(n1) + ibdn2 = this%gwfmodel2%ibound(n2) + ictn1 = this%gwfmodel1%npf%icelltype(n1) + ictn2 = this%gwfmodel2%npf%icelltype(n2) + topn1 = this%gwfmodel1%dis%top(n1) + topn2 = this%gwfmodel2%dis%top(n2) + botn1 = this%gwfmodel1%dis%bot(n1) + botn2 = this%gwfmodel2%dis%bot(n2) + satn1 = this%gwfmodel1%npf%sat(n1) + satn2 = this%gwfmodel2%npf%sat(n2) + hn1 = this%gwfmodel1%x(n1) + hn2 = this%gwfmodel2%x(n2) + ! + ! -- If both cells are active then calculate flow rate, and add ghost + ! node contribution + if(ibdn1 /= 0 .and. ibdn2 /= 0) then + rrate = this%qcalc(i, n1, n2) + if(this%ingnc > 0) then + rrate = rrate + this%gnc%deltaqgnc(i) + endif + endif + ! + ! -- Calculate face normal components + if(ihc == 0) then + nx = DZERO + ny = DZERO + area = hwva + if (botn1 < botn2) then + ! -- n1 is beneath n2, so rate is positive downward. Flip rate + ! upward so that points in positive z direction + rrate = - rrate + endif + else + if(this%ianglex > 0) then + angle = this%auxvar(this%ianglex, i) * DPIO180 + nx = cos(angle) + ny = sin(angle) + else + ! error? + call ustop('error in gwf_gwf_cq') + endif + ! + ! -- Calculate the saturated thickness at interface between n1 and n2 + thksat = thksatnm(ibdn1, ibdn2, ictn1, ictn2, this%inewton, ihc, & + iusg, hn1, hn2, satn1, satn2, & + topn1, topn2, botn1, botn2, this%satomega) + area = hwva * thksat + endif + ! + ! -- Submit this connection and flow information to the npf + ! package of gwfmodel1 + if(this%icdist > 0) then + dltot = this%auxvar(this%icdist, i) + else + call ustop('error in gwf_gwf_cq') + endif + distance = dltot * this%cl1(i) / (this%cl1(i) + this%cl2(i)) + if (this%gwfmodel1%npf%icalcspdis == 1) then + call this%gwfmodel1%npf%set_edge_properties(n1, ihc, rrate, area, & + nx, ny, distance) + endif + ! + ! -- Submit this connection and flow information to the npf + ! package of gwfmodel2 + if(this%icdist > 0) then + dltot = this%auxvar(this%icdist, i) + else + call ustop('error in gwf_gwf_cq') + endif + if (this%gwfmodel2%npf%icalcspdis == 1) then + distance = dltot * this%cl2(i) / (this%cl1(i) + this%cl2(i)) + if (ihc /= 0) rrate = -rrate + call this%gwfmodel2%npf%set_edge_properties(n2, ihc, rrate, area, & + -nx, -ny, distance) + endif + ! + enddo + ! + ! -- return + return + end subroutine gwf_gwf_cq + + subroutine gwf_gwf_bd(this, icnvg, isuppress_output, isolnid) +! ****************************************************************************** +! gwf_gwf_bd -- Budget for implicit gwf to gwf exchange; the budget for the +! explicit exchange connections is handled for each model by +! the exchange boundary package. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DZERO, LENBUDTXT, LENPACKAGENAME + !use TdisModule, only: kstp, kper + ! -- dummy + class(GwfExchangeType) :: this + integer(I4B), intent(inout) :: icnvg + integer(I4B), intent(in) :: isuppress_output + integer(I4B), intent(in) :: isolnid + ! -- local + character(len=LENBOUNDNAME) :: bname + character(len=LENPACKAGENAME+4) :: packname1 + character(len=LENPACKAGENAME+4) :: packname2 + character(len=LENBUDTXT), dimension(1) :: budtxt + character(len=20) :: nodestr + integer(I4B) :: ntabrows + integer(I4B) :: nodeu + real(DP), dimension(2, 1) :: budterm + integer(I4B) :: i, n1, n2, n1u, n2u + integer(I4B) :: ibinun1, ibinun2 + integer(I4B) :: icbcfl, ibudfl + real(DP) :: ratin, ratout, rrate, deltaqgnc + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- initialize local variables + budtxt(1) = ' FLOW-JA-FACE' + packname1 = 'EXG '//this%name + packname1 = adjustr(packname1) + packname2 = 'EXG '//this%name + packname2 = adjustr(packname2) + ! + ! -- update output tables + if (this%iprflow /= 0) then + ! + ! -- update titles + if (this%gwfmodel1%oc%oc_save('BUDGET')) then + call this%outputtab1%set_title(packname1) + end if + if (this%gwfmodel2%oc%oc_save('BUDGET')) then + call this%outputtab2%set_title(packname2) + end if + ! + ! -- update maxbound of tables + ntabrows = 0 + do i = 1, this%nexg + n1 = this%nodem1(i) + n2 = this%nodem2(i) + ! + ! -- If both cells are active then calculate flow rate + if (this%gwfmodel1%ibound(n1) /= 0 .and. & + this%gwfmodel2%ibound(n2) /= 0) then + ntabrows = ntabrows + 1 + end if + end do + if (ntabrows > 0) then + call this%outputtab1%set_maxbound(ntabrows) + call this%outputtab2%set_maxbound(ntabrows) + end if + end if + ! + ! -- Print and write budget terms for model 1 + ! + ! -- Set binary unit numbers for saving flows + if(this%ipakcb /= 0) then + ibinun1 = this%gwfmodel1%oc%oc_save_unit('BUDGET') + else + ibinun1 = 0 + endif + ! + ! -- If save budget flag is zero for this stress period, then + ! shut off saving + if(.not. this%gwfmodel1%oc%oc_save('BUDGET')) ibinun1 = 0 + if(isuppress_output /= 0) then + ibinun1 = 0 + endif + ! + ! -- If cell-by-cell flows will be saved as a list, write header. + if(ibinun1 /= 0) then + call this%gwfmodel1%dis%record_srcdst_list_header(budtxt(1), & + this%m1%name, this%name, & + this%m2%name, this%name, & + this%naux, this%auxname, & + ibinun1, this%nexg, this%gwfmodel1%iout) + endif + ! + ! Initialize accumulators + ratin = DZERO + ratout = DZERO + ! + ! -- Loop through all exchanges + do i = 1, this%nexg + ! + ! -- Assign boundary name + if (this%inamedbound>0) then + bname = this%boundname(i) + else + bname = '' + endif + ! + ! -- Calculate the flow rate between n1 and n2 + rrate = DZERO + n1 = this%nodem1(i) + n2 = this%nodem2(i) + ! + ! -- If both cells are active then calculate flow rate + if(this%gwfmodel1%ibound(n1) /= 0 .and. & + this%gwfmodel2%ibound(n2) /= 0) then + rrate = this%qcalc(i, n1, n2) + ! + ! -- add ghost node contribution + if(this%ingnc > 0) then + deltaqgnc = this%gnc%deltaqgnc(i) + rrate = rrate + deltaqgnc + endif + ! + ! -- Print the individual rates to model list files if requested + if(this%iprflow /= 0) then + if(this%gwfmodel1%oc%oc_save('BUDGET')) then + ! + ! -- set nodestr and write outputtab table + nodeu = this%gwfmodel1%dis%get_nodeuser(n1) + call this%gwfmodel1%dis%nodeu_to_string(nodeu, nodestr) + call this%outputtab1%print_list_entry(i, trim(adjustl(nodestr)), & + rrate, bname) + end if + endif + if(rrate < DZERO) then + ratout = ratout - rrate + else + ratin = ratin + rrate + endif + endif + ! + ! -- If saving cell-by-cell flows in list, write flow + n1u = this%gwfmodel1%dis%get_nodeuser(n1) + n2u = this%gwfmodel2%dis%get_nodeuser(n2) + if(ibinun1 /= 0) & + call this%gwfmodel1%dis%record_mf6_list_entry( & + ibinun1, n1u, n2u, rrate, this%naux, this%auxvar(:, i), & + .false., .false.) + ! + enddo + ! + ! -- Add the budget terms to model 1 + budterm(1, 1) = ratin + budterm(2, 1) = ratout + call this%m1%model_bdentry(budterm, budtxt, this%name) + ! + ! -- Print and write budget terms for model 2 + ! + ! -- Set binary unit numbers for saving flows + if(this%ipakcb /= 0) then + ibinun2 = this%gwfmodel2%oc%oc_save_unit('BUDGET') + else + ibinun2 = 0 + endif + ! + ! -- If save budget flag is zero for this stress period, then + ! shut off saving + if(.not. this%gwfmodel2%oc%oc_save('BUDGET')) ibinun2 = 0 + if(isuppress_output /= 0) then + ibinun2 = 0 + endif + ! + ! -- If cell-by-cell flows will be saved as a list, write header. + if(ibinun2 /= 0) then + call this%gwfmodel2%dis%record_srcdst_list_header(budtxt(1), & + this%m2%name, this%name, & + this%m1%name, this%name, & + this%naux, this%auxname, & + ibinun2, this%nexg, this%gwfmodel2%iout) + endif + ! + ! Initialize accumulators + ratin = DZERO + ratout = DZERO + ! + ! -- Loop through all exchanges + do i = 1, this%nexg + ! + ! -- Assign boundary name + if (this%inamedbound>0) then + bname = this%boundname(i) + else + bname = '' + endif + ! + ! -- Calculate the flow rate between n1 and n2 + rrate = DZERO + n1 = this%nodem1(i) + n2 = this%nodem2(i) + ! + ! -- If both cells are active then calculate flow rate + if(this%gwfmodel1%ibound(n1) /= 0 .and. & + this%gwfmodel2%ibound(n2) /= 0) then + rrate = this%cond(i) * this%m2%x(n2) - this%cond(i) * this%m1%x(n1) + ! + ! -- add ghost node contribution + if(this%ingnc > 0) then + deltaqgnc = this%gnc%deltaqgnc(i) + rrate = rrate + deltaqgnc + endif + ! + ! -- Print the individual rates to model list files if requested + if(this%iprflow /= 0) then + if(this%gwfmodel2%oc%oc_save('BUDGET')) then + ! + ! -- set nodestr and write outputtab table + nodeu = this%gwfmodel2%dis%get_nodeuser(n2) + call this%gwfmodel2%dis%nodeu_to_string(nodeu, nodestr) + call this%outputtab2%print_list_entry(i, trim(adjustl(nodestr)), & + -rrate, bname) + end if + endif + if(rrate < DZERO) then + ratout = ratout - rrate + else + ratin = ratin + rrate + endif + endif + ! + ! -- If saving cell-by-cell flows in list, write flow + n1u = this%gwfmodel1%dis%get_nodeuser(n1) + n2u = this%gwfmodel2%dis%get_nodeuser(n2) + if(ibinun2 /= 0) & + call this%gwfmodel2%dis%record_mf6_list_entry( & + ibinun2, n2u, n1u, -rrate, this%naux, this%auxvar(:, i), & + .false., .false.) + ! + enddo + ! + ! -- Add the budget terms to model 2 + budterm(1, 1) = ratout + budterm(2, 1) = ratin + call this%m2%model_bdentry(budterm, budtxt, this%name) + ! + ! -- Set icbcfl, ibudfl to zero so that flows will be printed and + ! saved, if the options were set in the MVR package + icbcfl = 1 + ibudfl = 1 + ! + ! -- Call mvr bd routine + if(this%inmvr > 0) call this%mvr%mvr_bd(icbcfl, ibudfl, isuppress_output) + ! + ! -- Calculate and write simulated values for observations + if(this%inobs /= 0) then + call this%gwf_gwf_save_simvals() + endif + ! + ! -- return + return + end subroutine gwf_gwf_bd + + subroutine gwf_gwf_ot(this) +! ****************************************************************************** +! gwf_gwf_ot +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimVariablesModule, only: iout + use ConstantsModule, only: DZERO, LINELENGTH + ! -- dummy + class(GwfExchangeType) :: this + ! -- local + integer(I4B) :: iexg, n1, n2 + real(DP) :: flow, deltaqgnc + character(len=LINELENGTH) :: node1str, node2str + ! -- format + character(len=*), parameter :: fmtheader = & + "(/1x, 'SUMMARY OF EXCHANGE RATES FOR EXCHANGE ', a, ' WITH ID ', i0, /, & + &2a16, 5a16, /, 112('-'))" + character(len=*), parameter :: fmtheader2 = & + "(/1x, 'SUMMARY OF EXCHANGE RATES FOR EXCHANGE ', a, ' WITH ID ', i0, /, & + &2a16, 4a16, /, 96('-'))" + character(len=*), parameter :: fmtdata = & + "(2a16, 5(1pg16.6))" +! ------------------------------------------------------------------------------ + ! + ! -- Initialize + deltaqgnc = DZERO + ! + ! -- Write a table of exchanges + if(this%iprflow /= 0) then + if(this%ingnc > 0) then + write(iout, fmtheader) trim(adjustl(this%name)), this%id, 'NODEM1', & + 'NODEM2', 'COND', 'X_M1', 'X_M2', 'DELTAQGNC', & + 'FLOW' + else + write(iout, fmtheader2) trim(adjustl(this%name)), this%id, 'NODEM1', & + 'NODEM2', 'COND', 'X_M1', 'X_M2', 'FLOW' + endif + do iexg = 1, this%nexg + n1 = this%nodem1(iexg) + n2 = this%nodem2(iexg) + flow = this%cond(iexg) * (this%m2%x(n2) - this%m1%x(n1)) + call this%m1%dis%noder_to_string(n1, node1str) + call this%m2%dis%noder_to_string(n2, node2str) + if(this%ingnc > 0) then + deltaqgnc = this%gnc%deltaqgnc(iexg) + write(iout, fmtdata) trim(adjustl(node1str)), & + trim(adjustl(node2str)), & + this%cond(iexg), this%m1%x(n1), this%m2%x(n2), & + deltaqgnc, flow + deltaqgnc + else + write(iout, fmtdata) trim(adjustl(node1str)), & + trim(adjustl(node2str)), & + this%cond(iexg), this%m1%x(n1), this%m2%x(n2), & + flow + endif + enddo + endif + ! + ! -- Mover budget output + if(this%inmvr > 0) call this%mvr%mvr_ot() + ! + ! -- OBS output + call this%obs%obs_ot() + ! + ! -- return + return + end subroutine gwf_gwf_ot + + subroutine read_options(this, iout) +! ****************************************************************************** +! read_options -- Read Options +! Subroutine: (1) read options from input file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ArrayHandlersModule, only: ifind + use ConstantsModule, only: LINELENGTH, DEM6 + use InputOutputModule, only: getunit, openfile, urdaux + use SimModule, only: store_error, store_error_unit, ustop + ! -- dummy + class(GwfExchangeType) :: this + integer(I4B), intent(in) :: iout + ! -- local + character(len=LINELENGTH) :: line, errmsg, keyword, fname + integer(I4B) :: istart,istop,lloc,ierr,ival + integer(I4B) :: inobs + logical :: isfound, endOfBlock +! ------------------------------------------------------------------------------ + ! + ! -- get options block + call this%parser%GetBlock('OPTIONS', isfound, ierr, & + supportOpenClose=.true., blockRequired=.false.) + ! + ! -- parse options block if detected + if (isfound) then + write(iout,'(1x,a)')'PROCESSING GWF EXCHANGE OPTIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case('AUXILIARY') + call this%parser%GetRemainingLine(line) + lloc = 1 + call urdaux(this%naux, this%parser%iuactive, iout, lloc, istart, & + istop, this%auxname, line, 'GWF_GWF_Exchange') + ! + ! -- If ANGLDEGX is an auxiliary variable, then anisotropy can be + ! used in either model. Store ANGLDEGX position in this%ianglex + ival = ifind(this%auxname, 'ANGLDEGX') + if(ival > 0) this%ianglex = ival + ival = ifind(this%auxname, 'CDIST') + if(ival > 0) this%icdist = ival + case ('PRINT_INPUT') + this%iprpak = 1 + write(iout,'(4x,a)') & + 'THE LIST OF EXCHANGES WILL BE PRINTED.' + case ('PRINT_FLOWS') + this%iprflow = 1 + write(iout,'(4x,a)') & + 'EXCHANGE FLOWS WILL BE PRINTED TO LIST FILES.' + case ('SAVE_FLOWS') + this%ipakcb = -1 + write(iout,'(4x,a)') & + 'EXCHANGE FLOWS WILL BE SAVED TO BINARY BUDGET FILES.' + case ('ALTERNATIVE_CELL_AVERAGING') + call this%parser%GetStringCaps(keyword) + select case(keyword) + case('LOGARITHMIC') + this%icellavg = 1 + case('AMT-LMK') + this%icellavg = 2 + case default + write(errmsg,'(4x,a,a)')'UNKNOWN CELL AVERAGING METHOD: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + write(iout,'(4x,a,a)') & + 'CELL AVERAGING METHOD HAS BEEN SET TO: ', trim(keyword) + case ('VARIABLECV') + this%ivarcv = 1 + write(iout,'(4x,a)') & + 'VERTICAL CONDUCTANCE VARIES WITH WATER TABLE.' + call this%parser%GetStringCaps(keyword) + if(keyword == 'DEWATERED') then + this%idewatcv = 1 + write(iout,'(4x,a)') & + 'VERTICAL CONDUCTANCE ACCOUNTS FOR DEWATERED PORTION OF ' // & + 'AN UNDERLYING CELL.' + endif + case ('NEWTON') + this%inewton = 1 + write(iout, '(4x,a)') & + 'NEWTON-RAPHSON method used for unconfined cells' + case ('GNC6') + call this%parser%GetStringCaps(keyword) + if(keyword /= 'FILEIN') then + call store_error('GNC6 KEYWORD MUST BE FOLLOWED BY ' // & + '"FILEIN" then by filename.') + call this%parser%StoreErrorUnit() + call ustop() + endif + call this%parser%GetString(fname) + if(fname == '') then + call store_error('NO GNC6 FILE SPECIFIED.') + call this%parser%StoreErrorUnit() + call ustop() + endif + this%ingnc = getunit() + call openfile(this%ingnc, iout, fname, 'GNC') + write(iout,'(4x,a)') & + 'GHOST NODES WILL BE READ FROM ', trim(fname) + case ('MVR6') + call this%parser%GetStringCaps(keyword) + if(keyword /= 'FILEIN') then + call store_error('MVR6 KEYWORD MUST BE FOLLOWED BY ' // & + '"FILEIN" then by filename.') + call this%parser%StoreErrorUnit() + call ustop() + endif + call this%parser%GetString(fname) + if(fname == '') then + call store_error('NO MVR6 FILE SPECIFIED.') + call this%parser%StoreErrorUnit() + call ustop() + endif + this%inmvr = getunit() + call openfile(this%inmvr, iout, fname, 'MVR') + write(iout,'(4x,a)') & + 'WATER MOVER INFORMATION WILL BE READ FROM ', trim(fname) + case ('BOUNDNAMES') + this%inamedbound = 1 + write(iout,'(4x,a)') 'EXCHANGE BOUNDARIES HAVE NAMES' // & + ' IN LAST COLUMN.' + case ('OBS6') + call this%parser%GetStringCaps(keyword) + if(keyword /= 'FILEIN') then + call store_error('OBS8 KEYWORD MUST BE FOLLOWED BY ' // & + '"FILEIN" then by filename.') + call this%parser%StoreErrorUnit() + call ustop() + endif + this%obs%active = .true. + call this%parser%GetString(this%obs%inputFilename) + inobs = GetUnit() + call openfile(inobs, iout, this%obs%inputFilename, 'OBS') + this%obs%inUnitObs = inobs + case default + write(errmsg,'(4x,a,a)')'***ERROR. UNKNOWN GWF EXCHANGE OPTION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + end do + write(iout,'(1x,a)')'END OF GWF EXCHANGE OPTIONS' + end if + ! + ! -- set omega value used for saturation calculations + if (this%inewton > 0) then + this%satomega = DEM6 + end if + ! + ! -- return + return + end subroutine read_options + + subroutine read_data(this, iout) +! ****************************************************************************** +! read_data -- Read EXGDATA block +! Subroutine: (1) read list of EXGs from input file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, store_error_unit, count_errors + ! -- dummy + class(GwfExchangeType) :: this + integer(I4B), intent(in) :: iout + ! -- local + character(len=LINELENGTH) :: errmsg, nodestr, node1str, node2str, cellid + character(len=2) :: cnfloat + integer(I4B) :: lloc, ierr, nerr, iaux + integer(I4B) :: iexg, nodem1, nodem2, nodeum1, nodeum2 + logical :: isfound, endOfBlock + ! -- format + character(len=*), parameter :: fmtexglabel = "(5x, 3a10, 50(a16))" + character(len=*), parameter :: fmtexgdata = & + "(5x, a, 1x, a ,I10, 50(1pg16.6))" + character(len=40) :: fmtexgdata2 +! ------------------------------------------------------------------------------ + ! + ! -- get ExchangeData block + call this%parser%GetBlock('EXCHANGEDATA', isfound, ierr, & + supportOpenClose=.true.) + ! + ! -- parse ExchangeData block if detected + if (isfound) then + write(iout,'(1x,a)')'PROCESSING EXCHANGEDATA' + if(this%iprpak /= 0) then + if (this%inamedbound==0) then + write(iout, fmtexglabel) 'NODEM1', 'NODEM2', 'IHC', & + 'CL1', 'CL2', 'HWVA', (adjustr(this%auxname(iaux)), & + iaux = 1, this%naux) + else + write(iout, fmtexglabel) 'NODEM1', 'NODEM2', 'IHC', 'CL1', 'CL2', & + 'HWVA', (adjustr(this%auxname(iaux)),iaux=1,this%naux), & + ' BOUNDNAME ' + ! Define format suitable for writing input data, + ! any auxiliary variables, and boundname. + write(cnfloat,'(i0)') 3+this%naux + fmtexgdata2 = '(5x, a, 1x, a, i10, ' // trim(cnfloat) // & + '(1pg16.6), 1x, a)' + endif + endif + do iexg = 1, this%nexg + call this%parser%GetNextLine(endOfBlock) + lloc = 1 + ! + ! -- Read and check node 1 + call this%parser%GetCellid(this%m1%dis%ndim, cellid, flag_string=.true.) + nodem1 = this%m1%dis%noder_from_cellid(cellid, this%parser%iuactive, & + iout, flag_string=.true.) + this%nodem1(iexg) = nodem1 + ! + ! -- Read and check node 2 + call this%parser%GetCellid(this%m2%dis%ndim, cellid, flag_string=.true.) + nodem2 = this%m2%dis%noder_from_cellid(cellid, this%parser%iuactive, & + iout, flag_string=.true.) + this%nodem2(iexg) = nodem2 + ! + ! -- Read rest of input line + this%ihc(iexg) = this%parser%GetInteger() + this%cl1(iexg) = this%parser%GetDouble() + this%cl2(iexg) = this%parser%GetDouble() + this%hwva(iexg) = this%parser%GetDouble() + do iaux = 1, this%naux + this%auxvar(iaux, iexg) = this%parser%GetDouble() + enddo + if (this%inamedbound==1) then + call this%parser%GetStringCaps(this%boundname(iexg)) + endif + ! + ! -- Write the data to listing file if requested + if(this%iprpak /= 0) then + nodeum1 = this%m1%dis%get_nodeuser(nodem1) + call this%m1%dis%nodeu_to_string(nodeum1, node1str) + nodeum2 = this%m2%dis%get_nodeuser(nodem2) + call this%m2%dis%nodeu_to_string(nodeum2, node2str) + if (this%inamedbound == 0) then + write(iout, fmtexgdata) trim(node1str), trim(node2str), & + this%ihc(iexg), this%cl1(iexg), this%cl2(iexg), & + this%hwva(iexg), & + (this%auxvar(iaux, iexg), iaux=1,this%naux) + else + write(iout, fmtexgdata2) trim(node1str), trim(node2str), & + this%ihc(iexg), this%cl1(iexg), this%cl2(iexg), & + this%hwva(iexg), & + (this%auxvar(iaux, iexg), iaux=1,this%naux), & + trim(this%boundname(iexg)) + endif + endif + ! + ! -- Check to see if nodem1 is outside of active domain + if(nodem1 <= 0) then + call this%gwfmodel1%dis%nodeu_to_string(nodeum1, nodestr) + write(errmsg, *) & + trim(adjustl(this%gwfmodel1%name)) // & + ' Cell is outside active grid domain: ' // & + trim(adjustl(nodestr)) + call store_error(errmsg) + endif + ! + ! -- Check to see if nodem2 is outside of active domain + if(nodem2 <= 0) then + call this%gwfmodel2%dis%nodeu_to_string(nodeum2, nodestr) + write(errmsg, *) & + trim(adjustl(this%gwfmodel2%name)) // & + ' Cell is outside active grid domain: ' // & + trim(adjustl(nodestr)) + call store_error(errmsg) + endif + enddo + ! + ! -- Stop if errors + nerr = count_errors() + if(nerr > 0) then + call store_error('Errors encountered in exchange input file.') + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + write(iout,'(1x,a)')'END OF EXCHANGEDATA' + else + write(errmsg, '(1x,a)')'ERROR. REQUIRED EXCHANGEDATA BLOCK NOT FOUND.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- return + return + end subroutine read_data + + subroutine read_gnc(this, iout) +! ****************************************************************************** +! read_gnc -- Read ghost node information. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: store_error, store_error_unit, count_errors, ustop + use ConstantsModule, only: LINELENGTH + ! -- dummy + class(GwfExchangeType) :: this + integer(I4B), intent(in) :: iout + ! -- local + integer(I4B) :: i, nm1, nm2, nmgnc1, nmgnc2 + character(len=LINELENGTH) :: errmsg + character(len=*), parameter :: fmterr = & + "('EXCHANGE NODES ', i0, ' AND ', i0," // & + "' NOT CONSISTENT WITH GNC NODES ', i0, ' AND ', i0)" +! ------------------------------------------------------------------------------ + ! + ! -- If exchange has ghost nodes, then initialize ghost node object + ! This will read the ghost node blocks from the gnc input file. + call this%gnc%gnc_df(this%m1, m2=this%m2) + ! + ! -- Verify gnc is implicit if exchange has Newton Terms + if(.not. this%gnc%implicit .and. this%inewton /= 0) then + call store_error('GNC IS EXPLICIT, BUT GWF EXCHANGE HAS ACTIVE NEWTON.') + call store_error('ADD IMPLICIT OPTION TO GNC OR REMOVE NEWTON FROM ' // & + 'GWF EXCHANGE.') + call store_error_unit(this%ingnc) + call ustop() + endif + ! + ! -- Perform checks to ensure GNCs match with GWF-GWF nodes + if(this%nexg /= this%gnc%nexg) then + call store_error('NUMBER OF EXCHANGES DOES NOT MATCH NUMBER OF GNCs') + call store_error_unit(this%ingnc) + call ustop() + endif + ! + ! -- Go through each entry and confirm + do i = 1, this%nexg + if(this%nodem1(i) /= this%gnc%nodem1(i) .or. & + this%nodem2(i) /= this%gnc%nodem2(i) ) then + nm1 = this%gwfmodel1%dis%get_nodeuser(this%nodem1(i)) + nm2 = this%gwfmodel2%dis%get_nodeuser(this%nodem2(i)) + nmgnc1 = this%gwfmodel1%dis%get_nodeuser(this%gnc%nodem1(i)) + nmgnc2 = this%gwfmodel2%dis%get_nodeuser(this%gnc%nodem2(i)) + write(errmsg, fmterr) nm1, nm2, nmgnc1, nmgnc2 + call store_error(errmsg) + endif + enddo + if(count_errors() > 0) then + call store_error_unit(this%ingnc) + call ustop() + endif + ! + ! -- close the file + close(this%ingnc) + ! + ! -- return + return + end subroutine read_gnc + + subroutine read_mvr(this, iout) +! ****************************************************************************** +! read_mvr -- Read water mover information. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use GwfMvrModule, only: mvr_cr + ! -- dummy + class(GwfExchangeType) :: this + integer(I4B), intent(in) :: iout + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Create and initialize the mover object + call mvr_cr(this%mvr, this%name, this%inmvr, iout, iexgmvr=1) + ! + ! -- Return + return + end subroutine read_mvr + + subroutine rewet(this, kiter) +! ****************************************************************************** +! rewet -- Check for rewetting across models +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: kper, kstp + ! -- dummy + class(GwfExchangeType) :: this + integer(I4B), intent(in) :: kiter + ! -- local + integer(I4B) :: iexg + integer(I4B) :: n, m + integer(I4B) :: ibdn, ibdm + integer(I4B) :: ihc + real(DP) :: hn, hm + integer(I4B) :: irewet + character(len=30) :: nodestrn, nodestrm + character(len=*),parameter :: fmtrwt = & + "(1x, 'CELL ',A,' REWET FROM GWF MODEL ',A,' CELL ',A, & + &' FOR ITER. ',I0, ' STEP ',I0, ' PERIOD ', I0)" +! ------------------------------------------------------------------------------ + ! + ! -- Use model 1 to rewet model 2 and vice versa + do iexg = 1, this%nexg + n = this%nodem1(iexg) + m = this%nodem2(iexg) + hn = this%gwfmodel1%x(n) + hm = this%gwfmodel2%x(m) + ibdn = this%gwfmodel1%ibound(n) + ibdm = this%gwfmodel2%ibound(m) + ihc = this%ihc(iexg) + call this%gwfmodel1%npf%rewet_check(kiter, n, hm, ibdm, ihc, & + this%gwfmodel1%x, irewet) + if(irewet == 1) then + call this%gwfmodel1%dis%noder_to_string(n, nodestrn) + call this%gwfmodel2%dis%noder_to_string(m, nodestrm) + write(this%gwfmodel1%iout, fmtrwt) trim(nodestrn), & + trim(this%gwfmodel2%name), trim(nodestrm), kiter, kstp, kper + endif + call this%gwfmodel2%npf%rewet_check(kiter, m, hn, ibdn, ihc, & + this%gwfmodel2%x, irewet) + if(irewet == 1) then + call this%gwfmodel1%dis%noder_to_string(n, nodestrm) + call this%gwfmodel2%dis%noder_to_string(m, nodestrn) + write(this%gwfmodel2%iout, fmtrwt) trim(nodestrn), & + trim(this%gwfmodel1%name), trim(nodestrm), kiter, kstp, kper + endif + ! + enddo + ! + ! -- Return + return + end subroutine rewet + + subroutine condcalc(this) +! ****************************************************************************** +! condcalc -- Calculate the conductance +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DHALF, DZERO, DONE + use GwfNpfModule, only: hcond, vcond + ! -- dummy + class(GwfExchangeType) :: this + ! -- local + integer(I4B) :: iexg + integer(I4B) :: n, m, ihc + integer(I4B) :: ibdn, ibdm + integer(I4B) :: ictn, ictm + real(DP) :: topn, topm + real(DP) :: botn, botm + real(DP) :: satn, satm + real(DP) :: hyn, hym + real(DP) :: angle + real(DP) :: hn, hm + real(DP) :: cond + real(DP) :: fawidth + real(DP), dimension(3) :: vg +! ------------------------------------------------------------------------------ + ! + ! -- Calculate conductance and put into amat + do iexg = 1, this%nexg + ihc = this%ihc(iexg) + n = this%nodem1(iexg) + m = this%nodem2(iexg) + ibdn = this%gwfmodel1%ibound(n) + ibdm = this%gwfmodel2%ibound(m) + ictn = this%gwfmodel1%npf%icelltype(n) + ictm = this%gwfmodel2%npf%icelltype(m) + topn = this%gwfmodel1%dis%top(n) + topm = this%gwfmodel2%dis%top(m) + botn = this%gwfmodel1%dis%bot(n) + botm = this%gwfmodel2%dis%bot(m) + satn = this%gwfmodel1%npf%sat(n) + satm = this%gwfmodel2%npf%sat(m) + hn = this%gwfmodel1%x(n) + hm = this%gwfmodel2%x(m) + ! + ! -- Calculate conductance depending on connection orientation + if(ihc == 0) then + ! + ! -- Vertical connection + vg(1) = DZERO + vg(2) = DZERO + vg(3) = DONE + hyn = this%gwfmodel1%npf%hy_eff(n, 0, ihc, vg=vg) + hym = this%gwfmodel2%npf%hy_eff(m, 0, ihc, vg=vg) + cond = vcond(ibdn, ibdm, ictn, ictm, this%inewton, this%ivarcv, & + this%idewatcv, this%condsat(iexg), hn, hm, hyn, hym, & + satn, satm, topn, topm, botn, botm, this%hwva(iexg)) + else + ! + ! -- Horizontal Connection + hyn = this%gwfmodel1%npf%k11(n) + hym = this%gwfmodel2%npf%k11(m) + ! + ! -- Check for anisotropy in models, and recalculate hyn and hym + if(this%ianglex > 0) then + angle = this%auxvar(this%ianglex, iexg) + vg(1) = abs(cos(angle)) + vg(2) = abs(sin(angle)) + vg(3) = DZERO + ! + ! -- anisotropy in model 1 + if(this%gwfmodel1%npf%ik22 /= 0) then + hyn = this%gwfmodel1%npf%hy_eff(n, 0, ihc, vg=vg) + endif + ! + ! -- anisotropy in model 2 + if(this%gwfmodel2%npf%ik22 /= 0) then + hym = this%gwfmodel2%npf%hy_eff(m, 0, ihc, vg=vg) + endif + endif + ! + fawidth = this%hwva(iexg) + cond = hcond(ibdn, ibdm, ictn, ictm, this%inewton, this%inewton, & + this%ihc(iexg), this%icellavg, 0, 0, this%condsat(iexg), & + hn, hm, satn, satm, hyn, hym, topn, topm, botn, botm, & + this%cl1(iexg), this%cl2(iexg), fawidth, this%satomega) + endif + ! + this%cond(iexg) = cond + ! + enddo + ! + ! -- Return + return + end subroutine condcalc + + subroutine allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + use ConstantsModule, only: LENORIGIN, DZERO + ! -- dummy + class(GwfExchangeType) :: this + ! -- local + character(len=LENORIGIN) :: origin +! ------------------------------------------------------------------------------ + ! + ! -- create the origin name + origin = trim(this%name) + ! + ! -- Call parent type allocate_scalars + call this%NumericalExchangeType%allocate_scalars() + ! + call mem_allocate(this%icellavg, 'ICELLAVG', origin) + call mem_allocate(this%ivarcv, 'IVARCV', origin) + call mem_allocate(this%idewatcv, 'IDEWATCV', origin) + call mem_allocate(this%inewton, 'INEWTON', origin) + call mem_allocate(this%ianglex, 'IANGLEX', origin) + call mem_allocate(this%icdist, 'ICDIST', origin) + call mem_allocate(this%ingnc, 'INGNC', origin) + call mem_allocate(this%inmvr, 'INMVR', origin) + call mem_allocate(this%inobs, 'INOBS', origin) + call mem_allocate(this%inamedbound, 'INAMEDBOUND', origin) + call mem_allocate(this%satomega, 'SATOMEGA', origin) + this%icellavg = 0 + this%ivarcv = 0 + this%idewatcv = 0 + this%inewton = 0 + this%ianglex = 0 + this%icdist = 0 + this%ingnc = 0 + this%inmvr = 0 + this%inobs = 0 + this%inamedbound = 0 + this%satomega = DZERO + ! + ! -- return + return + end subroutine allocate_scalars + + subroutine gwf_gwf_da(this) +! ****************************************************************************** +! gwf_gwf_da +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(GwfExchangeType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Call parent type allocate_scalars + call this%NumericalExchangeType%exg_da() + ! + ! -- objects + if(this%ingnc > 0) then + call this%gnc%gnc_da() + deallocate(this%gnc) + endif + if (this%inmvr > 0) then + call this%mvr%mvr_da() + deallocate(this%mvr) + endif + call this%obs%obs_da() + deallocate(this%obs) + ! + ! -- arrays + call mem_deallocate(this%ihc) + call mem_deallocate(this%cl1) + call mem_deallocate(this%cl2) + call mem_deallocate(this%hwva) + call mem_deallocate(this%condsat) + deallocate(this%boundname) + ! + ! -- output table objects + if (associated(this%outputtab1)) then + call this%outputtab1%table_da() + deallocate(this%outputtab1) + nullify(this%outputtab1) + end if + if (associated(this%outputtab2)) then + call this%outputtab2%table_da() + deallocate(this%outputtab2) + nullify(this%outputtab2) + end if + ! + ! -- scalars + call mem_deallocate(this%icellavg) + call mem_deallocate(this%ivarcv) + call mem_deallocate(this%idewatcv) + call mem_deallocate(this%inewton) + call mem_deallocate(this%ianglex) + call mem_deallocate(this%icdist) + call mem_deallocate(this%ingnc) + call mem_deallocate(this%inmvr) + call mem_deallocate(this%inobs) + call mem_deallocate(this%inamedbound) + call mem_deallocate(this%satomega) + ! + ! -- return + return + end subroutine gwf_gwf_da + + subroutine allocate_arrays(this) +! ****************************************************************************** +! allocate_scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + use ConstantsModule, only: LENORIGIN + ! -- dummy + class(GwfExchangeType) :: this + ! -- local + character(len=LINELENGTH) :: text + character(len=LENORIGIN) :: origin + integer(I4B) :: ntabcol +! ------------------------------------------------------------------------------ + ! + ! -- create the origin name + origin = trim(this%name) + ! + ! -- Call parent type allocate_scalars + call this%NumericalExchangeType%allocate_arrays() + ! + call mem_allocate(this%ihc, this%nexg, 'IHC', origin) + call mem_allocate(this%cl1, this%nexg, 'CL1', origin) + call mem_allocate(this%cl2, this%nexg, 'CL2', origin) + call mem_allocate(this%hwva, this%nexg, 'HWVA', origin) + call mem_allocate(this%condsat, this%nexg, 'CONDSAT', origin) + ! + ! -- Allocate boundname + if(this%inamedbound==1) then + allocate(this%boundname(this%nexg)) + else + allocate(this%boundname(1)) + endif + this%boundname(:) = '' + ! + ! -- allocate and initialize the output table + if (this%iprflow /= 0) then + ! + ! -- dimension table + ntabcol = 3 + if (this%inamedbound > 0) then + ntabcol = ntabcol + 1 + end if + ! + ! -- initialize the output table objects + ! outouttab1 + call table_cr(this%outputtab1, this%name, ' ') + call this%outputtab1%table_df(this%nexg, ntabcol, this%gwfmodel1%iout, & + transient=.TRUE.) + text = 'NUMBER' + call this%outputtab1%initialize_column(text, 10, alignment=TABCENTER) + text = 'CELLID' + call this%outputtab1%initialize_column(text, 20, alignment=TABLEFT) + text = 'RATE' + call this%outputtab1%initialize_column(text, 15, alignment=TABCENTER) + if (this%inamedbound > 0) then + text = 'NAME' + call this%outputtab1%initialize_column(text, 20, alignment=TABLEFT) + end if + ! outouttab2 + call table_cr(this%outputtab2, this%name, ' ') + call this%outputtab2%table_df(this%nexg, ntabcol, this%gwfmodel2%iout, & + transient=.TRUE.) + text = 'NUMBER' + call this%outputtab2%initialize_column(text, 10, alignment=TABCENTER) + text = 'CELLID' + call this%outputtab2%initialize_column(text, 20, alignment=TABLEFT) + text = 'RATE' + call this%outputtab2%initialize_column(text, 15, alignment=TABCENTER) + if (this%inamedbound > 0) then + text = 'NAME' + call this%outputtab2%initialize_column(text, 20, alignment=TABLEFT) + end if + end if + ! + ! -- return + return + end subroutine allocate_arrays + + subroutine gwf_gwf_df_obs(this) +! ****************************************************************************** +! gwf_gwf_df_obs +! -- Store observation type supported by GWF-GWF exchange. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfExchangeType) :: this + ! -- local + integer(I4B) :: indx +! ------------------------------------------------------------------------------ + ! + ! -- Store obs type and assign procedure pointer + ! for gwf-gwf observation type. + call this%obs%StoreObsType('flow-ja-face', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => gwf_gwf_process_obsID + ! + ! -- return + return + end subroutine gwf_gwf_df_obs + + subroutine gwf_gwf_rp_obs(this) +! ****************************************************************************** +! gwf_gwf_rp_obs +! -- Handle observation IDs that are exchange-boundary names. +! Store exchange numbers included in observation. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DZERO + ! -- dummy + class(GwfExchangeType) :: this + ! -- local + integer(I4B) :: i, j, n + class(ObserveType), pointer :: obsrv => null() + character(len=LENBOUNDNAME) :: bname + character(len=1000) :: ermsg + logical :: jfound + ! -- formats +10 format('Error: Boundary "',a,'" for observation "',a, & + '" is invalid in package "',a,'"') +! ------------------------------------------------------------------------------ + ! + do i=1,this%obs%npakobs + obsrv => this%obs%pakobs(i)%obsrv + ! + ! -- indxbnds needs to be deallocated and reallocated (using + ! ExpandArray) each stress period because list of boundaries + ! can change each stress period. + ! -- Not true for exchanges, but leave this in for now anyway. + if (allocated(obsrv%indxbnds)) then + deallocate(obsrv%indxbnds) + endif + obsrv%BndFound = .false. + ! + bname = obsrv%FeatureName + if (bname /= '') then + ! -- Observation location(s) is(are) based on a boundary name. + ! Iterate through all boundaries to identify and store + ! corresponding index(indices) in bound array. + jfound = .false. + do j=1,this%nexg + if (this%boundname(j) == bname) then + jfound = .true. + obsrv%BndFound = .true. + obsrv%CurrentTimeStepEndValue = DZERO + call ExpandArray(obsrv%indxbnds) + n = size(obsrv%indxbnds) + obsrv%indxbnds(n) = j + endif + enddo + if (.not. jfound) then + write(ermsg,10)trim(bname) + call store_error(ermsg) + endif + else + ! -- Observation location is a single exchange number + if (obsrv%intPak1 <= this%nexg) then + jfound = .true. + obsrv%BndFound = .true. + obsrv%CurrentTimeStepEndValue = DZERO + call ExpandArray(obsrv%indxbnds) + n = size(obsrv%indxbnds) + obsrv%indxbnds(n) = obsrv%intPak1 + else + jfound = .false. + endif + endif + enddo + ! + if (count_errors() > 0) then + call store_error_unit(this%inobs) + call ustop() + endif + ! + ! -- Return + return + end subroutine gwf_gwf_rp_obs + + subroutine gwf_gwf_fp(this) +! ****************************************************************************** +! gwf_gwf_fp +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfExchangeType) :: this +! ------------------------------------------------------------------------------ + ! + return + end subroutine gwf_gwf_fp + + function qcalc(this, iexg, n1, n2) +! ****************************************************************************** +! qcalc -- calculate flow between two cells, positive into n1 +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + real(DP) :: qcalc + ! -- dummy + class(GwfExchangeType) :: this + integer(I4B), intent(in) :: iexg + integer(I4B), intent(in) :: n1 + integer(I4B), intent(in) :: n2 + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Calculate flow between nodes in the two models + qcalc = this%cond(iexg) * (this%m2%x(n2) - this%m1%x(n1)) + ! + ! -- return + return + end function qcalc + + function gwf_gwf_get_iasym(this) result (iasym) +! ****************************************************************************** +! gwf_gwf_get_iasym -- return 1 if any option causes the matrix to be asymmetric. +! Otherwise return 0. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfExchangeType) :: this + ! -- local + integer(I4B) :: iasym +! ------------------------------------------------------------------------------ + ! + ! -- Start by setting iasym to zero + iasym = 0 + ! + ! -- Groundwater flow + if (this%inewton /= 0) iasym = 1 + ! + ! -- GNC + if (this%ingnc > 0) then + if (this%gnc%iasym /= 0) iasym = 1 + endif + ! + ! -- return + return + end function gwf_gwf_get_iasym + + subroutine gwf_gwf_save_simvals(this) +! ****************************************************************************** +! gwf_gwf_save_simvals +! -- Calculate observations this time step and call +! ObsType%SaveOneSimval for each GWF-GWF Type observation. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + use SimModule, only: store_error, store_error_unit, ustop + use ConstantsModule, only: DZERO + use ObserveModule, only: ObserveType + class(GwfExchangeType), intent(inout) :: this + ! -- local + integer(I4B) :: i, j, n1, n2, nbndobs + integer(I4B) :: iexg + real(DP) :: v + character(len=100) :: msg + type(ObserveType), pointer :: obsrv => null() +! ------------------------------------------------------------------------------ + ! + ! -- Write simulated values for all gwf-gwf observations + if (this%obs%npakobs > 0) then + call this%obs%obs_bd_clear() + do i = 1, this%obs%npakobs + obsrv => this%obs%pakobs(i)%obsrv + nbndobs = size(obsrv%indxbnds) + do j = 1, nbndobs + iexg = obsrv%indxbnds(j) + v = DZERO + select case (obsrv%ObsTypeId) + case ('FLOW-JA-FACE') + n1 = this%nodem1(iexg) + n2 = this%nodem2(iexg) + v = this%cond(iexg) * (this%m2%x(n2) - this%m1%x(n1)) + if(this%ingnc > 0) then + v = v + this%gnc%deltaqgnc(iexg) + endif + case default + msg = 'Error: Unrecognized observation type: ' // & + trim(obsrv%ObsTypeId) + call store_error(msg) + call store_error_unit(this%inobs) + call ustop() + end select + call this%obs%SaveOneSimval(obsrv, v) + enddo + enddo + endif + ! + return + end subroutine gwf_gwf_save_simvals + + subroutine gwf_gwf_process_obsID(obsrv, dis, inunitobs, iout) +! ****************************************************************************** +! -- This procedure is pointed to by ObsDataType%ProcesssIdPtr. It processes +! the ID string of an observation definition for GWF-GWF-package observations +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use InputOutputModule, only: urword + use ObserveModule, only: ObserveType + use BaseDisModule, only: DisBaseType + ! -- dummy + type(ObserveType), intent(inout) :: obsrv + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: inunitobs + integer(I4B), intent(in) :: iout + ! -- local + integer(I4B) :: n, iexg, istat + integer(I4B) :: icol, istart, istop + real(DP) :: r + character(len=LINELENGTH) :: strng +! ------------------------------------------------------------------------------ + ! + strng = obsrv%IDstring + icol = 1 + ! -- get exchange index + call urword(strng, icol, istart, istop, 0, n, r, iout, inunitobs) + read (strng(istart:istop), '(i10)', iostat=istat) iexg + if (istat == 0) then + obsrv%intPak1 = iexg + else + ! Integer can't be read from strng; it's presumed to be an exchange + ! boundary name (already converted to uppercase) + obsrv%FeatureName = strng(istart:istop) + ! -- Observation may require summing rates from multiple exchange + ! boundaries, so assign intPak1 as a value that indicates observation + ! is for a named exchange boundary or group of exchange boundaries. + obsrv%intPak1 = NAMEDBOUNDFLAG + endif + ! + return + end subroutine gwf_gwf_process_obsID + +end module GwfGwfExchangeModule + diff --git a/src/Exchange/NumericalExchange.f90 b/src/Exchange/NumericalExchange.f90 index 50fdd256c19..028802a3ebb 100644 --- a/src/Exchange/NumericalExchange.f90 +++ b/src/Exchange/NumericalExchange.f90 @@ -1,655 +1,655 @@ -module NumericalExchangeModule - - use KindModule, only: DP, I4B - use BaseExchangeModule, only: BaseExchangeType - use NumericalModelModule, only: NumericalModelType - use BaseExchangeModule, only: BaseExchangeType, AddBaseExchangeToList - use ConstantsModule, only: LINELENGTH, DZERO - use ListModule, only: ListType - use BlockParserModule, only: BlockParserType - - implicit none - - private - public :: NumericalExchangeType, & - AddNumericalExchangeToList, GetNumericalExchangeFromList - - type, extends(BaseExchangeType) :: NumericalExchangeType - character(len=LINELENGTH), pointer :: filename => null() !name of the input file - character(len=7), pointer :: typename => null() !name of the type (e.g., 'NM-NM') - logical, pointer :: implicit => null() !logical flag to indicate implicit or explict exchange - integer(I4B), pointer :: iprpak => null() !print input flag - integer(I4B), pointer :: iprflow => null() !print flag for cell by cell flows - integer(I4B), pointer :: ipakcb => null() !save flag for cell by cell flows - integer(I4B), pointer :: nexg => null() !number of exchanges - integer(I4B), dimension(:), pointer, contiguous :: nodem1 => null() !node numbers in model 1 - integer(I4B), dimension(:), pointer, contiguous :: nodem2 => null() !node numbers in model 2 - real(DP), dimension(:), pointer, contiguous :: cond => null() !conductance - integer(I4B), dimension(:), pointer, contiguous :: idxglo => null() !pointer to solution amat for each connection - integer(I4B), dimension(:), pointer, contiguous :: idxsymglo => null() !pointer to symmetric amat position for each connection - class(NumericalModelType), pointer :: m1 => null() !pointer to model 1 - class(NumericalModelType), pointer :: m2 => null() !pointer to model 2 - integer(I4B), pointer :: naux => null() !number of auxiliary variables - character(len=16), allocatable, dimension(:) :: auxname !array of auxiliary variable names - real(DP), dimension(:, :), pointer, contiguous :: auxvar => null() !array of auxiliary variable values - type(BlockParserType) :: parser !block parser - contains - procedure :: exg_df - procedure :: exg_ac - procedure :: exg_mc - procedure :: exg_ar - !procedure :: exg_rp (not needed yet; base exg_rp does nothing) - procedure :: exg_ad - procedure :: exg_cf - procedure :: exg_fc - procedure :: exg_nr - procedure :: exg_cc - procedure :: exg_cq - procedure :: exg_bd - procedure :: exg_cnvg - procedure :: exg_ot - procedure :: exg_da - procedure :: allocate_scalars - procedure :: allocate_arrays - procedure :: read_options - procedure :: read_dimensions - procedure :: get_iasym - end type NumericalExchangeType - -contains - - subroutine exg_df(this) -! ****************************************************************************** -! exg_df -- define the exchange -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use BaseModelModule, only: BaseModelType - use InputOutputModule, only: getunit, openfile - ! -- dummy - class(NumericalExchangeType) :: this - ! -- local -! ------------------------------------------------------------------------------ - ! - ! - ! -- return - return - end subroutine exg_df - - subroutine exg_ac(this, sparse) -! ****************************************************************************** -! exg_ac -- If an implicit exchange then add connections to sparse -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SparseModule, only:sparsematrix - ! -- dummy - class(NumericalExchangeType) :: this - type(sparsematrix), intent(inout) :: sparse - ! -- local - integer(I4B) :: n, iglo, jglo -! ------------------------------------------------------------------------------ - ! - if(this%implicit) then - do n = 1, this%nexg - iglo = this%nodem1(n) + this%m1%moffset - jglo = this%nodem2(n) + this%m2%moffset - call sparse%addconnection(iglo, jglo, 1) - call sparse%addconnection(jglo, iglo, 1) - enddo - endif - ! - ! -- return - return - end subroutine exg_ac - - subroutine exg_mc(this, iasln, jasln) -! ****************************************************************************** -! exg_mc -- Map the connections in the global matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- module - use SparseModule, only:sparsematrix - ! -- dummy - class(NumericalExchangeType) :: this - integer(I4B), dimension(:), intent(in) :: iasln - integer(I4B), dimension(:), intent(in) :: jasln - ! -- local - integer(I4B) :: n, iglo, jglo, ipos -! ------------------------------------------------------------------------------ - ! - if(this%implicit) then - do n = 1, this%nexg - iglo = this%nodem1(n)+this%m1%moffset - jglo = this%nodem2(n)+this%m2%moffset - ! -- find jglobal value in row iglo and store in idxglo - do ipos = iasln(iglo), iasln(iglo + 1) - 1 - if(jglo == jasln(ipos)) then - this%idxglo(n) = ipos - exit - endif - enddo - ! -- find and store symmetric location - do ipos = iasln(jglo), iasln(jglo + 1) - 1 - if(iglo == jasln(ipos)) then - this%idxsymglo(n) = ipos - exit - endif - enddo - enddo - endif - ! - ! -- Return - return - end subroutine exg_mc - - subroutine exg_ar(this) -! ****************************************************************************** -! exg_ar -- Allocate and read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(NumericalExchangeType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- return - return - end subroutine exg_ar - - subroutine exg_ad(this, isolnid, kpicard, isubtime) -! ****************************************************************************** -! exg_ad -- Advance -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(NumericalExchangeType) :: this - integer(I4B), intent(in) :: isolnid - integer(I4B), intent(in) :: kpicard - integer(I4B), intent(in) :: isubtime - ! -- local -! ------------------------------------------------------------------------------ - ! - ! - ! -- return - return - end subroutine exg_ad - - subroutine exg_cf(this, kiter) -! ****************************************************************************** -! exg_cf -- Calculate conductance, and for explicit exchanges, set the -! conductance in the boundary package. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(NumericalExchangeType) :: this - integer(I4B),intent(in) :: kiter - ! -- local -! ------------------------------------------------------------------------------ - ! - ! - ! -- return - return - end subroutine exg_cf - - subroutine exg_fc(this, kiter, iasln, amatsln, inwtflag) -! ****************************************************************************** -! exg_fc -- Fill the matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(NumericalExchangeType) :: this - integer(I4B), intent(in) :: kiter - integer(I4B), dimension(:), intent(in) :: iasln - real(DP), dimension(:), intent(inout) :: amatsln - integer(I4B), optional, intent(in) :: inwtflag - ! -- local - integer(I4B) :: i, nodem1sln, nodem2sln, idiagsln -! ------------------------------------------------------------------------------ - ! - if(this%implicit) then - do i = 1, this%nexg - amatsln(this%idxglo(i)) = this%cond(i) - amatsln(this%idxsymglo(i)) = this%cond(i) - nodem1sln = this%nodem1(i) + this%m1%moffset - nodem2sln = this%nodem2(i) + this%m2%moffset - idiagsln = iasln(nodem1sln) - amatsln(idiagsln) = amatsln(idiagsln) - this%cond(i) - idiagsln = iasln(nodem2sln) - amatsln(idiagsln) = amatsln(idiagsln) - this%cond(i) - enddo - else - ! -- nothing to do here - endif - ! - ! -- return - return - end subroutine exg_fc - - subroutine exg_nr(this, kiter, iasln, amatsln, inwtflag) -! ****************************************************************************** -! exg_nr -- Add Newton-Raphson terms to the solution -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(NumericalExchangeType) :: this - integer(I4B), intent(in) :: kiter - integer(I4B), dimension(:), intent(in) :: iasln - real(DP), dimension(:), intent(inout) :: amatsln - integer(I4B), optional, intent(in) :: inwtflag - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- return - return - end subroutine exg_nr - - subroutine exg_cc(this, icnvg) -! ****************************************************************************** -! exg_cc -- Additional convergence check -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(NumericalExchangeType) :: this - integer(I4B), intent(inout) :: icnvg - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- return - return - end subroutine exg_cc - - subroutine exg_cq(this, icnvg, isuppress_output, isolnid) -! ****************************************************************************** -! exg_cq -- Calculate flow -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LENBUDTXT - ! -- dummy - class(NumericalExchangeType) :: this - integer(I4B), intent(inout) :: icnvg - integer(I4B), intent(in) :: isuppress_output - integer(I4B), intent(in) :: isolnid - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- return - return - end subroutine exg_cq - - subroutine exg_bd(this, icnvg, isuppress_output, isolnid) -! ****************************************************************************** -! exg_bd -- Exchange budget -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LENBUDTXT - ! -- dummy - class(NumericalExchangeType) :: this - integer(I4B), intent(inout) :: icnvg - integer(I4B), intent(in) :: isuppress_output - integer(I4B), intent(in) :: isolnid - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- return - return - end subroutine exg_bd - - subroutine exg_cnvg(this, isolnid, icnvg) -! ****************************************************************************** -! exg_cnvg -- Check for convergence for explicit exchange -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DZERO - ! -- dummy - class(NumericalExchangeType) :: this - integer(I4B), intent(in) :: isolnid - integer(I4B), intent(inout) :: icnvg - ! -- local -! ------------------------------------------------------------------------------ - ! - ! - ! -- return - return - end subroutine exg_cnvg - - subroutine exg_ot(this) -! ****************************************************************************** -! exg_ot -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimVariablesModule, only: iout - ! -- dummy - class(NumericalExchangeType) :: this - ! -- local - integer(I4B) :: iexg, n1, n2 - real(DP) :: flow - character(len=LINELENGTH) :: node1str, node2str - ! -- format - character(len=*), parameter :: fmtheader = & - "(/1x, 'SUMMARY OF EXCHANGE RATES FOR EXCHANGE ', a, ' WITH ID ', i0, /, & - &2a16, 4a16, /, 96('-'))" - character(len=*), parameter :: fmtdata = & - "(2a16, 4(1pg16.6))" -! ------------------------------------------------------------------------------ - ! - ! -- Write a table of exchanges - if(this%iprflow /= 0) then - write(iout, fmtheader) trim(adjustl(this%name)), this%id, 'NODEM1', & - 'NODEM2', 'COND', 'X_M1', 'X_M2', 'FLOW' - do iexg = 1, this%nexg - n1 = this%nodem1(iexg) - n2 = this%nodem2(iexg) - flow = this%cond(iexg) * (this%m2%x(n2) - this%m1%x(n1)) - call this%m1%dis%noder_to_string(n1, node1str) - call this%m2%dis%noder_to_string(n2, node2str) - write(iout, fmtdata) trim(adjustl(node1str)), trim(adjustl(node2str)), & - this%cond(iexg), this%m1%x(n1), this%m2%x(n2), & - flow - enddo - endif - ! - ! -- return - return - end subroutine exg_ot - - subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - use ConstantsModule, only: LENORIGIN - ! -- dummy - class(NumericalExchangeType) :: this - ! -- local -! ------------------------------------------------------------------------------ - ! - allocate(this%filename) - allocate(this%typename) - call mem_allocate(this%implicit, 'IMPLICIT', this%name) - call mem_allocate(this%iprpak, 'IPRPAK', this%name) - call mem_allocate(this%iprflow, 'IPRFLOW', this%name) - call mem_allocate(this%ipakcb, 'IPAKCB', this%name) - call mem_allocate(this%nexg, 'NEXG', this%name) - call mem_allocate(this%naux, 'NAUX', this%name) - allocate(this%auxname(0)) - this%filename = '' - this%typename = '' - this%implicit = .false. - this%iprpak = 0 - this%iprflow = 0 - this%ipakcb = 0 - this%nexg = 0 - this%naux = 0 - ! - ! -- return - return - end subroutine allocate_scalars - - subroutine allocate_arrays(this) -! ****************************************************************************** -! allocate_arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - use ConstantsModule, only: LENORIGIN - ! -- dummy - class(NumericalExchangeType) :: this - ! -- local - character(len=LENORIGIN) :: origin -! ------------------------------------------------------------------------------ - ! - ! -- create the origin name - origin = trim(this%name) - ! - call mem_allocate(this%nodem1, this%nexg, 'NODEM1', origin) - call mem_allocate(this%nodem2, this%nexg, 'NODEM2', origin) - call mem_allocate(this%cond, this%nexg, 'COND', origin) - call mem_allocate(this%idxglo, this%nexg, 'IDXGLO', origin) - call mem_allocate(this%idxsymglo, this%nexg, 'IDXSYMGLO', origin) - call mem_allocate(this%auxvar, this%naux, this%nexg, 'AUXVAR', origin) - ! - ! -- return - return - end subroutine allocate_arrays - - subroutine exg_da(this) -! ****************************************************************************** -! exg_da -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - use ConstantsModule, only: LENORIGIN - ! -- dummy - class(NumericalExchangeType) :: this - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- scalars - deallocate(this%filename) - deallocate(this%typename) - call mem_deallocate(this%implicit) - call mem_deallocate(this%iprpak) - call mem_deallocate(this%iprflow) - call mem_deallocate(this%ipakcb) - call mem_deallocate(this%nexg) - call mem_deallocate(this%naux) - deallocate(this%auxname) - ! - ! -- arrays - call mem_deallocate(this%nodem1) - call mem_deallocate(this%nodem2) - call mem_deallocate(this%cond) - call mem_deallocate(this%idxglo) - call mem_deallocate(this%idxsymglo) - call mem_deallocate(this%auxvar) - ! - ! -- return - return - end subroutine exg_da - - subroutine read_options(this, iout) -! ****************************************************************************** -! read_options -- Read Options -! Subroutine: (1) read options from input file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error, ustop - use InputOutputModule, only: urdaux - use ArrayHandlersModule, only: expandarray - ! -- dummy - class(NumericalExchangeType) :: this - integer(I4B), intent(in) :: iout - ! -- local - character(len=LINELENGTH) :: line, errmsg, keyword - integer(I4B) :: istart,istop,lloc,ierr - logical :: isfound, endOfBlock -! ------------------------------------------------------------------------------ - ! - ! -- get options block - call this%parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) - ! - ! -- parse options block if detected - if (isfound) then - write(iout,'(1x,a)')'PROCESSING EXCHANGE OPTIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case('AUX', 'AUXILIARY') - call this%parser%GetRemainingLine(line) - lloc = 1 - call urdaux(this%naux, this%parser%iuactive, iout, lloc, istart, & - istop, this%auxname, line, 'NM_NM_Exchange') - case ('PRINT_INPUT') - this%iprpak = 1 - write(iout,'(4x,a)') & - 'THE LIST OF EXCHANGES WILL BE PRINTED.' - case ('PRINT_FLOWS') - this%iprflow = 1 - write(iout,'(4x,a)') & - 'EXCHANGE FLOWS WILL BE PRINTED TO LIST FILES.' - case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN EXCHANGE OPTION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - end do - write(iout,'(1x,a)')'END OF EXCHANGE OPTIONS' - end if - ! - ! -- return - return - end subroutine read_options - - subroutine read_dimensions(this, iout) -! ****************************************************************************** -! read_dimensions -- Read Dimensions -! Subroutine: (1) read dimensions (size of exchange list) from input file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error, ustop - implicit none - ! -- dummy - class(NumericalExchangeType) :: this - integer(I4B), intent(in) :: iout - ! -- local - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock -! ------------------------------------------------------------------------------ - ! - ! -- get options block - call this%parser%GetBlock('DIMENSIONS', isfound, ierr, & - supportOpenClose=.true.) - ! - ! -- parse options block if detected - if (isfound) then - write(iout,'(1x,a)')'PROCESSING EXCHANGE DIMENSIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('NEXG') - this%nexg = this%parser%GetInteger() - write(iout,'(4x,a,i7)')'NEXG = ', this%nexg - case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN DIMENSION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - end do - write(iout,'(1x,a)')'END OF EXCHANGE DIMENSIONS' - else - call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- return - return - end subroutine read_dimensions - - function get_iasym(this) result (iasym) - class(NumericalExchangeType) :: this - integer(I4B) :: iasym - iasym = 0 - end function get_iasym - - function CastAsNumericalExchangeClass(obj) result (res) - implicit none - class(*), pointer, intent(inout) :: obj - class(NumericalExchangeType), pointer :: res - ! - res => null() - if (.not. associated(obj)) return - ! - select type (obj) - class is (NumericalExchangeType) - res => obj - end select - return - end function CastAsNumericalExchangeClass - - subroutine AddNumericalExchangeToList(list, exchange) - implicit none - ! -- dummy - type(ListType), intent(inout) :: list - class(NumericalExchangeType), pointer, intent(in) :: exchange - ! -- local - class(*), pointer :: obj - ! - obj => exchange - call list%Add(obj) - ! - return - end subroutine AddNumericalExchangeToList - - function GetNumericalExchangeFromList(list, idx) result (res) - implicit none - ! -- dummy - type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx - class(NumericalExchangeType), pointer :: res - ! -- local - class(*), pointer :: obj - ! - obj => list%GetItem(idx) - res => CastAsNumericalExchangeClass(obj) - ! - return - end function GetNumericalExchangeFromList - -end module NumericalExchangeModule +module NumericalExchangeModule + + use KindModule, only: DP, I4B + use BaseExchangeModule, only: BaseExchangeType + use NumericalModelModule, only: NumericalModelType + use BaseExchangeModule, only: BaseExchangeType, AddBaseExchangeToList + use ConstantsModule, only: LINELENGTH, DZERO + use ListModule, only: ListType + use BlockParserModule, only: BlockParserType + + implicit none + + private + public :: NumericalExchangeType, & + AddNumericalExchangeToList, GetNumericalExchangeFromList + + type, extends(BaseExchangeType) :: NumericalExchangeType + character(len=LINELENGTH), pointer :: filename => null() !name of the input file + character(len=7), pointer :: typename => null() !name of the type (e.g., 'NM-NM') + logical, pointer :: implicit => null() !logical flag to indicate implicit or explict exchange + integer(I4B), pointer :: iprpak => null() !print input flag + integer(I4B), pointer :: iprflow => null() !print flag for cell by cell flows + integer(I4B), pointer :: ipakcb => null() !save flag for cell by cell flows + integer(I4B), pointer :: nexg => null() !number of exchanges + integer(I4B), dimension(:), pointer, contiguous :: nodem1 => null() !node numbers in model 1 + integer(I4B), dimension(:), pointer, contiguous :: nodem2 => null() !node numbers in model 2 + real(DP), dimension(:), pointer, contiguous :: cond => null() !conductance + integer(I4B), dimension(:), pointer, contiguous :: idxglo => null() !pointer to solution amat for each connection + integer(I4B), dimension(:), pointer, contiguous :: idxsymglo => null() !pointer to symmetric amat position for each connection + class(NumericalModelType), pointer :: m1 => null() !pointer to model 1 + class(NumericalModelType), pointer :: m2 => null() !pointer to model 2 + integer(I4B), pointer :: naux => null() !number of auxiliary variables + character(len=16), allocatable, dimension(:) :: auxname !array of auxiliary variable names + real(DP), dimension(:, :), pointer, contiguous :: auxvar => null() !array of auxiliary variable values + type(BlockParserType) :: parser !block parser + contains + procedure :: exg_df + procedure :: exg_ac + procedure :: exg_mc + procedure :: exg_ar + !procedure :: exg_rp (not needed yet; base exg_rp does nothing) + procedure :: exg_ad + procedure :: exg_cf + procedure :: exg_fc + procedure :: exg_nr + procedure :: exg_cc + procedure :: exg_cq + procedure :: exg_bd + procedure :: exg_cnvg + procedure :: exg_ot + procedure :: exg_da + procedure :: allocate_scalars + procedure :: allocate_arrays + procedure :: read_options + procedure :: read_dimensions + procedure :: get_iasym + end type NumericalExchangeType + +contains + + subroutine exg_df(this) +! ****************************************************************************** +! exg_df -- define the exchange +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use BaseModelModule, only: BaseModelType + use InputOutputModule, only: getunit, openfile + ! -- dummy + class(NumericalExchangeType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! + ! -- return + return + end subroutine exg_df + + subroutine exg_ac(this, sparse) +! ****************************************************************************** +! exg_ac -- If an implicit exchange then add connections to sparse +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SparseModule, only:sparsematrix + ! -- dummy + class(NumericalExchangeType) :: this + type(sparsematrix), intent(inout) :: sparse + ! -- local + integer(I4B) :: n, iglo, jglo +! ------------------------------------------------------------------------------ + ! + if(this%implicit) then + do n = 1, this%nexg + iglo = this%nodem1(n) + this%m1%moffset + jglo = this%nodem2(n) + this%m2%moffset + call sparse%addconnection(iglo, jglo, 1) + call sparse%addconnection(jglo, iglo, 1) + enddo + endif + ! + ! -- return + return + end subroutine exg_ac + + subroutine exg_mc(this, iasln, jasln) +! ****************************************************************************** +! exg_mc -- Map the connections in the global matrix +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- module + use SparseModule, only:sparsematrix + ! -- dummy + class(NumericalExchangeType) :: this + integer(I4B), dimension(:), intent(in) :: iasln + integer(I4B), dimension(:), intent(in) :: jasln + ! -- local + integer(I4B) :: n, iglo, jglo, ipos +! ------------------------------------------------------------------------------ + ! + if(this%implicit) then + do n = 1, this%nexg + iglo = this%nodem1(n)+this%m1%moffset + jglo = this%nodem2(n)+this%m2%moffset + ! -- find jglobal value in row iglo and store in idxglo + do ipos = iasln(iglo), iasln(iglo + 1) - 1 + if(jglo == jasln(ipos)) then + this%idxglo(n) = ipos + exit + endif + enddo + ! -- find and store symmetric location + do ipos = iasln(jglo), iasln(jglo + 1) - 1 + if(iglo == jasln(ipos)) then + this%idxsymglo(n) = ipos + exit + endif + enddo + enddo + endif + ! + ! -- Return + return + end subroutine exg_mc + + subroutine exg_ar(this) +! ****************************************************************************** +! exg_ar -- Allocate and read +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(NumericalExchangeType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- return + return + end subroutine exg_ar + + subroutine exg_ad(this, isolnid, kpicard, isubtime) +! ****************************************************************************** +! exg_ad -- Advance +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(NumericalExchangeType) :: this + integer(I4B), intent(in) :: isolnid + integer(I4B), intent(in) :: kpicard + integer(I4B), intent(in) :: isubtime + ! -- local +! ------------------------------------------------------------------------------ + ! + ! + ! -- return + return + end subroutine exg_ad + + subroutine exg_cf(this, kiter) +! ****************************************************************************** +! exg_cf -- Calculate conductance, and for explicit exchanges, set the +! conductance in the boundary package. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(NumericalExchangeType) :: this + integer(I4B),intent(in) :: kiter + ! -- local +! ------------------------------------------------------------------------------ + ! + ! + ! -- return + return + end subroutine exg_cf + + subroutine exg_fc(this, kiter, iasln, amatsln, inwtflag) +! ****************************************************************************** +! exg_fc -- Fill the matrix +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(NumericalExchangeType) :: this + integer(I4B), intent(in) :: kiter + integer(I4B), dimension(:), intent(in) :: iasln + real(DP), dimension(:), intent(inout) :: amatsln + integer(I4B), optional, intent(in) :: inwtflag + ! -- local + integer(I4B) :: i, nodem1sln, nodem2sln, idiagsln +! ------------------------------------------------------------------------------ + ! + if(this%implicit) then + do i = 1, this%nexg + amatsln(this%idxglo(i)) = this%cond(i) + amatsln(this%idxsymglo(i)) = this%cond(i) + nodem1sln = this%nodem1(i) + this%m1%moffset + nodem2sln = this%nodem2(i) + this%m2%moffset + idiagsln = iasln(nodem1sln) + amatsln(idiagsln) = amatsln(idiagsln) - this%cond(i) + idiagsln = iasln(nodem2sln) + amatsln(idiagsln) = amatsln(idiagsln) - this%cond(i) + enddo + else + ! -- nothing to do here + endif + ! + ! -- return + return + end subroutine exg_fc + + subroutine exg_nr(this, kiter, iasln, amatsln, inwtflag) +! ****************************************************************************** +! exg_nr -- Add Newton-Raphson terms to the solution +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(NumericalExchangeType) :: this + integer(I4B), intent(in) :: kiter + integer(I4B), dimension(:), intent(in) :: iasln + real(DP), dimension(:), intent(inout) :: amatsln + integer(I4B), optional, intent(in) :: inwtflag + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- return + return + end subroutine exg_nr + + subroutine exg_cc(this, icnvg) +! ****************************************************************************** +! exg_cc -- Additional convergence check +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(NumericalExchangeType) :: this + integer(I4B), intent(inout) :: icnvg + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- return + return + end subroutine exg_cc + + subroutine exg_cq(this, icnvg, isuppress_output, isolnid) +! ****************************************************************************** +! exg_cq -- Calculate flow +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LENBUDTXT + ! -- dummy + class(NumericalExchangeType) :: this + integer(I4B), intent(inout) :: icnvg + integer(I4B), intent(in) :: isuppress_output + integer(I4B), intent(in) :: isolnid + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- return + return + end subroutine exg_cq + + subroutine exg_bd(this, icnvg, isuppress_output, isolnid) +! ****************************************************************************** +! exg_bd -- Exchange budget +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LENBUDTXT + ! -- dummy + class(NumericalExchangeType) :: this + integer(I4B), intent(inout) :: icnvg + integer(I4B), intent(in) :: isuppress_output + integer(I4B), intent(in) :: isolnid + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- return + return + end subroutine exg_bd + + subroutine exg_cnvg(this, isolnid, icnvg) +! ****************************************************************************** +! exg_cnvg -- Check for convergence for explicit exchange +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DZERO + ! -- dummy + class(NumericalExchangeType) :: this + integer(I4B), intent(in) :: isolnid + integer(I4B), intent(inout) :: icnvg + ! -- local +! ------------------------------------------------------------------------------ + ! + ! + ! -- return + return + end subroutine exg_cnvg + + subroutine exg_ot(this) +! ****************************************************************************** +! exg_ot +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimVariablesModule, only: iout + ! -- dummy + class(NumericalExchangeType) :: this + ! -- local + integer(I4B) :: iexg, n1, n2 + real(DP) :: flow + character(len=LINELENGTH) :: node1str, node2str + ! -- format + character(len=*), parameter :: fmtheader = & + "(/1x, 'SUMMARY OF EXCHANGE RATES FOR EXCHANGE ', a, ' WITH ID ', i0, /, & + &2a16, 4a16, /, 96('-'))" + character(len=*), parameter :: fmtdata = & + "(2a16, 4(1pg16.6))" +! ------------------------------------------------------------------------------ + ! + ! -- Write a table of exchanges + if(this%iprflow /= 0) then + write(iout, fmtheader) trim(adjustl(this%name)), this%id, 'NODEM1', & + 'NODEM2', 'COND', 'X_M1', 'X_M2', 'FLOW' + do iexg = 1, this%nexg + n1 = this%nodem1(iexg) + n2 = this%nodem2(iexg) + flow = this%cond(iexg) * (this%m2%x(n2) - this%m1%x(n1)) + call this%m1%dis%noder_to_string(n1, node1str) + call this%m2%dis%noder_to_string(n2, node2str) + write(iout, fmtdata) trim(adjustl(node1str)), trim(adjustl(node2str)), & + this%cond(iexg), this%m1%x(n1), this%m2%x(n2), & + flow + enddo + endif + ! + ! -- return + return + end subroutine exg_ot + + subroutine allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + use ConstantsModule, only: LENORIGIN + ! -- dummy + class(NumericalExchangeType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + allocate(this%filename) + allocate(this%typename) + call mem_allocate(this%implicit, 'IMPLICIT', this%name) + call mem_allocate(this%iprpak, 'IPRPAK', this%name) + call mem_allocate(this%iprflow, 'IPRFLOW', this%name) + call mem_allocate(this%ipakcb, 'IPAKCB', this%name) + call mem_allocate(this%nexg, 'NEXG', this%name) + call mem_allocate(this%naux, 'NAUX', this%name) + allocate(this%auxname(0)) + this%filename = '' + this%typename = '' + this%implicit = .false. + this%iprpak = 0 + this%iprflow = 0 + this%ipakcb = 0 + this%nexg = 0 + this%naux = 0 + ! + ! -- return + return + end subroutine allocate_scalars + + subroutine allocate_arrays(this) +! ****************************************************************************** +! allocate_arrays +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + use ConstantsModule, only: LENORIGIN + ! -- dummy + class(NumericalExchangeType) :: this + ! -- local + character(len=LENORIGIN) :: origin +! ------------------------------------------------------------------------------ + ! + ! -- create the origin name + origin = trim(this%name) + ! + call mem_allocate(this%nodem1, this%nexg, 'NODEM1', origin) + call mem_allocate(this%nodem2, this%nexg, 'NODEM2', origin) + call mem_allocate(this%cond, this%nexg, 'COND', origin) + call mem_allocate(this%idxglo, this%nexg, 'IDXGLO', origin) + call mem_allocate(this%idxsymglo, this%nexg, 'IDXSYMGLO', origin) + call mem_allocate(this%auxvar, this%naux, this%nexg, 'AUXVAR', origin) + ! + ! -- return + return + end subroutine allocate_arrays + + subroutine exg_da(this) +! ****************************************************************************** +! exg_da +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + use ConstantsModule, only: LENORIGIN + ! -- dummy + class(NumericalExchangeType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- scalars + deallocate(this%filename) + deallocate(this%typename) + call mem_deallocate(this%implicit) + call mem_deallocate(this%iprpak) + call mem_deallocate(this%iprflow) + call mem_deallocate(this%ipakcb) + call mem_deallocate(this%nexg) + call mem_deallocate(this%naux) + deallocate(this%auxname) + ! + ! -- arrays + call mem_deallocate(this%nodem1) + call mem_deallocate(this%nodem2) + call mem_deallocate(this%cond) + call mem_deallocate(this%idxglo) + call mem_deallocate(this%idxsymglo) + call mem_deallocate(this%auxvar) + ! + ! -- return + return + end subroutine exg_da + + subroutine read_options(this, iout) +! ****************************************************************************** +! read_options -- Read Options +! Subroutine: (1) read options from input file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error, ustop + use InputOutputModule, only: urdaux + use ArrayHandlersModule, only: expandarray + ! -- dummy + class(NumericalExchangeType) :: this + integer(I4B), intent(in) :: iout + ! -- local + character(len=LINELENGTH) :: line, errmsg, keyword + integer(I4B) :: istart,istop,lloc,ierr + logical :: isfound, endOfBlock +! ------------------------------------------------------------------------------ + ! + ! -- get options block + call this%parser%GetBlock('OPTIONS', isfound, ierr, & + supportOpenClose=.true., blockRequired=.false.) + ! + ! -- parse options block if detected + if (isfound) then + write(iout,'(1x,a)')'PROCESSING EXCHANGE OPTIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case('AUX', 'AUXILIARY') + call this%parser%GetRemainingLine(line) + lloc = 1 + call urdaux(this%naux, this%parser%iuactive, iout, lloc, istart, & + istop, this%auxname, line, 'NM_NM_Exchange') + case ('PRINT_INPUT') + this%iprpak = 1 + write(iout,'(4x,a)') & + 'THE LIST OF EXCHANGES WILL BE PRINTED.' + case ('PRINT_FLOWS') + this%iprflow = 1 + write(iout,'(4x,a)') & + 'EXCHANGE FLOWS WILL BE PRINTED TO LIST FILES.' + case default + write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN EXCHANGE OPTION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + end do + write(iout,'(1x,a)')'END OF EXCHANGE OPTIONS' + end if + ! + ! -- return + return + end subroutine read_options + + subroutine read_dimensions(this, iout) +! ****************************************************************************** +! read_dimensions -- Read Dimensions +! Subroutine: (1) read dimensions (size of exchange list) from input file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error, ustop + implicit none + ! -- dummy + class(NumericalExchangeType) :: this + integer(I4B), intent(in) :: iout + ! -- local + character(len=LINELENGTH) :: errmsg, keyword + integer(I4B) :: ierr + logical :: isfound, endOfBlock +! ------------------------------------------------------------------------------ + ! + ! -- get options block + call this%parser%GetBlock('DIMENSIONS', isfound, ierr, & + supportOpenClose=.true.) + ! + ! -- parse options block if detected + if (isfound) then + write(iout,'(1x,a)')'PROCESSING EXCHANGE DIMENSIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('NEXG') + this%nexg = this%parser%GetInteger() + write(iout,'(4x,a,i7)')'NEXG = ', this%nexg + case default + write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN DIMENSION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + end do + write(iout,'(1x,a)')'END OF EXCHANGE DIMENSIONS' + else + call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- return + return + end subroutine read_dimensions + + function get_iasym(this) result (iasym) + class(NumericalExchangeType) :: this + integer(I4B) :: iasym + iasym = 0 + end function get_iasym + + function CastAsNumericalExchangeClass(obj) result (res) + implicit none + class(*), pointer, intent(inout) :: obj + class(NumericalExchangeType), pointer :: res + ! + res => null() + if (.not. associated(obj)) return + ! + select type (obj) + class is (NumericalExchangeType) + res => obj + end select + return + end function CastAsNumericalExchangeClass + + subroutine AddNumericalExchangeToList(list, exchange) + implicit none + ! -- dummy + type(ListType), intent(inout) :: list + class(NumericalExchangeType), pointer, intent(in) :: exchange + ! -- local + class(*), pointer :: obj + ! + obj => exchange + call list%Add(obj) + ! + return + end subroutine AddNumericalExchangeToList + + function GetNumericalExchangeFromList(list, idx) result (res) + implicit none + ! -- dummy + type(ListType), intent(inout) :: list + integer(I4B), intent(in) :: idx + class(NumericalExchangeType), pointer :: res + ! -- local + class(*), pointer :: obj + ! + obj => list%GetItem(idx) + res => CastAsNumericalExchangeClass(obj) + ! + return + end function GetNumericalExchangeFromList + +end module NumericalExchangeModule diff --git a/src/Model/BaseModel.f90 b/src/Model/BaseModel.f90 index 42ac1b4745b..3ec5c429c07 100644 --- a/src/Model/BaseModel.f90 +++ b/src/Model/BaseModel.f90 @@ -12,7 +12,7 @@ module BaseModelModule GetBaseModelFromList type :: BaseModelType - character(len=LENMODELNAME), pointer :: name => null() ! name of the model + character(len=LENMODELNAME), pointer :: name => null() ! name of the model character(len=3), pointer :: macronym => null() ! 3 letter model acronym (GWF, GWT, ...) integer(I4B), pointer :: idsoln => null() ! id of the solution model is in integer(I4B), pointer :: id => null() ! model id @@ -129,13 +129,13 @@ subroutine allocate_scalars(this, modelname) call mem_allocate(this%ipakcb, 'IPAKCB', modelname) call mem_allocate(this%idsoln, 'IDSOLN', modelname) ! - this%name = modelname + this%name = modelname this%macronym = '' this%idsoln = 0 this%id = 0 - this%iout = 0 - this%iprpak = 0 - this%iprflow = 0 + this%iout = 0 + this%iprpak = 0 + this%iprflow = 0 this%ipakcb = 0 this%inewton = 0 !default is standard formulation this%single_model_run = .false. @@ -165,7 +165,7 @@ subroutine model_da(this) deallocate(this%single_model_run) call mem_deallocate(this%id) call mem_deallocate(this%iout) - call mem_deallocate(this%inewton) + call mem_deallocate(this%inewton) call mem_deallocate(this%iprpak) call mem_deallocate(this%iprflow) call mem_deallocate(this%ipakcb) diff --git a/src/Model/Geometry/BaseGeometry.f90 b/src/Model/Geometry/BaseGeometry.f90 index b02a0e5f4f6..39bc2be3d4e 100644 --- a/src/Model/Geometry/BaseGeometry.f90 +++ b/src/Model/Geometry/BaseGeometry.f90 @@ -1,101 +1,101 @@ -module BaseGeometryModule - - use KindModule, only: DP, I4B - - implicit none - private - public BaseGeometryType - - integer(I4B), parameter :: GEONAMELEN = 20 - - type :: BaseGeometryType - character(len=20) :: geo_type = 'UNDEFINED' - integer(I4B) :: id = 0 - character(len=GEONAMELEN) :: name = '' - contains - procedure :: area_sat - procedure :: perimeter_sat - procedure :: area_wet - procedure :: perimeter_wet - procedure :: set_attribute - procedure :: print_attributes - end type BaseGeometryType - - contains - - function area_sat(this) - ! -- return - real(DP) :: area_sat - ! -- dummy - class(BaseGeometryType) :: this - area_sat = 0.d0 - ! -- return - return - end function area_sat - - function perimeter_sat(this) - ! -- return - real(DP) :: perimeter_sat - ! -- dummy - class(BaseGeometryType) :: this - perimeter_sat = 0.d0 - ! -- return - return - end function perimeter_sat - - function area_wet(this, depth) - ! -- return - real(DP) :: area_wet - ! -- dummy - class(BaseGeometryType) :: this - real(DP), intent(in) :: depth - area_wet = 0.d0 - ! -- return - return - end function area_wet - - function perimeter_wet(this, depth) - ! -- return - real(DP) :: perimeter_wet - ! -- dummy - class(BaseGeometryType) :: this - real(DP), intent(in) :: depth - perimeter_wet = 0.d0 - ! -- return - return - end function perimeter_wet - - subroutine set_attribute(this, line) - ! -- dummy - class(BaseGeometryType) :: this - character(len=*), intent(inout) :: line - ! -- return - return - end subroutine set_attribute - - subroutine print_attributes(this, iout) -! ****************************************************************************** -! print_attributes -- print the attributes for this object -! ***************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(BaseGeometryType) :: this - ! -- local - integer(I4B), intent(in) :: iout - ! -- formats - character(len=*), parameter :: fmtid = "(4x,a,i0)" - character(len=*), parameter :: fmtnm = "(4x,a,a)" -! ------------------------------------------------------------------------------ - ! - write(iout, fmtid) 'ID = ', this%id - write(iout, fmtnm) 'NAME = ', trim(adjustl(this%name)) - write(iout, fmtnm) 'GEOMETRY TYPE = ', trim(adjustl(this%geo_type)) - ! - ! -- return - return - end subroutine print_attributes - - +module BaseGeometryModule + + use KindModule, only: DP, I4B + + implicit none + private + public BaseGeometryType + + integer(I4B), parameter :: GEONAMELEN = 20 + + type :: BaseGeometryType + character(len=20) :: geo_type = 'UNDEFINED' + integer(I4B) :: id = 0 + character(len=GEONAMELEN) :: name = '' + contains + procedure :: area_sat + procedure :: perimeter_sat + procedure :: area_wet + procedure :: perimeter_wet + procedure :: set_attribute + procedure :: print_attributes + end type BaseGeometryType + + contains + + function area_sat(this) + ! -- return + real(DP) :: area_sat + ! -- dummy + class(BaseGeometryType) :: this + area_sat = 0.d0 + ! -- return + return + end function area_sat + + function perimeter_sat(this) + ! -- return + real(DP) :: perimeter_sat + ! -- dummy + class(BaseGeometryType) :: this + perimeter_sat = 0.d0 + ! -- return + return + end function perimeter_sat + + function area_wet(this, depth) + ! -- return + real(DP) :: area_wet + ! -- dummy + class(BaseGeometryType) :: this + real(DP), intent(in) :: depth + area_wet = 0.d0 + ! -- return + return + end function area_wet + + function perimeter_wet(this, depth) + ! -- return + real(DP) :: perimeter_wet + ! -- dummy + class(BaseGeometryType) :: this + real(DP), intent(in) :: depth + perimeter_wet = 0.d0 + ! -- return + return + end function perimeter_wet + + subroutine set_attribute(this, line) + ! -- dummy + class(BaseGeometryType) :: this + character(len=*), intent(inout) :: line + ! -- return + return + end subroutine set_attribute + + subroutine print_attributes(this, iout) +! ****************************************************************************** +! print_attributes -- print the attributes for this object +! ***************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BaseGeometryType) :: this + ! -- local + integer(I4B), intent(in) :: iout + ! -- formats + character(len=*), parameter :: fmtid = "(4x,a,i0)" + character(len=*), parameter :: fmtnm = "(4x,a,a)" +! ------------------------------------------------------------------------------ + ! + write(iout, fmtid) 'ID = ', this%id + write(iout, fmtnm) 'NAME = ', trim(adjustl(this%name)) + write(iout, fmtnm) 'GEOMETRY TYPE = ', trim(adjustl(this%geo_type)) + ! + ! -- return + return + end subroutine print_attributes + + end module BaseGeometryModule \ No newline at end of file diff --git a/src/Model/Geometry/CircularGeometry.f90 b/src/Model/Geometry/CircularGeometry.f90 index e1d6352b50b..2abafedd35c 100644 --- a/src/Model/Geometry/CircularGeometry.f90 +++ b/src/Model/Geometry/CircularGeometry.f90 @@ -1,211 +1,211 @@ -module CircularGeometryModule - use KindModule, only: DP, I4B - use BaseGeometryModule, only: BaseGeometryType - use ConstantsModule, only: DZERO - - implicit none - - private - public :: CircularGeometryType - - type, extends(BaseGeometryType) :: CircularGeometryType - real(DP) :: radius = DZERO - contains - procedure :: area_sat - procedure :: perimeter_sat - procedure :: area_wet - procedure :: perimeter_wet - procedure :: set_attribute - procedure :: print_attributes - end type CircularGeometryType - - contains - - function area_sat(this) -! ****************************************************************************** -! area_sat -- return area as if geometry is fully saturated -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DTWO, DPI - ! -- return - real(DP) :: area_sat - ! -- dummy - class(CircularGeometryType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Calculate area - area_sat = DPI * this%radius ** DTWO - ! - ! -- Return - return - end function area_sat - - function perimeter_sat(this) -! ****************************************************************************** -! perimeter_sat -- return perimeter as if geometry is fully saturated -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DTWO, DPI - ! -- return - real(DP) :: perimeter_sat - ! -- dummy - class(CircularGeometryType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Calculate area - perimeter_sat = DTWO * DPI * this%radius - ! - ! -- return - return - end function perimeter_sat - - function area_wet(this, depth) -! ****************************************************************************** -! area_wet -- return wetted area -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DTWO, DPI, DZERO - ! -- return - real(DP) :: area_wet - ! -- dummy - class(CircularGeometryType) :: this - real(DP), intent(in) :: depth -! ------------------------------------------------------------------------------ - ! - ! -- Calculate area - if(depth <= DZERO) then - area_wet = DZERO - elseif(depth <= this%radius) then - area_wet = this%radius * this%radius * & - acos((this%radius - depth) / this%radius) - & - (this%radius - depth) * sqrt(this%radius * this%radius - & - (this%radius - depth) ** DTWO) - elseif(depth <= DTWO * this%radius) then - area_wet = this%radius * this%radius * (DPI - acos((depth - this%radius) & - / this%radius)) - (this%radius - depth) * sqrt(this%radius * & - this%radius - (this%radius - depth) ** DTWO) - else - area_wet = DPI * this%radius * this%radius - endif - ! - ! -- Return - return - end function area_wet - - function perimeter_wet(this, depth) -! ****************************************************************************** -! perimeter_wet -- return wetted perimeter -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DTWO, DPI - ! -- return - real(DP) :: perimeter_wet - ! -- dummy - class(CircularGeometryType) :: this - real(DP), intent(in) :: depth -! ------------------------------------------------------------------------------ - ! - ! -- Calculate area - if(depth <= DZERO) then - perimeter_wet = DZERO - elseif(depth <= this%radius) then - perimeter_wet = DTWO * this%radius * acos((this%radius - depth) / & - this%radius) - elseif(depth <= DTWO * this%radius) then - perimeter_wet = DTWO * this%radius * (DPI - acos((depth - this%radius) / & - this%radius)) - else - perimeter_wet = DTWO * DPI * this%radius - endif - ! - ! -- return - return - end function perimeter_wet - - subroutine set_attribute(this, line) -! ****************************************************************************** -! set_attribute -- set a parameter for this circular object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- module - use InputOutputModule, only: urword - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors - ! -- dummy - class(CircularGeometryType) :: this - character(len=LINELENGTH) :: errmsg - character(len=*), intent(inout) :: line - ! -- local - integer(I4B) :: lloc, istart, istop, ival - real(DP) :: rval -! ------------------------------------------------------------------------------ - ! - ! -- should change this and set id if uninitialized or store it - lloc=1 - call urword(line, lloc, istart, istop, 2, ival, rval, 0, 0) - this%id = ival - - ! -- Parse the attribute - call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) - select case(line(istart:istop)) - case('NAME') - call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) - this%name = line(istart:istop) - case('RADIUS') - call urword(line, lloc, istart, istop, 3, ival, rval, 0, 0) - this%radius = rval - case default - write(errmsg,'(4x,a,a)') & - '****ERROR. UNKNOWN CIRCULAR GEOMETRY ATTRIBUTE: ', & - line(istart:istop) - call store_error(errmsg) - call ustop() - end select - ! - ! -- return - return - end subroutine set_attribute - - subroutine print_attributes(this, iout) -! ****************************************************************************** -! print_attributes -- print the attributes for this object -! ***************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(CircularGeometryType) :: this - ! -- local - integer(I4B), intent(in) :: iout - ! -- formats - character(len=*), parameter :: fmtnm = "(4x,a,a)" - character(len=*), parameter :: fmttd = "(4x,a,1(1PG15.6))" -! ------------------------------------------------------------------------------ - ! - ! -- call parent to print parent attributes - call this%BaseGeometryType%print_attributes(iout) - ! - ! -- Print specifics of this geometry type - write(iout, fmttd) 'RADIUS = ', this%radius - write(iout, fmttd) 'SATURATED AREA = ', this%area_sat() - write(iout, fmttd) 'SATURATED WETTED PERIMETER = ', this%perimeter_sat() - ! - ! -- return - return - end subroutine print_attributes - +module CircularGeometryModule + use KindModule, only: DP, I4B + use BaseGeometryModule, only: BaseGeometryType + use ConstantsModule, only: DZERO + + implicit none + + private + public :: CircularGeometryType + + type, extends(BaseGeometryType) :: CircularGeometryType + real(DP) :: radius = DZERO + contains + procedure :: area_sat + procedure :: perimeter_sat + procedure :: area_wet + procedure :: perimeter_wet + procedure :: set_attribute + procedure :: print_attributes + end type CircularGeometryType + + contains + + function area_sat(this) +! ****************************************************************************** +! area_sat -- return area as if geometry is fully saturated +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DTWO, DPI + ! -- return + real(DP) :: area_sat + ! -- dummy + class(CircularGeometryType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Calculate area + area_sat = DPI * this%radius ** DTWO + ! + ! -- Return + return + end function area_sat + + function perimeter_sat(this) +! ****************************************************************************** +! perimeter_sat -- return perimeter as if geometry is fully saturated +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DTWO, DPI + ! -- return + real(DP) :: perimeter_sat + ! -- dummy + class(CircularGeometryType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Calculate area + perimeter_sat = DTWO * DPI * this%radius + ! + ! -- return + return + end function perimeter_sat + + function area_wet(this, depth) +! ****************************************************************************** +! area_wet -- return wetted area +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DTWO, DPI, DZERO + ! -- return + real(DP) :: area_wet + ! -- dummy + class(CircularGeometryType) :: this + real(DP), intent(in) :: depth +! ------------------------------------------------------------------------------ + ! + ! -- Calculate area + if(depth <= DZERO) then + area_wet = DZERO + elseif(depth <= this%radius) then + area_wet = this%radius * this%radius * & + acos((this%radius - depth) / this%radius) - & + (this%radius - depth) * sqrt(this%radius * this%radius - & + (this%radius - depth) ** DTWO) + elseif(depth <= DTWO * this%radius) then + area_wet = this%radius * this%radius * (DPI - acos((depth - this%radius) & + / this%radius)) - (this%radius - depth) * sqrt(this%radius * & + this%radius - (this%radius - depth) ** DTWO) + else + area_wet = DPI * this%radius * this%radius + endif + ! + ! -- Return + return + end function area_wet + + function perimeter_wet(this, depth) +! ****************************************************************************** +! perimeter_wet -- return wetted perimeter +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DTWO, DPI + ! -- return + real(DP) :: perimeter_wet + ! -- dummy + class(CircularGeometryType) :: this + real(DP), intent(in) :: depth +! ------------------------------------------------------------------------------ + ! + ! -- Calculate area + if(depth <= DZERO) then + perimeter_wet = DZERO + elseif(depth <= this%radius) then + perimeter_wet = DTWO * this%radius * acos((this%radius - depth) / & + this%radius) + elseif(depth <= DTWO * this%radius) then + perimeter_wet = DTWO * this%radius * (DPI - acos((depth - this%radius) / & + this%radius)) + else + perimeter_wet = DTWO * DPI * this%radius + endif + ! + ! -- return + return + end function perimeter_wet + + subroutine set_attribute(this, line) +! ****************************************************************************** +! set_attribute -- set a parameter for this circular object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- module + use InputOutputModule, only: urword + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors + ! -- dummy + class(CircularGeometryType) :: this + character(len=LINELENGTH) :: errmsg + character(len=*), intent(inout) :: line + ! -- local + integer(I4B) :: lloc, istart, istop, ival + real(DP) :: rval +! ------------------------------------------------------------------------------ + ! + ! -- should change this and set id if uninitialized or store it + lloc=1 + call urword(line, lloc, istart, istop, 2, ival, rval, 0, 0) + this%id = ival + + ! -- Parse the attribute + call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) + select case(line(istart:istop)) + case('NAME') + call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) + this%name = line(istart:istop) + case('RADIUS') + call urword(line, lloc, istart, istop, 3, ival, rval, 0, 0) + this%radius = rval + case default + write(errmsg,'(4x,a,a)') & + '****ERROR. UNKNOWN CIRCULAR GEOMETRY ATTRIBUTE: ', & + line(istart:istop) + call store_error(errmsg) + call ustop() + end select + ! + ! -- return + return + end subroutine set_attribute + + subroutine print_attributes(this, iout) +! ****************************************************************************** +! print_attributes -- print the attributes for this object +! ***************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(CircularGeometryType) :: this + ! -- local + integer(I4B), intent(in) :: iout + ! -- formats + character(len=*), parameter :: fmtnm = "(4x,a,a)" + character(len=*), parameter :: fmttd = "(4x,a,1(1PG15.6))" +! ------------------------------------------------------------------------------ + ! + ! -- call parent to print parent attributes + call this%BaseGeometryType%print_attributes(iout) + ! + ! -- Print specifics of this geometry type + write(iout, fmttd) 'RADIUS = ', this%radius + write(iout, fmttd) 'SATURATED AREA = ', this%area_sat() + write(iout, fmttd) 'SATURATED WETTED PERIMETER = ', this%perimeter_sat() + ! + ! -- return + return + end subroutine print_attributes + end module CircularGeometryModule \ No newline at end of file diff --git a/src/Model/Geometry/RectangularChGeometry.f90 b/src/Model/Geometry/RectangularChGeometry.f90 index 0a589fbd717..194af7b7a4d 100644 --- a/src/Model/Geometry/RectangularChGeometry.f90 +++ b/src/Model/Geometry/RectangularChGeometry.f90 @@ -1,254 +1,254 @@ -module RectangularChGeometryModule - use KindModule, only: DP, I4B - use BaseGeometryModule, only: BaseGeometryType - use ConstantsModule, only: DZERO, DEM5 - use SmoothingModule, only: sCubicSaturation - implicit none - private - public :: RectangularChGeometryType - - type, extends(BaseGeometryType) :: RectangularChGeometryType - real(DP) :: width = DZERO - real(DP) :: length = DZERO - contains - procedure :: surface_area - procedure :: top_width_wet - procedure :: surface_area_wet - procedure :: area_wet - procedure :: perimeter_wet - procedure :: set_attribute - procedure :: init - procedure :: print_attributes - end type RectangularChGeometryType - - contains - - function surface_area(this) -! ****************************************************************************** -! area_wet -- return surface area -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DTWO, DPI, DZERO - ! -- return - real(DP) :: surface_area - ! -- dummy - class(RectangularChGeometryType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Calculate surface area - surface_area = this%width * this%length - ! - ! -- Return - return - end function surface_area - - function top_width_wet(this, depth) -! ****************************************************************************** -! area_wet -- return wetted surface area -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DTWO, DPI, DZERO - ! -- return - real(DP) :: top_width_wet - ! -- dummy - class(RectangularChGeometryType) :: this - real(DP), intent(in) :: depth - ! -- local - real(DP) :: sat -! ------------------------------------------------------------------------------ - ! - ! -- Calculate surface area - sat = sCubicSaturation(DEM5, DZERO, depth, DEM5) - top_width_wet = this%width * sat - ! - ! -- Return - return - end function top_width_wet - - function surface_area_wet(this, depth) -! ****************************************************************************** -! area_wet -- return wetted surface area -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DTWO, DPI, DZERO - ! -- return - real(DP) :: surface_area_wet - ! -- dummy - class(RectangularChGeometryType) :: this - real(DP), intent(in) :: depth - ! -- local - real(DP) :: top_width -! ------------------------------------------------------------------------------ - ! - ! -- Calculate surface area - top_width = this%top_width_wet(depth) - surface_area_wet = top_width * this%length - ! - ! -- Return - return - end function surface_area_wet - - function area_wet(this, depth) -! ****************************************************************************** -! area_wet -- return wetted area -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DTWO, DPI, DZERO - ! -- return - real(DP) :: area_wet - ! -- dummy - class(RectangularChGeometryType) :: this - real(DP), intent(in) :: depth -! ------------------------------------------------------------------------------ - ! - ! -- Calculate area - area_wet = depth * this%width - ! - ! -- Return - return - end function area_wet - - function perimeter_wet(this, depth) -! ****************************************************************************** -! perimeter_wet -- return wetted perimeter -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DTWO, DPI - ! -- return - real(DP) :: perimeter_wet - ! -- dummy - class(RectangularChGeometryType) :: this - real(DP), intent(in) :: depth -! ------------------------------------------------------------------------------ - ! - ! -- Calculate wetted perimeter - !perimeter_wet = DTWO * depth + this%width - perimeter_wet = this%width - ! - ! -- return - return - end function perimeter_wet - - subroutine set_attribute(this, line) -! ****************************************************************************** -! set_attribute -- set a parameter for this rectangular channel object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- module - use InputOutputModule, only: urword - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors - ! -- dummy - class(RectangularChGeometryType) :: this - character(len=LINELENGTH) :: errmsg - character(len=*), intent(inout) :: line - ! -- local - integer(I4B) :: lloc, istart, istop, ival - real(DP) :: rval -! ------------------------------------------------------------------------------ - ! - ! -- should change this and set id if uninitialized or store it - lloc=1 - call urword(line, lloc, istart, istop, 2, ival, rval, 0, 0) - this%id = ival - - ! -- Parse the attribute - call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) - select case(line(istart:istop)) - case('NAME') - call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) - this%name = line(istart:istop) - case('WIDTH') - call urword(line, lloc, istart, istop, 3, ival, rval, 0, 0) - this%width = rval - case('LENGTH') - call urword(line, lloc, istart, istop, 3, ival, rval, 0, 0) - this%length = rval - case default - write(errmsg,'(4x,a,a)') & - '****ERROR. UNKNOWN RECTANGULAR CHANNEL GEOMETRY ATTRIBUTE: ', & - line(istart:istop) - call store_error(errmsg) - call ustop() - end select - ! - ! -- return - return - end subroutine set_attribute - - - subroutine init(this, id, name, width, length) -! ****************************************************************************** -! init -- initialize this rectangular channel object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(RectangularChGeometryType) :: this - integer(I4B), intent(in) :: id - character (len=*), intent(in) :: name - real(DP), intent(in) :: width - real(DP), intent(in) :: length -! ------------------------------------------------------------------------------ - ! - ! -- initialize rectangular channel object using passed variables - this%geo_type = 'RECTANGULAR CH' - this%id = id - this%name = name - this%width = width - this%length = length - ! - ! -- return - return - end subroutine init - - subroutine print_attributes(this, iout) -! ****************************************************************************** -! print_attributes -- print the attributes for this object -! ***************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(RectangularChGeometryType) :: this - ! -- local - integer(I4B), intent(in) :: iout - ! -- formats - character(len=*), parameter :: fmtnm = "(4x,a,a)" - character(len=*), parameter :: fmttd = "(4x,a,1(1PG15.6))" - character(len=*), parameter :: fmtline = "(4x,36('-'))" - character(len=*), parameter :: fmtend = "(4x)" -! ------------------------------------------------------------------------------ - ! - ! -- call parent to print parent attributes - call this%BaseGeometryType%print_attributes(iout) - ! - ! -- Print specifics of this geometry type - write(iout, fmttd) 'WIDTH = ', this%width - write(iout, fmttd) 'LENGTH = ', this%length - write(iout, fmtline) - write(iout, fmtend) - ! - ! -- return - return - end subroutine print_attributes - +module RectangularChGeometryModule + use KindModule, only: DP, I4B + use BaseGeometryModule, only: BaseGeometryType + use ConstantsModule, only: DZERO, DEM5 + use SmoothingModule, only: sCubicSaturation + implicit none + private + public :: RectangularChGeometryType + + type, extends(BaseGeometryType) :: RectangularChGeometryType + real(DP) :: width = DZERO + real(DP) :: length = DZERO + contains + procedure :: surface_area + procedure :: top_width_wet + procedure :: surface_area_wet + procedure :: area_wet + procedure :: perimeter_wet + procedure :: set_attribute + procedure :: init + procedure :: print_attributes + end type RectangularChGeometryType + + contains + + function surface_area(this) +! ****************************************************************************** +! area_wet -- return surface area +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DTWO, DPI, DZERO + ! -- return + real(DP) :: surface_area + ! -- dummy + class(RectangularChGeometryType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Calculate surface area + surface_area = this%width * this%length + ! + ! -- Return + return + end function surface_area + + function top_width_wet(this, depth) +! ****************************************************************************** +! area_wet -- return wetted surface area +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DTWO, DPI, DZERO + ! -- return + real(DP) :: top_width_wet + ! -- dummy + class(RectangularChGeometryType) :: this + real(DP), intent(in) :: depth + ! -- local + real(DP) :: sat +! ------------------------------------------------------------------------------ + ! + ! -- Calculate surface area + sat = sCubicSaturation(DEM5, DZERO, depth, DEM5) + top_width_wet = this%width * sat + ! + ! -- Return + return + end function top_width_wet + + function surface_area_wet(this, depth) +! ****************************************************************************** +! area_wet -- return wetted surface area +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DTWO, DPI, DZERO + ! -- return + real(DP) :: surface_area_wet + ! -- dummy + class(RectangularChGeometryType) :: this + real(DP), intent(in) :: depth + ! -- local + real(DP) :: top_width +! ------------------------------------------------------------------------------ + ! + ! -- Calculate surface area + top_width = this%top_width_wet(depth) + surface_area_wet = top_width * this%length + ! + ! -- Return + return + end function surface_area_wet + + function area_wet(this, depth) +! ****************************************************************************** +! area_wet -- return wetted area +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DTWO, DPI, DZERO + ! -- return + real(DP) :: area_wet + ! -- dummy + class(RectangularChGeometryType) :: this + real(DP), intent(in) :: depth +! ------------------------------------------------------------------------------ + ! + ! -- Calculate area + area_wet = depth * this%width + ! + ! -- Return + return + end function area_wet + + function perimeter_wet(this, depth) +! ****************************************************************************** +! perimeter_wet -- return wetted perimeter +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DTWO, DPI + ! -- return + real(DP) :: perimeter_wet + ! -- dummy + class(RectangularChGeometryType) :: this + real(DP), intent(in) :: depth +! ------------------------------------------------------------------------------ + ! + ! -- Calculate wetted perimeter + !perimeter_wet = DTWO * depth + this%width + perimeter_wet = this%width + ! + ! -- return + return + end function perimeter_wet + + subroutine set_attribute(this, line) +! ****************************************************************************** +! set_attribute -- set a parameter for this rectangular channel object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- module + use InputOutputModule, only: urword + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors + ! -- dummy + class(RectangularChGeometryType) :: this + character(len=LINELENGTH) :: errmsg + character(len=*), intent(inout) :: line + ! -- local + integer(I4B) :: lloc, istart, istop, ival + real(DP) :: rval +! ------------------------------------------------------------------------------ + ! + ! -- should change this and set id if uninitialized or store it + lloc=1 + call urword(line, lloc, istart, istop, 2, ival, rval, 0, 0) + this%id = ival + + ! -- Parse the attribute + call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) + select case(line(istart:istop)) + case('NAME') + call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) + this%name = line(istart:istop) + case('WIDTH') + call urword(line, lloc, istart, istop, 3, ival, rval, 0, 0) + this%width = rval + case('LENGTH') + call urword(line, lloc, istart, istop, 3, ival, rval, 0, 0) + this%length = rval + case default + write(errmsg,'(4x,a,a)') & + '****ERROR. UNKNOWN RECTANGULAR CHANNEL GEOMETRY ATTRIBUTE: ', & + line(istart:istop) + call store_error(errmsg) + call ustop() + end select + ! + ! -- return + return + end subroutine set_attribute + + + subroutine init(this, id, name, width, length) +! ****************************************************************************** +! init -- initialize this rectangular channel object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(RectangularChGeometryType) :: this + integer(I4B), intent(in) :: id + character (len=*), intent(in) :: name + real(DP), intent(in) :: width + real(DP), intent(in) :: length +! ------------------------------------------------------------------------------ + ! + ! -- initialize rectangular channel object using passed variables + this%geo_type = 'RECTANGULAR CH' + this%id = id + this%name = name + this%width = width + this%length = length + ! + ! -- return + return + end subroutine init + + subroutine print_attributes(this, iout) +! ****************************************************************************** +! print_attributes -- print the attributes for this object +! ***************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(RectangularChGeometryType) :: this + ! -- local + integer(I4B), intent(in) :: iout + ! -- formats + character(len=*), parameter :: fmtnm = "(4x,a,a)" + character(len=*), parameter :: fmttd = "(4x,a,1(1PG15.6))" + character(len=*), parameter :: fmtline = "(4x,36('-'))" + character(len=*), parameter :: fmtend = "(4x)" +! ------------------------------------------------------------------------------ + ! + ! -- call parent to print parent attributes + call this%BaseGeometryType%print_attributes(iout) + ! + ! -- Print specifics of this geometry type + write(iout, fmttd) 'WIDTH = ', this%width + write(iout, fmttd) 'LENGTH = ', this%length + write(iout, fmtline) + write(iout, fmtend) + ! + ! -- return + return + end subroutine print_attributes + end module RectangularChGeometryModule \ No newline at end of file diff --git a/src/Model/Geometry/RectangularGeometry.f90 b/src/Model/Geometry/RectangularGeometry.f90 index cf8980fbe38..1728dac4dfd 100644 --- a/src/Model/Geometry/RectangularGeometry.f90 +++ b/src/Model/Geometry/RectangularGeometry.f90 @@ -1,203 +1,203 @@ -module RectangularGeometryModule - use KindModule, only: DP, I4B - use BaseGeometryModule, only: BaseGeometryType - use ConstantsModule, only: DZERO - implicit none - private - public :: RectangularGeometryType - - type, extends(BaseGeometryType) :: RectangularGeometryType - real(DP) :: height = DZERO - real(DP) :: width = DZERO - contains - procedure :: area_sat - procedure :: perimeter_sat - procedure :: area_wet - procedure :: perimeter_wet - procedure :: set_attribute - procedure :: print_attributes - end type RectangularGeometryType - - contains - - function area_sat(this) -! ****************************************************************************** -! area_sat -- return saturated area -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DTWO, DPI - ! -- return - real(DP) :: area_sat - ! -- dummy - class(RectangularGeometryType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Calculate area - area_sat = this%height * this%width - ! - ! -- Return - return - end function area_sat - - function perimeter_sat(this) -! ****************************************************************************** -! perimeter_sat -- return saturated perimeter -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DTWO, DPI - ! -- return - real(DP) :: perimeter_sat - ! -- dummy - class(RectangularGeometryType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Calculate area - perimeter_sat = DTWO * (this%height + this%width) - ! - ! -- return - return - end function perimeter_sat - - function area_wet(this, depth) -! ****************************************************************************** -! area_wet -- return wetted area -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DTWO, DPI, DZERO - ! -- return - real(DP) :: area_wet - ! -- dummy - class(RectangularGeometryType) :: this - real(DP), intent(in) :: depth -! ------------------------------------------------------------------------------ - ! - ! -- Calculate area - if(depth <= DZERO) then - area_wet = DZERO - elseif(depth <= this%height) then - area_wet = depth * this%width - else - area_wet = this%width * this%height - endif - ! - ! -- Return - return - end function area_wet - - function perimeter_wet(this, depth) -! ****************************************************************************** -! perimeter_wet -- return wetted perimeter -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DTWO, DPI - ! -- return - real(DP) :: perimeter_wet - ! -- dummy - class(RectangularGeometryType) :: this - real(DP), intent(in) :: depth -! ------------------------------------------------------------------------------ - ! - ! -- Calculate area - if(depth <= DZERO) then - perimeter_wet = DZERO - elseif(depth <= this%height) then - perimeter_wet = DTWO * (depth + this%width) - else - perimeter_wet = DTWO * (this%height + this%width) - endif - ! - ! -- return - return - end function perimeter_wet - - subroutine set_attribute(this, line) -! ****************************************************************************** -! set_attribute -- set a parameter for this rectangular object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- module - use InputOutputModule, only: urword - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors - ! -- dummy - class(RectangularGeometryType) :: this - character(len=LINELENGTH) :: errmsg - character(len=*), intent(inout) :: line - ! -- local - integer(I4B) :: lloc, istart, istop, ival - real(DP) :: rval -! ------------------------------------------------------------------------------ - ! - ! -- should change this and set id if uninitialized or store it - lloc=1 - call urword(line, lloc, istart, istop, 2, ival, rval, 0, 0) - this%id = ival - - ! -- Parse the attribute - call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) - select case(line(istart:istop)) - case('NAME') - call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) - this%name = line(istart:istop) - case('HEIGHT') - call urword(line, lloc, istart, istop, 3, ival, rval, 0, 0) - this%height = rval - case('WIDTH') - call urword(line, lloc, istart, istop, 3, ival, rval, 0, 0) - this%width = rval - case default - write(errmsg,'(4x,a,a)') & - '****ERROR. UNKNOWN RECTANGULAR GEOMETRY ATTRIBUTE: ', & - line(istart:istop) - call store_error(errmsg) - call ustop() - end select - ! - ! -- return - return - end subroutine set_attribute - - subroutine print_attributes(this, iout) -! ****************************************************************************** -! print_attributes -- print the attributes for this object -! ***************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(RectangularGeometryType) :: this - ! -- local - integer(I4B), intent(in) :: iout - ! -- formats - character(len=*), parameter :: fmtnm = "(4x,a,a)" - character(len=*), parameter :: fmttd = "(4x,a,1(1PG15.6))" -! ------------------------------------------------------------------------------ - ! - ! -- call parent to print parent attributes - call this%BaseGeometryType%print_attributes(iout) - ! - ! -- Print specifics of this geometry type - write(iout, fmttd) 'HEIGHT = ', this%height - write(iout, fmttd) 'WIDTH = ', this%width - write(iout, fmttd) 'SATURATED AREA = ', this%area_sat() - write(iout, fmttd) 'SATURATED WETTED PERIMETER = ', this%perimeter_sat() - ! - ! -- return - return - end subroutine print_attributes - +module RectangularGeometryModule + use KindModule, only: DP, I4B + use BaseGeometryModule, only: BaseGeometryType + use ConstantsModule, only: DZERO + implicit none + private + public :: RectangularGeometryType + + type, extends(BaseGeometryType) :: RectangularGeometryType + real(DP) :: height = DZERO + real(DP) :: width = DZERO + contains + procedure :: area_sat + procedure :: perimeter_sat + procedure :: area_wet + procedure :: perimeter_wet + procedure :: set_attribute + procedure :: print_attributes + end type RectangularGeometryType + + contains + + function area_sat(this) +! ****************************************************************************** +! area_sat -- return saturated area +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DTWO, DPI + ! -- return + real(DP) :: area_sat + ! -- dummy + class(RectangularGeometryType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Calculate area + area_sat = this%height * this%width + ! + ! -- Return + return + end function area_sat + + function perimeter_sat(this) +! ****************************************************************************** +! perimeter_sat -- return saturated perimeter +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DTWO, DPI + ! -- return + real(DP) :: perimeter_sat + ! -- dummy + class(RectangularGeometryType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Calculate area + perimeter_sat = DTWO * (this%height + this%width) + ! + ! -- return + return + end function perimeter_sat + + function area_wet(this, depth) +! ****************************************************************************** +! area_wet -- return wetted area +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DTWO, DPI, DZERO + ! -- return + real(DP) :: area_wet + ! -- dummy + class(RectangularGeometryType) :: this + real(DP), intent(in) :: depth +! ------------------------------------------------------------------------------ + ! + ! -- Calculate area + if(depth <= DZERO) then + area_wet = DZERO + elseif(depth <= this%height) then + area_wet = depth * this%width + else + area_wet = this%width * this%height + endif + ! + ! -- Return + return + end function area_wet + + function perimeter_wet(this, depth) +! ****************************************************************************** +! perimeter_wet -- return wetted perimeter +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DTWO, DPI + ! -- return + real(DP) :: perimeter_wet + ! -- dummy + class(RectangularGeometryType) :: this + real(DP), intent(in) :: depth +! ------------------------------------------------------------------------------ + ! + ! -- Calculate area + if(depth <= DZERO) then + perimeter_wet = DZERO + elseif(depth <= this%height) then + perimeter_wet = DTWO * (depth + this%width) + else + perimeter_wet = DTWO * (this%height + this%width) + endif + ! + ! -- return + return + end function perimeter_wet + + subroutine set_attribute(this, line) +! ****************************************************************************** +! set_attribute -- set a parameter for this rectangular object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- module + use InputOutputModule, only: urword + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors + ! -- dummy + class(RectangularGeometryType) :: this + character(len=LINELENGTH) :: errmsg + character(len=*), intent(inout) :: line + ! -- local + integer(I4B) :: lloc, istart, istop, ival + real(DP) :: rval +! ------------------------------------------------------------------------------ + ! + ! -- should change this and set id if uninitialized or store it + lloc=1 + call urword(line, lloc, istart, istop, 2, ival, rval, 0, 0) + this%id = ival + + ! -- Parse the attribute + call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) + select case(line(istart:istop)) + case('NAME') + call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) + this%name = line(istart:istop) + case('HEIGHT') + call urword(line, lloc, istart, istop, 3, ival, rval, 0, 0) + this%height = rval + case('WIDTH') + call urword(line, lloc, istart, istop, 3, ival, rval, 0, 0) + this%width = rval + case default + write(errmsg,'(4x,a,a)') & + '****ERROR. UNKNOWN RECTANGULAR GEOMETRY ATTRIBUTE: ', & + line(istart:istop) + call store_error(errmsg) + call ustop() + end select + ! + ! -- return + return + end subroutine set_attribute + + subroutine print_attributes(this, iout) +! ****************************************************************************** +! print_attributes -- print the attributes for this object +! ***************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(RectangularGeometryType) :: this + ! -- local + integer(I4B), intent(in) :: iout + ! -- formats + character(len=*), parameter :: fmtnm = "(4x,a,a)" + character(len=*), parameter :: fmttd = "(4x,a,1(1PG15.6))" +! ------------------------------------------------------------------------------ + ! + ! -- call parent to print parent attributes + call this%BaseGeometryType%print_attributes(iout) + ! + ! -- Print specifics of this geometry type + write(iout, fmttd) 'HEIGHT = ', this%height + write(iout, fmttd) 'WIDTH = ', this%width + write(iout, fmttd) 'SATURATED AREA = ', this%area_sat() + write(iout, fmttd) 'SATURATED WETTED PERIMETER = ', this%perimeter_sat() + ! + ! -- return + return + end subroutine print_attributes + end module RectangularGeometryModule \ No newline at end of file diff --git a/src/Model/GroundWaterFlow/gwf3.f90 b/src/Model/GroundWaterFlow/gwf3.f90 index ed2b8cf4c86..aa72d09acd5 100644 --- a/src/Model/GroundWaterFlow/gwf3.f90 +++ b/src/Model/GroundWaterFlow/gwf3.f90 @@ -1,1535 +1,1535 @@ -module GwfModule - - use KindModule, only: DP, I4B - use InputOutputModule, only: ParseLine, upcase - use ConstantsModule, only: LENFTYPE, LENPAKLOC, DZERO, DEM1, DTEN, DEP20 - use NumericalModelModule, only: NumericalModelType - use BaseDisModule, only: DisBaseType - use BndModule, only: BndType, AddBndToList, GetBndFromList - use GwfIcModule, only: GwfIcType - use GwfNpfModule, only: GwfNpfType - use Xt3dModule, only: Xt3dType - use GwfHfbModule, only: GwfHfbType - use GwfStoModule, only: GwfStoType - use GwfCsubModule, only: GwfCsubType - use GwfMvrModule, only: GwfMvrType - use BudgetModule, only: BudgetType - use GwfOcModule, only: GwfOcType - use GhostNodeModule, only: GhostNodeType, gnc_cr - use GwfObsModule, only: GwfObsType, gwf_obs_cr - use SimModule, only: count_errors, store_error, & - store_error_unit, ustop - use BaseModelModule, only: BaseModelType - - implicit none - - private - public :: gwf_cr - public :: GwfModelType - - type, extends(NumericalModelType) :: GwfModelType - - type(GwfIcType), pointer :: ic => null() ! initial conditions package - type(GwfNpfType), pointer :: npf => null() ! node property flow package - type(Xt3dType), pointer :: xt3d => null() ! xt3d option for npf - type(GwfStoType), pointer :: sto => null() ! storage package - type(GwfCsubType), pointer :: csub => null() ! subsidence package - type(GwfOcType), pointer :: oc => null() ! output control package - type(GhostNodeType), pointer :: gnc => null() ! ghost node correction package - type(GwfHfbType), pointer :: hfb => null() ! horizontal flow barrier package - type(GwfMvrType), pointer :: mvr => null() ! water mover package - type(GwfObsType), pointer :: obs => null() ! observation package - type(BudgetType), pointer :: budget => null() ! budget object - integer(I4B), pointer :: inic => null() ! unit number IC - integer(I4B), pointer :: inoc => null() ! unit number OC - integer(I4B), pointer :: innpf => null() ! unit number NPF - integer(I4B), pointer :: insto => null() ! unit number STO - integer(I4B), pointer :: incsub => null() ! unit number CSUB - integer(I4B), pointer :: inmvr => null() ! unit number MVR - integer(I4B), pointer :: inhfb => null() ! unit number HFB - integer(I4B), pointer :: ingnc => null() ! unit number GNC - integer(I4B), pointer :: inobs => null() ! unit number OBS - integer(I4B), pointer :: iss => null() ! steady state flag - integer(I4B), pointer :: inewtonur => null() ! newton under relaxation flag - - contains - - procedure :: model_df => gwf_df - procedure :: model_ac => gwf_ac - procedure :: model_mc => gwf_mc - procedure :: model_ar => gwf_ar - procedure :: model_rp => gwf_rp - procedure :: model_ad => gwf_ad - procedure :: model_cf => gwf_cf - procedure :: model_fc => gwf_fc - procedure :: model_cc => gwf_cc - procedure :: model_ptcchk => gwf_ptcchk - procedure :: model_ptc => gwf_ptc - procedure :: model_nur => gwf_nur - procedure :: model_cq => gwf_cq - procedure :: model_bd => gwf_bd - procedure :: model_ot => gwf_ot - procedure :: model_fp => gwf_fp - procedure :: model_da => gwf_da - procedure :: get_nsubtimes => gwf_get_nsubtimes - procedure :: model_bdentry => gwf_bdentry - procedure :: get_iasym => gwf_get_iasym - ! -- private - procedure :: allocate_scalars - procedure :: package_create - procedure :: ftype_check - ! - end type GwfModelType - - ! -- Module variables constant for simulation - integer(I4B), parameter :: NIUNIT=100 - character(len=LENFTYPE), dimension(NIUNIT) :: cunit - data cunit/ 'IC6 ', 'DIS6 ', 'DISU6', 'OC6 ', 'NPF6 ', & ! 5 - 'STO6 ', 'HFB6 ', 'WEL6 ', 'DRN6 ', 'RIV6 ', & ! 10 - 'GHB6 ', 'RCH6 ', 'EVT6 ', 'OBS6 ', 'GNC6 ', & ! 15 - ' ', 'CHD6 ', ' ', ' ', ' ', & ! 20 - ' ', 'MAW6 ', 'SFR6 ', 'LAK6 ', 'UZF6 ', & ! 25 - 'DISV6', 'MVR6 ', 'CSUB6', ' ', ' ', & ! 30 - 70 * ' '/ - - contains - - subroutine gwf_cr(filename, id, modelname, smr) -! ****************************************************************************** -! gwf_cr -- Create a new groundwater flow model object -! Subroutine: (1) creates model object and add to modellist -! (2) assign values -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ListsModule, only: basemodellist - use BaseModelModule, only: AddBaseModelToList - use SimModule, only: ustop, store_error, count_errors - use GenericUtilitiesModule, only: write_centered - use ConstantsModule, only: LINELENGTH, LENPACKAGENAME - use VersionModule, only: VERSION, MFVNAM, MFTITLE, & - FMTDISCLAIMER, IDEVELOPMODE - use CompilerVersion - use MemoryManagerModule, only: mem_allocate - use GwfDisModule, only: dis_cr - use GwfDisvModule, only: disv_cr - use GwfDisuModule, only: disu_cr - use GwfNpfModule, only: npf_cr - use Xt3dModule, only: xt3d_cr - use GwfStoModule, only: sto_cr - use GwfCsubModule, only: csub_cr - use GwfMvrModule, only: mvr_cr - use GwfHfbModule, only: hfb_cr - use GwfIcModule, only: ic_cr - use GwfOcModule, only: oc_cr - use BudgetModule, only: budget_cr - use NameFileModule, only: NameFileType - ! -- dummy - character(len=*), intent(in) :: filename - integer(I4B), intent(in) :: id - character(len=*), intent(in) :: modelname - logical, optional, intent(in) :: smr - ! -- local - integer(I4B) :: indis, indis6, indisu6, indisv6 - integer(I4B) :: ipakid, i, j, iu, ipaknum - character(len=LINELENGTH) :: errmsg - character(len=LENPACKAGENAME) :: pakname - type(NameFileType) :: namefile_obj - type(GwfModelType), pointer :: this - class(BaseModelType), pointer :: model - integer(I4B) :: nwords - character(len=LINELENGTH), allocatable, dimension(:) :: words - character(len=80) :: compiler - ! -- format -! ------------------------------------------------------------------------------ - ! - ! -- Allocate a new GWF Model (this) and add it to basemodellist - allocate(this) - call this%allocate_scalars(modelname) - model => this - call AddBaseModelToList(basemodellist, model) - ! - ! -- Assign values - this%filename = filename - this%name = modelname - this%macronym = 'GWF' - this%id = id - if(present(smr)) this%single_model_run = smr - ! - ! -- Open namefile and set iout - call namefile_obj%init(this%filename, 0) - call namefile_obj%add_cunit(niunit, cunit) - call namefile_obj%openlistfile(this%iout) - ! - ! -- Write title to list file - call write_centered('MODFLOW'//MFVNAM, 80, iunit=this%iout) - call write_centered(MFTITLE, 80, iunit=this%iout) - call write_centered('GROUNDWATER FLOW MODEL (GWF)', 80, iunit=this%iout) - call write_centered('VERSION '//VERSION, 80, iunit=this%iout) - ! - ! -- Write if develop mode - if (IDEVELOPMODE == 1) then - call write_centered('***DEVELOP MODE***', 80, iunit=this%iout) - end if - ! - ! -- Write compiler version - call get_compiler(compiler) - call write_centered(' ', 80, iunit=this%iout) - call write_centered(trim(adjustl(compiler)), 80, iunit=this%iout) - ! - ! -- Write disclaimer - write(this%iout, FMTDISCLAIMER) - ! - ! -- Write precision of real variables - write(this%iout, '(/,a)') 'MODFLOW was compiled using uniform precision.' - write(this%iout, '(a,i0,/)') 'Precision of REAL variables: ', & - precision(DZERO) - ! - ! -- Open files - call namefile_obj%openfiles(this%iout) - ! - ! -- GWF options - if (size(namefile_obj%opts) > 0) then - write(this%iout, '(1x,a)') 'NAMEFILE OPTIONS:' - end if - ! - ! -- Parse options in the GWF name file - do i = 1, size(namefile_obj%opts) - call ParseLine(namefile_obj%opts(i), nwords, words) - call upcase(words(1)) - select case(words(1)) - case('NEWTON') - this%inewton = 1 - write(this%iout, '(4x,a)') & - 'NEWTON-RAPHSON method enabled for the model.' - if (nwords > 1) then - call upcase(words(2)) - if (words(2) == 'UNDER_RELAXATION') then - this%inewtonur = 1 - write(this%iout, '(4x,a,a)') & - 'NEWTON-RAPHSON UNDER-RELAXATION based on the bottom ', & - 'elevation of the model will be applied to the model.' - end if - end if - case ('PRINT_INPUT') - this%iprpak = 1 - write(this%iout,'(4x,a)') 'STRESS PACKAGE INPUT WILL BE PRINTED '// & - 'FOR ALL MODEL STRESS PACKAGES' - case ('PRINT_FLOWS') - this%iprflow = 1 - write(this%iout,'(4x,a)') 'PACKAGE FLOWS WILL BE PRINTED '// & - 'FOR ALL MODEL PACKAGES' - case ('SAVE_FLOWS') - this%ipakcb = -1 - write(this%iout, '(4x,a)') & - 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL' - case default - write(errmsg,'(4x,a,a,a,a)') & - '****ERROR. UNKNOWN GWF NAMEFILE (', & - trim(adjustl(this%filename)), ') OPTION: ', & - trim(adjustl(namefile_obj%opts(i))) - call store_error(errmsg) - call ustop() - end select - end do - ! - ! -- Assign unit numbers to attached modules, and remove - ! -- from unitnumber (by specifying 1 for iremove) - ! - indis = 0 - indis6 = 0 - indisu6 = 0 - indisv6 = 0 - call namefile_obj%get_unitnumber('DIS6', indis6, 1) - if(indis6 > 0) indis = indis6 - if(indis <= 0) call namefile_obj%get_unitnumber('DISU6', indisu6, 1) - if(indisu6 > 0) indis = indisu6 - if(indis <= 0) call namefile_obj%get_unitnumber('DISV6', indisv6, 1) - if(indisv6 > 0) indis = indisv6 - call namefile_obj%get_unitnumber('IC6', this%inic, 1) - call namefile_obj%get_unitnumber('OC6', this%inoc, 1) - call namefile_obj%get_unitnumber('NPF6', this%innpf, 1) - call namefile_obj%get_unitnumber('STO6', this%insto, 1) - call namefile_obj%get_unitnumber('CSUB6', this%incsub, 1) - call namefile_obj%get_unitnumber('MVR6', this%inmvr, 1) - call namefile_obj%get_unitnumber('HFB6', this%inhfb, 1) - call namefile_obj%get_unitnumber('GNC6', this%ingnc, 1) - call namefile_obj%get_unitnumber('OBS6', this%inobs, 1) - ! - ! -- Check to make sure that required ftype's have been specified - call this%ftype_check(namefile_obj, indis) - ! - ! -- Create discretization object - if(indis6 > 0) then - call dis_cr(this%dis, this%name, indis, this%iout) - elseif(indisu6 > 0) then - call disu_cr(this%dis, this%name, indis, this%iout) - elseif(indisv6 > 0) then - call disv_cr(this%dis, this%name, indis, this%iout) - endif - ! - ! -- Create utility objects - call budget_cr(this%budget, this%name) - ! - ! -- Create packages that are tied directly to model - call npf_cr(this%npf, this%name, this%innpf, this%iout) - call xt3d_cr(this%xt3d, this%name, this%innpf, this%iout) - call gnc_cr(this%gnc, this%name, this%ingnc, this%iout) - call hfb_cr(this%hfb, this%name, this%inhfb, this%iout) - call sto_cr(this%sto, this%name, this%insto, this%iout) - call csub_cr(this%csub, this%name, this%insto, this%sto%name, & - this%incsub, this%iout) - call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis) - call mvr_cr(this%mvr, this%name, this%inmvr, this%iout, dis=this%dis) - call oc_cr(this%oc, this%name, this%inoc, this%iout) - call gwf_obs_cr(this%obs, this%inobs) - ! - ! -- Create stress packages - ipakid = 1 - do i = 1, niunit - ipaknum = 1 - do j = 1, namefile_obj%get_nval_for_row(i) - iu = namefile_obj%get_unitnumber_rowcol(i, j) - call namefile_obj%get_pakname(i, j, pakname) - call this%package_create(cunit(i), ipakid, ipaknum, pakname, iu, & - this%iout) - ipaknum = ipaknum + 1 - ipakid = ipakid + 1 - enddo - enddo - ! - ! -- return - return - end subroutine gwf_cr - - subroutine gwf_df(this) -! ****************************************************************************** -! gwf_df -- Define packages of the model -! Subroutine: (1) call df routines for each package -! (2) set gwf variables and pointers -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(GwfModelType) :: this - ! -- local - integer(I4B) :: ip - class(BndType), pointer :: packobj -! ------------------------------------------------------------------------------ - ! - ! -- Define packages and utility objects - call this%dis%dis_df() - call this%npf%npf_df(this%dis, this%xt3d, this%ingnc) - call this%oc%oc_df() - ! -- todo: niunit is not a good indicator of budterm size - call this%budget%budget_df(niunit, 'VOLUME', 'L**3') - if(this%ingnc > 0) call this%gnc%gnc_df(this) - ! - ! -- Assign or point model members to dis members - ! this%neq will be incremented if packages add additional unknowns - this%neq = this%dis%nodes - this%nja = this%dis%nja - this%ia => this%dis%con%ia - this%ja => this%dis%con%ja - ! - ! -- Allocate model arrays, now that neq and nja are known - call this%allocate_arrays() - ! - ! -- Define packages and assign iout for time series managers - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_df(this%neq, this%dis) - enddo - ! - ! -- Store information needed for observations - call this%obs%obs_df(this%iout, this%name, 'GWF', this%dis) - ! - ! -- return - return - end subroutine gwf_df - - subroutine gwf_ac(this, sparse) -! ****************************************************************************** -! gwf_ac -- Add the internal connections of this model to the sparse matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SparseModule, only: sparsematrix - ! -- dummy - class(GwfModelType) :: this - type(sparsematrix), intent(inout) :: sparse - ! -- local - class(BndType), pointer :: packobj - integer(I4B) :: ip -! ------------------------------------------------------------------------------ - ! - ! -- Add the primary grid connections of this model to sparse - call this%dis%dis_ac(this%moffset, sparse) - ! - ! -- Add any additional connections that NPF may need - if(this%innpf > 0) call this%npf%npf_ac(this%moffset, sparse) - ! - ! -- Add any package connections - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_ac(this%moffset, sparse) - enddo - ! - ! -- If GNC is active, then add the gnc connections to sparse - if(this%ingnc > 0) call this%gnc%gnc_ac(sparse) - ! - ! -- return - return - end subroutine gwf_ac - - subroutine gwf_mc(this, iasln, jasln) -! ****************************************************************************** -! gwf_mc -- Map the positions of this models connections in the -! numerical solution coefficient matrix. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfModelType) :: this - integer(I4B), dimension(:), intent(in) :: iasln - integer(I4B), dimension(:), intent(in) :: jasln - ! -- local - class(BndType), pointer :: packobj - integer(I4B) :: ip -! ------------------------------------------------------------------------------ - ! - ! -- Find the position of each connection in the global ia, ja structure - ! and store them in idxglo. - call this%dis%dis_mc(this%moffset, this%idxglo, iasln, jasln) - ! - ! -- Map any additional connections that NPF may need - if(this%innpf > 0) call this%npf%npf_mc(this%moffset, iasln, jasln) - ! - ! -- Map any package connections - do ip=1,this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_mc(this%moffset, iasln, jasln) - enddo - ! - ! -- For implicit gnc, need to store positions of gnc connections - ! in solution matrix connection - if(this%ingnc > 0) call this%gnc%gnc_mc(iasln, jasln) - ! - ! -- return - return - end subroutine gwf_mc - - subroutine gwf_ar(this) -! ****************************************************************************** -! gwf_ar -- GroundWater Flow Model Allocate and Read -! Subroutine: (1) allocates and reads packages part of this model, -! (2) allocates memory for arrays part of this model object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfModelType) :: this - ! -- locals - integer(I4B) :: ip - class(BndType), pointer :: packobj -! ------------------------------------------------------------------------------ - ! - ! -- Allocate and read modules attached to model - if(this%inic > 0) call this%ic%ic_ar(this%x) - if(this%innpf > 0) call this%npf%npf_ar(this%ic, this%ibound, this%x) - if(this%inhfb > 0) call this%hfb%hfb_ar(this%ibound, this%xt3d, this%dis) - if(this%insto > 0) call this%sto%sto_ar(this%dis, this%ibound) - if(this%incsub > 0) call this%csub%csub_ar(this%dis, this%ibound) - if(this%inmvr > 0) call this%mvr%mvr_ar() - if(this%inobs > 0) call this%obs%gwf_obs_ar(this%ic, this%x, this%flowja) - ! - ! -- Call dis_ar to write binary grid file - call this%dis%dis_ar(this%npf%icelltype) - ! - ! -- set up output control - call this%oc%oc_ar(this%x, this%dis, this%npf%hnoflo) - ! - ! -- Package input files now open, so allocate and read - do ip = 1,this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%set_pointers(this%dis%nodes, this%ibound, this%x, & - this%xold, this%flowja) - ! -- Read and allocate package - call packobj%bnd_ar() - enddo - ! - ! -- return - return - end subroutine gwf_ar - - subroutine gwf_rp(this) -! ****************************************************************************** -! gwf_rp -- GroundWater Flow Model Read and Prepare -! Subroutine: (1) calls package read and prepare routines -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: readnewdata - ! -- dummy - class(GwfModelType) :: this - ! -- local - class(BndType), pointer :: packobj - integer(I4B) :: ip -! ------------------------------------------------------------------------------ - ! - ! -- Check with TDIS on whether or not it is time to RP - if (.not. readnewdata) return - ! - ! -- Read and prepare - if(this%inhfb > 0) call this%hfb%hfb_rp() - if(this%inoc > 0) call this%oc%oc_rp() - if(this%insto > 0) call this%sto%sto_rp() - if(this%incsub > 0) call this%csub%csub_rp() - if(this%inmvr > 0) call this%mvr%mvr_rp() - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_rp() - call packobj%bnd_rp_obs() - enddo - ! - ! -- Return - return - end subroutine gwf_rp - - subroutine gwf_ad(this, ipicard, isubtime) -! ****************************************************************************** -! gwf_ad -- GroundWater Flow Model Time Step Advance -! Subroutine: (1) calls package advance subroutines -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimVariablesModule, only: isimcheck - ! -- dummy - class(GwfModelType) :: this - class(BndType), pointer :: packobj - integer(I4B), intent(in) :: ipicard - integer(I4B), intent(in) :: isubtime - ! -- local - integer(I4B) :: ip, n -! ------------------------------------------------------------------------------ - ! - ! -- copy x into xold - do n=1,this%dis%nodes - this%xold(n)=this%x(n) - enddo - ! - ! -- Advance - if(this%innpf > 0) call this%npf%npf_ad(this%dis%nodes, this%xold) - if(this%insto > 0) call this%sto%sto_ad() - if(this%incsub > 0) call this%csub%csub_ad(this%dis%nodes, this%x) - if(this%inmvr > 0) call this%mvr%mvr_ad() - do ip=1,this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_ad() - if (isimcheck > 0) then - call packobj%bnd_ck() - end if - enddo - ! - ! -- Push simulated values to preceding time/subtime step - call this%obs%obs_ad() - ! - ! -- return - return - end subroutine gwf_ad - - subroutine gwf_cf(this, kiter) -! ****************************************************************************** -! gwf_cf -- GroundWater Flow Model calculate coefficients -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfModelType) :: this - integer(I4B),intent(in) :: kiter - ! -- local - class(BndType), pointer :: packobj - integer(I4B) :: ip -! ------------------------------------------------------------------------------ - ! - ! -- Call package cf routines - if(this%innpf > 0) call this%npf%npf_cf(kiter, this%dis%nodes, this%x) - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_cf() - enddo - ! - ! -- return - return - end subroutine gwf_cf - - subroutine gwf_fc(this, kiter, amatsln, njasln, inwtflag) -! ****************************************************************************** -! gwf_fc -- GroundWater Flow Model fill coefficients -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfModelType) :: this - integer(I4B), intent(in) :: kiter - integer(I4B), intent(in) :: njasln - real(DP), dimension(njasln), intent(inout) :: amatsln - integer(I4B), intent(in) :: inwtflag - ! -- local - class(BndType), pointer :: packobj - integer(I4B) :: ip - integer(I4B) :: inwt, inwtsto, inwtcsub, inwtpak -! ------------------------------------------------------------------------------ - ! - ! -- newton flags - inwt = inwtflag - if(inwtflag == 1) inwt = this%npf%inewton - inwtsto = inwtflag - if(this%insto > 0) then - if(inwtflag == 1) inwtsto = this%sto%inewton - endif - inwtcsub = inwtflag - if(this%incsub > 0) then - if(inwtflag == 1) inwtcsub = this%csub%inewton - endif - ! - ! -- Fill standard conductance terms - if(this%innpf > 0) call this%npf%npf_fc(kiter, njasln, amatsln, & - this%idxglo, this%rhs, this%x) - if(this%inhfb > 0) call this%hfb%hfb_fc(kiter, njasln, amatsln, & - this%idxglo, this%rhs, this%x) - if(this%ingnc > 0) call this%gnc%gnc_fc(kiter, amatsln) - ! -- storage - if(this%insto > 0) then - call this%sto%sto_fc(kiter, this%xold, this%x, njasln, amatsln, & - this%idxglo, this%rhs) - end if - ! -- skeletal storage, compaction, and land subsidence - if(this%incsub > 0) then - call this%csub%csub_fc(kiter, this%xold, this%x, njasln, amatsln, & - this%idxglo, this%rhs) - end if - if(this%inmvr > 0) call this%mvr%mvr_fc() - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_fc(this%rhs, this%ia, this%idxglo, amatsln) - enddo - ! - !--Fill newton terms - if(this%innpf > 0) then - if(inwt /= 0) then - call this%npf%npf_fn(kiter, njasln, amatsln, this%idxglo, this%rhs, & - this%x) - endif - endif - ! - ! -- Fill newton terms for ghost nodes - if(this%ingnc > 0) then - if(inwt /= 0) then - call this%gnc%gnc_fn(kiter, njasln, amatsln, this%npf%condsat, & - ivarcv_opt=this%npf%ivarcv, & - ictm1_opt=this%npf%icelltype, & - ictm2_opt=this%npf%icelltype) - endif - endif - ! - ! -- Fill newton terms for storage - if(this%insto > 0) then - if (inwtsto /= 0) then - call this%sto%sto_fn(kiter, this%xold, this%x, njasln, amatsln, & - this%idxglo, this%rhs) - end if - end if - ! - ! -- Fill newton terms for skeletal storage, compaction, and land subsidence - if(this%incsub > 0) then - if (inwtcsub /= 0) then - call this%csub%csub_fn(kiter, this%xold, this%x, njasln, amatsln, & - this%idxglo, this%rhs) - end if - end if - ! - ! -- Fill Newton terms for packages - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - inwtpak = inwtflag - if(inwtflag == 1) inwtpak = packobj%inewton - if (inwtpak /= 0) then - call packobj%bnd_fn(this%rhs, this%ia, this%idxglo, amatsln) - end if - enddo - ! - ! -- return - return - end subroutine gwf_fc - - subroutine gwf_cc(this, kiter, iend, icnvgmod, cpak, dpak) -! ****************************************************************************** -! gwf_cc -- GroundWater Flow Model Final Convergence Check for Boundary Packages -! Subroutine: (1) calls package cc routines -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfModelType) :: this - integer(I4B),intent(in) :: kiter - integer(I4B),intent(in) :: iend - integer(I4B),intent(in) :: icnvgmod - character(len=LENPAKLOC), intent(inout) :: cpak - real(DP), intent(inout) :: dpak - ! -- local - class(BndType), pointer :: packobj - integer(I4B) :: ip - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- If mover is on, then at least 2 outers required - if (this%inmvr > 0) then - call this%mvr%mvr_cc(kiter, iend, icnvgmod, cpak, dpak) - end if - ! - ! -- csub convergence check - if (this%incsub > 0) then - call this%csub%csub_cc(kiter, iend, icnvgmod, & - this%dis%nodes, this%x, this%xold, & - cpak, dpak) - end if - ! - ! -- Call package cc routines - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_cc(kiter, iend, icnvgmod, cpak, dpak) - enddo - ! - ! -- return - return - end subroutine gwf_cc - - subroutine gwf_ptcchk(this, iptc) -! ****************************************************************************** -! gwf_ptcchk -- check if pseudo-transient continuation factor should be used -! Subroutine: (1) Check if pseudo-transient continuation factor should be used -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! modules - ! -- dummy - class(GwfModelType) :: this - integer(I4B), intent(inout) :: iptc -! ------------------------------------------------------------------------------ - ! -- determine if pseudo-transient continuation should be applied to this - ! model - pseudo-transient continuation only applied to problems that - ! use the Newton-Raphson formulation during steady-state stress periods - iptc = 0 - if (this%iss > 0) then - if (this%inewton > 0) then - iptc = this%inewton - else - iptc = this%npf%inewton - end if - end if - ! - ! -- return - return - end subroutine gwf_ptcchk - - subroutine gwf_ptc(this, kiter, neqsln, njasln, ia, ja, & - x, rhs, amatsln, iptc, ptcf) -! ****************************************************************************** -! gwf_ptc -- calculate maximum pseudo-transient continuation factor -! Subroutine: (1) Calculate maximum pseudo-transient continuation factor -! for the current outer iteration -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! modules - use ConstantsModule, only: DONE, DP9 - ! -- dummy - class(GwfModelType) :: this - integer(I4B),intent(in) :: kiter - integer(I4B), intent(in) :: neqsln - integer(I4B),intent(in) :: njasln - integer(I4B), dimension(neqsln+1), intent(in) :: ia - integer(I4B),dimension(njasln),intent(in) :: ja - real(DP), dimension(neqsln), intent(in) :: x - real(DP), dimension(neqsln), intent(in) :: rhs - real(DP),dimension(njasln),intent(in) :: amatsln - integer(I4B), intent(inout) :: iptc - real(DP),intent(inout) :: ptcf - ! -- local - integer(I4B) :: iptct - integer(I4B) :: n - integer(I4B) :: jcol - integer(I4B) :: j, jj - real(DP) :: v - real(DP) :: resid - real(DP) :: ptcdelem1 - real(DP) :: diag - real(DP) :: diagcnt - real(DP) :: diagmin - real(DP) :: diagmax -! ------------------------------------------------------------------------------ - ! -- set temporary flag indicating if pseudo-transient continuation should - ! be used for this model and time step - iptct = 0 - ! -- only apply pseudo-transient continuation to problems using the - ! Newton-Raphson formulations for steady-state stress periods - if (this%iss > 0) then - if (this%inewton > 0) then - iptct = this%inewton - else - iptct = this%npf%inewton - end if - end if - ! - ! -- calculate pseudo-transient continuation factor for model - if (iptct > 0) then - diagmin = DEP20 - diagmax = DZERO - diagcnt = DZERO - do n = 1, this%dis%nodes - if (this%npf%ibound(n) < 1) cycle - jcol = n + this%moffset - ! - ! get the maximum volume of the cell (head at top of cell) - v = this%dis%get_cell_volume(n, this%dis%top(n)) - ! - ! -- calculate the residual for the cell - resid = DZERO - do j = ia(jcol), ia(jcol+1)-1 - jj = ja(j) - resid = resid + amatsln(j) * x(jcol) - end do - resid = resid - rhs(jcol) - ! - ! -- calculate the reciprocal of the pseudo-time step - ! resid [L3/T] / volume [L3] = [1/T] - ptcdelem1 = abs(resid) / v - ! - ! -- set ptcf if the reciprocal of the pseudo-time step - ! exceeds the current value (equivalent to using the - ! smallest pseudo-time step) - if (ptcdelem1 > ptcf) ptcf = ptcdelem1 - ! - ! -- determine minimum and maximum diagonal entries - j = ia(jcol) - diag = abs(amatsln(j)) - diagcnt = diagcnt + DONE - if (diag > DZERO) then - if (diag < diagmin) diagmin = diag - if (diag > diagmax) diagmax = diag - end if - end do - ! - ! -- set the reciprocal of the pseudo-time step - ! to a fraction of the minimum or maximum - ! diagonal entry to prevent excessively small - ! or large values - if (diagcnt > DZERO) then - diagmin = diagmin * DEM1 - diagmax = diagmax * DEM1 - if (ptcf < diagmin) ptcf = diagmin - if (ptcf > diagmax) ptcf = diagmax - end if - end if - - ! reset ipc if needed - if (iptc == 0) then - if (iptct > 0) iptc = 1 - end if - ! - ! -- return - return - end subroutine gwf_ptc - - subroutine gwf_nur(this, neqmod, x, xtemp, dx, inewtonur, dxmax, locmax) -! ****************************************************************************** -! gwf_nur -- under-relaxation -! Subroutine: (1) Under-relaxation of Groundwater Flow Model Heads for current -! outer iteration using the cell bottoms at the bottom of the -! model -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! modules - use ConstantsModule, only: DONE, DP9 - ! -- dummy - class(GwfModelType) :: this - integer(I4B), intent(in) :: neqmod - real(DP), dimension(neqmod), intent(inout) :: x - real(DP), dimension(neqmod), intent(in) :: xtemp - real(DP), dimension(neqmod), intent(inout) :: dx - integer(I4B), intent(inout) :: inewtonur - real(DP), intent(inout) :: dxmax - integer(I4B), intent(inout) :: locmax - ! -- local - integer(I4B) :: i0 - integer(I4B) :: i1 - class(BndType), pointer :: packobj - integer(I4B) :: ip -! ------------------------------------------------------------------------------ - ! - ! -- apply Newton-Raphson under-relaxation if model is using - ! the Newton-Raphson formulation and this Newton-Raphson - ! under-relaxation is turned on. - if (this%inewton /= 0 .and. this%inewtonur /= 0) then - if (this%innpf > 0) then - call this%npf%npf_nur(neqmod, x, xtemp, dx, inewtonur, dxmax, locmax) - end if - ! - ! -- Call package nur routines - i0 = this%dis%nodes + 1 - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - if (packobj%npakeq > 0) then - i1 = i0 + packobj%npakeq - 1 - call packobj%bnd_nur(packobj%npakeq, x(i0:i1), xtemp(i0:i1), & - dx(i0:i1), inewtonur, dxmax, locmax) - i0 = i1 + 1 - end if - enddo - end if - ! - ! -- return - return - end subroutine gwf_nur - - subroutine gwf_cq(this, icnvg, isuppress_output) -! ****************************************************************************** -! gwf_cq --Groundwater flow model calculate flow -! Subroutine: (1) Calculate intercell flows (flowja) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(GwfModelType) :: this - integer(I4B), intent(in) :: icnvg - integer(I4B), intent(in) :: isuppress_output - ! -- local - integer(I4B) :: i -! ------------------------------------------------------------------------------ - ! - ! -- Construct the flowja array. Flowja is calculated each time, even if - ! output is suppressed. (flowja is positive into a cell.) - do i = 1, this%nja - this%flowja(i) = DZERO - enddo - if(this%innpf > 0) call this%npf%npf_flowja(this%x, this%flowja) - if(this%inhfb > 0) call this%hfb%hfb_flowja(this%x, this%flowja) - if(this%ingnc > 0) call this%gnc%flowja(this%flowja) - ! - ! -- Return - return - end subroutine gwf_cq - - subroutine gwf_bd(this, icnvg, isuppress_output) -! ****************************************************************************** -! gwf_bd --GroundWater Flow Model Budget -! Subroutine: (1) Calculate stress package contributions to model budget -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(GwfModelType) :: this - integer(I4B), intent(in) :: icnvg - integer(I4B), intent(in) :: isuppress_output - ! -- local - integer(I4B) :: icbcfl, ibudfl, icbcun, iprobs, idvfl - integer(I4B) :: ip - class(BndType),pointer :: packobj -! ------------------------------------------------------------------------------ - ! - ! -- Save the solution convergence flag - this%icnvg = icnvg - ! - ! -- Set write and print flags differently if output is suppressed. - if(isuppress_output == 0) then - idvfl = 0 - if(this%oc%oc_save('HEAD')) idvfl = 1 - icbcfl = 0 - if(this%oc%oc_save('BUDGET')) icbcfl = 1 - icbcun = this%oc%oc_save_unit('BUDGET') - ibudfl = 0 - if(this%oc%oc_print('BUDGET')) ibudfl = 1 - iprobs = 1 - else - icbcfl = 0 - ibudfl = 0 - icbcun = 0 - iprobs = 0 - idvfl = 0 - endif - ! - ! -- Budget routines (start by resetting) - call this%budget%reset() - ! - ! -- Storage - if(this%insto > 0) then - call this%sto%bdcalc(this%dis%nodes, this%x, this%xold, & - isuppress_output, this%budget) - call this%sto%bdsav(icbcfl, icbcun) - endif - ! -- Skeletal storage, compaction and subsidence - if (this%incsub > 0) then - call this%csub%bdcalc(this%dis%nodes, this%x, this%xold, & - isuppress_output, this%budget) - call this%csub%bdsav(idvfl, icbcfl, icbcun) - end if - ! - ! -- Node Property Flow - if(this%innpf > 0) then - call this%npf%npf_bdadj(this%flowja, icbcfl, icbcun) - endif - ! - ! -- Clear obs - call this%obs%obs_bd_clear() - ! - ! -- Mover budget - if(this%inmvr > 0) call this%mvr%mvr_bd(icbcfl, ibudfl, isuppress_output) - ! - ! -- Recalculate package hcof and rhs so that bnd_bd will calculate - ! flows based on the final head solution - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_cf(reset_mover=.false.) - enddo - ! - ! -- Boundary packages calculate budget and total flows to model budget - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_bd(this%x, idvfl, icbcfl, ibudfl, icbcun, iprobs, & - isuppress_output, this%budget) - enddo - ! - ! -- Calculate and write simulated values for observations - if(iprobs /= 0) then - if (icnvg > 0) then - call this%obs%obs_bd() - endif - endif - ! - ! -- Return - return - end subroutine gwf_bd - - subroutine gwf_ot(this) -! ****************************************************************************** -! gwf_ot -- GroundWater Flow Model Output -! Subroutine: (1) Output budget items -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule,only:kstp, kper, endofperiod, tdis_ot - ! -- dummy - class(GwfModelType) :: this - ! -- local - integer(I4B) :: ipflg, ibudfl, ihedfl - integer(I4B) :: ip - class(BndType), pointer :: packobj - ! -- formats - character(len=*),parameter :: fmtnocnvg = & - "(1X,/9X,'****FAILED TO MEET SOLVER CONVERGENCE CRITERIA IN TIME STEP ', & - &I0,' OF STRESS PERIOD ',I0,'****')" -! ------------------------------------------------------------------------------ - ! - ! -- Set ibudfl flag for printing budget information - ibudfl = 0 - if(this%oc%oc_print('BUDGET')) ibudfl = 1 - if(this%icnvg == 0) ibudfl = 1 - if(endofperiod) ibudfl = 1 - ! - ! -- Set ibudfl flag for printing dependent variable information - ihedfl = 0 - if(this%oc%oc_print('HEAD')) ihedfl = 1 - if(this%icnvg == 0) ihedfl = 1 - if(endofperiod) ihedfl = 1 - ! - ! -- Output individual flows if requested - if(ibudfl /= 0) then - ! - ! -- NPF output - if(this%innpf > 0) call this%npf%npf_ot(this%flowja) - ! - ! -- GNC output - if(this%ingnc > 0) & - call this%gnc%gnc_ot() - endif - ! - ! -- Output control - ipflg = 0 - this%budget%budperc = 1.e30 - if(this%icnvg == 0) then - write(this%iout,fmtnocnvg) kstp, kper - ipflg = 1 - endif - call this%oc%oc_ot(ipflg) - ! - ! -- Write Budget and Head if these conditions are met - if (ibudfl /= 0 .or. ihedfl /=0) then - ipflg = 1 - ! - ! -- Package budget output - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_ot(kstp, kper, this%iout, ihedfl, ibudfl) - enddo - ! - if (ibudfl /= 0) then - ! - ! -- Mover budget output - if(this%inmvr > 0) call this%mvr%mvr_ot() - ! - ! -- gwf model budget - call this%budget%budget_ot(kstp, kper, this%iout) - end if - end if - ! - ! -- Timing Output - if(ipflg == 1) call tdis_ot(this%iout) - ! - ! -- OBS output - call this%obs%obs_ot() - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_ot_obs() - enddo - ! - ! -- return - return - end subroutine gwf_ot - - subroutine gwf_fp(this) -! ****************************************************************************** -! gwf_fp -- Final processing -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(GwfModelType) :: this - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- csub final processing - if (this%incsub > 0) then - call this%csub%csub_fp() - end if - ! - return - end subroutine gwf_fp - - subroutine gwf_da(this) -! ****************************************************************************** -! gwf_da -- Deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(GwfModelType) :: this - ! -- local - integer(I4B) :: ip - class(BndType),pointer :: packobj -! ------------------------------------------------------------------------------ - ! - ! -- Internal flow packages deallocate - call this%dis%dis_da() - call this%ic%ic_da() - call this%npf%npf_da() - call this%xt3d%xt3d_da() - call this%gnc%gnc_da() - call this%sto%sto_da() - call this%csub%csub_da() - call this%budget%budget_da() - call this%hfb%hfb_da() - call this%mvr%mvr_da() - call this%oc%oc_da() - call this%obs%obs_da() - ! - ! -- Internal package objects - deallocate(this%dis) - deallocate(this%ic) - deallocate(this%npf) - deallocate(this%xt3d) - deallocate(this%gnc) - deallocate(this%sto) - deallocate(this%csub) - deallocate(this%budget) - deallocate(this%hfb) - deallocate(this%mvr) - deallocate(this%obs) - deallocate(this%oc) - ! - ! -- Boundary packages - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_da() - deallocate(packobj) - enddo - ! - ! -- Scalars - call mem_deallocate(this%inic) - call mem_deallocate(this%inoc) - call mem_deallocate(this%inobs) - call mem_deallocate(this%innpf) - call mem_deallocate(this%insto) - call mem_deallocate(this%incsub) - call mem_deallocate(this%inmvr) - call mem_deallocate(this%inhfb) - call mem_deallocate(this%ingnc) - call mem_deallocate(this%iss) - call mem_deallocate(this%inewtonur) - ! - ! -- NumericalModelType - call this%NumericalModelType%model_da() - ! - ! -- return - return - end subroutine gwf_da - - function gwf_get_nsubtimes(this) result(nsubtimes) -! ****************************************************************************** -! gwf_get_nsubtimes -- Return number of subtimesteps -! Subtimesteps not implemented yet, so just return 1. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! - ! -- result - integer(I4B) :: nsubtimes - class(GwfModelType) :: this -! ------------------------------------------------------------------------------ - ! - nsubtimes = 1 - ! - ! -- return - return - end function gwf_get_nsubtimes - - subroutine gwf_bdentry(this, budterm, budtxt, rowlabel) -! ****************************************************************************** -! gwf_bdentry -- GroundWater Flow Model Budget Entry -! This subroutine adds a budget entry to the flow budget. It was added as -! a method for the gwf3 model object so that the exchange object could add its -! contributions. -! Subroutine: (1) adds the entry to the budget object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LENBUDTXT, LENPACKAGENAME - use TdisModule, only:delt - ! -- dummy - class(GwfModelType) :: this - real(DP), dimension(:, :), intent(in) :: budterm - character(len=LENBUDTXT), dimension(:), intent(in) :: budtxt - character(len=LENPACKAGENAME), intent(in) :: rowlabel -! ------------------------------------------------------------------------------ - ! - call this%budget%addentry(budterm, delt, budtxt, rowlabel=rowlabel) - ! - ! -- return - return - end subroutine gwf_bdentry - - function gwf_get_iasym(this) result (iasym) -! ****************************************************************************** -! gwf_get_iasym -- return 1 if any package causes the matrix to be asymmetric. -! Otherwise return 0. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfModelType) :: this - ! -- local - integer(I4B) :: iasym - integer(I4B) :: ip - class(BndType), pointer :: packobj -! ------------------------------------------------------------------------------ - ! - ! -- Start by setting iasym to zero - iasym = 0 - ! - ! -- NPF - if (this%innpf > 0) then - if (this%npf%iasym /= 0) iasym = 1 - if (this%npf%ixt3d /= 0) iasym = 1 - endif - ! - ! -- GNC - if (this%ingnc > 0) then - if (this%gnc%iasym /= 0) iasym = 1 - endif - ! - ! -- Check for any packages that introduce matrix asymmetry - do ip=1,this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - if (packobj%iasym /= 0) iasym = 1 - enddo - ! - ! -- return - return - end function gwf_get_iasym - - subroutine allocate_scalars(this, modelname) -! ****************************************************************************** -! allocate_scalars -- Allocate memory for non-allocatable members -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(GwfModelType) :: this - character(len=*), intent(in) :: modelname -! ------------------------------------------------------------------------------ - ! - ! -- allocate members from parent class - call this%NumericalModelType%allocate_scalars(modelname) - ! - ! -- allocate members that are part of model class - call mem_allocate(this%inic, 'INIC', modelname) - call mem_allocate(this%inoc, 'INOC', modelname) - call mem_allocate(this%innpf, 'INNPF', modelname) - call mem_allocate(this%insto, 'INSTO', modelname) - call mem_allocate(this%incsub, 'INCSUB', modelname) - call mem_allocate(this%inmvr, 'INMVR', modelname) - call mem_allocate(this%inhfb, 'INHFB', modelname) - call mem_allocate(this%ingnc, 'INGNC', modelname) - call mem_allocate(this%inobs, 'INOBS', modelname) - call mem_allocate(this%iss, 'ISS', modelname) - call mem_allocate(this%inewtonur, 'INEWTONUR', modelname) - ! - this%inic = 0 - this%inoc = 0 - this%innpf = 0 - this%insto = 0 - this%incsub = 0 - this%inmvr = 0 - this%inhfb = 0 - this%ingnc = 0 - this%inobs = 0 - this%iss = 1 !default is steady-state (i.e., no STO package) - this%inewtonur = 0 !default is to not use newton bottom head dampening - ! - ! -- return - return - end subroutine allocate_scalars - - subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & - iout) -! ****************************************************************************** -! package_create -- Create boundary condition packages for this model -! Subroutine: (1) create new-style package -! (2) add a pointer to the package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error, ustop - use ChdModule, only: chd_create - use WelModule, only: wel_create - use DrnModule, only: drn_create - use RivModule, only: riv_create - use GhbModule, only: ghb_create - use RchModule, only: rch_create - use EvtModule, only: evt_create - use MawModule, only: maw_create - use SfrModule, only: sfr_create - use LakModule, only: lak_create - use UzfModule, only: uzf_create - ! -- dummy - class(GwfModelType) :: this - character(len=*),intent(in) :: filtyp - character(len=LINELENGTH) :: errmsg - integer(I4B),intent(in) :: ipakid - integer(I4B),intent(in) :: ipaknum - character(len=*), intent(in) :: pakname - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout - ! -- local - class(BndType), pointer :: packobj - class(BndType), pointer :: packobj2 - integer(I4B) :: ip -! ------------------------------------------------------------------------------ - ! - ! -- This part creates the package object - select case(filtyp) - case('CHD6') - call chd_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('WEL6') - call wel_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('DRN6') - call drn_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('RIV6') - call riv_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('GHB6') - call ghb_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('RCH6') - call rch_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('EVT6') - call evt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('MAW6') - call maw_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('SFR6') - call sfr_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('LAK6') - call lak_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('UZF6') - call uzf_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case default - write(errmsg, *) 'Invalid package type: ', filtyp - call store_error(errmsg) - call ustop() - end select - ! - ! -- Check to make sure that the package name is unique, then store a - ! pointer to the package in the model bndlist - do ip = 1, this%bndlist%Count() - packobj2 => GetBndFromList(this%bndlist, ip) - if(packobj2%name == pakname) then - write(errmsg, '(a,a)') 'Cannot create package. Package name ' // & - 'already exists: ', trim(pakname) - call store_error(errmsg) - call ustop() - endif - enddo - call AddBndToList(this%bndlist, packobj) - ! - ! -- return - return - end subroutine package_create - - subroutine ftype_check(this, namefile_obj, indis) -! ****************************************************************************** -! ftype_check -- Check to make sure required input files have been specified -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors - use NameFileModule, only: NameFileType - ! -- dummy - class(GwfModelType) :: this - type(NameFileType), intent(in) :: namefile_obj - integer(I4B), intent(in) :: indis - ! -- local - character(len=LINELENGTH) :: errmsg - integer(I4B) :: i, iu - character(len=LENFTYPE), dimension(11) :: nodupftype = & - (/'DIS6 ', 'DISU6', 'DISV6', 'IC6 ', 'OC6 ', 'NPF6 ', 'STO6 ', & - 'MVR6 ', 'HFB6 ', 'GNC6 ', 'OBS6 '/) -! ------------------------------------------------------------------------------ - ! - if(this%single_model_run) then - ! - ! -- Ensure TDIS6 is present - call namefile_obj%get_unitnumber('TDIS6', iu, 1) - if(iu == 0) then - call store_error('TDIS6 ftype not specified in name file.') - endif - ! - ! -- Ensure IMS6 is present - call namefile_obj%get_unitnumber('IMS6', iu, 1) - if(iu == 0) then - call store_error('IMS6 ftype not specified in name file.') - endif - ! - else - ! - ! -- Warn if TDIS6 is present - call namefile_obj%get_unitnumber('TDIS6', iu, 1) - if(iu > 0) then - write(this%iout, '(/a)') 'Warning TDIS6 detected in GWF name file.' - write(this%iout, *) 'Simulation TDIS file will be used instead.' - close(iu) - endif - ! - ! -- Warn if SMS8 is present - call namefile_obj%get_unitnumber('IMS6', iu, 1) - if(iu > 0) then - write(this%iout, '(/a)') 'Warning IMS6 detected in GWF name file.' - write(this%iout, *) 'Simulation IMS6 file will be used instead.' - close(iu) - endif - endif - ! - ! -- Check for IC8, DIS(u), and NPF. Stop if not present. - if(this%inic==0) then - write(errmsg, '(1x,a)') 'ERROR. INITIAL CONDITIONS (IC6) PACKAGE NOT SPECIFIED.' - call store_error(errmsg) - endif - if(indis==0) then - write(errmsg, '(1x,a)') & - 'ERROR. DISCRETIZATION (DIS6, DISV6, or DISU6) PACKAGE NOT SPECIFIED.' - call store_error(errmsg) - endif - if(this%innpf==0) then - write(errmsg, '(1x,a)') & - 'ERROR. NODE PROPERTY FLOW (NPF6) PACKAGE NOT SPECIFIED.' - call store_error(errmsg) - endif - if(count_errors() > 0) then - write(errmsg,'(1x,a)') 'ERROR. REQUIRED PACKAGE(S) NOT SPECIFIED.' - call store_error(errmsg) - endif - ! - ! -- Check to make sure that some GWF packages are not specified more - ! than once - do i = 1, size(nodupftype) - call namefile_obj%get_unitnumber(trim(nodupftype(i)), iu, 0) - if (iu > 0) then - write(errmsg,'(1x, a, a, a)') & - 'DUPLICATE ENTRIES FOR FTYPE ', trim(nodupftype(i)), & - ' NOT ALLOWED FOR GWF MODEL.' - call store_error(errmsg) - endif - enddo - ! - ! -- Stop if errors - if(count_errors() > 0) then - write(errmsg, '(a, a)') 'ERROR OCCURRED WHILE READING FILE: ', & - trim(namefile_obj%filename) - call store_error(errmsg) - call ustop() - endif - ! - ! -- return - return - end subroutine ftype_check - -end module GwfModule +module GwfModule + + use KindModule, only: DP, I4B + use InputOutputModule, only: ParseLine, upcase + use ConstantsModule, only: LENFTYPE, LENPAKLOC, DZERO, DEM1, DTEN, DEP20 + use NumericalModelModule, only: NumericalModelType + use BaseDisModule, only: DisBaseType + use BndModule, only: BndType, AddBndToList, GetBndFromList + use GwfIcModule, only: GwfIcType + use GwfNpfModule, only: GwfNpfType + use Xt3dModule, only: Xt3dType + use GwfHfbModule, only: GwfHfbType + use GwfStoModule, only: GwfStoType + use GwfCsubModule, only: GwfCsubType + use GwfMvrModule, only: GwfMvrType + use BudgetModule, only: BudgetType + use GwfOcModule, only: GwfOcType + use GhostNodeModule, only: GhostNodeType, gnc_cr + use GwfObsModule, only: GwfObsType, gwf_obs_cr + use SimModule, only: count_errors, store_error, & + store_error_unit, ustop + use BaseModelModule, only: BaseModelType + + implicit none + + private + public :: gwf_cr + public :: GwfModelType + + type, extends(NumericalModelType) :: GwfModelType + + type(GwfIcType), pointer :: ic => null() ! initial conditions package + type(GwfNpfType), pointer :: npf => null() ! node property flow package + type(Xt3dType), pointer :: xt3d => null() ! xt3d option for npf + type(GwfStoType), pointer :: sto => null() ! storage package + type(GwfCsubType), pointer :: csub => null() ! subsidence package + type(GwfOcType), pointer :: oc => null() ! output control package + type(GhostNodeType), pointer :: gnc => null() ! ghost node correction package + type(GwfHfbType), pointer :: hfb => null() ! horizontal flow barrier package + type(GwfMvrType), pointer :: mvr => null() ! water mover package + type(GwfObsType), pointer :: obs => null() ! observation package + type(BudgetType), pointer :: budget => null() ! budget object + integer(I4B), pointer :: inic => null() ! unit number IC + integer(I4B), pointer :: inoc => null() ! unit number OC + integer(I4B), pointer :: innpf => null() ! unit number NPF + integer(I4B), pointer :: insto => null() ! unit number STO + integer(I4B), pointer :: incsub => null() ! unit number CSUB + integer(I4B), pointer :: inmvr => null() ! unit number MVR + integer(I4B), pointer :: inhfb => null() ! unit number HFB + integer(I4B), pointer :: ingnc => null() ! unit number GNC + integer(I4B), pointer :: inobs => null() ! unit number OBS + integer(I4B), pointer :: iss => null() ! steady state flag + integer(I4B), pointer :: inewtonur => null() ! newton under relaxation flag + + contains + + procedure :: model_df => gwf_df + procedure :: model_ac => gwf_ac + procedure :: model_mc => gwf_mc + procedure :: model_ar => gwf_ar + procedure :: model_rp => gwf_rp + procedure :: model_ad => gwf_ad + procedure :: model_cf => gwf_cf + procedure :: model_fc => gwf_fc + procedure :: model_cc => gwf_cc + procedure :: model_ptcchk => gwf_ptcchk + procedure :: model_ptc => gwf_ptc + procedure :: model_nur => gwf_nur + procedure :: model_cq => gwf_cq + procedure :: model_bd => gwf_bd + procedure :: model_ot => gwf_ot + procedure :: model_fp => gwf_fp + procedure :: model_da => gwf_da + procedure :: get_nsubtimes => gwf_get_nsubtimes + procedure :: model_bdentry => gwf_bdentry + procedure :: get_iasym => gwf_get_iasym + ! -- private + procedure :: allocate_scalars + procedure :: package_create + procedure :: ftype_check + ! + end type GwfModelType + + ! -- Module variables constant for simulation + integer(I4B), parameter :: NIUNIT=100 + character(len=LENFTYPE), dimension(NIUNIT) :: cunit + data cunit/ 'IC6 ', 'DIS6 ', 'DISU6', 'OC6 ', 'NPF6 ', & ! 5 + 'STO6 ', 'HFB6 ', 'WEL6 ', 'DRN6 ', 'RIV6 ', & ! 10 + 'GHB6 ', 'RCH6 ', 'EVT6 ', 'OBS6 ', 'GNC6 ', & ! 15 + ' ', 'CHD6 ', ' ', ' ', ' ', & ! 20 + ' ', 'MAW6 ', 'SFR6 ', 'LAK6 ', 'UZF6 ', & ! 25 + 'DISV6', 'MVR6 ', 'CSUB6', ' ', ' ', & ! 30 + 70 * ' '/ + + contains + + subroutine gwf_cr(filename, id, modelname, smr) +! ****************************************************************************** +! gwf_cr -- Create a new groundwater flow model object +! Subroutine: (1) creates model object and add to modellist +! (2) assign values +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ListsModule, only: basemodellist + use BaseModelModule, only: AddBaseModelToList + use SimModule, only: ustop, store_error, count_errors + use GenericUtilitiesModule, only: write_centered + use ConstantsModule, only: LINELENGTH, LENPACKAGENAME + use VersionModule, only: VERSION, MFVNAM, MFTITLE, & + FMTDISCLAIMER, IDEVELOPMODE + use CompilerVersion + use MemoryManagerModule, only: mem_allocate + use GwfDisModule, only: dis_cr + use GwfDisvModule, only: disv_cr + use GwfDisuModule, only: disu_cr + use GwfNpfModule, only: npf_cr + use Xt3dModule, only: xt3d_cr + use GwfStoModule, only: sto_cr + use GwfCsubModule, only: csub_cr + use GwfMvrModule, only: mvr_cr + use GwfHfbModule, only: hfb_cr + use GwfIcModule, only: ic_cr + use GwfOcModule, only: oc_cr + use BudgetModule, only: budget_cr + use NameFileModule, only: NameFileType + ! -- dummy + character(len=*), intent(in) :: filename + integer(I4B), intent(in) :: id + character(len=*), intent(in) :: modelname + logical, optional, intent(in) :: smr + ! -- local + integer(I4B) :: indis, indis6, indisu6, indisv6 + integer(I4B) :: ipakid, i, j, iu, ipaknum + character(len=LINELENGTH) :: errmsg + character(len=LENPACKAGENAME) :: pakname + type(NameFileType) :: namefile_obj + type(GwfModelType), pointer :: this + class(BaseModelType), pointer :: model + integer(I4B) :: nwords + character(len=LINELENGTH), allocatable, dimension(:) :: words + character(len=80) :: compiler + ! -- format +! ------------------------------------------------------------------------------ + ! + ! -- Allocate a new GWF Model (this) and add it to basemodellist + allocate(this) + call this%allocate_scalars(modelname) + model => this + call AddBaseModelToList(basemodellist, model) + ! + ! -- Assign values + this%filename = filename + this%name = modelname + this%macronym = 'GWF' + this%id = id + if(present(smr)) this%single_model_run = smr + ! + ! -- Open namefile and set iout + call namefile_obj%init(this%filename, 0) + call namefile_obj%add_cunit(niunit, cunit) + call namefile_obj%openlistfile(this%iout) + ! + ! -- Write title to list file + call write_centered('MODFLOW'//MFVNAM, 80, iunit=this%iout) + call write_centered(MFTITLE, 80, iunit=this%iout) + call write_centered('GROUNDWATER FLOW MODEL (GWF)', 80, iunit=this%iout) + call write_centered('VERSION '//VERSION, 80, iunit=this%iout) + ! + ! -- Write if develop mode + if (IDEVELOPMODE == 1) then + call write_centered('***DEVELOP MODE***', 80, iunit=this%iout) + end if + ! + ! -- Write compiler version + call get_compiler(compiler) + call write_centered(' ', 80, iunit=this%iout) + call write_centered(trim(adjustl(compiler)), 80, iunit=this%iout) + ! + ! -- Write disclaimer + write(this%iout, FMTDISCLAIMER) + ! + ! -- Write precision of real variables + write(this%iout, '(/,a)') 'MODFLOW was compiled using uniform precision.' + write(this%iout, '(a,i0,/)') 'Precision of REAL variables: ', & + precision(DZERO) + ! + ! -- Open files + call namefile_obj%openfiles(this%iout) + ! + ! -- GWF options + if (size(namefile_obj%opts) > 0) then + write(this%iout, '(1x,a)') 'NAMEFILE OPTIONS:' + end if + ! + ! -- Parse options in the GWF name file + do i = 1, size(namefile_obj%opts) + call ParseLine(namefile_obj%opts(i), nwords, words) + call upcase(words(1)) + select case(words(1)) + case('NEWTON') + this%inewton = 1 + write(this%iout, '(4x,a)') & + 'NEWTON-RAPHSON method enabled for the model.' + if (nwords > 1) then + call upcase(words(2)) + if (words(2) == 'UNDER_RELAXATION') then + this%inewtonur = 1 + write(this%iout, '(4x,a,a)') & + 'NEWTON-RAPHSON UNDER-RELAXATION based on the bottom ', & + 'elevation of the model will be applied to the model.' + end if + end if + case ('PRINT_INPUT') + this%iprpak = 1 + write(this%iout,'(4x,a)') 'STRESS PACKAGE INPUT WILL BE PRINTED '// & + 'FOR ALL MODEL STRESS PACKAGES' + case ('PRINT_FLOWS') + this%iprflow = 1 + write(this%iout,'(4x,a)') 'PACKAGE FLOWS WILL BE PRINTED '// & + 'FOR ALL MODEL PACKAGES' + case ('SAVE_FLOWS') + this%ipakcb = -1 + write(this%iout, '(4x,a)') & + 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL' + case default + write(errmsg,'(4x,a,a,a,a)') & + '****ERROR. UNKNOWN GWF NAMEFILE (', & + trim(adjustl(this%filename)), ') OPTION: ', & + trim(adjustl(namefile_obj%opts(i))) + call store_error(errmsg) + call ustop() + end select + end do + ! + ! -- Assign unit numbers to attached modules, and remove + ! -- from unitnumber (by specifying 1 for iremove) + ! + indis = 0 + indis6 = 0 + indisu6 = 0 + indisv6 = 0 + call namefile_obj%get_unitnumber('DIS6', indis6, 1) + if(indis6 > 0) indis = indis6 + if(indis <= 0) call namefile_obj%get_unitnumber('DISU6', indisu6, 1) + if(indisu6 > 0) indis = indisu6 + if(indis <= 0) call namefile_obj%get_unitnumber('DISV6', indisv6, 1) + if(indisv6 > 0) indis = indisv6 + call namefile_obj%get_unitnumber('IC6', this%inic, 1) + call namefile_obj%get_unitnumber('OC6', this%inoc, 1) + call namefile_obj%get_unitnumber('NPF6', this%innpf, 1) + call namefile_obj%get_unitnumber('STO6', this%insto, 1) + call namefile_obj%get_unitnumber('CSUB6', this%incsub, 1) + call namefile_obj%get_unitnumber('MVR6', this%inmvr, 1) + call namefile_obj%get_unitnumber('HFB6', this%inhfb, 1) + call namefile_obj%get_unitnumber('GNC6', this%ingnc, 1) + call namefile_obj%get_unitnumber('OBS6', this%inobs, 1) + ! + ! -- Check to make sure that required ftype's have been specified + call this%ftype_check(namefile_obj, indis) + ! + ! -- Create discretization object + if(indis6 > 0) then + call dis_cr(this%dis, this%name, indis, this%iout) + elseif(indisu6 > 0) then + call disu_cr(this%dis, this%name, indis, this%iout) + elseif(indisv6 > 0) then + call disv_cr(this%dis, this%name, indis, this%iout) + endif + ! + ! -- Create utility objects + call budget_cr(this%budget, this%name) + ! + ! -- Create packages that are tied directly to model + call npf_cr(this%npf, this%name, this%innpf, this%iout) + call xt3d_cr(this%xt3d, this%name, this%innpf, this%iout) + call gnc_cr(this%gnc, this%name, this%ingnc, this%iout) + call hfb_cr(this%hfb, this%name, this%inhfb, this%iout) + call sto_cr(this%sto, this%name, this%insto, this%iout) + call csub_cr(this%csub, this%name, this%insto, this%sto%name, & + this%incsub, this%iout) + call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis) + call mvr_cr(this%mvr, this%name, this%inmvr, this%iout, dis=this%dis) + call oc_cr(this%oc, this%name, this%inoc, this%iout) + call gwf_obs_cr(this%obs, this%inobs) + ! + ! -- Create stress packages + ipakid = 1 + do i = 1, niunit + ipaknum = 1 + do j = 1, namefile_obj%get_nval_for_row(i) + iu = namefile_obj%get_unitnumber_rowcol(i, j) + call namefile_obj%get_pakname(i, j, pakname) + call this%package_create(cunit(i), ipakid, ipaknum, pakname, iu, & + this%iout) + ipaknum = ipaknum + 1 + ipakid = ipakid + 1 + enddo + enddo + ! + ! -- return + return + end subroutine gwf_cr + + subroutine gwf_df(this) +! ****************************************************************************** +! gwf_df -- Define packages of the model +! Subroutine: (1) call df routines for each package +! (2) set gwf variables and pointers +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfModelType) :: this + ! -- local + integer(I4B) :: ip + class(BndType), pointer :: packobj +! ------------------------------------------------------------------------------ + ! + ! -- Define packages and utility objects + call this%dis%dis_df() + call this%npf%npf_df(this%dis, this%xt3d, this%ingnc) + call this%oc%oc_df() + ! -- todo: niunit is not a good indicator of budterm size + call this%budget%budget_df(niunit, 'VOLUME', 'L**3') + if(this%ingnc > 0) call this%gnc%gnc_df(this) + ! + ! -- Assign or point model members to dis members + ! this%neq will be incremented if packages add additional unknowns + this%neq = this%dis%nodes + this%nja = this%dis%nja + this%ia => this%dis%con%ia + this%ja => this%dis%con%ja + ! + ! -- Allocate model arrays, now that neq and nja are known + call this%allocate_arrays() + ! + ! -- Define packages and assign iout for time series managers + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_df(this%neq, this%dis) + enddo + ! + ! -- Store information needed for observations + call this%obs%obs_df(this%iout, this%name, 'GWF', this%dis) + ! + ! -- return + return + end subroutine gwf_df + + subroutine gwf_ac(this, sparse) +! ****************************************************************************** +! gwf_ac -- Add the internal connections of this model to the sparse matrix +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SparseModule, only: sparsematrix + ! -- dummy + class(GwfModelType) :: this + type(sparsematrix), intent(inout) :: sparse + ! -- local + class(BndType), pointer :: packobj + integer(I4B) :: ip +! ------------------------------------------------------------------------------ + ! + ! -- Add the primary grid connections of this model to sparse + call this%dis%dis_ac(this%moffset, sparse) + ! + ! -- Add any additional connections that NPF may need + if(this%innpf > 0) call this%npf%npf_ac(this%moffset, sparse) + ! + ! -- Add any package connections + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_ac(this%moffset, sparse) + enddo + ! + ! -- If GNC is active, then add the gnc connections to sparse + if(this%ingnc > 0) call this%gnc%gnc_ac(sparse) + ! + ! -- return + return + end subroutine gwf_ac + + subroutine gwf_mc(this, iasln, jasln) +! ****************************************************************************** +! gwf_mc -- Map the positions of this models connections in the +! numerical solution coefficient matrix. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfModelType) :: this + integer(I4B), dimension(:), intent(in) :: iasln + integer(I4B), dimension(:), intent(in) :: jasln + ! -- local + class(BndType), pointer :: packobj + integer(I4B) :: ip +! ------------------------------------------------------------------------------ + ! + ! -- Find the position of each connection in the global ia, ja structure + ! and store them in idxglo. + call this%dis%dis_mc(this%moffset, this%idxglo, iasln, jasln) + ! + ! -- Map any additional connections that NPF may need + if(this%innpf > 0) call this%npf%npf_mc(this%moffset, iasln, jasln) + ! + ! -- Map any package connections + do ip=1,this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_mc(this%moffset, iasln, jasln) + enddo + ! + ! -- For implicit gnc, need to store positions of gnc connections + ! in solution matrix connection + if(this%ingnc > 0) call this%gnc%gnc_mc(iasln, jasln) + ! + ! -- return + return + end subroutine gwf_mc + + subroutine gwf_ar(this) +! ****************************************************************************** +! gwf_ar -- GroundWater Flow Model Allocate and Read +! Subroutine: (1) allocates and reads packages part of this model, +! (2) allocates memory for arrays part of this model object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfModelType) :: this + ! -- locals + integer(I4B) :: ip + class(BndType), pointer :: packobj +! ------------------------------------------------------------------------------ + ! + ! -- Allocate and read modules attached to model + if(this%inic > 0) call this%ic%ic_ar(this%x) + if(this%innpf > 0) call this%npf%npf_ar(this%ic, this%ibound, this%x) + if(this%inhfb > 0) call this%hfb%hfb_ar(this%ibound, this%xt3d, this%dis) + if(this%insto > 0) call this%sto%sto_ar(this%dis, this%ibound) + if(this%incsub > 0) call this%csub%csub_ar(this%dis, this%ibound) + if(this%inmvr > 0) call this%mvr%mvr_ar() + if(this%inobs > 0) call this%obs%gwf_obs_ar(this%ic, this%x, this%flowja) + ! + ! -- Call dis_ar to write binary grid file + call this%dis%dis_ar(this%npf%icelltype) + ! + ! -- set up output control + call this%oc%oc_ar(this%x, this%dis, this%npf%hnoflo) + ! + ! -- Package input files now open, so allocate and read + do ip = 1,this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%set_pointers(this%dis%nodes, this%ibound, this%x, & + this%xold, this%flowja) + ! -- Read and allocate package + call packobj%bnd_ar() + enddo + ! + ! -- return + return + end subroutine gwf_ar + + subroutine gwf_rp(this) +! ****************************************************************************** +! gwf_rp -- GroundWater Flow Model Read and Prepare +! Subroutine: (1) calls package read and prepare routines +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: readnewdata + ! -- dummy + class(GwfModelType) :: this + ! -- local + class(BndType), pointer :: packobj + integer(I4B) :: ip +! ------------------------------------------------------------------------------ + ! + ! -- Check with TDIS on whether or not it is time to RP + if (.not. readnewdata) return + ! + ! -- Read and prepare + if(this%inhfb > 0) call this%hfb%hfb_rp() + if(this%inoc > 0) call this%oc%oc_rp() + if(this%insto > 0) call this%sto%sto_rp() + if(this%incsub > 0) call this%csub%csub_rp() + if(this%inmvr > 0) call this%mvr%mvr_rp() + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_rp() + call packobj%bnd_rp_obs() + enddo + ! + ! -- Return + return + end subroutine gwf_rp + + subroutine gwf_ad(this, ipicard, isubtime) +! ****************************************************************************** +! gwf_ad -- GroundWater Flow Model Time Step Advance +! Subroutine: (1) calls package advance subroutines +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimVariablesModule, only: isimcheck + ! -- dummy + class(GwfModelType) :: this + class(BndType), pointer :: packobj + integer(I4B), intent(in) :: ipicard + integer(I4B), intent(in) :: isubtime + ! -- local + integer(I4B) :: ip, n +! ------------------------------------------------------------------------------ + ! + ! -- copy x into xold + do n=1,this%dis%nodes + this%xold(n)=this%x(n) + enddo + ! + ! -- Advance + if(this%innpf > 0) call this%npf%npf_ad(this%dis%nodes, this%xold) + if(this%insto > 0) call this%sto%sto_ad() + if(this%incsub > 0) call this%csub%csub_ad(this%dis%nodes, this%x) + if(this%inmvr > 0) call this%mvr%mvr_ad() + do ip=1,this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_ad() + if (isimcheck > 0) then + call packobj%bnd_ck() + end if + enddo + ! + ! -- Push simulated values to preceding time/subtime step + call this%obs%obs_ad() + ! + ! -- return + return + end subroutine gwf_ad + + subroutine gwf_cf(this, kiter) +! ****************************************************************************** +! gwf_cf -- GroundWater Flow Model calculate coefficients +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfModelType) :: this + integer(I4B),intent(in) :: kiter + ! -- local + class(BndType), pointer :: packobj + integer(I4B) :: ip +! ------------------------------------------------------------------------------ + ! + ! -- Call package cf routines + if(this%innpf > 0) call this%npf%npf_cf(kiter, this%dis%nodes, this%x) + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_cf() + enddo + ! + ! -- return + return + end subroutine gwf_cf + + subroutine gwf_fc(this, kiter, amatsln, njasln, inwtflag) +! ****************************************************************************** +! gwf_fc -- GroundWater Flow Model fill coefficients +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfModelType) :: this + integer(I4B), intent(in) :: kiter + integer(I4B), intent(in) :: njasln + real(DP), dimension(njasln), intent(inout) :: amatsln + integer(I4B), intent(in) :: inwtflag + ! -- local + class(BndType), pointer :: packobj + integer(I4B) :: ip + integer(I4B) :: inwt, inwtsto, inwtcsub, inwtpak +! ------------------------------------------------------------------------------ + ! + ! -- newton flags + inwt = inwtflag + if(inwtflag == 1) inwt = this%npf%inewton + inwtsto = inwtflag + if(this%insto > 0) then + if(inwtflag == 1) inwtsto = this%sto%inewton + endif + inwtcsub = inwtflag + if(this%incsub > 0) then + if(inwtflag == 1) inwtcsub = this%csub%inewton + endif + ! + ! -- Fill standard conductance terms + if(this%innpf > 0) call this%npf%npf_fc(kiter, njasln, amatsln, & + this%idxglo, this%rhs, this%x) + if(this%inhfb > 0) call this%hfb%hfb_fc(kiter, njasln, amatsln, & + this%idxglo, this%rhs, this%x) + if(this%ingnc > 0) call this%gnc%gnc_fc(kiter, amatsln) + ! -- storage + if(this%insto > 0) then + call this%sto%sto_fc(kiter, this%xold, this%x, njasln, amatsln, & + this%idxglo, this%rhs) + end if + ! -- skeletal storage, compaction, and land subsidence + if(this%incsub > 0) then + call this%csub%csub_fc(kiter, this%xold, this%x, njasln, amatsln, & + this%idxglo, this%rhs) + end if + if(this%inmvr > 0) call this%mvr%mvr_fc() + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_fc(this%rhs, this%ia, this%idxglo, amatsln) + enddo + ! + !--Fill newton terms + if(this%innpf > 0) then + if(inwt /= 0) then + call this%npf%npf_fn(kiter, njasln, amatsln, this%idxglo, this%rhs, & + this%x) + endif + endif + ! + ! -- Fill newton terms for ghost nodes + if(this%ingnc > 0) then + if(inwt /= 0) then + call this%gnc%gnc_fn(kiter, njasln, amatsln, this%npf%condsat, & + ivarcv_opt=this%npf%ivarcv, & + ictm1_opt=this%npf%icelltype, & + ictm2_opt=this%npf%icelltype) + endif + endif + ! + ! -- Fill newton terms for storage + if(this%insto > 0) then + if (inwtsto /= 0) then + call this%sto%sto_fn(kiter, this%xold, this%x, njasln, amatsln, & + this%idxglo, this%rhs) + end if + end if + ! + ! -- Fill newton terms for skeletal storage, compaction, and land subsidence + if(this%incsub > 0) then + if (inwtcsub /= 0) then + call this%csub%csub_fn(kiter, this%xold, this%x, njasln, amatsln, & + this%idxglo, this%rhs) + end if + end if + ! + ! -- Fill Newton terms for packages + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + inwtpak = inwtflag + if(inwtflag == 1) inwtpak = packobj%inewton + if (inwtpak /= 0) then + call packobj%bnd_fn(this%rhs, this%ia, this%idxglo, amatsln) + end if + enddo + ! + ! -- return + return + end subroutine gwf_fc + + subroutine gwf_cc(this, kiter, iend, icnvgmod, cpak, dpak) +! ****************************************************************************** +! gwf_cc -- GroundWater Flow Model Final Convergence Check for Boundary Packages +! Subroutine: (1) calls package cc routines +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfModelType) :: this + integer(I4B),intent(in) :: kiter + integer(I4B),intent(in) :: iend + integer(I4B),intent(in) :: icnvgmod + character(len=LENPAKLOC), intent(inout) :: cpak + real(DP), intent(inout) :: dpak + ! -- local + class(BndType), pointer :: packobj + integer(I4B) :: ip + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- If mover is on, then at least 2 outers required + if (this%inmvr > 0) then + call this%mvr%mvr_cc(kiter, iend, icnvgmod, cpak, dpak) + end if + ! + ! -- csub convergence check + if (this%incsub > 0) then + call this%csub%csub_cc(kiter, iend, icnvgmod, & + this%dis%nodes, this%x, this%xold, & + cpak, dpak) + end if + ! + ! -- Call package cc routines + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_cc(kiter, iend, icnvgmod, cpak, dpak) + enddo + ! + ! -- return + return + end subroutine gwf_cc + + subroutine gwf_ptcchk(this, iptc) +! ****************************************************************************** +! gwf_ptcchk -- check if pseudo-transient continuation factor should be used +! Subroutine: (1) Check if pseudo-transient continuation factor should be used +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! modules + ! -- dummy + class(GwfModelType) :: this + integer(I4B), intent(inout) :: iptc +! ------------------------------------------------------------------------------ + ! -- determine if pseudo-transient continuation should be applied to this + ! model - pseudo-transient continuation only applied to problems that + ! use the Newton-Raphson formulation during steady-state stress periods + iptc = 0 + if (this%iss > 0) then + if (this%inewton > 0) then + iptc = this%inewton + else + iptc = this%npf%inewton + end if + end if + ! + ! -- return + return + end subroutine gwf_ptcchk + + subroutine gwf_ptc(this, kiter, neqsln, njasln, ia, ja, & + x, rhs, amatsln, iptc, ptcf) +! ****************************************************************************** +! gwf_ptc -- calculate maximum pseudo-transient continuation factor +! Subroutine: (1) Calculate maximum pseudo-transient continuation factor +! for the current outer iteration +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! modules + use ConstantsModule, only: DONE, DP9 + ! -- dummy + class(GwfModelType) :: this + integer(I4B),intent(in) :: kiter + integer(I4B), intent(in) :: neqsln + integer(I4B),intent(in) :: njasln + integer(I4B), dimension(neqsln+1), intent(in) :: ia + integer(I4B),dimension(njasln),intent(in) :: ja + real(DP), dimension(neqsln), intent(in) :: x + real(DP), dimension(neqsln), intent(in) :: rhs + real(DP),dimension(njasln),intent(in) :: amatsln + integer(I4B), intent(inout) :: iptc + real(DP),intent(inout) :: ptcf + ! -- local + integer(I4B) :: iptct + integer(I4B) :: n + integer(I4B) :: jcol + integer(I4B) :: j, jj + real(DP) :: v + real(DP) :: resid + real(DP) :: ptcdelem1 + real(DP) :: diag + real(DP) :: diagcnt + real(DP) :: diagmin + real(DP) :: diagmax +! ------------------------------------------------------------------------------ + ! -- set temporary flag indicating if pseudo-transient continuation should + ! be used for this model and time step + iptct = 0 + ! -- only apply pseudo-transient continuation to problems using the + ! Newton-Raphson formulations for steady-state stress periods + if (this%iss > 0) then + if (this%inewton > 0) then + iptct = this%inewton + else + iptct = this%npf%inewton + end if + end if + ! + ! -- calculate pseudo-transient continuation factor for model + if (iptct > 0) then + diagmin = DEP20 + diagmax = DZERO + diagcnt = DZERO + do n = 1, this%dis%nodes + if (this%npf%ibound(n) < 1) cycle + jcol = n + this%moffset + ! + ! get the maximum volume of the cell (head at top of cell) + v = this%dis%get_cell_volume(n, this%dis%top(n)) + ! + ! -- calculate the residual for the cell + resid = DZERO + do j = ia(jcol), ia(jcol+1)-1 + jj = ja(j) + resid = resid + amatsln(j) * x(jcol) + end do + resid = resid - rhs(jcol) + ! + ! -- calculate the reciprocal of the pseudo-time step + ! resid [L3/T] / volume [L3] = [1/T] + ptcdelem1 = abs(resid) / v + ! + ! -- set ptcf if the reciprocal of the pseudo-time step + ! exceeds the current value (equivalent to using the + ! smallest pseudo-time step) + if (ptcdelem1 > ptcf) ptcf = ptcdelem1 + ! + ! -- determine minimum and maximum diagonal entries + j = ia(jcol) + diag = abs(amatsln(j)) + diagcnt = diagcnt + DONE + if (diag > DZERO) then + if (diag < diagmin) diagmin = diag + if (diag > diagmax) diagmax = diag + end if + end do + ! + ! -- set the reciprocal of the pseudo-time step + ! to a fraction of the minimum or maximum + ! diagonal entry to prevent excessively small + ! or large values + if (diagcnt > DZERO) then + diagmin = diagmin * DEM1 + diagmax = diagmax * DEM1 + if (ptcf < diagmin) ptcf = diagmin + if (ptcf > diagmax) ptcf = diagmax + end if + end if + + ! reset ipc if needed + if (iptc == 0) then + if (iptct > 0) iptc = 1 + end if + ! + ! -- return + return + end subroutine gwf_ptc + + subroutine gwf_nur(this, neqmod, x, xtemp, dx, inewtonur, dxmax, locmax) +! ****************************************************************************** +! gwf_nur -- under-relaxation +! Subroutine: (1) Under-relaxation of Groundwater Flow Model Heads for current +! outer iteration using the cell bottoms at the bottom of the +! model +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! modules + use ConstantsModule, only: DONE, DP9 + ! -- dummy + class(GwfModelType) :: this + integer(I4B), intent(in) :: neqmod + real(DP), dimension(neqmod), intent(inout) :: x + real(DP), dimension(neqmod), intent(in) :: xtemp + real(DP), dimension(neqmod), intent(inout) :: dx + integer(I4B), intent(inout) :: inewtonur + real(DP), intent(inout) :: dxmax + integer(I4B), intent(inout) :: locmax + ! -- local + integer(I4B) :: i0 + integer(I4B) :: i1 + class(BndType), pointer :: packobj + integer(I4B) :: ip +! ------------------------------------------------------------------------------ + ! + ! -- apply Newton-Raphson under-relaxation if model is using + ! the Newton-Raphson formulation and this Newton-Raphson + ! under-relaxation is turned on. + if (this%inewton /= 0 .and. this%inewtonur /= 0) then + if (this%innpf > 0) then + call this%npf%npf_nur(neqmod, x, xtemp, dx, inewtonur, dxmax, locmax) + end if + ! + ! -- Call package nur routines + i0 = this%dis%nodes + 1 + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + if (packobj%npakeq > 0) then + i1 = i0 + packobj%npakeq - 1 + call packobj%bnd_nur(packobj%npakeq, x(i0:i1), xtemp(i0:i1), & + dx(i0:i1), inewtonur, dxmax, locmax) + i0 = i1 + 1 + end if + enddo + end if + ! + ! -- return + return + end subroutine gwf_nur + + subroutine gwf_cq(this, icnvg, isuppress_output) +! ****************************************************************************** +! gwf_cq --Groundwater flow model calculate flow +! Subroutine: (1) Calculate intercell flows (flowja) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfModelType) :: this + integer(I4B), intent(in) :: icnvg + integer(I4B), intent(in) :: isuppress_output + ! -- local + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + ! -- Construct the flowja array. Flowja is calculated each time, even if + ! output is suppressed. (flowja is positive into a cell.) + do i = 1, this%nja + this%flowja(i) = DZERO + enddo + if(this%innpf > 0) call this%npf%npf_flowja(this%x, this%flowja) + if(this%inhfb > 0) call this%hfb%hfb_flowja(this%x, this%flowja) + if(this%ingnc > 0) call this%gnc%flowja(this%flowja) + ! + ! -- Return + return + end subroutine gwf_cq + + subroutine gwf_bd(this, icnvg, isuppress_output) +! ****************************************************************************** +! gwf_bd --GroundWater Flow Model Budget +! Subroutine: (1) Calculate stress package contributions to model budget +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfModelType) :: this + integer(I4B), intent(in) :: icnvg + integer(I4B), intent(in) :: isuppress_output + ! -- local + integer(I4B) :: icbcfl, ibudfl, icbcun, iprobs, idvfl + integer(I4B) :: ip + class(BndType),pointer :: packobj +! ------------------------------------------------------------------------------ + ! + ! -- Save the solution convergence flag + this%icnvg = icnvg + ! + ! -- Set write and print flags differently if output is suppressed. + if(isuppress_output == 0) then + idvfl = 0 + if(this%oc%oc_save('HEAD')) idvfl = 1 + icbcfl = 0 + if(this%oc%oc_save('BUDGET')) icbcfl = 1 + icbcun = this%oc%oc_save_unit('BUDGET') + ibudfl = 0 + if(this%oc%oc_print('BUDGET')) ibudfl = 1 + iprobs = 1 + else + icbcfl = 0 + ibudfl = 0 + icbcun = 0 + iprobs = 0 + idvfl = 0 + endif + ! + ! -- Budget routines (start by resetting) + call this%budget%reset() + ! + ! -- Storage + if(this%insto > 0) then + call this%sto%bdcalc(this%dis%nodes, this%x, this%xold, & + isuppress_output, this%budget) + call this%sto%bdsav(icbcfl, icbcun) + endif + ! -- Skeletal storage, compaction and subsidence + if (this%incsub > 0) then + call this%csub%bdcalc(this%dis%nodes, this%x, this%xold, & + isuppress_output, this%budget) + call this%csub%bdsav(idvfl, icbcfl, icbcun) + end if + ! + ! -- Node Property Flow + if(this%innpf > 0) then + call this%npf%npf_bdadj(this%flowja, icbcfl, icbcun) + endif + ! + ! -- Clear obs + call this%obs%obs_bd_clear() + ! + ! -- Mover budget + if(this%inmvr > 0) call this%mvr%mvr_bd(icbcfl, ibudfl, isuppress_output) + ! + ! -- Recalculate package hcof and rhs so that bnd_bd will calculate + ! flows based on the final head solution + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_cf(reset_mover=.false.) + enddo + ! + ! -- Boundary packages calculate budget and total flows to model budget + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_bd(this%x, idvfl, icbcfl, ibudfl, icbcun, iprobs, & + isuppress_output, this%budget) + enddo + ! + ! -- Calculate and write simulated values for observations + if(iprobs /= 0) then + if (icnvg > 0) then + call this%obs%obs_bd() + endif + endif + ! + ! -- Return + return + end subroutine gwf_bd + + subroutine gwf_ot(this) +! ****************************************************************************** +! gwf_ot -- GroundWater Flow Model Output +! Subroutine: (1) Output budget items +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule,only:kstp, kper, endofperiod, tdis_ot + ! -- dummy + class(GwfModelType) :: this + ! -- local + integer(I4B) :: ipflg, ibudfl, ihedfl + integer(I4B) :: ip + class(BndType), pointer :: packobj + ! -- formats + character(len=*),parameter :: fmtnocnvg = & + "(1X,/9X,'****FAILED TO MEET SOLVER CONVERGENCE CRITERIA IN TIME STEP ', & + &I0,' OF STRESS PERIOD ',I0,'****')" +! ------------------------------------------------------------------------------ + ! + ! -- Set ibudfl flag for printing budget information + ibudfl = 0 + if(this%oc%oc_print('BUDGET')) ibudfl = 1 + if(this%icnvg == 0) ibudfl = 1 + if(endofperiod) ibudfl = 1 + ! + ! -- Set ibudfl flag for printing dependent variable information + ihedfl = 0 + if(this%oc%oc_print('HEAD')) ihedfl = 1 + if(this%icnvg == 0) ihedfl = 1 + if(endofperiod) ihedfl = 1 + ! + ! -- Output individual flows if requested + if(ibudfl /= 0) then + ! + ! -- NPF output + if(this%innpf > 0) call this%npf%npf_ot(this%flowja) + ! + ! -- GNC output + if(this%ingnc > 0) & + call this%gnc%gnc_ot() + endif + ! + ! -- Output control + ipflg = 0 + this%budget%budperc = 1.e30 + if(this%icnvg == 0) then + write(this%iout,fmtnocnvg) kstp, kper + ipflg = 1 + endif + call this%oc%oc_ot(ipflg) + ! + ! -- Write Budget and Head if these conditions are met + if (ibudfl /= 0 .or. ihedfl /=0) then + ipflg = 1 + ! + ! -- Package budget output + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_ot(kstp, kper, this%iout, ihedfl, ibudfl) + enddo + ! + if (ibudfl /= 0) then + ! + ! -- Mover budget output + if(this%inmvr > 0) call this%mvr%mvr_ot() + ! + ! -- gwf model budget + call this%budget%budget_ot(kstp, kper, this%iout) + end if + end if + ! + ! -- Timing Output + if(ipflg == 1) call tdis_ot(this%iout) + ! + ! -- OBS output + call this%obs%obs_ot() + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_ot_obs() + enddo + ! + ! -- return + return + end subroutine gwf_ot + + subroutine gwf_fp(this) +! ****************************************************************************** +! gwf_fp -- Final processing +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfModelType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- csub final processing + if (this%incsub > 0) then + call this%csub%csub_fp() + end if + ! + return + end subroutine gwf_fp + + subroutine gwf_da(this) +! ****************************************************************************** +! gwf_da -- Deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(GwfModelType) :: this + ! -- local + integer(I4B) :: ip + class(BndType),pointer :: packobj +! ------------------------------------------------------------------------------ + ! + ! -- Internal flow packages deallocate + call this%dis%dis_da() + call this%ic%ic_da() + call this%npf%npf_da() + call this%xt3d%xt3d_da() + call this%gnc%gnc_da() + call this%sto%sto_da() + call this%csub%csub_da() + call this%budget%budget_da() + call this%hfb%hfb_da() + call this%mvr%mvr_da() + call this%oc%oc_da() + call this%obs%obs_da() + ! + ! -- Internal package objects + deallocate(this%dis) + deallocate(this%ic) + deallocate(this%npf) + deallocate(this%xt3d) + deallocate(this%gnc) + deallocate(this%sto) + deallocate(this%csub) + deallocate(this%budget) + deallocate(this%hfb) + deallocate(this%mvr) + deallocate(this%obs) + deallocate(this%oc) + ! + ! -- Boundary packages + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_da() + deallocate(packobj) + enddo + ! + ! -- Scalars + call mem_deallocate(this%inic) + call mem_deallocate(this%inoc) + call mem_deallocate(this%inobs) + call mem_deallocate(this%innpf) + call mem_deallocate(this%insto) + call mem_deallocate(this%incsub) + call mem_deallocate(this%inmvr) + call mem_deallocate(this%inhfb) + call mem_deallocate(this%ingnc) + call mem_deallocate(this%iss) + call mem_deallocate(this%inewtonur) + ! + ! -- NumericalModelType + call this%NumericalModelType%model_da() + ! + ! -- return + return + end subroutine gwf_da + + function gwf_get_nsubtimes(this) result(nsubtimes) +! ****************************************************************************** +! gwf_get_nsubtimes -- Return number of subtimesteps +! Subtimesteps not implemented yet, so just return 1. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! + ! -- result + integer(I4B) :: nsubtimes + class(GwfModelType) :: this +! ------------------------------------------------------------------------------ + ! + nsubtimes = 1 + ! + ! -- return + return + end function gwf_get_nsubtimes + + subroutine gwf_bdentry(this, budterm, budtxt, rowlabel) +! ****************************************************************************** +! gwf_bdentry -- GroundWater Flow Model Budget Entry +! This subroutine adds a budget entry to the flow budget. It was added as +! a method for the gwf3 model object so that the exchange object could add its +! contributions. +! Subroutine: (1) adds the entry to the budget object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LENBUDTXT, LENPACKAGENAME + use TdisModule, only:delt + ! -- dummy + class(GwfModelType) :: this + real(DP), dimension(:, :), intent(in) :: budterm + character(len=LENBUDTXT), dimension(:), intent(in) :: budtxt + character(len=LENPACKAGENAME), intent(in) :: rowlabel +! ------------------------------------------------------------------------------ + ! + call this%budget%addentry(budterm, delt, budtxt, rowlabel=rowlabel) + ! + ! -- return + return + end subroutine gwf_bdentry + + function gwf_get_iasym(this) result (iasym) +! ****************************************************************************** +! gwf_get_iasym -- return 1 if any package causes the matrix to be asymmetric. +! Otherwise return 0. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfModelType) :: this + ! -- local + integer(I4B) :: iasym + integer(I4B) :: ip + class(BndType), pointer :: packobj +! ------------------------------------------------------------------------------ + ! + ! -- Start by setting iasym to zero + iasym = 0 + ! + ! -- NPF + if (this%innpf > 0) then + if (this%npf%iasym /= 0) iasym = 1 + if (this%npf%ixt3d /= 0) iasym = 1 + endif + ! + ! -- GNC + if (this%ingnc > 0) then + if (this%gnc%iasym /= 0) iasym = 1 + endif + ! + ! -- Check for any packages that introduce matrix asymmetry + do ip=1,this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + if (packobj%iasym /= 0) iasym = 1 + enddo + ! + ! -- return + return + end function gwf_get_iasym + + subroutine allocate_scalars(this, modelname) +! ****************************************************************************** +! allocate_scalars -- Allocate memory for non-allocatable members +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GwfModelType) :: this + character(len=*), intent(in) :: modelname +! ------------------------------------------------------------------------------ + ! + ! -- allocate members from parent class + call this%NumericalModelType%allocate_scalars(modelname) + ! + ! -- allocate members that are part of model class + call mem_allocate(this%inic, 'INIC', modelname) + call mem_allocate(this%inoc, 'INOC', modelname) + call mem_allocate(this%innpf, 'INNPF', modelname) + call mem_allocate(this%insto, 'INSTO', modelname) + call mem_allocate(this%incsub, 'INCSUB', modelname) + call mem_allocate(this%inmvr, 'INMVR', modelname) + call mem_allocate(this%inhfb, 'INHFB', modelname) + call mem_allocate(this%ingnc, 'INGNC', modelname) + call mem_allocate(this%inobs, 'INOBS', modelname) + call mem_allocate(this%iss, 'ISS', modelname) + call mem_allocate(this%inewtonur, 'INEWTONUR', modelname) + ! + this%inic = 0 + this%inoc = 0 + this%innpf = 0 + this%insto = 0 + this%incsub = 0 + this%inmvr = 0 + this%inhfb = 0 + this%ingnc = 0 + this%inobs = 0 + this%iss = 1 !default is steady-state (i.e., no STO package) + this%inewtonur = 0 !default is to not use newton bottom head dampening + ! + ! -- return + return + end subroutine allocate_scalars + + subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & + iout) +! ****************************************************************************** +! package_create -- Create boundary condition packages for this model +! Subroutine: (1) create new-style package +! (2) add a pointer to the package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error, ustop + use ChdModule, only: chd_create + use WelModule, only: wel_create + use DrnModule, only: drn_create + use RivModule, only: riv_create + use GhbModule, only: ghb_create + use RchModule, only: rch_create + use EvtModule, only: evt_create + use MawModule, only: maw_create + use SfrModule, only: sfr_create + use LakModule, only: lak_create + use UzfModule, only: uzf_create + ! -- dummy + class(GwfModelType) :: this + character(len=*),intent(in) :: filtyp + character(len=LINELENGTH) :: errmsg + integer(I4B),intent(in) :: ipakid + integer(I4B),intent(in) :: ipaknum + character(len=*), intent(in) :: pakname + integer(I4B),intent(in) :: inunit + integer(I4B),intent(in) :: iout + ! -- local + class(BndType), pointer :: packobj + class(BndType), pointer :: packobj2 + integer(I4B) :: ip +! ------------------------------------------------------------------------------ + ! + ! -- This part creates the package object + select case(filtyp) + case('CHD6') + call chd_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + case('WEL6') + call wel_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + case('DRN6') + call drn_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + case('RIV6') + call riv_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + case('GHB6') + call ghb_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + case('RCH6') + call rch_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + case('EVT6') + call evt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + case('MAW6') + call maw_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + case('SFR6') + call sfr_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + case('LAK6') + call lak_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + case('UZF6') + call uzf_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + case default + write(errmsg, *) 'Invalid package type: ', filtyp + call store_error(errmsg) + call ustop() + end select + ! + ! -- Check to make sure that the package name is unique, then store a + ! pointer to the package in the model bndlist + do ip = 1, this%bndlist%Count() + packobj2 => GetBndFromList(this%bndlist, ip) + if(packobj2%name == pakname) then + write(errmsg, '(a,a)') 'Cannot create package. Package name ' // & + 'already exists: ', trim(pakname) + call store_error(errmsg) + call ustop() + endif + enddo + call AddBndToList(this%bndlist, packobj) + ! + ! -- return + return + end subroutine package_create + + subroutine ftype_check(this, namefile_obj, indis) +! ****************************************************************************** +! ftype_check -- Check to make sure required input files have been specified +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors + use NameFileModule, only: NameFileType + ! -- dummy + class(GwfModelType) :: this + type(NameFileType), intent(in) :: namefile_obj + integer(I4B), intent(in) :: indis + ! -- local + character(len=LINELENGTH) :: errmsg + integer(I4B) :: i, iu + character(len=LENFTYPE), dimension(11) :: nodupftype = & + (/'DIS6 ', 'DISU6', 'DISV6', 'IC6 ', 'OC6 ', 'NPF6 ', 'STO6 ', & + 'MVR6 ', 'HFB6 ', 'GNC6 ', 'OBS6 '/) +! ------------------------------------------------------------------------------ + ! + if(this%single_model_run) then + ! + ! -- Ensure TDIS6 is present + call namefile_obj%get_unitnumber('TDIS6', iu, 1) + if(iu == 0) then + call store_error('TDIS6 ftype not specified in name file.') + endif + ! + ! -- Ensure IMS6 is present + call namefile_obj%get_unitnumber('IMS6', iu, 1) + if(iu == 0) then + call store_error('IMS6 ftype not specified in name file.') + endif + ! + else + ! + ! -- Warn if TDIS6 is present + call namefile_obj%get_unitnumber('TDIS6', iu, 1) + if(iu > 0) then + write(this%iout, '(/a)') 'Warning TDIS6 detected in GWF name file.' + write(this%iout, *) 'Simulation TDIS file will be used instead.' + close(iu) + endif + ! + ! -- Warn if SMS8 is present + call namefile_obj%get_unitnumber('IMS6', iu, 1) + if(iu > 0) then + write(this%iout, '(/a)') 'Warning IMS6 detected in GWF name file.' + write(this%iout, *) 'Simulation IMS6 file will be used instead.' + close(iu) + endif + endif + ! + ! -- Check for IC8, DIS(u), and NPF. Stop if not present. + if(this%inic==0) then + write(errmsg, '(1x,a)') 'ERROR. INITIAL CONDITIONS (IC6) PACKAGE NOT SPECIFIED.' + call store_error(errmsg) + endif + if(indis==0) then + write(errmsg, '(1x,a)') & + 'ERROR. DISCRETIZATION (DIS6, DISV6, or DISU6) PACKAGE NOT SPECIFIED.' + call store_error(errmsg) + endif + if(this%innpf==0) then + write(errmsg, '(1x,a)') & + 'ERROR. NODE PROPERTY FLOW (NPF6) PACKAGE NOT SPECIFIED.' + call store_error(errmsg) + endif + if(count_errors() > 0) then + write(errmsg,'(1x,a)') 'ERROR. REQUIRED PACKAGE(S) NOT SPECIFIED.' + call store_error(errmsg) + endif + ! + ! -- Check to make sure that some GWF packages are not specified more + ! than once + do i = 1, size(nodupftype) + call namefile_obj%get_unitnumber(trim(nodupftype(i)), iu, 0) + if (iu > 0) then + write(errmsg,'(1x, a, a, a)') & + 'DUPLICATE ENTRIES FOR FTYPE ', trim(nodupftype(i)), & + ' NOT ALLOWED FOR GWF MODEL.' + call store_error(errmsg) + endif + enddo + ! + ! -- Stop if errors + if(count_errors() > 0) then + write(errmsg, '(a, a)') 'ERROR OCCURRED WHILE READING FILE: ', & + trim(namefile_obj%filename) + call store_error(errmsg) + call ustop() + endif + ! + ! -- return + return + end subroutine ftype_check + +end module GwfModule diff --git a/src/Model/GroundWaterFlow/gwf3chd8.f90 b/src/Model/GroundWaterFlow/gwf3chd8.f90 index 38ccfb5f23c..bfbdc1964ee 100644 --- a/src/Model/GroundWaterFlow/gwf3chd8.f90 +++ b/src/Model/GroundWaterFlow/gwf3chd8.f90 @@ -1,471 +1,471 @@ -module ChdModule - ! - use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, DONE, NAMEDBOUNDFLAG, LENFTYPE, & - LENPACKAGENAME - use ObsModule, only: DefaultObsIdProcessor - use BndModule, only: BndType - use ObserveModule, only: ObserveType - use TimeSeriesLinkModule, only: TimeSeriesLinkType, & - GetTimeSeriesLinkFromList - ! - implicit none - ! - private - public :: chd_create, ChdType - ! - character(len=LENFTYPE) :: ftype = 'CHD' - character(len=LENPACKAGENAME) :: text = ' CHD' - ! - type, extends(BndType) :: ChdType - contains - procedure :: bnd_rp => chd_rp - procedure :: bnd_ad => chd_ad - procedure :: bnd_ck => chd_ck - procedure :: bnd_fc => chd_fc - procedure :: bnd_bd => chd_bd - procedure :: define_listlabel - ! -- methods for observations - procedure, public :: bnd_obs_supported => chd_obs_supported - procedure, public :: bnd_df_obs => chd_df_obs - ! -- method for time series - procedure, public :: bnd_rp_ts => chd_rp_ts - end type ChdType - -contains - - subroutine chd_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) -! ****************************************************************************** -! chd_create -- Create a New Constant Head Package -! Subroutine: (1) create new-style package -! (2) point packobj to the new package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout - character(len=*), intent(in) :: namemodel - character(len=*), intent(in) :: pakname - ! -- local - type(ChdType), pointer :: chdobj -! ------------------------------------------------------------------------------ - ! - ! -- allocate the object and assign values to object variables - allocate(chdobj) - packobj => chdobj - ! - ! -- create name and origin - call packobj%set_names(ibcnum, namemodel, pakname, ftype) - packobj%text = text - ! - ! -- allocate scalars - call packobj%allocate_scalars() - ! - ! -- initialize package - call packobj%pack_initialize() - ! - ! -- store values - packobj%inunit = inunit - packobj%iout = iout - packobj%id = id - packobj%ibcnum = ibcnum - packobj%ncolbnd = 1 - packobj%iscloc = 1 - packobj%ictorigin = 'NPF' - ! - ! -- return - return - end subroutine chd_create - - subroutine chd_rp(this) -! ****************************************************************************** -! chd_rp -- Read and prepare -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use SimModule, only: ustop, store_error - implicit none - class(ChdType), intent(inout) :: this - integer(I4B) :: i, node, ibd, ierr - character(len=30) :: nodestr -! ------------------------------------------------------------------------------ - ! - ! -- Reset previous CHDs to active cell - do i=1,this%nbound - node = this%nodelist(i) - this%ibound(node) = this%ibcnum - enddo - ! - ! -- Call the parent class read and prepare - call this%BndType%bnd_rp() - ! - ! -- Set ibound to -(ibcnum + 1) for constant head cells - ierr = 0 - do i=1,this%nbound - node = this%nodelist(i) - ibd = this%ibound(node) - if(ibd < 0) then - call this%dis%noder_to_string(node, nodestr) - call store_error('Error. Cell is already a constant head: ' & - // trim(adjustl(nodestr))) - ierr = ierr + 1 - else - this%ibound(node) = -this%ibcnum - endif - enddo - ! - ! -- Stop if errors detected - if(ierr > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- return - return - end subroutine chd_rp - - subroutine chd_ad(this) -! ****************************************************************************** -! chd_ad -- Advance -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(ChdType) :: this - ! -- local - integer(I4B) :: i, node - real(DP) :: hb - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- Advance the time series - call this%TsManager%ad() - ! - ! -- Process each entry in the specified-head cell list - do i = 1, this%nbound - node = this%nodelist(i) - hb = this%bound(1, i) - this%xnew(node) = hb - this%xold(node) = this%xnew(node) - enddo - ! - ! -- For each observation, push simulated value and corresponding - ! simulation time from "current" to "preceding" and reset - ! "current" value. - call this%obs%obs_ad() - ! - ! -- return - return - end subroutine chd_ad - - subroutine chd_ck(this) -! ****************************************************************************** -! chd_ck -- Check chd boundary condition data -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors, store_error_unit - ! -- dummy - class(ChdType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: errmsg - character(len=30) :: nodestr - integer(I4B) :: i - integer(I4B) :: node - real(DP) :: bt - ! -- formats - character(len=*), parameter :: fmtchderr = & - "('CHD BOUNDARY ',i0,' HEAD (',g0,') IS LESS THAN CELL " // & - "BOTTOM (',g0,')',' FOR CELL ',a)" -! ------------------------------------------------------------------------------ - ! - ! -- check stress period data - do i=1,this%nbound - node=this%nodelist(i) - bt = this%dis%bot(node) - ! -- accumulate errors - if (this%bound(1,i) < bt .and. this%icelltype(node) /= 0) then - call this%dis%noder_to_string(node, nodestr) - write(errmsg, fmt=fmtchderr) i, this%bound(1,i), bt, trim(nodestr) - call store_error(errmsg) - end if - end do - ! - !write summary of chd package error messages - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- return - return - end subroutine chd_ck - - subroutine chd_fc(this, rhs, ia, idxglo, amatsln) -! ************************************************************************** -! chd_fc -- Override bnd_fc and do nothing -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - ! -- dummy - class(ChdType) :: this - real(DP), dimension(:), intent(inout) :: rhs - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln - ! -- local -! -------------------------------------------------------------------------- - ! - ! -- return - return - end subroutine chd_fc - - subroutine chd_bd(this, x, idvfl, icbcfl, ibudfl, icbcun, iprobs, & - isuppress_output, model_budget, imap, iadv) -! ****************************************************************************** -! chd_bd -- Calculate constant head flow budget -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: delt - use ConstantsModule, only: LENBOUNDNAME - use BudgetModule, only: BudgetType - ! -- dummy - class(ChdType) :: this - real(DP),dimension(:),intent(in) :: x - integer(I4B), intent(in) :: idvfl - integer(I4B), intent(in) :: icbcfl - integer(I4B), intent(in) :: ibudfl - integer(I4B), intent(in) :: icbcun - integer(I4B), intent(in) :: iprobs - integer(I4B), intent(in) :: isuppress_output - type(BudgetType), intent(inout) :: model_budget - integer(I4B), dimension(:), optional, intent(in) :: imap - integer(I4B), optional, intent(in) :: iadv - ! -- local - character(len=20) :: nodestr - integer(I4B) :: nodeu - integer(I4B) :: i, node, ibinun, n2 - real(DP) :: rrate, chin, chout, q - integer(I4B) :: naux, ipos - ! -- for observations - character(len=LENBOUNDNAME) :: bname - ! -- formats - character(len=*), parameter :: fmttkk = & - "(1X,/1X,A,' PERIOD ',I0,' STEP ',I0)" -! ------------------------------------------------------------------------------ - ! - ! -- initialize local variables - chin = DZERO - chout = DZERO - ! - ! -- Set unit number for binary output - if(this%ipakcb < 0) then - ibinun = icbcun - elseif(this%ipakcb == 0) then - ibinun = 0 - else - ibinun = this%ipakcb - endif - if(icbcfl == 0) ibinun = 0 - ! - ! -- If cell-by-cell flows will be saved as a list, write header. - if(ibinun /= 0) then - naux = this%naux - call this%dis%record_srcdst_list_header(this%text, this%name_model, & - this%name_model, this%name_model, this%name, naux, & - this%auxname, ibinun, this%nbound, this%iout) - endif - ! - ! -- If no boundaries, skip flow calculations. - if(this%nbound > 0) then - ! - ! -- reset size of table - if (this%iprflow /= 0) then - call this%outputtab%set_maxbound(this%nbound) - end if - ! - ! -- Loop through each boundary calculating flow. - do i = 1, this%nbound - node = this%nodelist(i) - rrate = DZERO - ! -- assign boundary name - if (this%inamedbound>0) then - bname = this%boundname(i) - else - bname = '' - endif - ! - ! -- Calculate the flow rate into the cell. - do ipos = this%dis%con%ia(node) + 1, & - this%dis%con%ia(node + 1) - 1 - q = this%flowja(ipos) - rrate = rrate - q - ! -- only accumulate chin and chout for active - ! connected cells - n2 = this%dis%con%ja(ipos) - if (this%ibound(n2) < 1) cycle - if (q < DZERO) then - chin = chin - q - else - chout = chout + q - end if - end do - ! - ! -- For chd, store total flow in rhs so it is available for other - ! calculations - this%rhs(i) = -rrate - this%hcof(i) = DZERO - ! - ! -- Print the individual rates if requested(this%iprflow<0) - if (ibudfl /= 0) then - if(this%iprflow /= 0) then - ! - ! -- set nodestr and write outputtab table - nodeu = this%dis%get_nodeuser(node) - call this%dis%nodeu_to_string(nodeu, nodestr) - call this%outputtab%print_list_entry(i, nodestr, rrate, bname) - end if - end if - ! - ! -- If saving cell-by-cell flows in list, write flow - if (ibinun /= 0) then - n2 = i - if (present(imap)) n2 = imap(i) - call this%dis%record_mf6_list_entry(ibinun, node, n2, rrate, & - naux, this%auxvar(:,i), & - olconv2=.FALSE.) - end if - ! - ! -- Save simulated value to simvals array. - this%simvals(i) = rrate - ! - end do - ! - end if - ! - ! -- Store the rates - call model_budget%addentry(chin, chout, delt, this%text, & - isuppress_output, this%name) - ! - ! -- Save the simulated values to the ObserveType objects - if (this%obs%npakobs > 0 .and. iprobs > 0) then - call this%bnd_bd_obs() - end if - ! - ! -- return - return - end subroutine chd_bd - - subroutine define_listlabel(this) -! ****************************************************************************** -! define_listlabel -- Define the list heading that is written to iout when -! PRINT_INPUT option is used. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(ChdType), intent(inout) :: this -! ------------------------------------------------------------------------------ - ! - ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' - else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'HEAD' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif - ! - ! -- return - return - end subroutine define_listlabel - - ! -- Procedures related to observations - -logical function chd_obs_supported(this) -! ****************************************************************************** -! chd_obs_supported -! -- Return true because CHD package supports observations. -! -- Overrides packagetype%_obs_supported() -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - class(ChdType) :: this -! ------------------------------------------------------------------------------ - chd_obs_supported = .true. - return -end function chd_obs_supported - -subroutine chd_df_obs(this) -! ****************************************************************************** -! chd_df_obs (implements bnd_df_obs) -! -- Store observation type supported by CHD package. -! -- Overrides BndType%bnd_df_obs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - class(ChdType) :: this - ! -- local - integer(I4B) :: indx -! ------------------------------------------------------------------------------ - call this%obs%StoreObsType('chd', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor - return -end subroutine chd_df_obs - - ! -- Procedure related to time series - - subroutine chd_rp_ts(this) - ! -- Assign tsLink%Text appropriately for - ! all time series in use by package. - ! In CHD package variable HEAD - ! can be controlled by time series. - ! -- dummy - class(ChdType), intent(inout) :: this - ! -- local - integer(I4B) :: i, nlinks - type(TimeSeriesLinkType), pointer :: tslink => null() - ! - nlinks = this%TsManager%boundtslinks%Count() - do i=1,nlinks - tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) - if (associated(tslink)) then - select case (tslink%JCol) - case (1) - tslink%Text = 'HEAD' - end select - endif - enddo - ! - return - end subroutine chd_rp_ts - -end module ChdModule +module ChdModule + ! + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, DONE, NAMEDBOUNDFLAG, LENFTYPE, & + LENPACKAGENAME + use ObsModule, only: DefaultObsIdProcessor + use BndModule, only: BndType + use ObserveModule, only: ObserveType + use TimeSeriesLinkModule, only: TimeSeriesLinkType, & + GetTimeSeriesLinkFromList + ! + implicit none + ! + private + public :: chd_create, ChdType + ! + character(len=LENFTYPE) :: ftype = 'CHD' + character(len=LENPACKAGENAME) :: text = ' CHD' + ! + type, extends(BndType) :: ChdType + contains + procedure :: bnd_rp => chd_rp + procedure :: bnd_ad => chd_ad + procedure :: bnd_ck => chd_ck + procedure :: bnd_fc => chd_fc + procedure :: bnd_bd => chd_bd + procedure :: define_listlabel + ! -- methods for observations + procedure, public :: bnd_obs_supported => chd_obs_supported + procedure, public :: bnd_df_obs => chd_df_obs + ! -- method for time series + procedure, public :: bnd_rp_ts => chd_rp_ts + end type ChdType + +contains + + subroutine chd_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) +! ****************************************************************************** +! chd_create -- Create a New Constant Head Package +! Subroutine: (1) create new-style package +! (2) point packobj to the new package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BndType), pointer :: packobj + integer(I4B),intent(in) :: id + integer(I4B),intent(in) :: ibcnum + integer(I4B),intent(in) :: inunit + integer(I4B),intent(in) :: iout + character(len=*), intent(in) :: namemodel + character(len=*), intent(in) :: pakname + ! -- local + type(ChdType), pointer :: chdobj +! ------------------------------------------------------------------------------ + ! + ! -- allocate the object and assign values to object variables + allocate(chdobj) + packobj => chdobj + ! + ! -- create name and origin + call packobj%set_names(ibcnum, namemodel, pakname, ftype) + packobj%text = text + ! + ! -- allocate scalars + call packobj%allocate_scalars() + ! + ! -- initialize package + call packobj%pack_initialize() + ! + ! -- store values + packobj%inunit = inunit + packobj%iout = iout + packobj%id = id + packobj%ibcnum = ibcnum + packobj%ncolbnd = 1 + packobj%iscloc = 1 + packobj%ictorigin = 'NPF' + ! + ! -- return + return + end subroutine chd_create + + subroutine chd_rp(this) +! ****************************************************************************** +! chd_rp -- Read and prepare +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use SimModule, only: ustop, store_error + implicit none + class(ChdType), intent(inout) :: this + integer(I4B) :: i, node, ibd, ierr + character(len=30) :: nodestr +! ------------------------------------------------------------------------------ + ! + ! -- Reset previous CHDs to active cell + do i=1,this%nbound + node = this%nodelist(i) + this%ibound(node) = this%ibcnum + enddo + ! + ! -- Call the parent class read and prepare + call this%BndType%bnd_rp() + ! + ! -- Set ibound to -(ibcnum + 1) for constant head cells + ierr = 0 + do i=1,this%nbound + node = this%nodelist(i) + ibd = this%ibound(node) + if(ibd < 0) then + call this%dis%noder_to_string(node, nodestr) + call store_error('Error. Cell is already a constant head: ' & + // trim(adjustl(nodestr))) + ierr = ierr + 1 + else + this%ibound(node) = -this%ibcnum + endif + enddo + ! + ! -- Stop if errors detected + if(ierr > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- return + return + end subroutine chd_rp + + subroutine chd_ad(this) +! ****************************************************************************** +! chd_ad -- Advance +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(ChdType) :: this + ! -- local + integer(I4B) :: i, node + real(DP) :: hb + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- Advance the time series + call this%TsManager%ad() + ! + ! -- Process each entry in the specified-head cell list + do i = 1, this%nbound + node = this%nodelist(i) + hb = this%bound(1, i) + this%xnew(node) = hb + this%xold(node) = this%xnew(node) + enddo + ! + ! -- For each observation, push simulated value and corresponding + ! simulation time from "current" to "preceding" and reset + ! "current" value. + call this%obs%obs_ad() + ! + ! -- return + return + end subroutine chd_ad + + subroutine chd_ck(this) +! ****************************************************************************** +! chd_ck -- Check chd boundary condition data +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors, store_error_unit + ! -- dummy + class(ChdType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + character(len=30) :: nodestr + integer(I4B) :: i + integer(I4B) :: node + real(DP) :: bt + ! -- formats + character(len=*), parameter :: fmtchderr = & + "('CHD BOUNDARY ',i0,' HEAD (',g0,') IS LESS THAN CELL " // & + "BOTTOM (',g0,')',' FOR CELL ',a)" +! ------------------------------------------------------------------------------ + ! + ! -- check stress period data + do i=1,this%nbound + node=this%nodelist(i) + bt = this%dis%bot(node) + ! -- accumulate errors + if (this%bound(1,i) < bt .and. this%icelltype(node) /= 0) then + call this%dis%noder_to_string(node, nodestr) + write(errmsg, fmt=fmtchderr) i, this%bound(1,i), bt, trim(nodestr) + call store_error(errmsg) + end if + end do + ! + !write summary of chd package error messages + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- return + return + end subroutine chd_ck + + subroutine chd_fc(this, rhs, ia, idxglo, amatsln) +! ************************************************************************** +! chd_fc -- Override bnd_fc and do nothing +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + ! -- dummy + class(ChdType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + real(DP), dimension(:), intent(inout) :: amatsln + ! -- local +! -------------------------------------------------------------------------- + ! + ! -- return + return + end subroutine chd_fc + + subroutine chd_bd(this, x, idvfl, icbcfl, ibudfl, icbcun, iprobs, & + isuppress_output, model_budget, imap, iadv) +! ****************************************************************************** +! chd_bd -- Calculate constant head flow budget +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: delt + use ConstantsModule, only: LENBOUNDNAME + use BudgetModule, only: BudgetType + ! -- dummy + class(ChdType) :: this + real(DP),dimension(:),intent(in) :: x + integer(I4B), intent(in) :: idvfl + integer(I4B), intent(in) :: icbcfl + integer(I4B), intent(in) :: ibudfl + integer(I4B), intent(in) :: icbcun + integer(I4B), intent(in) :: iprobs + integer(I4B), intent(in) :: isuppress_output + type(BudgetType), intent(inout) :: model_budget + integer(I4B), dimension(:), optional, intent(in) :: imap + integer(I4B), optional, intent(in) :: iadv + ! -- local + character(len=20) :: nodestr + integer(I4B) :: nodeu + integer(I4B) :: i, node, ibinun, n2 + real(DP) :: rrate, chin, chout, q + integer(I4B) :: naux, ipos + ! -- for observations + character(len=LENBOUNDNAME) :: bname + ! -- formats + character(len=*), parameter :: fmttkk = & + "(1X,/1X,A,' PERIOD ',I0,' STEP ',I0)" +! ------------------------------------------------------------------------------ + ! + ! -- initialize local variables + chin = DZERO + chout = DZERO + ! + ! -- Set unit number for binary output + if(this%ipakcb < 0) then + ibinun = icbcun + elseif(this%ipakcb == 0) then + ibinun = 0 + else + ibinun = this%ipakcb + endif + if(icbcfl == 0) ibinun = 0 + ! + ! -- If cell-by-cell flows will be saved as a list, write header. + if(ibinun /= 0) then + naux = this%naux + call this%dis%record_srcdst_list_header(this%text, this%name_model, & + this%name_model, this%name_model, this%name, naux, & + this%auxname, ibinun, this%nbound, this%iout) + endif + ! + ! -- If no boundaries, skip flow calculations. + if(this%nbound > 0) then + ! + ! -- reset size of table + if (this%iprflow /= 0) then + call this%outputtab%set_maxbound(this%nbound) + end if + ! + ! -- Loop through each boundary calculating flow. + do i = 1, this%nbound + node = this%nodelist(i) + rrate = DZERO + ! -- assign boundary name + if (this%inamedbound>0) then + bname = this%boundname(i) + else + bname = '' + endif + ! + ! -- Calculate the flow rate into the cell. + do ipos = this%dis%con%ia(node) + 1, & + this%dis%con%ia(node + 1) - 1 + q = this%flowja(ipos) + rrate = rrate - q + ! -- only accumulate chin and chout for active + ! connected cells + n2 = this%dis%con%ja(ipos) + if (this%ibound(n2) < 1) cycle + if (q < DZERO) then + chin = chin - q + else + chout = chout + q + end if + end do + ! + ! -- For chd, store total flow in rhs so it is available for other + ! calculations + this%rhs(i) = -rrate + this%hcof(i) = DZERO + ! + ! -- Print the individual rates if requested(this%iprflow<0) + if (ibudfl /= 0) then + if(this%iprflow /= 0) then + ! + ! -- set nodestr and write outputtab table + nodeu = this%dis%get_nodeuser(node) + call this%dis%nodeu_to_string(nodeu, nodestr) + call this%outputtab%print_list_entry(i, nodestr, rrate, bname) + end if + end if + ! + ! -- If saving cell-by-cell flows in list, write flow + if (ibinun /= 0) then + n2 = i + if (present(imap)) n2 = imap(i) + call this%dis%record_mf6_list_entry(ibinun, node, n2, rrate, & + naux, this%auxvar(:,i), & + olconv2=.FALSE.) + end if + ! + ! -- Save simulated value to simvals array. + this%simvals(i) = rrate + ! + end do + ! + end if + ! + ! -- Store the rates + call model_budget%addentry(chin, chout, delt, this%text, & + isuppress_output, this%name) + ! + ! -- Save the simulated values to the ObserveType objects + if (this%obs%npakobs > 0 .and. iprobs > 0) then + call this%bnd_bd_obs() + end if + ! + ! -- return + return + end subroutine chd_bd + + subroutine define_listlabel(this) +! ****************************************************************************** +! define_listlabel -- Define the list heading that is written to iout when +! PRINT_INPUT option is used. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(ChdType), intent(inout) :: this +! ------------------------------------------------------------------------------ + ! + ! -- create the header list label + this%listlabel = trim(this%filtyp) // ' NO.' + if(this%dis%ndim == 3) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif(this%dis%ndim == 2) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + else + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + endif + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'HEAD' + if(this%inamedbound == 1) then + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + endif + ! + ! -- return + return + end subroutine define_listlabel + + ! -- Procedures related to observations + +logical function chd_obs_supported(this) +! ****************************************************************************** +! chd_obs_supported +! -- Return true because CHD package supports observations. +! -- Overrides packagetype%_obs_supported() +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + class(ChdType) :: this +! ------------------------------------------------------------------------------ + chd_obs_supported = .true. + return +end function chd_obs_supported + +subroutine chd_df_obs(this) +! ****************************************************************************** +! chd_df_obs (implements bnd_df_obs) +! -- Store observation type supported by CHD package. +! -- Overrides BndType%bnd_df_obs +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + ! -- dummy + class(ChdType) :: this + ! -- local + integer(I4B) :: indx +! ------------------------------------------------------------------------------ + call this%obs%StoreObsType('chd', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor + return +end subroutine chd_df_obs + + ! -- Procedure related to time series + + subroutine chd_rp_ts(this) + ! -- Assign tsLink%Text appropriately for + ! all time series in use by package. + ! In CHD package variable HEAD + ! can be controlled by time series. + ! -- dummy + class(ChdType), intent(inout) :: this + ! -- local + integer(I4B) :: i, nlinks + type(TimeSeriesLinkType), pointer :: tslink => null() + ! + nlinks = this%TsManager%boundtslinks%Count() + do i=1,nlinks + tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) + if (associated(tslink)) then + select case (tslink%JCol) + case (1) + tslink%Text = 'HEAD' + end select + endif + enddo + ! + return + end subroutine chd_rp_ts + +end module ChdModule diff --git a/src/Model/GroundWaterFlow/gwf3csub8.f90 b/src/Model/GroundWaterFlow/gwf3csub8.f90 index df85a496a97..a0f2a2e697a 100644 --- a/src/Model/GroundWaterFlow/gwf3csub8.f90 +++ b/src/Model/GroundWaterFlow/gwf3csub8.f90 @@ -1,7119 +1,7119 @@ -module GwfCsubModule - use KindModule, only: I4B, DP - use ConstantsModule, only: DPREC, DZERO, DEM20, DEM15, DEM10, DEM8, DEM7, & - DEM6, DEM4, DP9, DHALF, DEM1, DONE, DTWO, DTHREE, & - DGRAVITY, DTEN, DHUNDRED, DNODATA, DHNOFLO, & - LENFTYPE, LENPACKAGENAME, & - LINELENGTH, LENBOUNDNAME, NAMEDBOUNDFLAG, & - LENBUDTXT, LENAUXNAME, LENORIGIN, LENPAKLOC, & - TABLEFT, TABCENTER, TABRIGHT, & - TABSTRING, TABUCSTRING, TABINTEGER, TABREAL - use GenericUtilitiesModule, only: is_same, sim_message - use SmoothingModule, only: sQuadraticSaturation, & - sQuadraticSaturationDerivative - use NumericalPackageModule, only: NumericalPackageType - use ObserveModule, only: ObserveType - use ObsModule, only: ObsType, obs_cr - use BlockParserModule, only: BlockParserType - use TimeSeriesLinkModule, only: TimeSeriesLinkType, & - GetTimeSeriesLinkFromList - use InputOutputModule, only: get_node, extract_idnum_or_bndname - use BaseDisModule, only: DisBaseType - use SimModule, only: count_errors, store_error, store_error_unit, ustop - use ArrayHandlersModule, only: ExpandArray - use SortModule, only: qsort, selectn - ! - use TimeSeriesLinkModule, only: TimeSeriesLinkType - use TimeSeriesManagerModule, only: TimeSeriesManagerType, tsmanager_cr - use ListModule, only: ListType - use TableModule, only: TableType, table_cr - ! - implicit none - ! - private - public :: csub_cr - public :: GwfCsubType - ! - character(len=LENBUDTXT), dimension(4) :: budtxt = & !text labels for budget terms - [' CSUB-CGELASTIC', & - ' CSUB-ELASTIC', ' CSUB-INELASTIC', & - ' CSUB-WATERCOMP'] - character(len=LENBUDTXT), dimension(6) :: comptxt = & !text labels for compaction terms - ['CSUB-COMPACTION', ' CSUB-INELASTIC', ' CSUB-ELASTIC', & - ' CSUB-INTERBED', ' CSUB-COARSE', ' CSUB-ZDISPLACE'] - - ! - ! -- local parameter - derivative of the log of effective stress - real(DP), parameter :: dlog10es = 0.4342942_DP - ! - ! CSUB type - type, extends(NumericalPackageType) :: GwfCsubType - character(len=LENBOUNDNAME), dimension(:), & - pointer, contiguous :: boundname => null() !vector of boundnames - character(len=LENBOUNDNAME), dimension(:) , & - pointer, contiguous :: sig0bname => null() !vector of sig0bnames - character(len=LENAUXNAME), allocatable, dimension(:) :: auxname !name for each auxiliary variable - character(len=500) :: listlabel = '' !title of table written for RP - character(len=LENORIGIN) :: stoname - integer(I4B), pointer :: istounit => null() - integer(I4B), pointer :: istrainib => null() - integer(I4B), pointer :: istrainsk => null() - integer(I4B), pointer :: ioutcomp => null() - integer(I4B), pointer :: ioutcompi => null() - integer(I4B), pointer :: ioutcompe => null() - integer(I4B), pointer :: ioutcompib => null() - integer(I4B), pointer :: ioutcomps => null() - integer(I4B), pointer :: ioutzdisp => null() - integer(I4B), pointer :: ipakcsv => null() - integer(I4B), pointer :: iupdatematprop => null() - integer(I4B), pointer :: istoragec => null() - integer(I4B), pointer :: icellf => null() - integer(I4B), pointer :: ispecified_pcs => null() - integer(I4B), pointer :: ispecified_dbh => null() - integer(I4B), pointer :: inamedbound => null() !flag to read boundnames - integer(I4B), pointer :: iconvchk => NULL() - integer(I4B), pointer :: naux => null() !number of auxiliary variables - integer(I4B), pointer :: ninterbeds => null() - integer(I4B), pointer :: maxsig0 => null() - integer(I4B), pointer :: nbound => null() !number of boundaries for current stress period - integer(I4B), pointer :: ncolbnd => null() !number of columns of the bound array - integer(I4B), pointer :: iscloc => null() !bound column to scale with SFAC - integer(I4B), pointer :: iauxmultcol => null() !column to use as multiplier for column iscloc - integer(I4B), pointer :: ndelaycells => null() - integer(I4B), pointer :: ndelaybeds => null() - integer(I4B), pointer :: initialized => null() - integer(I4B), pointer :: ieslag => null() - integer(I4B), pointer :: ipch => null() - logical, pointer :: lhead_based => null() - integer(I4B), pointer :: iupdatestress => null() - real(DP), pointer :: epsilon => null() !epsilon for stress smoothing - real(DP), pointer :: cc_crit => null() !convergence criteria for csub-gwf convergence check - real(DP), pointer :: gammaw => null() !product of fluid density, and gravity - real(DP), pointer :: beta => null() !water compressibility - real(DP), pointer :: brg => null() !product of gammaw and water compressibility - real(DP), pointer :: dbfact => null() - real(DP), pointer :: dbfacti => null() - real(DP), pointer :: satomega => null() !newton-raphson saturation omega - - integer(I4B), pointer :: gwfiss => NULL() !pointer to model iss flag - integer(I4B), pointer :: gwfiss0 => NULL() !iss flag for last stress period - integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !pointer to model ibound - integer(I4B), dimension(:), pointer, contiguous :: stoiconv => null() !pointer to iconvert in storage - real(DP), dimension(:), pointer, contiguous :: stosc1 => null() !pointer to sc1 in storage - real(DP), dimension(:), pointer, contiguous :: buff => null() !buff array - real(DP), dimension(:), pointer, contiguous :: buffusr => null() !buffusr array - integer, dimension(:), pointer, contiguous :: nodelist => null() !reduced node that the interbed is attached to - integer, dimension(:), pointer, contiguous :: unodelist => null() !user node that the interbed is attached to - ! - ! -- coarse-grained storage variables - real(DP), dimension(:), pointer, contiguous :: sgm => null() !specific gravity moist sediments - real(DP), dimension(:), pointer, contiguous :: sgs => null() !specific gravity saturated sediments - real(DP), dimension(:), pointer, contiguous :: cg_ske_cr => null() !coarse-grained specified storage - real(DP), dimension(:), pointer, contiguous :: cg_gs => null() !geostatic stress for a cell - real(DP), dimension(:), pointer, contiguous :: cg_es => null() !coarse-grained (aquifer) effective stress - real(DP), dimension(:), pointer, contiguous :: cg_es0 => null() !coarse-grained (aquifer) effective stress for the previous time step - real(DP), dimension(:), pointer, contiguous :: cg_pcs => null() !coarse-grained (aquifer) preconsolidation stress - real(DP), dimension(:), pointer, contiguous :: cg_comp => null() !coarse-grained (aquifer) incremental compaction - real(DP), dimension(:), pointer, contiguous :: cg_tcomp => null() !coarse-grained (aquifer) total compaction - real(DP), dimension(:), pointer, contiguous :: cg_stor => null() !coarse-grained (aquifer) storage - real(DP), dimension(:), pointer, contiguous :: cg_ske => null() !coarse-grained (aquifer) elastic storage coefficient - real(DP), dimension(:), pointer, contiguous :: cg_sk => null() !coarse-grained (aquifer) first storage coefficient - real(DP), dimension(:), pointer, contiguous :: cg_thickini => null() !initial coarse-grained (aquifer) thickness - real(DP), dimension(:), pointer, contiguous :: cg_thetaini => null() !initial coarse-grained (aquifer) porosity - real(DP), dimension(:), pointer, contiguous :: cg_thick => null() !current coarse-grained (aquifer) thickness - real(DP), dimension(:), pointer, contiguous :: cg_thick0 => null() !previous coarse-grained (aquifer) thickness - real(DP), dimension(:), pointer, contiguous :: cg_theta => null() !current coarse-grained (aquifer) porosity - real(DP), dimension(:), pointer, contiguous :: cg_theta0 => null() !previous coarse-grained (aquifer) porosity - ! - ! -- cell storage variables - real(DP), dimension(:), pointer, contiguous :: cell_wcstor => null() !cell water compressibility storage - real(DP), dimension(:), pointer, contiguous :: cell_thick => null() !cell compressible material thickness - ! - ! -- interbed variables - integer(I4B), dimension(:), pointer, contiguous :: idelay => null() !0 = nodelay, > 0 = delay - integer(I4B), dimension(:), pointer, contiguous :: ielastic => null() !0 = inelastic and elastic, > 0 = elastic - integer(I4B), dimension(:), pointer, contiguous :: iconvert => null() !0 = elastic, > 0 = inelastic - real(DP), dimension(:), pointer, contiguous :: ci => null() !compression index - real(DP), dimension(:), pointer, contiguous :: rci => null() !recompression index - real(DP), dimension(:), pointer, contiguous :: pcs => null() !preconsolidation stress - real(DP), dimension(:), pointer, contiguous :: rnb => null() !interbed system material factor - real(DP), dimension(:), pointer, contiguous :: kv => null() !vertical hydraulic conductivity of interbed - real(DP), dimension(:), pointer, contiguous :: h0 => null() !initial head in interbed - real(DP), dimension(:), pointer, contiguous :: comp => null() !interbed incremental compaction - real(DP), dimension(:), pointer, contiguous :: tcomp => null() !total interbed compaction - real(DP), dimension(:), pointer, contiguous :: tcompi => null() !total inelastic interbed compaction - real(DP), dimension(:), pointer, contiguous :: tcompe => null() !total elastic interbed compaction - real(DP), dimension(:), pointer, contiguous :: storagee => null() !elastic storage - real(DP), dimension(:), pointer, contiguous :: storagei => null() !inelastic storage - real(DP), dimension(:), pointer, contiguous :: ske => null() !elastic storage coefficient - real(DP), dimension(:), pointer, contiguous :: sk => null() !first storage coefficient - real(DP), dimension(:), pointer, contiguous :: thickini => null() !initial interbed thickness - real(DP), dimension(:), pointer, contiguous :: thetaini => null() !initial interbed theta - real(DP), dimension(:), pointer, contiguous :: thick => null() !current interbed thickness - real(DP), dimension(:), pointer, contiguous :: thick0 => null() !previous interbed thickness - real(DP), dimension(:), pointer, contiguous :: theta => null() !current interbed porosity - real(DP), dimension(:), pointer, contiguous :: theta0 => null() !previous interbed porosity - real(DP), dimension(:,:), pointer, contiguous :: auxvar => null() !auxiliary variable array - ! - ! -- delay interbed arrays - integer(I4B), dimension(:,:), pointer, contiguous :: idbconvert => null() !0 = elastic, > 0 = inelastic - real(DP), dimension(:), pointer, contiguous :: dbdhmax => null() !delay bed maximum head change - real(DP), dimension(:,:), pointer, contiguous :: dbz => null() !delay bed cell z - real(DP), dimension(:,:), pointer, contiguous :: dbrelz => null() !delay bed cell z relative to znode - real(DP), dimension(:,:), pointer, contiguous :: dbh => null() !delay bed cell h - real(DP), dimension(:,:), pointer, contiguous :: dbh0 => null() !delay bed cell previous h - real(DP), dimension(:,:), pointer, contiguous :: dbgeo => null() !delay bed cell geostatic stress - real(DP), dimension(:,:), pointer, contiguous :: dbes => null() !delay bed cell effective stress - real(DP), dimension(:,:), pointer, contiguous :: dbes0 => null() !delay bed cell previous effective stress - real(DP), dimension(:,:), pointer, contiguous :: dbpcs => null() !delay bed cell preconsolidation stress - real(DP), dimension(:), pointer, contiguous :: dbflowtop => null() !delay bed flow through interbed top - real(DP), dimension(:), pointer, contiguous :: dbflowbot => null() !delay bed flow through interbed bottom - real(DP), dimension(:,:), pointer, contiguous :: dbdzini => null() !initial delay bed cell thickness - real(DP), dimension(:,:), pointer, contiguous :: dbthetaini => null() !initial delay bed cell porosity - real(DP), dimension(:,:), pointer, contiguous :: dbdz => null() !delay bed dz - real(DP), dimension(:,:), pointer, contiguous :: dbdz0 => null() !delay bed previous dz - real(DP), dimension(:,:), pointer, contiguous :: dbtheta => null() !delay bed cell porosity - real(DP), dimension(:,:), pointer, contiguous :: dbtheta0 => null() !delay bed cell previous porosity - real(DP), dimension(:, :), pointer, contiguous :: dbcomp => null() !delay bed incremental compaction - real(DP), dimension(:, :), pointer, contiguous :: dbtcomp => null() !delay bed total interbed compaction - ! - ! -- delay interbed solution arrays - real(DP), dimension(:), pointer, contiguous :: dbal => null() !delay bed lower diagonal - real(DP), dimension(:), pointer, contiguous :: dbad => null() !delay bed diagonal - real(DP), dimension(:), pointer, contiguous :: dbau => null() !delay bed upper diagonal - real(DP), dimension(:), pointer, contiguous :: dbrhs => null() !delay bed right hand side - real(DP), dimension(:), pointer, contiguous :: dbdh => null() !delay bed dh - real(DP), dimension(:), pointer, contiguous :: dbaw => null() !delay bed work vector - ! - ! -- period data - integer(I4B), dimension(:), pointer, contiguous :: nodelistsig0 => null() !vector of reduced node numbers - real(DP), dimension(:,:), pointer, contiguous :: bound => null() !array of package specific boundary numbers - real(DP), dimension(:,:), pointer, contiguous :: auxvarsig0 => null() !auxiliary variable array - ! - ! -- timeseries - type(TimeSeriesManagerType), pointer :: TsManager => null() ! time series manager - ! - ! -- observation data - integer(I4B), pointer :: inobspkg => null() !unit number for obs package - type(ObsType), pointer :: obs => null() !observation package - ! - ! -- table objects - type(TableType), pointer :: inputtab => null() - type(TableType), pointer :: outputtab => null() - type(TableType), pointer :: pakcsvtab => null() - - contains - procedure :: define_listlabel - procedure :: read_options - procedure :: csub_ar - procedure :: csub_da - procedure :: csub_rp - procedure :: csub_ad - procedure :: csub_fc - procedure :: csub_fn - procedure :: csub_cc - procedure :: csub_fp - procedure :: bdcalc => csub_bdcalc - procedure :: bdsav => csub_bdsav - procedure :: read_dimensions => csub_read_dimensions - procedure, private :: csub_allocate_scalars - procedure, private :: csub_allocate_arrays - procedure, private :: csub_read_packagedata - ! - ! -- helper methods - procedure, private :: csub_calc_void - procedure, private :: csub_calc_theta - procedure, private :: csub_calc_znode - procedure, private :: csub_calc_adjes - procedure, private :: csub_calc_sat - procedure, private :: csub_calc_sat_derivative - procedure, private :: csub_calc_sfacts - procedure, private :: csub_adj_matprop - procedure, private :: csub_calc_interbed_thickness - procedure, private :: csub_calc_delay_flow - procedure, private :: csub_delay_eval - ! - ! -- stress methods - procedure, private :: csub_cg_calc_stress - procedure, private :: csub_cg_chk_stress - ! - ! -- initial states - procedure, private :: csub_set_initial_state - ! - ! -- coarse-grained coarse-grained methods - procedure, private :: csub_cg_update - procedure, private :: csub_cg_calc_comp - procedure, private :: csub_cg_calc_sske - procedure, private :: csub_cg_fc - procedure, private :: csub_cg_fn - procedure, private :: csub_cg_wcomp_fc - procedure, private :: csub_cg_wcomp_fn - ! - ! -- interbed methods - procedure, private :: csub_interbed_fc - procedure, private :: csub_interbed_fn - procedure, private :: csub_interbed_wcomp_fc - procedure, private :: csub_interbed_wcomp_fn - ! - ! -- no-delay interbed methods - procedure, private :: csub_nodelay_update - procedure, private :: csub_nodelay_fc - procedure, private :: csub_nodelay_calc_comp - ! - ! -- delay interbed methods - procedure, private :: csub_delay_chk - procedure, private :: csub_delay_calc_zcell - procedure, private :: csub_delay_calc_stress - procedure, private :: csub_delay_calc_ssksske - procedure, private :: csub_delay_calc_comp - procedure, private :: csub_delay_update - procedure, private :: csub_delay_calc_dstor - procedure, private :: csub_delay_fc - procedure, private :: csub_delay_sln - procedure, private :: csub_delay_assemble - ! - ! -- methods for observations - procedure, public :: csub_obs_supported - procedure, public :: csub_df_obs - procedure, private :: csub_rp_obs - procedure, private :: csub_bd_obs - ! - ! -- method for time series - procedure, private :: csub_rp_ts - end type GwfCsubType - -contains - - subroutine csub_cr(csubobj, name_model, istounit, stoname, inunit, iout) -! ****************************************************************************** -! csub_cr -- Create a New CSUB Object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - implicit none - type(GwfCsubType), pointer :: csubobj - character(len=*), intent(in) :: name_model - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: istounit - character(len=*), intent(in) :: stoname - integer(I4B), intent(in) :: iout - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- allocate the object and assign values to object variables - allocate(csubobj) - - ! -- create name and origin - call csubobj%set_names(1, name_model, 'CSUB', 'CSUB') - ! - ! -- Allocate scalars - call csubobj%csub_allocate_scalars() - ! - ! -- Set variables - csubobj%istounit = istounit - csubobj%stoname = stoname - csubobj%inunit = inunit - csubobj%iout = iout - ! - ! -- Initialize block parser - call csubobj%parser%Initialize(csubobj%inunit, csubobj%iout) - ! - ! -- return - return - end subroutine csub_cr - - - subroutine csub_allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -- allocate scalar members -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(GwfCsubType), intent(inout) :: this -! ------------------------------------------------------------------------------ - ! - ! -- call standard NumericalPackageType allocate scalars - call this%NumericalPackageType%allocate_scalars() - ! - ! -- allocate the object and assign values to object variables - call mem_allocate(this%istounit, 'ISTOUNIT', this%origin) - call mem_allocate(this%inobspkg, 'INOBSPKG', this%origin) - call mem_allocate(this%ninterbeds, 'NINTERBEDS', this%origin) - call mem_allocate(this%maxsig0, 'MAXSIG0', this%origin) - call mem_allocate(this%nbound, 'NBOUND', this%origin) - call mem_allocate(this%ncolbnd, 'NCOLBND', this%origin) - call mem_allocate(this%iscloc, 'ISCLOC', this%origin) - call mem_allocate(this%iauxmultcol, 'IAUXMULTCOL', this%origin) - call mem_allocate(this%ndelaycells, 'NDELAYCELLS', this%origin) - call mem_allocate(this%ndelaybeds, 'NDELAYBEDS', this%origin) - call mem_allocate(this%initialized, 'INITIALIZED', this%origin) - call mem_allocate(this%ieslag, 'IESLAG', this%origin) - call mem_allocate(this%ipch, 'IPCH', this%origin) - call mem_allocate(this%lhead_based, 'LHEAD_BASED', this%origin) - call mem_allocate(this%iupdatestress, 'IUPDATESTRESS', this%origin) - call mem_allocate(this%ispecified_pcs, 'ISPECIFIED_PCS', this%origin) - call mem_allocate(this%ispecified_dbh, 'ISPECIFIED_DBH', this%origin) - call mem_allocate(this%inamedbound, 'INAMEDBOUND', this%origin) - call mem_allocate(this%iconvchk, 'ICONVCHK', this%origin) - call mem_allocate(this%naux, 'NAUX', this%origin) - call mem_allocate(this%istoragec, 'ISTORAGEC', this%origin) - call mem_allocate(this%istrainib, 'ISTRAINIB', this%origin) - call mem_allocate(this%istrainsk, 'ISTRAINSK', this%origin) - call mem_allocate(this%ioutcomp, 'IOUTCOMP', this%origin) - call mem_allocate(this%ioutcompi, 'IOUTCOMPI', this%origin) - call mem_allocate(this%ioutcompe, 'IOUTCOMPE', this%origin) - call mem_allocate(this%ioutcompib, 'IOUTCOMPIB', this%origin) - call mem_allocate(this%ioutcomps, 'IOUTCOMPS', this%origin) - call mem_allocate(this%ioutzdisp, 'IOUTZDISP', this%origin) - call mem_allocate(this%ipakcsv, 'IPAKCSV', this%origin) - call mem_allocate(this%iupdatematprop, 'IUPDATEMATPROP', this%origin) - call mem_allocate(this%epsilon, 'EPSILON', this%origin) - call mem_allocate(this%cc_crit, 'CC_CRIT', this%origin) - call mem_allocate(this%gammaw, 'GAMMAW', this%origin) - call mem_allocate(this%beta, 'BETA', this%origin) - call mem_allocate(this%brg, 'BRG', this%origin) - call mem_allocate(this%satomega, 'SATOMEGA', this%origin) - call mem_allocate(this%icellf, 'ICELLF', this%origin) - call mem_allocate(this%gwfiss0, 'GWFISS0', this%origin) - ! - ! -- allocate TS object - allocate(this%TsManager) - ! - ! -- Allocate text strings - allocate(this%auxname(0)) - ! - ! -- initialize values - this%istounit = 0 - this%inobspkg = 0 - this%ninterbeds = 0 - this%maxsig0 = 0 - this%nbound = 0 - this%ncolbnd = 1 - this%iscloc = 0 - this%iauxmultcol = 0 - this%ndelaycells = 19 - this%ndelaybeds = 0 - this%initialized = 0 - this%ieslag = 0 - this%ipch = 0 - this%lhead_based = .FALSE. - this%iupdatestress = 1 - this%ispecified_pcs = 0 - this%ispecified_dbh = 0 - this%inamedbound = 0 - this%iconvchk = 1 - this%naux = 0 - this%istoragec = 1 - this%istrainib = 0 - this%istrainsk = 0 - this%ioutcomp = 0 - this%ioutcompi = 0 - this%ioutcompe = 0 - this%ioutcompib = 0 - this%ioutcomps = 0 - this%ioutzdisp = 0 - this%ipakcsv = 0 - this%iupdatematprop = 0 - this%epsilon = DZERO - this%cc_crit = DEM7 - this%gammaw = DGRAVITY * 1000._DP - this%beta = 4.6512e-10_DP - this%brg = this%gammaw * this%beta - ! - ! -- set omega value used for saturation calculations - if (this%inewton /= 0) then - this%satomega = DEM6 - this%epsilon = DHALF * DEM6 - else - this%satomega = DZERO - end if - this%icellf = 0 - this%ninterbeds = 0 - this%gwfiss0 = 0 - ! - ! -- return - return - end subroutine csub_allocate_scalars - - subroutine csub_cc(this, kiter, iend, icnvgmod, nodes, hnew, hold, & - cpak, dpak) -! ************************************************************************** -! csub_cc -- Final convergence check for package -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - use TdisModule, only: totim, kstp, kper, delt - ! -- dummy - class(GwfCsubType) :: this - integer(I4B), intent(in) :: kiter - integer(I4B), intent(in) :: iend - integer(I4B), intent(in) :: icnvgmod - integer(I4B), intent(in) :: nodes - real(DP), dimension(nodes), intent(in) :: hnew - real(DP), dimension(nodes), intent(in) :: hold - character(len=LENPAKLOC), intent(inout) :: cpak - real(DP), intent(inout) :: dpak - ! -- local - character(len=LINELENGTH) :: tag - character(len=LENPAKLOC) :: cloc - integer(I4B) :: icheck - integer(I4B) :: ipakfail - integer(I4B) :: ntabrows - integer(I4B) :: ntabcols - integer(I4B) :: ib - integer(I4B) :: node - integer(I4B) :: idelay - integer(I4B) :: locdhmax - integer(I4B) :: locrmax - integer(I4B) :: ifirst - real(DP) :: dhmax - real(DP) :: rmax - real(DP) :: dh - real(DP) :: area - real(DP) :: hcell - real(DP) :: hcellold - real(DP) :: snnew - real(DP) :: snold - real(DP) :: stoe - real(DP) :: stoi - real(DP) :: tled - real(DP) :: hcof - real(DP) :: rhs - real(DP) :: v1 - real(DP) :: v2 - real(DP) :: df - ! format -! -------------------------------------------------------------------------- - ! - ! -- initialize local variables - icheck = this%iconvchk - ipakfail = 0 - locdhmax = 0 - locrmax = 0 - dhmax = DZERO - rmax = DZERO - ifirst = 1 - ! - ! -- additional checks to see if convergence needs to be checked - ! -- no convergence check for steady-state stress periods - if (this%gwfiss /= 0) then - icheck = 0 - else - ! - ! -- if not saving package convergence data on check convergence if - ! the model is considered converged - if (this%ipakcsv == 0) then - if (icnvgmod == 0) then - icheck = 0 - end if - else - ! - ! -- header for package csv - if (.not. associated(this%pakcsvtab)) then - ! - ! -- determine the number of columns and rows - ntabrows = 1 - ntabcols = 8 - ! - ! -- setup table - call table_cr(this%pakcsvtab, this%name, '') - call this%pakcsvtab%table_df(ntabrows, ntabcols, this%ipakcsv, & - lineseparator=.FALSE., separator=',', & - finalize=.FALSE.) - ! - ! -- add columns to package csv - tag = 'totim' - call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'kper' - call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'kstp' - call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'nouter' - call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'dvmax' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - tag = 'dvmax_loc' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - tag = 'dstoragemax' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - tag = 'dstoragemax_loc' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - end if - end if - end if - ! - ! -- perform package convergence check - if (icheck /= 0) then - if (DELT > DZERO) then - tled = DONE / DELT - else - tled = DZERO - end if - final_check: do ib = 1, this%ninterbeds - idelay = this%idelay(ib) - ! - ! -- skip nodelay interbeds - if (idelay == 0) cycle - ! - ! -- evaluate the maximum head change in the interbed - dh = this%dbdhmax(idelay) - ! - ! -- evaluate difference between storage changes - ! in the interbed and exchange between the interbed - ! and the gwf cell - node = this%nodelist(ib) - area = this%dis%get_area(node) - hcell = hnew(node) - hcellold = hold(node) - ! - ! -- calculate cell saturation - call this%csub_calc_sat(node, hcell, hcellold, snnew, snold) - ! - ! -- calculate the change in storage - call this%csub_delay_calc_dstor(ib, hcell, stoe, stoi) - v1 = (stoe + stoi) * area * this%rnb(ib) * snnew * tled - ! - ! -- calculate the flow between the interbed and the cell - call this%csub_delay_fc(ib, hcof, rhs) - v2 = (-hcof * hcell - rhs) * area * this%rnb(ib) * snnew - ! - ! -- calculate the difference between the interbed change in - ! storage and the flow between the interbed and the cell - df = v2 - v1 - ! - ! -- normalize by cell area and convert to a depth - df = df * delt / area - ! - ! -- evaluate magnitude of differences - if (ifirst == 1) then - ifirst = 0 - locdhmax = ib - dhmax = dh - locrmax = ib - rmax = df - else - if (abs(dh) > abs(dhmax)) then - locdhmax = ib - dhmax = dh - end if - if (abs(df) > abs(rmax)) then - locrmax = ib - rmax = df - end if - end if - end do final_check - ! - ! -- set dpak and cpak - ! -- update head error - if (abs(dhmax) > abs(dpak)) then - dpak = dhmax - write(cloc, "(a,'-(',i0,')-',a)") trim(this%name), locdhmax, 'head' - cpak = cloc - end if - ! - ! -- update storage error - if (abs(rmax) > abs(dpak)) then - dpak = rmax - write(cloc, "(a,'-(',i0,')-',a)") trim(this%name), locrmax, 'storage' - cpak = cloc - end if - ! - ! -- write convergence data to package csv - if (this%ipakcsv /= 0) then - ! - ! -- write the data - call this%pakcsvtab%add_term(totim) - call this%pakcsvtab%add_term(kper) - call this%pakcsvtab%add_term(kstp) - call this%pakcsvtab%add_term(kiter) - call this%pakcsvtab%add_term(dhmax) - call this%pakcsvtab%add_term(locdhmax) - call this%pakcsvtab%add_term(rmax) - call this%pakcsvtab%add_term(locrmax) - ! - ! -- finalize the package csv - if (iend == 1) then - call this%pakcsvtab%finalize_table() - end if - end if - end if - ! - ! -- return - return - end subroutine csub_cc - - subroutine csub_bdcalc(this, nodes, hnew, hold, isuppress_output, & - model_budget) -! ****************************************************************************** -! csub_bd -- calculate budget for coarse-grained storage, interbeds, and water -! compression -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: delt - use ConstantsModule, only: LENBOUNDNAME, DZERO, DONE - use BudgetModule, only: BudgetType - ! -- dummy - class(GwfCsubType) :: this - integer(I4B), intent(in) :: nodes - real(DP), intent(in), dimension(nodes) :: hnew - real(DP), intent(in), dimension(nodes) :: hold - integer(I4B), intent(in) :: isuppress_output - type(BudgetType), intent(inout) :: model_budget - ! -- local - integer(I4B) :: ib - integer(I4B) :: idelay - integer(I4B) :: ielastic - integer(I4B) :: iconvert - integer(I4B) :: node - integer(I4B) :: nn - integer(I4B) :: n - real(DP) :: es - real(DP) :: pcs - real(DP) :: rho1 - real(DP) :: rho2 - real(DP) :: tled - real(DP) :: tledm - real(DP) :: es0 - real(DP) :: rrate - real(DP) :: ratein - real(DP) :: rateout - real(DP) :: comp - real(DP) :: compi - real(DP) :: compe - real(DP) :: area - real(DP) :: h - real(DP) :: h0 - real(DP) :: snnew - real(DP) :: snold - real(DP) :: hcof - real(DP) :: rhs - real(DP) :: stoe - real(DP) :: stoi - real(DP) :: b - real(DP) :: q - real(DP) :: ratecgin - real(DP) :: ratecgout - real(DP) :: rateibein - real(DP) :: rateibeout - real(DP) :: rateibiin - real(DP) :: rateibiout - real(DP) :: rratewc - real(DP) :: ratewcin - real(DP) :: ratewcout - ! -- for observations - integer(I4B) :: iprobslocal - ! -- formats -! -------------------------------------------------------------------------- - ! - ! -- Suppress saving of simulated values; they - ! will be saved at end of this procedure. - iprobslocal = 0 - ratein = DZERO - rateout= DZERO - ratewcin = DZERO - ratewcout = DZERO - ! - ! -- coarse-grained coarse-grained storage - ratecgin = DZERO - ratecgout= DZERO - do node = 1, this%dis%nodes - area = this%dis%get_area(node) - comp = DZERO - rrate = DZERO - rratewc = DZERO - if (this%gwfiss == 0) then - if (DELT > DZERO) then - tled = DONE / DELT - else - tled = DZERO - end if - if (this%ibound(node) > 0 .and. this%cg_thickini(node) > DZERO) then - ! - ! -- calculate coarse-grained storage terms - call this%csub_cg_fc(node, tled, area, hnew(node), hold(node), & - hcof, rhs) - rrate = hcof * hnew(node) - rhs - ! - ! -- calculate compaction - call this%csub_cg_calc_comp(node, hnew(node), hold(node), comp) - ! - ! -- budget terms - if (rrate < DZERO) then - ratecgout = ratecgout - rrate - else - ratecgin = ratecgin + rrate - end if - ! - ! -- calculate coarse-grained water compressibility storage terms - call this%csub_cg_wcomp_fc(node, tled, area, hnew(node), hold(node), & - hcof, rhs) - rratewc = hcof * hnew(node) - rhs - ! - ! -- water compressibility budget terms - if (rratewc < DZERO) then - ratewcout = ratewcout - rratewc - else - ratewcin = ratewcin + rratewc - end if - end if - end if - ! - ! -- update coarse-grained storage and water - ! compresion variables - this%cg_stor(node) = rrate - this%cell_wcstor(node) = rratewc - this%cell_thick(node) = this%cg_thick(node) - ! - ! -- update incremental coarse-grained compaction - this%cg_comp(node) = comp - ! - ! - ! -- update states if required - if (isuppress_output == 0) then - ! - ! -- calculate strain and change in coarse-grained void ratio and thickness - if (this%iupdatematprop /= 0) then - call this%csub_cg_update(node) - end if - ! - ! -- update total compaction - this%cg_tcomp(node) = this%cg_tcomp(node) + comp - end if - end do - ! - ! -- interbed storage - rateibein = DZERO - rateibeout = DZERO - rateibiin = DZERO - rateibiout = DZERO - - tled = DONE - do ib = 1, this%ninterbeds - rratewc = DZERO - idelay = this%idelay(ib) - ielastic = this%ielastic(ib) - ! - ! -- calculate interbed thickness - ! -- no delay interbeds - if (idelay == 0) then - b = this%thick(ib) - ! -- delay interbeds - else - b = this%thick(ib) * this%rnb(ib) - end if - ! - ! -- set variables required for no-delay and delay interbeds - node = this%nodelist(ib) - area = this%dis%get_area(node) - ! - ! -- add interbed thickness to cell thickness - this%cell_thick(node) = this%cell_thick(node) + b - ! - ! -- update budget terms if transient stress period - if (this%gwfiss == 0) then - if (DELT > DZERO) then - tledm = DONE / DELT - else - tledm = DZERO - end if - ! - ! -- skip inactive and constant head cells - if (this%ibound(node) < 1) cycle - ! - ! -- no delay interbeds - if (idelay == 0) then - iconvert = this%iconvert(ib) - stoi = DZERO - ! - ! -- calculate compaction - call this%csub_nodelay_calc_comp(ib, hnew(node), hold(node), comp, & - rho1, rho2) - ! - ! -- interbed stresses - es = this%cg_es(node) - pcs = this%pcs(ib) - es0 = this%cg_es0(node) - ! - ! -- calculate inelastic and elastic compaction - if (ielastic > 0 .or. iconvert == 0) then - stoe = comp - else - stoi = -pcs * rho2 + (rho2 * es) - stoe = pcs * rho1 - (rho1 * es0) - end if - compe = stoe - compi = stoi - stoe = stoe * area - stoi = stoi * area - this%storagee(ib) = stoe * tledm - this%storagei(ib) = stoi * tledm - ! - ! -- update compaction - this%comp(ib) = comp - ! - ! -- update states if required - if (isuppress_output == 0) then - ! - ! -- calculate strain and change in interbed void ratio and thickness - if (this%iupdatematprop /= 0) then - call this%csub_nodelay_update(ib) - end if - ! - ! -- update total compaction - this%tcomp(ib) = this%tcomp(ib) + comp - this%tcompe(ib) = this%tcompe(ib) + compe - this%tcompi(ib) = this%tcompi(ib) + compi - end if - ! - ! -- delay interbeds - else - h = hnew(node) - h0 = hold(node) - ! - ! -- calculate cell saturation - call this%csub_calc_sat(node, h, h0, snnew, snold) - ! - ! -- calculate inelastic and elastic storage contributions - call this%csub_delay_calc_dstor(ib, h, stoe, stoi) - this%storagee(ib) = stoe * area * this%rnb(ib) * snnew * tledm - this%storagei(ib) = stoi * area * this%rnb(ib) * snnew * tledm - ! - ! -- calculate flow across the top and bottom of the delay interbed - q = this%csub_calc_delay_flow(ib, 1, h) * area * this%rnb(ib) - this%dbflowtop(idelay) = q - nn = this%ndelaycells - q = this%csub_calc_delay_flow(ib, nn, h) * area * this%rnb(ib) - this%dbflowbot(idelay) = q - ! - ! -- update states if required - if (isuppress_output == 0) then - ! - ! -- calculate sum of compaction in delay interbed - call this%csub_delay_calc_comp(ib, h, h0, comp, compi, compe) - ! - ! - calculate strain and change in interbed void ratio and thickness - if (this%iupdatematprop /= 0) then - call this%csub_delay_update(ib) - end if - ! - ! -- update total compaction for interbed - this%tcomp(ib) = this%tcomp(ib) + comp - this%tcompi(ib) = this%tcompi(ib) + compi - this%tcompe(ib) = this%tcompe(ib) + compe - ! - ! -- update total compaction for each delay bed cell - do n = 1, this%ndelaycells - this%dbtcomp(n, idelay) = this%dbtcomp(n, idelay) + this%dbcomp(n, idelay) - end do - end if - end if - ! - ! -- budget terms - if (this%storagee(ib) < DZERO) then - rateibeout = rateibeout - this%storagee(ib) - else - rateibein = rateibein + this%storagee(ib) - end if - if (this%storagei(ib) < DZERO) then - rateibiout = rateibiout - this%storagei(ib) - else - rateibiin = rateibiin + this%storagei(ib) - end if - ! - ! -- interbed water compressibility - call this%csub_interbed_wcomp_fc(ib, node, tledm, area, & - hnew(node), hold(node), hcof, rhs) - rratewc = hcof * hnew(node) - rhs - this%cell_wcstor(node) = this%cell_wcstor(node) + rratewc - ! - ! -- water compressibility budget terms - if (rratewc < DZERO) then - ratewcout = ratewcout - rratewc - else - ratewcin = ratewcin + rratewc - end if - else - this%storagee(ib) = DZERO - this%storagei(ib) = DZERO - if (idelay /= 0) then - this%dbflowtop(idelay) = DZERO - this%dbflowbot(idelay) = DZERO - end if - end if - end do - ! - ! -- Add contributions to model budget - ! - ! -- interbed elastic storage - call model_budget%addentry(ratecgin, ratecgout, delt, budtxt(1), & - isuppress_output, ' CSUB') - if (this%ninterbeds > 0) then - ! - ! -- interbed elastic storage - call model_budget%addentry(rateibein, rateibeout, delt, budtxt(2), & - isuppress_output, ' CSUB') - ! - ! -- interbed elastic storage - call model_budget%addentry(rateibiin, rateibiout, delt, budtxt(3), & - isuppress_output, ' CSUB') - end if - call model_budget%addentry(ratewcin, ratewcout, delt, budtxt(4), & - isuppress_output, ' CSUB') - ! - ! -- For continuous observations, save simulated values. - if (this%obs%npakobs > 0) then - call this%csub_bd_obs() - end if - ! - ! -- terminate if errors encountered when updating material properties - if (this%iupdatematprop /= 0) then - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - end if - ! - ! -- return - return - - end subroutine csub_bdcalc - - subroutine csub_bdsav(this, idvfl, icbcfl, icbcun) -! ****************************************************************************** -! sto_bdsav -- Save budget terms -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfCsubType) :: this - integer(I4B), intent(in) :: idvfl - integer(I4B), intent(in) :: icbcfl - integer(I4B), intent(in) :: icbcun - ! -- local - character(len=1) :: cdatafmp=' ', editdesc=' ' - integer(I4B) :: ibinun - integer(I4B) :: iprint, nvaluesp, nwidthp - integer(I4B) :: ib - integer(I4B) :: node - integer(I4B) :: nodem - integer(I4B) :: nodeu - integer(I4B) :: i - integer(I4B) :: k - integer(I4B) :: ncpl - integer(I4B) :: nlay - integer(I4B) :: naux - real(DP) :: dinact - real(DP) :: Q - -! ------------------------------------------------------------------------------ - ! - ! -- Set unit number for binary output - if(this%ipakcb < 0) then - ibinun = icbcun - elseif(this%ipakcb == 0) then - ibinun = 0 - else - ibinun = this%ipakcb - endif - if(icbcfl == 0) ibinun = 0 - ! - ! -- Record the storage rates if requested - if (ibinun /= 0) then - iprint = 0 - dinact = DZERO - ! - ! -- coarse-grained storage (sske) - call this%dis%record_array(this%cg_stor, this%iout, iprint, -ibinun, & - budtxt(1), cdatafmp, nvaluesp, & - nwidthp, editdesc, dinact) - if (this%ninterbeds > 0) then - naux = 0 - ! -- interbed elastic storage - call this%dis%record_srcdst_list_header(budtxt(2), this%name_model, & - this%name_model, this%name_model, this%name, naux, & - this%auxname, ibinun, this%ninterbeds, this%iout) - do ib = 1, this%ninterbeds - q = this%storagee(ib) - node = this%nodelist(ib) - call this%dis%record_mf6_list_entry(ibinun, node, node, q, naux, & - this%auxvar(:,ib)) - end do - ! -- interbed inelastic storage - call this%dis%record_srcdst_list_header(budtxt(3), this%name_model, & - this%name_model, this%name_model, this%name, naux, & - this%auxname, ibinun, this%ninterbeds, this%iout) - do ib = 1, this%ninterbeds - q = this%storagei(ib) - node = this%nodelist(ib) - call this%dis%record_mf6_list_entry(ibinun, node, node, q, naux, & - this%auxvar(:,ib)) - end do - end if - ! - ! -- water compressibility - call this%dis%record_array(this%cell_wcstor, this%iout, iprint, -ibinun, & - budtxt(4), cdatafmp, nvaluesp, & - nwidthp, editdesc, dinact) - end if - ! - ! -- Save compaction results - ! - ! -- Set unit number for binary compaction and z-displacement output - if(this%ioutcomp /= 0 .or. this%ioutzdisp /= 0) then - ibinun = 1 - else - ibinun = 0 - endif - if(idvfl == 0) ibinun = 0 - ! - ! -- save compaction results - if (ibinun /= 0) then - iprint = 0 - dinact = DHNOFLO - ! - ! -- fill buff with total compaction - do node = 1, this%dis%nodes - this%buff(node) = this%cg_tcomp(node) - end do - do ib = 1, this%ninterbeds - node = this%nodelist(ib) - this%buff(node) = this%buff(node) + this%tcomp(ib) - end do - ! - ! -- write compaction data to binary file - if (this%ioutcomp /= 0) then - ibinun = this%ioutcomp - call this%dis%record_array(this%buff, this%iout, iprint, ibinun, & - comptxt(1), cdatafmp, nvaluesp, & - nwidthp, editdesc, dinact) - end if - ! - ! -- calculate z-displacement (subsidence) and write data to binary file - if (this%ioutzdisp /= 0) then - ibinun = this%ioutzdisp - ! - ! -- initialize buffusr - do nodeu = 1, this%dis%nodesuser - this%buffusr(nodeu) = DZERO - end do - ! - ! -- fill buffusr with buff - do node = 1, this%dis%nodes - nodeu = this%dis%get_nodeuser(node) - this%buffusr(nodeu) = this%buff(node) - end do - ! - ! -- calculate z-displacement - ncpl = this%dis%get_ncpl() - ! - ! -- disu - if (this%dis%ndim == 1) then - ! TO DO - - ! -- disv or dis - else - nlay = this%dis%nodesuser / ncpl - do k = nlay - 1, 1, -1 - do i = 1, ncpl - node = (k - 1) * ncpl + i - nodem = k * ncpl + i - this%buffusr(node) = this%buffusr(node) + this%buffusr(nodem) - end do - end do - end if - ! - ! -- fill buff with data from buffusr - do nodeu = 1, this%dis%nodesuser - node = this%dis%get_nodenumber_idx1(nodeu, 1) - if (node /= 0) then - this%buff(node) = this%buffusr(nodeu) - end if - end do - ! - ! -- write z-displacement - call this%dis%record_array(this%buff, this%iout, iprint, ibinun, & - comptxt(6), cdatafmp, nvaluesp, & - nwidthp, editdesc, dinact) - - end if - end if - ! - ! -- Set unit number for binary inelastic interbed compaction - if(this%ioutcompi /= 0) then - ibinun = this%ioutcompi - else - ibinun = 0 - endif - if(idvfl == 0) ibinun = 0 - ! - ! -- save inelastic interbed compaction results - if(ibinun /= 0) then - iprint = 0 - dinact = DHNOFLO - ! - ! -- fill buff with inelastic interbed compaction - do node = 1, this%dis%nodes - this%buff(node) = DZERO - end do - do ib = 1, this%ninterbeds - node = this%nodelist(ib) - this%buff(node) = this%buff(node) + this%tcompi(ib) - end do - ! - ! -- write inelastic interbed compaction data to binary file - call this%dis%record_array(this%buff, this%iout, iprint, ibinun, & - comptxt(2), cdatafmp, nvaluesp, & - nwidthp, editdesc, dinact) - end if - ! - ! -- Set unit number for binary elastic interbed compaction - if(this%ioutcompe /= 0) then - ibinun = this%ioutcompe - else - ibinun = 0 - endif - if(idvfl == 0) ibinun = 0 - ! - ! -- save elastic interbed compaction results - if(ibinun /= 0) then - iprint = 0 - dinact = DHNOFLO - ! - ! -- fill buff with elastic interbed compaction - do node = 1, this%dis%nodes - this%buff(node) = DZERO - end do - do ib = 1, this%ninterbeds - node = this%nodelist(ib) - this%buff(node) = this%buff(node) + this%tcompe(ib) - end do - ! - ! -- write elastic interbed compaction data to binary file - call this%dis%record_array(this%buff, this%iout, iprint, ibinun, & - comptxt(3), cdatafmp, nvaluesp, & - nwidthp, editdesc, dinact) - end if - ! - ! -- Set unit number for binary interbed compaction - if(this%ioutcompib /= 0) then - ibinun = this%ioutcompib - else - ibinun = 0 - endif - if(idvfl == 0) ibinun = 0 - ! - ! -- save interbed compaction results - if(ibinun /= 0) then - iprint = 0 - dinact = DHNOFLO - ! - ! -- fill buff with interbed compaction - do node = 1, this%dis%nodes - this%buff(node) = DZERO - end do - do ib = 1, this%ninterbeds - node = this%nodelist(ib) - this%buff(node) = this%buff(node) + this%tcompe(ib) + this%tcompi(ib) - end do - ! - ! -- write interbed compaction data to binary file - call this%dis%record_array(this%buff, this%iout, iprint, ibinun, & - comptxt(4), cdatafmp, nvaluesp, & - nwidthp, editdesc, dinact) - end if - ! - ! -- Set unit number for binary coarse-grained compaction - if(this%ioutcomps /= 0) then - ibinun = this%ioutcomps - else - ibinun = 0 - endif - if(idvfl == 0) ibinun = 0 - ! - ! -- save coarse-grained compaction results - if(ibinun /= 0) then - iprint = 0 - dinact = DHNOFLO - ! - ! -- fill buff with coarse-grained compaction - do node = 1, this%dis%nodes - this%buff(node) = this%cg_tcomp(node) - end do - ! - ! -- write coarse-grained compaction data to binary file - call this%dis%record_array(this%buff, this%iout, iprint, ibinun, & - comptxt(5), cdatafmp, nvaluesp, & - nwidthp, editdesc, dinact) - end if - ! - ! -- Save observations. - if (this%obs%npakobs > 0) then - call this%obs%obs_ot() - end if - ! - ! -- check that final effective stress values for the time step - ! are greater than zero - if (this%gwfiss == 0) then - call this%csub_cg_chk_stress() - end if - ! - ! -- Return - return - end subroutine csub_bdsav - - subroutine csub_fp(this) -! ************************************************************************** -! csub_cc -- Final processing for package -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - ! -- dummy - class(GwfCsubType) :: this - ! -- local - character(len=LINELENGTH) :: title - character(len=LINELENGTH) :: tag - character(len=LINELENGTH) :: msg - character(len=10) :: ctype - character(len=20) :: cellid - character(len=10) :: cflag - integer(I4B) :: i - integer(I4B) :: ib - integer(I4B) :: i0 - integer(I4B) :: i1 - integer(I4B) :: node - integer(I4B) :: nn - integer(I4B) :: idelay - integer(I4B) :: iexceed - integer(I4B), parameter :: ncells = 20 - integer(I4B) :: nlen - integer(I4B) :: ntabrows - integer(I4B) :: ntabcols - integer(I4B) :: ipos - real(DP) :: b0 - real(DP) :: b1 - real(DP) :: strain - real(DP) :: pctcomp - integer(I4B), dimension(:), allocatable :: imap_sel - integer(I4B), dimension(:), allocatable :: locs - real(DP), dimension(:), allocatable :: pctcomp_arr - ! format -! -------------------------------------------------------------------------- - ! - ! -- initialize locs - allocate(locs(this%dis%ndim)) - ! - ! -- calculate and report strain for interbeds - if (this%ninterbeds > 0) then - nlen = min(ncells,this%ninterbeds) - allocate(imap_sel(nlen)) - allocate(pctcomp_arr(this%ninterbeds)) - iexceed = 0 - do ib = 1, this%ninterbeds - idelay = this%idelay(ib) - b0 = this%thickini(ib) - strain = this%tcomp(ib) / b0 - pctcomp = DHUNDRED * strain - pctcomp_arr(ib) = pctcomp - if (pctcomp >= DONE) then - iexceed = iexceed + 1 - end if - end do - call selectn(imap_sel, pctcomp_arr, reverse=.TRUE.) - ! - ! -- summary interbed strain table - i0 = max(1, this%ninterbeds-ncells+1) - i1 = this%ninterbeds - msg = '' - if (iexceed /= 0) then - write(msg,'(1x,a,1x,i0,1x,a,1x,i0,1x,a)') & - 'LARGEST', (i1 - i0 + 1), 'OF', this%ninterbeds, & - 'INTERBED STRAIN VALUES SHOWN' - call sim_message(msg, this%iout, skipbefore=1) - ! - ! -- interbed strain data - ! -- set title - title = trim(adjustl(this%name)) // ' PACKAGE INTERBED STRAIN SUMMARY' - ! - ! -- determine the number of columns and rows - ntabrows = nlen - ntabcols = 9 - ! - ! -- setup table - call table_cr(this%outputtab, this%name, title) - call this%outputtab%table_df(ntabrows, ntabcols, this%iout) - ! - ! add columns - tag = 'INTERBED NUMBER' - call this%outputtab%initialize_column(tag, 10, alignment=TABCENTER) - tag = 'INTERBED TYPE' - call this%outputtab%initialize_column(tag, 10, alignment=TABCENTER) - tag = 'CELLID' - call this%outputtab%initialize_column(tag, 20, alignment=TABLEFT) - tag = 'INITIAL THICKNESS' - call this%outputtab%initialize_column(tag, 12, alignment=TABCENTER) - tag = 'FINAL THICKNESS' - call this%outputtab%initialize_column(tag, 12, alignment=TABCENTER) - tag = 'TOTAL COMPACTION' - call this%outputtab%initialize_column(tag, 12, alignment=TABCENTER) - tag = 'FINAL STRAIN' - call this%outputtab%initialize_column(tag, 12, alignment=TABCENTER) - tag = 'PERCENT COMPACTION' - call this%outputtab%initialize_column(tag, 12, alignment=TABCENTER) - tag = 'FLAG' - call this%outputtab%initialize_column(tag, 10, alignment=TABCENTER) - ! - ! -- write data - do i = 1, nlen - ib = imap_sel(i) - idelay = this%idelay(ib) - b0 = this%thickini(ib) - b1 = this%csub_calc_interbed_thickness(ib) - if (idelay == 0) then - ctype = 'no-delay' - else - ctype = 'delay' - b0 = b0 * this%rnb(ib) - end if - strain = this%tcomp(ib) / b0 - pctcomp = DHUNDRED * strain - if (pctcomp >= 5.0_DP) then - cflag = '**>=5%' - else if (pctcomp >= DONE) then - cflag = '*>=1%' - else - cflag = '' - end if - node = this%nodelist(ib) - call this%dis%noder_to_string(node, cellid) - ! - ! -- fill table line - call this%outputtab%add_term(ib) - call this%outputtab%add_term(ctype) - call this%outputtab%add_term(cellid) - call this%outputtab%add_term(b0) - call this%outputtab%add_term(b1) - call this%outputtab%add_term(this%tcomp(ib)) - call this%outputtab%add_term(strain) - call this%outputtab%add_term(pctcomp) - call this%outputtab%add_term(cflag) - end do - write(this%iout, '(/1X,A,1X,I0,1X,A,1X,I0,1X,A,/1X,A,/1X,A)') & - 'PERCENT COMPACTION IS GREATER THAN OR EQUAL TO 1 PERCENT IN', & - iexceed, 'OF', this%ninterbeds, 'INTERBED(S).', & - 'USE THE STRAIN_CSV_INTERBED OPTION TO OUTPUT A CSV ' // & - 'FILE WITH PERCENT COMPACTION ', 'VALUES FOR ALL INTERBEDS.' - else - msg = 'PERCENT COMPACTION WAS LESS THAN 1 PERCENT IN ALL INTERBEDS' - write(this%iout, '(/1X,A)') trim(adjustl(msg)) - end if - ! - ! -- write csv file - if (this%istrainib /= 0) then - ! - ! -- determine the number of columns and rows - ntabrows = this%ninterbeds - ntabcols = 7 - if (this%dis%ndim > 1) then - ntabcols = ntabcols + 1 - end if - ntabcols = ntabcols + this%dis%ndim - ! - ! -- setup table - call table_cr(this%outputtab, this%name, '') - call this%outputtab%table_df(ntabrows, ntabcols, this%istrainib, & - lineseparator=.FALSE., separator=',') - ! - ! add columns - tag = 'INTERBED_NUMBER' - call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) - tag = 'INTERBED_TYPE' - call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) - tag = 'NODE' - call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) - if (this%dis%ndim == 2) then - tag = 'LAYER' - call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) - tag = 'ICELL2D' - call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) - else - tag = 'LAYER' - call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) - tag = 'ROW' - call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) - tag = 'COLUMN' - call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) - end if - tag = 'INITIAL_THICKNESS' - call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) - tag = 'FINAL_THICKNESS' - call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) - tag = 'TOTAL_COMPACTION' - call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) - tag = 'TOTAL_STRAIN' - call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) - tag = 'PERCENT_COMPACTION' - call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) - ! - ! -- write data - do ib = 1, this%ninterbeds - idelay = this%idelay(ib) - b0 = this%thickini(ib) - b1 = this%csub_calc_interbed_thickness(ib) - if (idelay == 0) then - ctype = 'no-delay' - else - ctype = 'delay' - b0 = b0 * this%rnb(ib) - end if - strain = this%tcomp(ib) / b0 - pctcomp = DHUNDRED * strain - node = this%nodelist(ib) - call this%dis%noder_to_array(node, locs) - ! - ! -- fill table line - call this%outputtab%add_term(ib) - call this%outputtab%add_term(ctype) - if (this%dis%ndim > 1) then - call this%outputtab%add_term(this%dis%get_nodeuser(node)) - end if - do ipos = 1, this%dis%ndim - call this%outputtab%add_term(locs(ipos)) - end do - call this%outputtab%add_term(b0) - call this%outputtab%add_term(b1) - call this%outputtab%add_term(this%tcomp(ib)) - call this%outputtab%add_term(strain) - call this%outputtab%add_term(pctcomp) - end do - end if - ! - ! -- deallocate temporary storage - deallocate(imap_sel) - deallocate(pctcomp_arr) - end if - ! - ! -- calculate and report strain for coarse-grained materials - nlen = min(ncells,this%dis%nodes) - allocate(imap_sel(nlen)) - allocate(pctcomp_arr(this%dis%nodes)) - iexceed = 0 - do node = 1, this%dis%nodes - strain = DZERO - if (this%cg_thickini(node) > DZERO) then - strain = this%cg_tcomp(node) / this%cg_thickini(node) - end if - pctcomp = DHUNDRED * strain - pctcomp_arr(node) = pctcomp - if (pctcomp >= DONE) then - iexceed = iexceed + 1 - end if - end do - call selectn(imap_sel, pctcomp_arr, reverse=.TRUE.) - ! - ! -- summary coarse-grained strain table - i0 = max(1, this%dis%nodes-ncells+1) - i1 = this%dis%nodes - msg = '' - if (iexceed /= 0) then - write(msg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & - 'LARGEST ', (i1 - i0 + 1), 'OF', this%dis%nodes, & - 'CELL COARSE-GRAINED VALUES SHOWN' - call sim_message(msg, this%iout, skipbefore=1) - ! - ! -- set title - title = trim(adjustl(this%name)) // & - ' PACKAGE COARSE-GRAINED STRAIN SUMMARY' - ! - ! -- determine the number of columns and rows - ntabrows = nlen - ntabcols = 7 - ! - ! -- setup table - call table_cr(this%outputtab, this%name, title) - call this%outputtab%table_df(ntabrows, ntabcols, this%iout) - ! - ! add columns - tag = 'CELLID' - call this%outputtab%initialize_column(tag, 20, alignment=TABLEFT) - tag = 'INITIAL THICKNESS' - call this%outputtab%initialize_column(tag, 12, alignment=TABCENTER) - tag = 'FINAL THICKNESS' - call this%outputtab%initialize_column(tag, 12, alignment=TABCENTER) - tag = 'TOTAL COMPACTION' - call this%outputtab%initialize_column(tag, 12, alignment=TABCENTER) - tag = 'FINAL STRAIN' - call this%outputtab%initialize_column(tag, 12, alignment=TABCENTER) - tag = 'PERCENT COMPACTION' - call this%outputtab%initialize_column(tag, 12, alignment=TABCENTER) - tag = 'FLAG' - call this%outputtab%initialize_column(tag, 10, alignment=TABCENTER) - ! -- write data - do nn = 1, nlen - node = imap_sel(nn) - if (this%cg_thickini(node) > DZERO) then - strain = this%cg_tcomp(node) / this%cg_thickini(node) - else - strain = DZERO - end if - pctcomp = DHUNDRED * strain - if (pctcomp >= 5.0_DP) then - cflag = '**>=5%' - else if (pctcomp >= DONE) then - cflag = '*>=1%' - else - cflag = '' - end if - call this%dis%noder_to_string(node, cellid) - ! - ! -- fill table line - call this%outputtab%add_term(cellid) - call this%outputtab%add_term(this%cg_thickini(node)) - call this%outputtab%add_term(this%cg_thick(node)) - call this%outputtab%add_term(this%cg_tcomp(node)) - call this%outputtab%add_term(strain) - call this%outputtab%add_term(pctcomp) - call this%outputtab%add_term(cflag) - end do - write(this%iout, '(/1X,A,1X,I0,1X,A,1X,I0,1X,A,/1X,A,/1X,A)') & - 'COARSE-GRAINED STORAGE PERCENT COMPACTION IS GREATER THAN OR ' // & - 'EQUAL TO 1 PERCENT IN', iexceed, 'OF', this%dis%nodes, 'CELL(S).', & - 'USE THE STRAIN_CSV_COARSE OPTION TO OUTPUT A CSV ' // & - 'FILE WITH PERCENT COMPACTION ', 'VALUES FOR ALL CELLS.' - else - msg = 'COARSE-GRAINED STORAGE PERCENT COMPACTION WAS LESS THAN ' // & - '1 PERCENT IN ALL CELLS ' - write(this%iout, '(/1X,A)') trim(adjustl(msg)) - end if - ! - ! -- write csv file - if (this%istrainsk /= 0) then - ! - ! -- determine the number of columns and rows - ntabrows = this%dis%nodes - ntabcols = 5 - if (this%dis%ndim > 1) then - ntabcols = ntabcols + 1 - end if - ntabcols = ntabcols + this%dis%ndim - ! - ! -- setup table - call table_cr(this%outputtab, this%name, '') - call this%outputtab%table_df(ntabrows, ntabcols, this%istrainsk, & - lineseparator=.FALSE., separator=',') - ! - ! add columns - tag = 'NODE' - call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) - if (this%dis%ndim == 2) then - tag = 'LAYER' - call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) - tag = 'ICELL2D' - call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) - else - tag = 'LAYER' - call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) - tag = 'ROW' - call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) - tag = 'COLUMN' - call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) - end if - tag = 'INITIAL_THICKNESS' - call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) - tag = 'FINAL_THICKNESS' - call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) - tag = 'TOTAL_COMPACTION' - call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) - tag = 'TOTAL_STRAIN' - call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) - tag = 'PERCENT_COMPACTION' - call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) - ! - ! -- write data - do node = 1, this%dis%nodes - if (this%cg_thickini(node) > DZERO) then - strain = this%cg_tcomp(node) / this%cg_thickini(node) - else - strain = DZERO - end if - pctcomp = DHUNDRED * strain - call this%dis%noder_to_array(node, locs) - ! - ! -- fill table line - if (this%dis%ndim > 1) then - call this%outputtab%add_term(this%dis%get_nodeuser(node)) - end if - do ipos = 1, this%dis%ndim - call this%outputtab%add_term(locs(ipos)) - end do - call this%outputtab%add_term(this%cg_thickini(node)) - call this%outputtab%add_term(this%cg_thick(node)) - call this%outputtab%add_term(this%cg_tcomp(node)) - call this%outputtab%add_term(strain) - call this%outputtab%add_term(pctcomp) - end do - end if - ! - ! -- deallocate temporary storage - deallocate(imap_sel) - deallocate(locs) - deallocate(pctcomp_arr) - ! - ! -- return - return - end subroutine csub_fp - - subroutine csub_read_packagedata(this) -! ****************************************************************************** -! pak1read_dimensions -- Read the dimensions for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use MemoryManagerModule, only: mem_allocate, mem_setptr -! use SimModule, only: ustop, store_error, count_errors, store_error_unit - use TimeSeriesManagerModule, only: read_single_value_or_time_series - ! -- dummy - class(GwfCsubType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: errmsg - character(len=LINELENGTH) :: cellid - character(len=LINELENGTH) :: title - character(len=LINELENGTH) :: tag - character(len=20) :: scellid - character(len=10) :: text - character(len=LENBOUNDNAME) :: bndName, bndNameTemp - character(len=7) :: cdelay - character(len=9) :: cno - integer(I4B) :: ival - logical :: isfound, endOfBlock - integer(I4B) :: n - integer(I4B) :: nn - integer(I4B) :: ib - integer(I4B) :: itmp - integer(I4B) :: ierr - integer(I4B) :: ndelaybeds - integer(I4B) :: idelay - integer(I4B) :: ntabrows - integer(I4B) :: ntabcols - real(DP) :: rval - real(DP) :: top - real(DP) :: bot - real(DP) :: baq - real(DP) :: q - integer, allocatable, dimension(:) :: nboundchk - ! - ! -- initialize temporary variables - ndelaybeds = 0 - ! - ! -- allocate temporary arrays - allocate(nboundchk(this%ninterbeds)) - do n = 1, this%ninterbeds - nboundchk(n) = 0 - end do - ! - call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & - supportopenclose=.true.) - ! - ! -- parse locations block if detected - if (isfound) then - write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%name))// & - ' PACKAGEDATA' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - ! -- read interbed number - itmp = this%parser%GetInteger() - - if (itmp < 1 .or. itmp > this%ninterbeds) then - write(errmsg,'(4x,a,1x,i0,1x,a,1x,i0)') & - '****ERROR. INTERBED NUMBER (', itmp, ') MUST BE > 0 and <= ', & - this%ninterbeds - call store_error(errmsg) - cycle - end if - - ! -- increment nboundchk - nboundchk(itmp) = nboundchk(itmp) + 1 - - ! -- read cellid - call this%parser%GetCellid(this%dis%ndim, cellid) - nn = this%dis%noder_from_cellid(cellid, & - this%parser%iuactive, this%iout) - n = this%dis%nodeu_from_cellid(cellid, & - this%parser%iuactive, this%iout) - top = this%dis%top(nn) - bot = this%dis%bot(nn) - baq = top - bot - ! -- determine if a valid cell location was provided - if (nn < 1) then - write(errmsg,'(4x,a,1x,i4,1x)') & - '****ERROR. INVALID cellid FOR PACKAGEDATA ENTRY', itmp - call store_error(errmsg) - end if - - ! -- set nodelist and unodelist - this%nodelist(itmp) = nn - this%unodelist(itmp) = n - - ! -- get cdelay - call this%parser%GetStringCaps(cdelay) - select case (cdelay) - case ('NODELAY') - ival = 0 - case ('DELAY') - ndelaybeds = ndelaybeds + 1 - ival = ndelaybeds - case default - write(errmsg,'(4x,a,1x,a,1x,i0,1x)') & - '****ERROR. INVALID CDELAY ', trim(adjustl(cdelay)), & - ' FOR PACKAGEDATA ENTRY', itmp - call store_error(errmsg) - cycle - end select - idelay = ival - this%idelay(itmp) = ival - - ! -- get initial preconsolidation stress - this%pcs(itmp) = this%parser%GetDouble() - - ! -- get thickness or cell fraction - rval = this%parser%GetDouble() - if (this%icellf == 0) then - if (rval < DZERO .or. rval > baq) then - write(errmsg,'(4x,a,1x,g0,1x,a,1x,g0,1x,a,1x,i0)') & - '****ERROR. thick (', rval,') MUST BE >= 0 AND <= ', baq, & - 'FOR PACKAGEDATA ENTRY', itmp - call store_error(errmsg) - end if - else - if (rval < DZERO .or. rval > DONE) then - write(errmsg,'(4x,a,1x,i0)') & - '****ERROR. frac MUST BE >= 0 AND <= 1 FOR PACKAGEDATA ENTRY', & - itmp - call store_error(errmsg) - end if - rval = rval * baq - end if - this%thickini(itmp) = rval - if (this%iupdatematprop /= 0) then - this%thick(itmp) = rval - end if - - ! -- get rnb - rval = this%parser%GetDouble() - if (idelay > 0) then - if (rval < DONE) then - write(errmsg,'(4x,a,1x,g0,1x,a,1x,a,1x,i0)') & - '****ERROR. rnb (', rval,') MUST BE >= 1.', & - 'FOR PACKAGEDATA ENTRY', itmp - call store_error(errmsg) - end if - else - rval = DONE - end if - this%rnb(itmp) = rval - ! - ! -- get skv or ci - rval = this%parser%GetDouble() - if (rval < DZERO) then - write(errmsg,'(4x,a,1x,i0)') & - '****ERROR. (skv,ci) MUST BE > 0 FOR PACKAGEDATA ENTRY', itmp - call store_error(errmsg) - end if - this%ci(itmp) = rval - ! - ! -- get ske or rci - rval = this%parser%GetDouble() - if (rval < DZERO) then - write(errmsg,'(4x,a,1x,i0)') & - '****ERROR. (ske,rci) MUST BE > 0 FOR PACKAGEDATA ENTRY', itmp - call store_error(errmsg) - end if - this%rci(itmp) = rval - ! - ! -- set ielastic - if (this%ci(itmp) == this%rci(itmp)) then - this%ielastic(itmp) = 1 - else - this%ielastic(itmp) = 0 - end if - ! - ! -- get porosity - rval = this%parser%GetDouble() - this%thetaini(itmp) = rval - if (this%iupdatematprop /= 0) then - this%theta(itmp) = rval - end if - if (rval <= DZERO .or. rval > DONE) then - write(errmsg,'(4x,a,1x,a,1x,i0)') & - '****ERROR. theta MUST BE > 0 and <= 1 FOR PACKAGEDATA ENTRY', & - 'ENTRY', itmp - call store_error(errmsg) - end if - ! - ! -- get kv - rval = this%parser%GetDouble() - if (idelay > 0) then - if (rval <= 0.0) then - write(errmsg,'(4x,a,1x,i0,1x)') & - '****ERROR. kv MUST BE > 0 FOR PACKAGEDATA ENTRY', itmp - call store_error(errmsg) - end if - end if - this%kv(itmp) = rval - - ! -- get h0 - rval = this%parser%GetDouble() - this%h0(itmp) = rval - - ! -- get bound names - write (cno,'(i9.9)') nn - bndName = 'nsystem' // cno - if (this%inamedbound /= 0) then - call this%parser%GetStringCaps(bndNameTemp) - if (bndNameTemp /= '') then - bndName = bndNameTemp(1:16) - else - write(errmsg,'(4x,2(a,1x),i4)') & - '****ERROR. BOUNDNAME MUST BE SPECIFIED FOR ', & - 'PACKAGEDATA ENTRY', itmp - call store_error(errmsg) - end if - end if - this%boundname(itmp) = bndName - end do - write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%name))//' PACKAGEDATA' - end if - ! - ! -- write summary of interbed data - if (this%iprpak == 1) then - ! -- set title - title = trim(adjustl(this%name)) // ' PACKAGE INTERBED DATA' - ! - ! -- determine the number of columns and rows - ntabrows = this%ninterbeds - ntabcols = 11 - if (this%inamedbound /= 0) then - ntabcols = ntabcols + 1 - end if - ! - ! -- setup table - call table_cr(this%inputtab, this%name, title) - call this%inputtab%table_df(ntabrows, ntabcols, this%iout) - ! - ! add columns - tag = 'INTERBED' - call this%inputtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'CELLID' - call this%inputtab%initialize_column(tag, 20, alignment=TABCENTER) - tag = 'CDELAY' - call this%inputtab%initialize_column(tag, 10, alignment=TABCENTER) - tag = 'PCS' - call this%inputtab%initialize_column(tag, 10, alignment=TABCENTER) - tag = 'THICK' - call this%inputtab%initialize_column(tag, 10, alignment=TABCENTER) - tag = 'RNB' - call this%inputtab%initialize_column(tag, 10, alignment=TABCENTER) - tag = 'SSV_CC' - call this%inputtab%initialize_column(tag, 10, alignment=TABCENTER) - tag = 'SSV_CR' - call this%inputtab%initialize_column(tag, 10, alignment=TABCENTER) - tag = 'THETA' - call this%inputtab%initialize_column(tag, 10, alignment=TABCENTER) - tag = 'KV' - call this%inputtab%initialize_column(tag, 10, alignment=TABCENTER) - tag = 'H0' - call this%inputtab%initialize_column(tag, 10, alignment=TABCENTER) - if (this%inamedbound /= 0) then - tag = 'BOUNDNAME' - call this%inputtab%initialize_column(tag, LENBOUNDNAME, & - alignment=TABLEFT) - end if - ! - ! -- write the data - do ib = 1, this%ninterbeds - call this%dis%noder_to_string(this%nodelist(ib), scellid) - if (this%idelay(ib) == 0) then - text = 'NODELAY' - else - text = 'DELAY' - end if - call this%inputtab%add_term(ib) - call this%inputtab%add_term(scellid) - call this%inputtab%add_term(text) - call this%inputtab%add_term(this%pcs(ib)) - call this%inputtab%add_term(this%thickini(ib)) - call this%inputtab%add_term(this%rnb(ib)) - call this%inputtab%add_term(this%ci(ib)) - call this%inputtab%add_term(this%rci(ib)) - call this%inputtab%add_term(this%thetaini(ib)) - if (this%idelay(ib) == 0) then - call this%inputtab%add_term('-') - call this%inputtab%add_term('-') - else - call this%inputtab%add_term(this%kv(ib)) - call this%inputtab%add_term(this%h0(ib)) - end if - if (this%inamedbound /= 0) then - call this%inputtab%add_term(this%boundname(ib)) - end if - end do - end if - ! - ! -- Check to make sure that every interbed is specified and that no - ! interbed is specified more than once. - do ib = 1, this%ninterbeds - if (nboundchk(ib) == 0) then - write(errmsg, '(a, i0, a)') 'ERROR: INFORMATION FOR INTERBED ', ib, & - ' NOT SPECIFIED IN PACKAGEDATA BLOCK.' - call store_error(errmsg) - else if (nboundchk(ib) > 1) then - write(errmsg, '(a, i0, i0)') 'ERROR: INFORMATION SPECIFIED ', & - nboundchk(ib), ' TIMES FOR INTERBED ', ib - call store_error(errmsg) - endif - end do - deallocate(nboundchk) - ! - ! -- set the number of delay interbeds - this%ndelaybeds = ndelaybeds - ! - ! -- process delay interbeds - if (ndelaybeds > 0) then - ! - ! -- reallocate and initialize delay interbed arrays - if (ierr == 0) then - call mem_allocate(this%idbconvert, this%ndelaycells, ndelaybeds, & - 'idbconvert', trim(this%origin)) - call mem_allocate(this%dbdhmax, ndelaybeds, & - 'dbdhmax', trim(this%origin)) - call mem_allocate(this%dbz, this%ndelaycells, ndelaybeds, & - 'dbz', trim(this%origin)) - call mem_allocate(this%dbrelz, this%ndelaycells, ndelaybeds, & - 'dbrelz', trim(this%origin)) - call mem_allocate(this%dbh, this%ndelaycells, ndelaybeds, & - 'dbh', trim(this%origin)) - call mem_allocate(this%dbh0, this%ndelaycells, ndelaybeds, & - 'dbh0', trim(this%origin)) - call mem_allocate(this%dbgeo, this%ndelaycells, ndelaybeds, & - 'dbgeo', trim(this%origin)) - call mem_allocate(this%dbes, this%ndelaycells, ndelaybeds, & - 'dbes', trim(this%origin)) - call mem_allocate(this%dbes0, this%ndelaycells, ndelaybeds, & - 'dbes0', trim(this%origin)) - call mem_allocate(this%dbpcs, this%ndelaycells, ndelaybeds, & - 'dbpcs', trim(this%origin)) - call mem_allocate(this%dbflowtop, ndelaybeds, & - 'dbflowtop', trim(this%origin)) - call mem_allocate(this%dbflowbot, ndelaybeds, & - 'dbflowbot', trim(this%origin)) - call mem_allocate(this%dbdzini, this%ndelaycells, ndelaybeds, & - 'dbdzini', trim(this%origin)) - call mem_allocate(this%dbthetaini, this%ndelaycells, ndelaybeds, & - 'dbthetaini', trim(this%origin)) - call mem_allocate(this%dbcomp, this%ndelaycells, ndelaybeds, & - 'dbcomp', trim(this%origin)) - call mem_allocate(this%dbtcomp, this%ndelaycells, ndelaybeds, & - 'dbtcomp', trim(this%origin)) - ! - ! -- allocate delay bed arrays - if (this%iupdatematprop == 0) then - call mem_setptr(this%dbdz, 'dbdzini', trim(this%origin)) - call mem_setptr(this%dbdz0, 'dbdzini', trim(this%origin)) - call mem_setptr(this%dbtheta, 'dbthetaini', trim(this%origin)) - call mem_setptr(this%dbtheta0, 'dbthetaini', trim(this%origin)) - else - call mem_allocate(this%dbdz, this%ndelaycells, ndelaybeds, & - 'dbdz', trim(this%origin)) - call mem_allocate(this%dbdz0, this%ndelaycells, ndelaybeds, & - 'dbdz0', trim(this%origin)) - call mem_allocate(this%dbtheta, this%ndelaycells, ndelaybeds, & - 'dbtheta', trim(this%origin)) - call mem_allocate(this%dbtheta0, this%ndelaycells, ndelaybeds, & - 'dbtheta0', trim(this%origin)) - end if - ! - ! -- allocate delay interbed solution arrays - call mem_allocate(this%dbal, this%ndelaycells, & - 'dbal', trim(this%origin)) - call mem_allocate(this%dbad, this%ndelaycells, & - 'dbad', trim(this%origin)) - call mem_allocate(this%dbau, this%ndelaycells, & - 'dbau', trim(this%origin)) - call mem_allocate(this%dbrhs, this%ndelaycells, & - 'dbrhs', trim(this%origin)) - call mem_allocate(this%dbdh, this%ndelaycells, & - 'dbdh', trim(this%origin)) - call mem_allocate(this%dbaw, this%ndelaycells, & - 'dbaw', trim(this%origin)) - ! - ! -- initialize delay bed storage - do ib = 1, this%ninterbeds - idelay = this%idelay(ib) - if (idelay == 0) then - cycle - end if - ! - ! -- initialize delay interbed variables - do n = 1, this%ndelaycells - rval = this%thickini(ib) / real(this%ndelaycells, DP) - this%dbdzini(n, idelay) = rval - this%dbh(n, idelay) = this%h0(ib) - this%dbh0(n, idelay) = this%h0(ib) - this%dbthetaini(n, idelay) = this%thetaini(ib) - this%dbgeo(n, idelay) = DZERO - this%dbes(n, idelay) = DZERO - this%dbes0(n, idelay) = DZERO - this%dbpcs(n, idelay) = this%pcs(ib) - this%dbcomp(n, idelay) = DZERO - this%dbtcomp(n, idelay) = DZERO - if (this%iupdatematprop /= 0) then - this%dbdz(n, idelay) = this%dbdzini(n, idelay) - this%dbdz0(n, idelay) = this%dbdzini(n, idelay) - this%dbtheta(n, idelay) = this%theta(ib) - this%dbtheta0(n, idelay) = this%theta(ib) - end if - end do - ! - ! -- initialize elevation of delay bed cells - call this%csub_delay_calc_zcell(ib) - - end do - ! - ! -- initialize delay bed solution arrays - do n = 1, this%ndelaycells - this%dbal(n) = DZERO - this%dbad(n) = DZERO - this%dbau(n) = DZERO - this%dbrhs(n) = DZERO - this%dbdh(n) = DZERO - this%dbaw(n) = DZERO - end do - end if - end if - ! - ! -- check that ndelaycells is odd when using - ! the effective stress formulation - if (ndelaybeds > 0) then - q = MOD(real(this%ndelaycells, DP), DTWO) - if (q == DZERO) then - write(errmsg, '(a,1x,i0,2(1x,a))') & - 'ERROR: NDELAYCELLS (', this%ndelaycells, ') MUST BE AN', & - 'ODD NUMBER WHEN USING THE EFFECTIVE STRESS FORMULATION.' - call store_error(errmsg) - end if - end if - ! - ! -- return - return - end subroutine csub_read_packagedata - - subroutine read_options(this) -! ****************************************************************************** -! read_options -- set options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: MAXCHARLEN, DZERO - use OpenSpecModule, only: access, form - use InputOutputModule, only: urword, getunit, urdaux, openfile - implicit none - ! -- dummy - class(GwfCsubType), intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: errmsg - character(len=LINELENGTH) :: keyword - character(len=LINELENGTH) :: line - character(len=MAXCHARLEN) :: fname - logical :: isfound - logical :: endOfBlock - integer(I4B) :: lloc - integer(I4B) :: istart - integer(I4B) :: istop - integer(I4B) :: ierr - integer(I4B) :: inobs - integer(I4B) :: ibrg - integer(I4B) :: ieslag - integer(I4B) :: isetgamma - ! -- formats - character(len=*), parameter :: fmtts = & - "(4x, 'TIME-SERIES DATA WILL BE READ FROM FILE: ', a)" - character(len=*),parameter :: fmtflow = & - "(4x, 'FLOWS WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" - character(len=*),parameter :: fmtflow2 = & - "(4x, 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL')" - character(len=*),parameter :: fmtssessv = & - "(4x, 'USING SSE AND SSV INSTEAD OF CR AND CC.')" - character(len=*),parameter :: fmtoffset = & - "(4x, 'INITIAL_STRESS TREATED AS AN OFFSET.')" - character(len=*),parameter :: fmtopt = & - "(4x, A)" - character(len=*),parameter :: fmtopti = & - "(4x, A, 1X, I0)" - character(len=*),parameter :: fmtoptr = & - "(4x, A, 1X, G0)" - character(len=*),parameter :: fmtfileout = & - "(4x, 'CSUB ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" -! ----------------------------------------------------------------------------- - ! - ! -- initialize variables - ibrg = 0 - ieslag = 0 - isetgamma = 0 - ! - ! -- get options block - call this%parser%GetBlock('OPTIONS', isfound, ierr, blockRequired=.false.) - ! - ! -- parse options block if detected - if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING CSUB OPTIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case('AUX', 'AUXILIARY') - call this%parser%GetRemainingLine(line) - lloc = 1 - call urdaux(this%naux, this%parser%iuactive, this%iout, lloc, & - istart, istop, this%auxname, line, this%name) - case ('SAVE_FLOWS') - this%ipakcb = -1 - write(this%iout, fmtflow2) - case ('PRINT_INPUT') - this%iprpak = 1 - write(this%iout,'(4x,a)') 'LISTS OF '//trim(adjustl(this%name))// & - ' CELLS WILL BE PRINTED.' - case ('PRINT_FLOWS') - this%iprflow = 1 - write(this%iout,'(4x,a)') trim(adjustl(this%name))// & - ' FLOWS WILL BE PRINTED TO LISTING FILE.' - case ('BOUNDNAMES') - this%inamedbound = 1 - write(this%iout,'(4x,a)') trim(adjustl(this%name))// & - ' BOUNDARIES HAVE NAMES IN LAST COLUMN.' ! user specified boundnames - case ('TS6') - call this%parser%GetStringCaps(keyword) - if(trim(adjustl(keyword)) /= 'FILEIN') then - errmsg = 'TS6 keyword must be followed by "FILEIN" ' // & - 'then by filename.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - call this%parser%GetString(fname) - write(this%iout,fmtts)trim(fname) - call this%TsManager%add_tsfile(fname, this%inunit) - case ('OBS6') - call this%parser%GetStringCaps(keyword) - if(trim(adjustl(keyword)) /= 'FILEIN') then - errmsg = 'OBS6 keyword must be followed by "FILEIN" ' // & - 'then by filename.' - call store_error(errmsg) - endif - if (this%obs%active) then - errmsg = 'Multiple OBS6 keywords detected in OPTIONS block. ' // & - 'Only one OBS6 entry allowed for a package.' - call store_error(errmsg) - endif - this%obs%active = .true. - call this%parser%GetString(this%obs%inputFilename) - inobs = GetUnit() - call openfile(inobs, this%iout, this%obs%inputFilename, 'OBS') - this%obs%inUnitObs = inobs - this%inobspkg = inobs - - call this%obs%obs_df(this%iout, this%name, this%filtyp, this%dis) - call this%csub_df_obs() - ! - ! -- CSUB specific options - case ('GAMMAW') - this%gammaw = this%parser%GetDouble() - ibrg = 1 - case ('BETA') - this%beta = this%parser%GetDouble() - ibrg = 1 - case ('HEAD_BASED') - this%ipch = 1 - this%lhead_based = .TRUE. - case ('INITIAL_PRECONSOLIDATION_HEAD') - this%ipch = 1 - case ('NDELAYCELLS') - this%ndelaycells = this%parser%GetInteger() - ! - ! -- compression indicies (CR amd CC) will be specified instead of - ! storage coefficients (SSE and SSV) - case ('COMPRESSION_INDICES') - this%istoragec = 0 - ! - ! -- variable thickness and void ratio - case ('UPDATE_MATERIAL_PROPERTIES') - this%iupdatematprop = 1 - ! - ! -- cell fraction will be specified instead of interbed thickness - case ('CELL_FRACTION') - this%icellf = 1 - ! - ! -- specified initial pcs and delay bed heads - case ('SPECIFIED_INITIAL_INTERBED_STATE') - this%ispecified_pcs = 1 - this%ispecified_dbh = 1 - ! - ! -- specified initial pcs - case ('SPECIFIED_INITIAL_PRECONSOLIDATION_STRESS') - this%ispecified_pcs = 1 - ! - ! -- specified initial delay bed heads - case ('SPECIFIED_INITIAL_DELAY_HEAD') - this%ispecified_dbh = 1 - ! - ! -- lag the effective stress used to calculate storage properties - case ('EFFECTIVE_STRESS_LAG') - ieslag = 1 - ! - ! -- strain table options - case ('STRAIN_CSV_INTERBED') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%istrainib = getunit() - call openfile(this%istrainib, this%iout, fname, 'CSV_OUTPUT', & - filstat_opt='REPLACE') - write(this%iout,fmtfileout) & - 'INTERBED STRAIN CSV', fname, this%istrainib - else - errmsg = 'OPTIONAL STRAIN_CSV_INTERBED KEYWORD MUST BE ' // & - 'FOLLOWED BY FILEOUT' - call store_error(errmsg) - end if - case ('STRAIN_CSV_COARSE') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%istrainsk = getunit() - call openfile(this%istrainsk, this%iout, fname, 'CSV_OUTPUT', & - filstat_opt='REPLACE') - write(this%iout,fmtfileout) & - 'COARSE STRAIN CSV', fname, this%istrainsk - else - errmsg = 'OPTIONAL STRAIN_CSV_COARSE KEYWORD MUST BE ' // & - 'FOLLOWED BY FILEOUT' - call store_error(errmsg) - end if - ! - ! -- compaction output - case ('COMPACTION') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ioutcomp = getunit() - call openfile(this%ioutcomp, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE') - write(this%iout,fmtfileout) & - 'COMPACTION', fname, this%ioutcomp - else - errmsg = 'OPTIONAL COMPACTION KEYWORD MUST BE ' // & - 'FOLLOWED BY FILEOUT' - call store_error(errmsg) - end if - case ('COMPACTION_INELASTIC') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ioutcompi = getunit() - call openfile(this%ioutcompi, this%iout, fname, & - 'DATA(BINARY)', form, access, 'REPLACE') - write(this%iout,fmtfileout) & - 'COMPACTION_INELASTIC', fname, this%ioutcompi - else - errmsg = 'OPTIONAL COMPACTION_INELASTIC KEYWORD MUST BE ' // & - 'FOLLOWED BY FILEOUT' - call store_error(errmsg) - end if - case ('COMPACTION_ELASTIC') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ioutcompe = getunit() - call openfile(this%ioutcompe, this%iout, fname, & - 'DATA(BINARY)', form, access, 'REPLACE') - write(this%iout,fmtfileout) & - 'COMPACTION_ELASTIC', fname, this%ioutcompe - else - errmsg = 'OPTIONAL COMPACTION_ELASTIC KEYWORD MUST BE ' // & - 'FOLLOWED BY FILEOUT' - call store_error(errmsg) - end if - case ('COMPACTION_INTERBED') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ioutcompib = getunit() - call openfile(this%ioutcompib, this%iout, fname, & - 'DATA(BINARY)', form, access, 'REPLACE') - write(this%iout,fmtfileout) & - 'COMPACTION_INTERBED', fname, this%ioutcompib - else - errmsg = 'OPTIONAL COMPACTION_INTERBED KEYWORD MUST BE ' // & - 'FOLLOWED BY FILEOUT' - call store_error(errmsg) - end if - case ('COMPACTION_COARSE') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ioutcomps = getunit() - call openfile(this%ioutcomps, this%iout, fname, & - 'DATA(BINARY)', form, access, 'REPLACE') - write(this%iout,fmtfileout) & - 'COMPACTION_COARSE', fname, this%ioutcomps - else - errmsg = 'OPTIONAL COMPACTION_COARSE KEYWORD MUST BE ' // & - 'FOLLOWED BY FILEOUT' - call store_error(errmsg) - end if - ! - ! -- zdisplacement output - case ('ZDISPLACEMENT') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ioutzdisp = getunit() - call openfile(this%ioutzdisp, this%iout, fname, & - 'DATA(BINARY)', form, access, 'REPLACE') - write(this%iout,fmtfileout) & - 'ZDISPLACEMENT', fname, this%ioutzdisp - else - errmsg = 'OPTIONAL ZDISPLACEMENT KEYWORD MUST BE ' // & - 'FOLLOWED BY FILEOUT' - call store_error(errmsg) - end if - ! -- package convergence - case('PACKAGE_CONVERGENCE') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ipakcsv = getunit() - call openfile(this%ipakcsv, this%iout, fname, 'CSV', & - filstat_opt='REPLACE') - write(this%iout,fmtfileout) 'PACKAGE_CONVERGENCE', fname, this%ipakcsv - else - call store_error('OPTIONAL PACKAGE_CONVERGENCE KEYWORD MUST BE ' // & - 'FOLLOWED BY FILEOUT') - end if - ! - ! -- right now these 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_FINAL_CHECK') - call this%parser%DevOpt() - this%iconvchk = 0 - write(this%iout, '(4x,a)') & - 'A FINAL CONVERGENCE CHECK OF THE CHANGE IN DELAY INTERBED ' // & - 'HEADS AND FLOWS WILL NOT BE MADE' - - ! - ! default case - case default - write(errmsg,'(4x,a,3(1x,a))') '****ERROR. UNKNOWN ', & - trim(adjustl(this%name)), & - 'OPTION: ', trim(keyword) - call store_error(errmsg) - end select - end do - write(this%iout,'(1x,a)') 'END OF ' // & - trim(adjustl(this%name)) // ' OPTIONS' - end if - ! - ! -- write messages for options - write(this%iout, '(//2(1X,A))') trim(adjustl(this%name)), & - 'PACKAGE SETTINGS' - write(this%iout, fmtopti) 'NUMBER OF DELAY CELLS =', & - this%ndelaycells - if (this%lhead_based .EQV. .TRUE.) then - write(this%iout, '(4x,a)') & - 'HEAD-BASED FORMULATION' - else - write(this%iout, '(4x,a)') & - 'EFFECTIVE-STRESS FORMULATION' - end if - if (this%istoragec == 0) then - write(this%iout, '(4x,a,1(/,6x,a))') & - 'COMPRESSION INDICES WILL BE SPECIFIED INSTEAD OF ELASTIC AND', & - 'INELASTIC SPECIFIC STORAGE COEFFICIENTS' - else - write(this%iout, '(4x,a,1(/,6x,a))') & - 'ELASTIC AND INELASTIC SPECIFIC STORAGE COEFFICIENTS WILL BE ', & - 'SPECIFIED' - end if - if (this%iupdatematprop /= 1) then - write(this%iout, '(4x,a,1(/,6x,a))') & - 'THICKNESS AND VOID RATIO WILL NOT BE ADJUSTED DURING THE', & - 'SIMULATION' - else - write(this%iout, '(4x,a)') & - 'THICKNESS AND VOID RATIO WILL BE ADJUSTED DURING THE SIMULATION' - end if - if (this%icellf /= 1) then - write(this%iout, '(4x,a)') & - 'INTERBED THICKNESS WILL BE SPECIFIED AS A THICKNESS' - else - write(this%iout,'(4x,a,1(/,6x,a))') & - 'INTERBED THICKNESS WILL BE SPECIFIED AS A AS A CELL FRACTION' - end if - if (this%ispecified_pcs /= 1) then - if (this%ipch /= 0) then - write(this%iout, '(4x,a,1(/,6x,a))') & - 'PRECONSOLIDATION HEAD WILL BE SPECIFIED RELATIVE TO INITIAL', & - 'STRESS CONDITIONS' - else - write(this%iout, '(4x,a,1(/,6x,a))') & - 'PRECONSOLIDATION STRESS WILL BE SPECIFIED RELATIVE TO INITIAL', & - 'STRESS CONDITIONS' - end if - else - if (this%ipch /= 0) then - write(this%iout, '(4x,a,1(/,6x,a))') & - 'PRECONSOLIDATION HEAD WILL BE SPECIFIED AS ABSOLUTE VALUES', & - 'INSTEAD OF RELATIVE TO INITIAL HEAD CONDITIONS' - else - write(this%iout, '(4x,a,1(/,6x,a))') & - 'PRECONSOLIDATION STRESS WILL BE SPECIFIED AS ABSOLUTE VALUES', & - 'INSTEAD OF RELATIVE TO INITIAL STRESS CONDITIONS' - end if - end if - if (this%ispecified_dbh /= 1) then - write(this%iout, '(4x,a,1(/,6x,a))') & - 'DELAY INTERBED HEADS WILL BE SPECIFIED RELATIVE TO INITIAL ', & - 'GWF HEADS' - else - write(this%iout, '(4x,a,1(/,6x,a))') & - 'DELAY INTERBED HEADS WILL BE SPECIFIED AS ABSOLUTE VALUES INSTEAD', & - 'OF RELATIVE TO INITIAL GWF HEADS' - end if - ! - ! -- process effective_stress_lag, if effective stress formulation - if (this%lhead_based .EQV. .FALSE.) then - if (ieslag /= 0) then - write(this%iout, '(4x,a,1(/,6x,a))') & - 'SPECIFIC STORAGE VALUES WILL BE CALCULATED USING THE EFFECTIVE', & - 'STRESS FROM THE PREVIOUS TIME STEP' - else - write(this%iout, '(4x,a,1(/,6x,a))') & - 'SPECIFIC STORAGE VALUES WILL BE CALCULATED USING THE CURRENT', & - 'EFFECTIVE STRESS' - end if - else - if (ieslag /= 0) then - ieslag = 0 - write(this%iout, '(4x,a,2(/,6x,a))') & - 'EFFECTIVE_STRESS_LAG HAS BEEN SPECIFIED BUT HAS NO EFFECT WHEN USING',& - 'THE HEAD-BASED FORMULATION (HEAD_BASED HAS BEEN SPECIFIED IN THE', & - 'OPTIONS BLOCK)' - end if - end if - this%ieslag = ieslag - ! - ! -- recalculate BRG if necessary and output - ! water compressibility values - if (ibrg /= 0) then - this%brg = this%gammaw * this%beta - end if - write(this%iout, fmtoptr) 'GAMMAW =', this%gammaw - write(this%iout, fmtoptr) 'BETA =', this%beta - write(this%iout, fmtoptr) 'GAMMAW * BETA =', this%brg - ! - ! -- terminate if errors encountered in reach block - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- return - return - end subroutine read_options - - subroutine csub_allocate_arrays(this) -! ****************************************************************************** -! allocate_arrays -- Allocate Package Members -! Subroutine: (1) allocate -! (2) initialize -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use MemoryManagerModule, only: mem_allocate, mem_setptr - implicit none - class(GwfCsubType), intent(inout) :: this - ! -- local variables - character(len=LENORIGIN) :: stoname - integer(I4B) :: j - integer(I4B) :: n - integer(I4B) :: iblen - integer(I4B) :: ilen - integer(I4B) :: naux - - ! -- grid based data - if (this%ioutcomp == 0 .and. this%ioutcompi == 0 .and. & - this%ioutcompe == 0 .and. this%ioutcompib == 0 .and. & - this%ioutcomps == 0 .and. this%ioutzdisp == 0) then - call mem_allocate(this%buff, 1, 'BUFF', trim(this%origin)) - else - call mem_allocate(this%buff, this%dis%nodes, 'BUFF', trim(this%origin)) - end if - if (this%ioutcomp == 0 .and. this%ioutzdisp == 0) then - call mem_allocate(this%buffusr, 1, 'buffusr', trim(this%origin)) - else - call mem_allocate(this%buffusr, this%dis%nodesuser, 'buffusr', & - trim(this%origin)) - end if - call mem_allocate(this%sgm, this%dis%nodes, 'sgm', trim(this%origin)) - call mem_allocate(this%sgs, this%dis%nodes, 'sgs', trim(this%origin)) - call mem_allocate(this%cg_ske_cr, this%dis%nodes, 'cg_ske_cr', & - trim(this%origin)) - call mem_allocate(this%cg_es, this%dis%nodes, 'cg_es', trim(this%origin)) - call mem_allocate(this%cg_es0, this%dis%nodes, 'cg_es0', trim(this%origin)) - call mem_allocate(this%cg_pcs, this%dis%nodes, 'cg_pcs', trim(this%origin)) - call mem_allocate(this%cg_comp, this%dis%nodes, 'cg_comp', trim(this%origin)) - call mem_allocate(this%cg_tcomp, this%dis%nodes, 'cg_tcomp', & - trim(this%origin)) - call mem_allocate(this%cg_stor, this%dis%nodes, 'cg_stor', trim(this%origin)) - call mem_allocate(this%cg_ske, this%dis%nodes, 'cg_ske', trim(this%origin)) - call mem_allocate(this%cg_sk, this%dis%nodes, 'cg_sk', trim(this%origin)) - call mem_allocate(this%cg_thickini, this%dis%nodes, 'cg_thickini', & - trim(this%origin)) - call mem_allocate(this%cg_thetaini, this%dis%nodes, 'cg_thetaini', & - trim(this%origin)) - if (this%iupdatematprop == 0) then - call mem_setptr(this%cg_thick, 'cg_thickini', trim(this%origin)) - call mem_setptr(this%cg_thick0, 'cg_thickini', trim(this%origin)) - call mem_setptr(this%cg_theta, 'cg_thetaini', trim(this%origin)) - call mem_setptr(this%cg_theta0, 'cg_thetaini', trim(this%origin)) - else - call mem_allocate(this%cg_thick, this%dis%nodes, 'cg_thick', & - trim(this%origin)) - call mem_allocate(this%cg_thick0, this%dis%nodes, 'cg_thick0', & - trim(this%origin)) - call mem_allocate(this%cg_theta, this%dis%nodes, 'cg_theta', & - trim(this%origin)) - call mem_allocate(this%cg_theta0, this%dis%nodes, 'cg_theta0', & - trim(this%origin)) - end if - ! - ! -- cell storage data - call mem_allocate(this%cell_wcstor, this%dis%nodes, 'cell_wcstor', & - trim(this%origin)) - call mem_allocate(this%cell_thick, this%dis%nodes, 'cell_thick', & - trim(this%origin)) - ! - ! -- interbed data - iblen = 1 - if (this%ninterbeds > 0) then - iblen = this%ninterbeds - end if - naux = 1 - if (this%naux > 0) then - naux = this%naux - end if - call mem_allocate(this%auxvar, naux, iblen, 'AUXVAR', this%origin) - do n = 1, iblen - do j = 1, naux - this%auxvar(j, n) = DZERO - end do - end do - call mem_allocate(this%unodelist, iblen, 'unodelist', trim(this%origin)) - call mem_allocate(this%nodelist, iblen, 'nodelist', trim(this%origin)) - call mem_allocate(this%cg_gs, this%dis%nodes, 'cg_gs', trim(this%origin)) - call mem_allocate(this%pcs, iblen, 'pcs', trim(this%origin)) - call mem_allocate(this%rnb, iblen, 'rnb', trim(this%origin)) - call mem_allocate(this%kv, iblen, 'kv', trim(this%origin)) - call mem_allocate(this%h0, iblen, 'h0', trim(this%origin)) - call mem_allocate(this%ci, iblen, 'ci', trim(this%origin)) - call mem_allocate(this%rci, iblen, 'rci', trim(this%origin)) - call mem_allocate(this%idelay, iblen, 'idelay', trim(this%origin)) - call mem_allocate(this%ielastic, iblen, 'ielastic', trim(this%origin)) - call mem_allocate(this%iconvert, iblen, 'iconvert', trim(this%origin)) - call mem_allocate(this%comp, iblen, 'comp', trim(this%origin)) - call mem_allocate(this%tcomp, iblen, 'tcomp', trim(this%origin)) - call mem_allocate(this%tcompi, iblen, 'tcompi', trim(this%origin)) - call mem_allocate(this%tcompe, iblen, 'tcompe', trim(this%origin)) - call mem_allocate(this%storagee, iblen, 'storagee', trim(this%origin)) - call mem_allocate(this%storagei, iblen, 'storagei', trim(this%origin)) - call mem_allocate(this%ske, iblen, 'ske', trim(this%origin)) - call mem_allocate(this%sk, iblen, 'sk', trim(this%origin)) - call mem_allocate(this%thickini, iblen, 'thickini', trim(this%origin)) - call mem_allocate(this%thetaini, iblen, 'thetaini', trim(this%origin)) - if (this%iupdatematprop == 0) then - call mem_setptr(this%thick, 'thickini', trim(this%origin)) - call mem_setptr(this%thick0, 'thickini', trim(this%origin)) - call mem_setptr(this%theta, 'thetaini', trim(this%origin)) - call mem_setptr(this%theta0, 'thetaini', trim(this%origin)) - else - call mem_allocate(this%thick, iblen, 'thick', trim(this%origin)) - call mem_allocate(this%thick0, iblen, 'thick0', trim(this%origin)) - call mem_allocate(this%theta, iblen, 'theta', trim(this%origin)) - call mem_allocate(this%theta0, iblen, 'theta0', trim(this%origin)) - end if - ! - ! -- delay bed storage - allocated in csub_read_packagedata - ! after number of delay beds is defined - ! - ! -- allocate boundname - allocate(this%boundname(this%ninterbeds)) - ! - ! -- allocate the nodelist and bound arrays - if (this%maxsig0 > 0) then - ilen = this%maxsig0 - else - ilen = 1 - end if - call mem_allocate(this%nodelistsig0, ilen, 'NODELISTSIG0', this%origin) - this%nodelistsig0 = 0 - call mem_allocate(this%bound, this%ncolbnd, ilen, 'BOUND', & - this%origin) - call mem_allocate(this%auxvarsig0, this%naux, ilen, 'AUXVARSIG0', & - this%origin) - ! - ! -- Allocate sig0boundname - allocate(this%sig0bname(ilen)) - ! - ! -- set pointers to gwf variables - call mem_setptr(this%gwfiss, 'ISS', trim(this%name_model)) - ! - ! -- set pointers to variables in the storage package - stoname = trim(this%name_model) // ' ' // trim(this%stoname) - call mem_setptr(this%stoiconv, 'ICONVERT', trim(stoname)) - call mem_setptr(this%stosc1, 'SC1', trim(stoname)) - ! - ! -- initialize variables that are not specified by user - do n = 1, this%dis%nodes - this%cg_gs(n) = DZERO - this%cg_es(n) = DZERO - this%cg_comp(n) = DZERO - this%cg_tcomp(n) = DZERO - this%cell_wcstor(n) = DZERO - end do - do n = 1, this%ninterbeds - this%theta(n) = DZERO - this%tcomp(n) = DZERO - this%tcompi(n) = DZERO - this%tcompe(n) = DZERO - end do - ! - ! -- return - return - - end subroutine csub_allocate_arrays - - subroutine csub_da(this) -! ****************************************************************************** -! csub_da -- Deallocate variables -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - implicit none - ! -- dummy - class(GwfCsubType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Deallocate arrays if package is active - if(this%inunit > 0) then - call mem_deallocate(this%unodelist) - call mem_deallocate(this%nodelist) - call mem_deallocate(this%idelay) - call mem_deallocate(this%ielastic) - call mem_deallocate(this%iconvert) - ! - ! -- grid-based storage data - call mem_deallocate(this%buff) - call mem_deallocate(this%buffusr) - call mem_deallocate(this%sgm) - call mem_deallocate(this%sgs) - call mem_deallocate(this%cg_ske_cr) - call mem_deallocate(this%cg_gs) - call mem_deallocate(this%cg_es) - call mem_deallocate(this%cg_es0) - call mem_deallocate(this%cg_pcs) - call mem_deallocate(this%cg_comp) - call mem_deallocate(this%cg_tcomp) - call mem_deallocate(this%cg_stor) - call mem_deallocate(this%cg_ske) - call mem_deallocate(this%cg_sk) - if (this%iupdatematprop == 0) then - nullify(this%cg_thick) - nullify(this%cg_thick0) - nullify(this%cg_theta) - nullify(this%cg_theta0) - else - call mem_deallocate(this%cg_thick) - call mem_deallocate(this%cg_thick0) - call mem_deallocate(this%cg_theta) - call mem_deallocate(this%cg_theta0) - end if - call mem_deallocate(this%cg_thickini) - call mem_deallocate(this%cg_thetaini) - ! - ! -- cell storage - call mem_deallocate(this%cell_wcstor) - call mem_deallocate(this%cell_thick) - ! - ! -- interbed storage - deallocate(this%boundname) - deallocate(this%sig0bname) - deallocate(this%auxname) - call mem_deallocate(this%auxvar) - call mem_deallocate(this%ci) - call mem_deallocate(this%rci) - call mem_deallocate(this%pcs) - !call mem_deallocate(this%thick) - !call mem_deallocate(this%theta) - call mem_deallocate(this%rnb) - call mem_deallocate(this%kv) - call mem_deallocate(this%h0) - call mem_deallocate(this%comp) - call mem_deallocate(this%tcomp) - call mem_deallocate(this%tcompi) - call mem_deallocate(this%tcompe) - call mem_deallocate(this%storagee) - call mem_deallocate(this%storagei) - call mem_deallocate(this%ske) - call mem_deallocate(this%sk) - if (this%iupdatematprop == 0) then - nullify(this%thick) - nullify(this%thick0) - nullify(this%theta) - nullify(this%theta0) - else - call mem_deallocate(this%thick) - call mem_deallocate(this%thick0) - call mem_deallocate(this%theta) - call mem_deallocate(this%theta0) - end if - call mem_deallocate(this%thickini) - call mem_deallocate(this%thetaini) - ! - ! -- delay bed storage - if (this%ndelaybeds > 0) then - if (this%iupdatematprop == 0) then - nullify(this%dbdz) - nullify(this%dbdz0) - nullify(this%dbtheta) - nullify(this%dbtheta0) - else - call mem_deallocate(this%dbdz) - call mem_deallocate(this%dbdz0) - call mem_deallocate(this%dbtheta) - call mem_deallocate(this%dbtheta0) - end if - call mem_deallocate(this%idbconvert) - call mem_deallocate(this%dbdhmax) - call mem_deallocate(this%dbz) - call mem_deallocate(this%dbrelz) - call mem_deallocate(this%dbh) - call mem_deallocate(this%dbh0) - call mem_deallocate(this%dbgeo) - call mem_deallocate(this%dbes) - call mem_deallocate(this%dbes0) - call mem_deallocate(this%dbpcs) - call mem_deallocate(this%dbflowtop) - call mem_deallocate(this%dbflowbot) - call mem_deallocate(this%dbdzini) - call mem_deallocate(this%dbthetaini) - call mem_deallocate(this%dbcomp) - call mem_deallocate(this%dbtcomp) - ! - ! -- delay interbed solution arrays - call mem_deallocate(this%dbal) - call mem_deallocate(this%dbad) - call mem_deallocate(this%dbau) - call mem_deallocate(this%dbrhs) - call mem_deallocate(this%dbdh) - call mem_deallocate(this%dbaw) - end if - ! - ! -- period data - call mem_deallocate(this%nodelistsig0) - call mem_deallocate(this%bound) - call mem_deallocate(this%auxvarsig0) - ! - ! -- pointers to gwf variables - nullify(this%gwfiss) - ! - ! -- pointers to storage variables - nullify(this%stoiconv) - nullify(this%stosc1) - ! - ! -- input table - if (this%iprpak > 0) then - call this%inputtab%table_da() - deallocate(this%inputtab) - nullify(this%inputtab) - end if - ! - ! -- output table - if (this%istrainib > 0 .or. this%istrainsk > 0) then - call this%outputtab%table_da() - deallocate(this%outputtab) - nullify(this%outputtab) - end if - end if - ! - ! -- package csv table - if (this%ipakcsv > 0) then - call this%pakcsvtab%table_da() - deallocate(this%pakcsvtab) - nullify(this%pakcsvtab) - end if - ! - ! -- deallocate scalars - call mem_deallocate(this%istounit) - call mem_deallocate(this%inobspkg) - call mem_deallocate(this%ninterbeds) - call mem_deallocate(this%maxsig0) - call mem_deallocate(this%nbound) - call mem_deallocate(this%ncolbnd) - call mem_deallocate(this%iscloc) - call mem_deallocate(this%iauxmultcol) - call mem_deallocate(this%ndelaycells) - call mem_deallocate(this%ndelaybeds) - call mem_deallocate(this%initialized) - call mem_deallocate(this%ieslag) - call mem_deallocate(this%ipch) - call mem_deallocate(this%lhead_based) - call mem_deallocate(this%iupdatestress) - call mem_deallocate(this%ispecified_pcs) - call mem_deallocate(this%ispecified_dbh) - call mem_deallocate(this%inamedbound) - call mem_deallocate(this%iconvchk) - call mem_deallocate(this%naux) - call mem_deallocate(this%istoragec) - call mem_deallocate(this%istrainib) - call mem_deallocate(this%istrainsk) - call mem_deallocate(this%ioutcomp) - call mem_deallocate(this%ioutcompi) - call mem_deallocate(this%ioutcompe) - call mem_deallocate(this%ioutcompib) - call mem_deallocate(this%ioutcomps) - call mem_deallocate(this%ioutzdisp) - call mem_deallocate(this%ipakcsv) - call mem_deallocate(this%iupdatematprop) - call mem_deallocate(this%epsilon) - call mem_deallocate(this%cc_crit) - call mem_deallocate(this%gammaw) - call mem_deallocate(this%beta) - call mem_deallocate(this%brg) - call mem_deallocate(this%satomega) - call mem_deallocate(this%icellf) - call mem_deallocate(this%gwfiss0) - ! - ! -- deallocate methods on objects - if(this%inunit > 0) then - call this%obs%obs_da() - call this%TsManager%da() - ! - ! -- deallocate objects - deallocate(this%obs) - deallocate(this%TsManager) - end if - ! - ! -- nullify TsManager - nullify(this%TsManager) - ! - ! -- deallocate parent - call this%NumericalPackageType%da() - ! - ! -- Return - return - end subroutine csub_da - - subroutine csub_read_dimensions(this) -! ****************************************************************************** -! pak1read_dimensions -- Read the dimensions for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH, LENBOUNDNAME - use KindModule, only: I4B -! use SimModule, only: ustop, store_error, count_errors - ! -- dummy - class(GwfCsubType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: errmsg - character(len=LENBOUNDNAME) :: keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock - ! -- format -! ------------------------------------------------------------------------------ - ! - ! -- initialize dimensions to -1 - this%ninterbeds = -1 - ! - ! -- 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 '//trim(adjustl(this%name))// & - ' DIMENSIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('NINTERBEDS') - this%ninterbeds = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)')'NINTERBEDS = ', this%ninterbeds - case ('MAXSIG0') - this%maxsig0 = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)')'MAXSIG0 = ', this%maxsig0 - case default - write(errmsg,'(4x,a,a)') & - '****ERROR. UNKNOWN '//trim(this%name)//' DIMENSION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - end do - write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%name))//' DIMENSIONS' - else - call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') - call ustop() - end if - ! - ! -- verify dimensions were set correctly - if (this%ninterbeds < 0) then - write(errmsg, '(1x,a)') & - 'ERROR: ninterbeds WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.' - call store_error(errmsg) - end if - ! - ! -- stop if errors were encountered in the DIMENSIONS block - ierr = count_errors() - if (ierr > 0) then - call ustop() - end if - - ! -- Call define_listlabel to construct the list label that is written - ! when PRINT_INPUT option is used. - call this%define_listlabel() - ! - ! -- return - return - end subroutine csub_read_dimensions - - subroutine csub_ar(this, dis, ibound) -! ****************************************************************************** -! csub_ar -- Allocate and Read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_setptr - use ConstantsModule, only: LINELENGTH - use KindModule, only: I4B - use InputOutputModule, only: urword, uget_block, u8rdcom, & - uterminate_block - implicit none - ! -- dummy - class(GwfCsubType),intent(inout) :: this - class(DisBaseType), pointer, intent(in) :: dis - integer(I4B), dimension(:), pointer, contiguous :: ibound - ! -- local - logical :: isfound, endOfBlock - character(len=LINELENGTH) :: line - character(len=LINELENGTH) :: errmsg - character(len=LINELENGTH) :: keyword - character(len=20) :: cellid - integer(I4B) :: iske - integer(I4B) :: istheta - integer(I4B) :: isgm - integer(I4B) :: isgs - integer(I4B) :: idelay - integer(I4B) :: ierr - integer(I4B) :: lloc - integer(I4B) :: istart - integer(I4B) :: istop - integer(I4B) :: ib - integer(I4B) :: node - integer(I4B) :: istoerr - real(DP) :: top - real(DP) :: bot - real(DP) :: thick - real(DP) :: cg_ske_cr - real(DP) :: theta - real(DP) :: v - ! -- format - character(len=*), parameter :: fmtcsub = & - "(1x,/1x,'CSUB -- COMPACTION PACKAGE, VERSION 1, 12/15/2019', & - &' INPUT READ FROM UNIT ', i0, //)" -! ------------------------------------------------------------------------------ - ! - ! --print a message identifying the csub package. - write(this%iout, fmtcsub) this%inunit - ! - ! -- store pointers to arguments that were passed in - this%dis => dis - this%ibound => ibound - ! - ! -- Create time series managers - call tsmanager_cr(this%TsManager, this%iout) - ! - ! -- create obs package - call obs_cr(this%obs, this%inobspkg) - ! - ! -- Read csub options - call this%read_options() - ! - ! -- Now that time series will have been read, need to call the df - ! routine to define the manager - call this%tsmanager%tsmanager_df() - ! - ! -- Read the csub dimensions - call this%read_dimensions() - ! - ! - observation data - call this%obs%obs_ar() - ! - ! -- terminate if errors dimensions block data - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - - ! -- Allocate arrays in - call this%csub_allocate_arrays() - ! - ! -- initialize local variables - iske = 0 - istheta = 0 - isgm = 0 - isgs = 0 - ! - ! -- read griddata block - call this%parser%GetBlock('GRIDDATA', isfound, ierr) - if (isfound) then - 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 ('CG_SKE_CR') - call this%dis%read_grid_array(line, lloc, istart, istop, & - this%iout, this%parser%iuactive, & - this%cg_ske_cr, 'CG_SKE_CR') - iske = 1 - case ('CG_THETA') - call this%dis%read_grid_array(line, lloc, istart, istop, & - this%iout, this%parser%iuactive, & - this%cg_thetaini, 'CG_THETA') - istheta = 1 - case ('SGM') - call this%dis%read_grid_array(line, lloc, istart, istop, & - this%iout, this%parser%iuactive, & - this%sgm, 'SGM') - isgm = 1 - case ('SGS') - call this%dis%read_grid_array(line, lloc, istart, istop, & - this%iout, this%parser%iuactive, & - this%sgs, 'SGS') - isgs = 1 - case default - write(errmsg,'(4x,a,a)')'ERROR. UNKNOWN GRIDDATA TAG: ', & - trim(keyword) - call store_error(errmsg) - end select - end do - else - call store_error('ERROR. REQUIRED GRIDDATA BLOCK NOT FOUND.') - end if - ! - ! -- detemine if cg_ske and cg_theta have been specified - if (iske == 0) then - write(errmsg,'(4x,a)') 'ERROR. cg_SKE GRIDDATA MUST BE SPECIFIED' - call store_error(errmsg) - end if - if (istheta == 0) then - write(errmsg,'(4x,a)') 'ERROR. cg_THETA GRIDDATA MUST BE SPECIFIED' - call store_error(errmsg) - end if - ! - ! -- determine if sgm and sgs have been specified, if not assign default values - if (isgm == 0) then - do node = 1, this%dis%nodes - this%sgm(node) = 1.7D0 - end do - end if - if (isgs == 0) then - do node = 1, this%dis%nodes - this%sgs(node) = 2.0D0 - end do - end if - ! - ! -- evaluate the coarse-grained material properties and if - ! non-zero specific storage values are specified in the - ! STO package - istoerr = 0 - do node = 1, this%dis%nodes - call this%dis%noder_to_string(node, cellid) - cg_ske_cr = this%cg_ske_cr(node) - theta = this%cg_thetaini(node) - ! - ! -- coarse-grained storage error condition - if (cg_ske_cr < DZERO) then - write(errmsg,'(4x,a,g0,a,1x,a,1x,a)') & - 'ERROR. COARSE-GRAINED MATERIAL cg_ske_cr (', cg_ske_cr, ') IS LESS', & - 'THAN ZERO IN CELL', trim(adjustl(cellid)) - end if - ! - ! -- storage (STO) package error condition - if (this%stosc1(node) /= DZERO) then - istoerr = 1 - end if - ! - ! -- porosity error condition - if (theta > DONE .or. theta < DZERO) then - write(errmsg,'(4x,a,g0,a,1x,a,1x,a)') & - 'ERROR. COARSE-GRAINED MATERIAL THETA (', theta, ') IS LESS', & - 'THAN ZERO OR GREATER THAN 1 IN CELL', trim(adjustl(cellid)) - end if - end do - ! - ! -- write single message if storage (STO) package has non-zero specific - ! storage values - if (istoerr /= 0) then - write(errmsg,'(4x,a,3(1x,a))') & - 'ERROR. SPECIFIC STORAGE VALUES IN THE STORAGE (STO) PACKAGE MUST', & - 'BE ZERO IN ALL ACTIVE CELLS WHEN USING THE', trim(adjustl(this%name)), & - 'PACKAGE' - call store_error(errmsg) - end if - ! - ! -- read interbed data - if (this%ninterbeds > 0) then - call this%csub_read_packagedata() - end if - ! - ! -- calculate the coarse-grained material thickness without the interbeds - do node = 1, this%dis%nodes - top = this%dis%top(node) - bot = this%dis%bot(node) - this%cg_thickini(node) = top - bot - this%cell_thick(node) = top - bot - end do - ! - ! -- subtract the interbed thickness from aquifer thickness - do ib = 1, this%ninterbeds - node = this%nodelist(ib) - idelay = this%idelay(ib) - if (idelay == 0) then - v = this%thickini(ib) - else - v = this%rnb(ib) * this%thickini(ib) - end if - this%cg_thickini(node) = this%cg_thickini(node) - v - end do - ! - ! -- evaluate if any cg_thick values are less than 0 - do node = 1, this%dis%nodes - thick = this%cg_thickini(node) - if (thick < DZERO) then - call this%dis%noder_to_string(node, cellid) - write(errmsg,'(4x,a,1x,g0,a,1x,a,1x,a)') & - 'ERROR. AQUIFER THICKNESS IS LESS THAN ZERO (', & - thick, ')', 'in cell', trim(adjustl(cellid)) - call store_error(errmsg) - end if - end do - ! - ! -- terminate if errors griddata, packagedata blocks, TDIS, or STO data - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- set current coarse-grained thickness (cg_thick) and - ! current coarse-grained porosity (cg_theta). Only needed - ! if updating material properties - if (this%iupdatematprop /= 0) then - do node = 1, this%dis%nodes - this%cg_thick(node) = this%cg_thickini(node) - this%cg_theta(node) = this%cg_thetaini(node) - end do - end if - ! - ! -- return - return - end subroutine csub_ar - - - subroutine csub_cg_calc_stress(this, nodes, hnew) -! ****************************************************************************** -! csub_cg_calc_stress -- calculate the geostatic stress for every gwf node -! in the model -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - class(GwfCsubType) :: this - integer(I4B), intent(in) :: nodes - real(DP), dimension(nodes), intent(in) :: hnew - ! -- local - integer(I4B) :: node - integer(I4B) :: ii - integer(I4B) :: nn - integer(I4B) :: m - integer(I4B) :: iis - real(DP) :: gs - real(DP) :: top - real(DP) :: bot - real(DP) :: thick - real(DP) :: va_scale - real(DP) :: hcell - real(DP) :: gs_conn - real(DP) :: area_node - real(DP) :: area_conn - real(DP) :: es - real(DP) :: hs - real(DP) :: hwva - real(DP) :: sadd - -! ------------------------------------------------------------------------------ - ! - ! -- calculate geostatic stress if necessary - if (this%iupdatestress /= 0) then - do node = 1, this%dis%nodes - ! - ! -- calculate geostatic stress for this node - ! this represents the geostatic stress component - ! for the cell - top = this%dis%top(node) - bot = this%dis%bot(node) - thick = top - bot - ! - ! -- calculate cell contribution to geostatic stress - if (this%ibound(node) /= 0) then - hcell = hnew(node) - else - hcell = bot - end if - if (hcell < bot) then - gs = thick * this%sgm(node) - else if (hcell < top) then - gs = (top - hcell) * this%sgm(node) + (hcell - bot) * this%sgs(node) - else - gs = thick * this%sgs(node) - end if - ! - ! -- cell contribution to geostatic stress - this%cg_gs(node) = gs - end do - ! - ! -- add user specified overlying geostatic stress - do nn = 1, this%nbound - node = this%nodelistsig0(nn) - sadd = this%bound(1, nn) - this%cg_gs(node) = this%cg_gs(node) + sadd - end do - ! - ! -- calculate geostatic stress above cell - do node = 1, this%dis%nodes - ! - ! -- area of cell - area_node = this%dis%get_area(node) - ! - ! -- geostatic stress of cell - gs = this%cg_gs(node) - ! - ! -- Add geostatic stress of overlying cells (ihc=0) - ! m < node = m is vertically above node - do ii = this%dis%con%ia(node) + 1, this%dis%con%ia(node + 1) - 1 - ! - ! -- Set the m cell number - m = this%dis%con%ja(ii) - iis = this%dis%con%jas(ii) - ! - ! -- vertical connection - if (this%dis%con%ihc(iis) == 0) then - ! - ! -- node has an overlying cell - if (m < node) then - ! - ! -- dis and disv discretization - if (this%dis%ndim /= 1) then - gs = gs + this%cg_gs(m) - ! - ! -- disu discretization - ! *** this needs to be checked *** - else - area_conn = this%dis%get_area(m) - hwva = this%dis%con%hwva(iis) - va_scale = this%dis%con%hwva(iis) / this%dis%get_area(m) - gs_conn = this%cg_gs(m) - gs = gs + (gs_conn * va_scale) - end if - - end if - end if - end do - ! - ! -- geostatic stress for cell with geostatic stress - ! of overlying cells - this%cg_gs(node) = gs - end do - end if - ! - ! -- save effective stress from the last iteration and - ! calculate the new effective stress for a cell - do node = 1, this%dis%nodes - top = this%dis%top(node) - bot = this%dis%bot(node) - if (this%ibound(node) /= 0) then - hcell = hnew(node) - if (hcell < bot) then - hcell = bot - end if - else - hcell = bot - end if - hs = hcell - bot - ! - ! -- calculate effective stress - es = this%cg_gs(node) - hs - this%cg_es(node) = es - end do - ! - ! -- return - return - - end subroutine csub_cg_calc_stress - - - subroutine csub_cg_chk_stress(this) -! ****************************************************************************** -! csub_cg_chk_stress -- check that the effective stress for every gwf node -! in the model is a positive value -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - class(GwfCsubType) :: this - ! -- local - character(len=LINELENGTH) :: errmsg - character(len=20) :: cellid - integer(I4B) :: ierr - integer(I4B) :: node - real(DP) :: gs - real(DP) :: bot - real(DP) :: hcell - real(DP) :: es - real(DP) :: u - -! ------------------------------------------------------------------------------ - ! - ! -- initialize variables - ierr = 0 - ! - ! -- check geostatic stress if necessary - ! - ! -- save effective stress from the last iteration and - ! calculate the new effective stress for a cell - do node = 1, this%dis%nodes - if (this%ibound(node) < 1) cycle - bot = this%dis%bot(node) - gs = this%cg_gs(node) - es = this%cg_es(node) - u = DZERO - if (this%ibound(node) /= 0) then - u = gs - es - end if - hcell = u + bot - if (this%lhead_based .EQV. .FALSE.) then - if (es < DEM6) then - ierr = ierr + 1 - call this%dis%noder_to_string(node, cellid) - write(errmsg, '(a,g0.7,a,1x,a)') & - 'ERROR: SMALL TO NEGATIVE EFFECTIVE STRESS (', es, ') IN CELL', & - trim(adjustl(cellid)) - call store_error(errmsg) - write(errmsg, '(4x,a,1x,g0.7,3(1x,a,1x,g0.7),1x,a)') & - '(', es, '=', this%cg_gs(node), '- (', hcell, '-', bot, ')' - call store_error(errmsg) - end if - end if - end do - ! - ! -- write a summary error message - if (ierr > 0) then - write(errmsg, '(a,1x,i0,3(1x,a))') & - 'ERROR SOLUTION: SMALL TO NEGATIVE EFFECTIVE STRESS VALUES IN', ierr, & - 'CELLS CAN BE ELIMINATED BY INCREASING STORAGE VALUES AND/OR ', & - 'ADDING/MODIFYINGSTRESS BOUNDARIES TO PREVENT WATER-LEVELS FROM', & - 'EXCEEDING THE TOP OF THE MODEL' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- return - return - - end subroutine csub_cg_chk_stress - - - subroutine csub_nodelay_update(this, i) -! ****************************************************************************** -! csub_nodelay_update -- Update material properties for no-delay interbeds. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - integer(I4B),intent(in) :: i - ! locals - character(len=LINELENGTH) :: errmsg - real(DP) :: comp - real(DP) :: thick - real(DP) :: theta -! ------------------------------------------------------------------------------ -! -! -- update thickness and theta - comp = this%tcomp(i) + this%comp(i) - if (ABS(comp) > DZERO) then - thick = this%thickini(i) - theta = this%thetaini(i) - call this%csub_adj_matprop(comp, thick, theta) - if (thick <= DZERO) then - write(errmsg,'(4x,2a,1x,i0,1x,a,1x,g0,1x,a)') & - '****ERROR. ADJUSTED THICKNESS FOR NO-DELAY ', & - 'INTERBED', i, 'IS <= 0 (', thick, ')' - call store_error(errmsg) - end if - if (theta <= DZERO) then - write(errmsg,'(4x,2a,1x,i0,1x,a,1x,g0,1x,a)') & - '****ERROR. ADJUSTED THETA FOR NO-DELAY ', & - 'INTERBED (', i, ') IS <= 0 (', theta, ')' - call store_error(errmsg) - end if - this%thick(i) = thick - this%theta(i) = theta - end if - ! - ! -- return - return - end subroutine csub_nodelay_update - - - subroutine csub_nodelay_fc(this, ib, hcell, hcellold, rho1, rho2, rhs, & - argtled) -! ****************************************************************************** -! csub_nodelay_fc -- Calculate rho1, rho2, and rhs for no-delay interbeds -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use TdisModule, only: delt - implicit none - ! -- dummy variables - class(GwfCsubType) :: this - integer(I4B), intent(in) :: ib - real(DP), intent(in) :: hcell - real(DP), intent(in) :: hcellold - real(DP), intent(inout) :: rho1 - real(DP), intent(inout) :: rho2 - real(DP), intent(inout) :: rhs - real(DP), intent(in), optional :: argtled - ! -- local variables - integer(I4B) :: node - real(DP) :: tled - real(DP) :: top - real(DP) :: bot - real(DP) :: thick - real(DP) :: znode - real(DP) :: snold - real(DP) :: snnew - real(DP) :: sto_fac - real(DP) :: sto_fac0 - real(DP) :: area - real(DP) :: theta - real(DP) :: es - real(DP) :: es0 - real(DP) :: f - real(DP) :: f0 -! ------------------------------------------------------------------------------ - if (present(argtled)) then - tled = argtled - else - tled = DONE / delt - endif - node = this%nodelist(ib) - area = this%dis%get_area(node) - bot = this%dis%bot(node) - top = this%dis%top(node) - thick = this%thickini(ib) - ! - ! -- set iconvert - this%iconvert(ib) = 0 - ! - ! -- aquifer saturation - call this%csub_calc_sat(node, hcell, hcellold, snnew, snold) - if (this%lhead_based .EQV. .TRUE.) then - f = DONE - f0 = DONE - else - znode = this%csub_calc_znode(top, bot, hcell) - es = this%cg_es(node) - es0 = this%cg_es0(node) - theta = this%thetaini(ib) - ! - ! -- calculate the compression index factors for the delay - ! node relative to the center of the cell based on the - ! current and previous head - call this%csub_calc_sfacts(node, bot, znode, theta, es, es0, f) - end if - sto_fac = tled * snnew * thick * f - sto_fac0 = tled * snold * thick * f - ! - ! -- calculate rho1 and rho2 - rho1 = this%rci(ib) * sto_fac0 - rho2 = this%rci(ib) * sto_fac - if (this%cg_es(node) > this%pcs(ib)) then - this%iconvert(ib) = 1 - rho2 = this%ci(ib) * sto_fac - end if - if (this%ielastic(ib) /= 0) then - rhs = rho1 * this%cg_es0(node) - & - rho2 * (this%cg_gs(node) + bot) - else - rhs = -rho2 * (this%cg_gs(node) + bot) + & - (this%pcs(ib) * (rho2 - rho1)) + & - (rho1 * this%cg_es0(node)) - end if - ! - ! -- save ske and sk - this%ske(ib) = rho1 - this%sk(ib) = rho2 - ! - ! -- return - return - - end subroutine csub_nodelay_fc - - subroutine csub_nodelay_calc_comp(this, ib, hcell, hcellold, comp, rho1, rho2) -! ****************************************************************************** -! csub_nodelay_calc_comp -- Calculate compaction, rho1, and rho2 for no-delay -! interbeds -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - ! -- dummy variables - class(GwfCsubType) :: this - integer(I4B), intent(in) :: ib - real(DP), intent(in) :: hcell - real(DP), intent(in) :: hcellold - real(DP), intent(inout) :: comp - real(DP), intent(inout) :: rho1 - real(DP), intent(inout) :: rho2 - ! -- local variables - integer(I4B) :: node - real(DP) :: es - real(DP) :: es0 - real(DP) :: pcs - real(DP) :: tled - real(DP) :: rhs -! ------------------------------------------------------------------------------ - ! - ! -- initialize variables - node = this%nodelist(ib) - tled = DONE - es = this%cg_es(node) - es0 = this%cg_es0(node) - pcs = this%pcs(ib) - ! - ! -- calculate no-delay interbed rho1 and rho2 - call this%csub_nodelay_fc(ib, hcell, hcellold, rho1, rho2, rhs, argtled=tled) - ! - ! -- calculate no-delay interbed compaction - if (this%ielastic(ib) /= 0) then - comp = rho2 * es - rho1 * es0 - else - comp = -pcs * (rho2 - rho1) - (rho1 * es0) + (rho2 * es) - end if - ! - ! -- return - return - - end subroutine csub_nodelay_calc_comp - - - subroutine csub_rp(this) -! ****************************************************************************** -! csub_rp -- Read and Prepare -! Subroutine: (1) read itmp -! (2) read new boundaries if itmp>0 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use TdisModule, only: kper, nper -! use SimModule, only: store_error, ustop, count_errors - implicit none - ! -- dummy - class(GwfCsubType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: line, errmsg - integer(I4B) :: ierr - integer(I4B) :: nlist - logical :: isfound - ! -- formats - character(len=*),parameter :: fmtblkerr = & - "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - character(len=*),parameter :: fmtlsp = & - "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" -! ------------------------------------------------------------------------------ - ! - if(this%inunit == 0) return - ! - ! -- get stress period data - if (this%ionper < kper) then - ! - ! -- get period block - call this%parser%GetBlock('PERIOD', isfound, ierr, & - supportOpenClose=.true.) - if (isfound) then - ! - ! -- read ionper and check for increasing period numbers - call this%read_check_ionper() - else - ! - ! -- PERIOD block not found - if (ierr < 0) then - ! -- End of file found; data applies for remainder of simulation. - this%ionper = nper + 1 - else - ! -- Found invalid block - call this%parser%GetCurrentLine(line) - write(errmsg, fmtblkerr) adjustl(trim(line)) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - endif - end if - ! - ! -- read data if ionper == kper - if(this%ionper == kper) then - nlist = -1 - ! -- Remove all time-series and time-array-series links associated with - ! this package. - call this%TsManager%Reset(this%name) - ! - ! -- Read data as a list - call this%dis%read_list(this%parser%iuactive, this%iout, & - this%iprpak, nlist, this%inamedbound, & - this%iauxmultcol, this%nodelistsig0, & - this%bound, this%auxvarsig0, this%auxname, & - this%sig0bname, this%listlabel, & - this%name, this%tsManager, this%iscloc) - this%nbound = nlist - ! - ! Define the tsLink%Text value(s) appropriately. - ! E.g. for CSUB package, entry 1, assign tsLink%Text = 'SIG0' - call this%csub_rp_ts() - ! - ! -- Terminate the block - call this%parser%terminateblock() - ! - else - write(this%iout,fmtlsp) trim(this%filtyp) - endif - - ! - ! -- terminate if errors encountered in reach block - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- read observations - call this%csub_rp_obs() - ! - ! -- return - return - end subroutine csub_rp - - subroutine csub_ad(this, nodes, hnew) -! ****************************************************************************** -! csub_ad -- Advance csub data -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use TdisModule, only: nper, kper - ! -- dummy - class(GwfCsubType) :: this - integer(I4B), intent(in) :: nodes - real(DP), dimension(nodes), intent(in) :: hnew - ! -- local - character(len=LINELENGTH) :: errmsg - integer(I4B) :: ib - integer(I4B) :: n - integer(I4B) :: idelay - integer(I4B) :: node - real(DP) :: h - real(DP) :: es - real(DP) :: pcs -! ------------------------------------------------------------------------------ - ! - ! -- evaluate if steady-state stress periods are specified for more - ! than the first and last stress period if interbeds are simulated - if (this%ninterbeds > 0) then - if (kper > 1 .and. kper < nper) then - if (this%gwfiss /= 0) then - write(errmsg, '(1x,a,i0,a,1x,a,1x,a,1x,i0,1x,a)') & - 'ERROR: Only the first and last (', nper, ')', & - 'stress period can be steady if interbeds are simulated.', & - 'Stress period', kper, 'has been defined to be steady state.' - call store_error(errmsg) - call ustop() - end if - end if - end if - ! - ! -- set initial states - if (this%initialized == 0) then - if (this%gwfiss == 0) then - call this%csub_set_initial_state(nodes, hnew) - end if - end if - ! - ! -- update state variables - ! - ! -- coarse-grained materials - do node = 1, nodes - this%cg_comp(node) = DZERO - this%cg_es0(node) = this%cg_es(node) - if (this%iupdatematprop /= 0) then - this%cg_thick0(node) = this%cg_thick(node) - this%cg_theta0(node) = this%cg_theta(node) - end if - end do - ! - ! -- interbeds - do ib = 1, this%ninterbeds - idelay = this%idelay(ib) - ! - ! -- update common terms for no-delay and delay interbeds - this%comp(ib) = DZERO - node = this%nodelist(ib) - if (this%initialized /= 0) then - es = this%cg_es(node) - pcs = this%pcs(ib) - if (es > pcs) then - this%pcs(ib) = es - end if - end if - if (this%iupdatematprop /= 0) then - this%thick0(ib) = this%thick(ib) - this%theta0(ib) = this%theta(ib) - end if - ! - ! -- update delay interbed terms - if (idelay /= 0) then - ! - ! -- update state if previous period was steady state - if (kper > 1) then - if (this%gwfiss0 /= 0) then - node = this%nodelist(ib) - h = hnew(node) - do n = 1, this%ndelaycells - this%dbh(n, idelay) = h - end do - end if - end if - ! - ! -- update preconsolidation stress, stresses, head, dbdz0, and theta0 - do n = 1, this%ndelaycells - ! update preconsolidation stress - if (this%initialized /= 0) then - if (this%dbes(n, idelay) > this%dbpcs(n, idelay)) then - this%dbpcs(n, idelay) = this%dbes(n, idelay) - end if - end if - this%dbh0(n, idelay) = this%dbh(n, idelay) - this%dbes0(n, idelay) = this%dbes(n, idelay) - if (this%iupdatematprop /= 0) then - this%dbdz0(n, idelay) = this%dbdz(n, idelay) - this%dbtheta0(n, idelay) = this%dbtheta(n, idelay) - end if - end do - end if - end do - ! - ! -- set gwfiss0 - this%gwfiss0 = this%gwfiss - ! - ! -- Advance the time series managers - call this%TsManager%ad() - ! - ! -- For each observation, push simulated value and corresponding - ! simulation time from "current" to "preceding" and reset - ! "current" value. - call this%obs%obs_ad() - ! - ! -- return - return - end subroutine csub_ad - - subroutine csub_set_initial_state(this, nodes, hnew) -! ****************************************************************************** -! csub_set_initial_state -- Set initial state for coarse-grained materials -! and interbeds -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType) :: this - integer(I4B), intent(in) :: nodes - real(DP), dimension(nodes), intent(in) :: hnew - character(len=LINELENGTH) :: title - character(len=LINELENGTH) :: tag - character(len=20) :: cellid - character (len=LINELENGTH) :: errmsg - integer(I4B) :: ib - integer(I4B) :: node - integer(I4B) :: n - integer(I4B) :: idelay - integer(I4B) :: ntabrows - integer(I4B) :: ntabcols - real(DP) :: pcs0 - real(DP) :: pcs - real(DP) :: fact - real(DP) :: top - real(DP) :: bot - real(DP) :: void - real(DP) :: es - real(DP) :: znode - real(DP) :: hcell - real(DP) :: dzhalf - real(DP) :: zbot - real(DP) :: dbpcs -! ------------------------------------------------------------------------------ - ! - ! -- update geostatic load calculation - call this%csub_cg_calc_stress(nodes, hnew) - ! - ! -- initialize coarse-grained material effective stress - ! for the previous time step and the previous iteration - do node = 1, nodes - this%cg_es0(node) = this%cg_es(node) - end do - ! - ! -- check that aquifer head is greater than or equal to the - ! top of each delay interbed - do ib = 1, this%ninterbeds - idelay = this%idelay(ib) - if (idelay == 0) then - cycle - end if - node = this%nodelist(ib) - hcell = hnew(node) - call this%csub_delay_chk(ib, hcell) - end do - ! - ! -- initialize interbed initial states - do ib = 1, this%ninterbeds - idelay = this%idelay(ib) - node = this%nodelist(ib) - top = this%dis%top(node) - bot = this%dis%bot(node) - hcell = hnew(node) - pcs = this%pcs(ib) - pcs0 = pcs - if (this%ispecified_pcs == 0) then - ! relative pcs...subtract head (u) from sigma' - if (this%ipch /= 0) then - pcs = this%cg_es(node) - pcs0 - else - pcs = this%cg_es(node) + pcs0 - end if - else - ! specified pcs...substract head (u) from sigma - if (this%ipch /= 0) then - pcs = this%cg_gs(node) - (pcs0 - bot) - end if - if (pcs < this%cg_es(node)) then - pcs = this%cg_es(node) - end if - end if - this%pcs(ib) = pcs - ! - ! -- delay bed initial states - if (idelay /= 0) then - dzhalf = DHALF * this%dbdzini(1, idelay) - ! - ! -- fill delay bed head with aquifer head or offset from aquifer head - ! heads need to be filled first since used to calculate - ! the effective stress for each delay bed - do n = 1, this%ndelaycells - if (this%ispecified_dbh == 0) then - this%dbh(n, idelay) = hcell + this%dbh(n, idelay) - else - this%dbh(n, idelay) = hcell - end if - this%dbh0(n, idelay) = this%dbh(n, idelay) - end do - ! - ! -- fill delay bed effective stress - call this%csub_delay_calc_stress(ib, hcell) - ! - ! -- fill delay bed pcs - pcs = this%pcs(ib) - do n = 1, this%ndelaycells - zbot = this%dbz(n, idelay) - dzhalf - ! -- adjust pcs to bottom of each delay bed cell - ! not using csub_calc_adjes() since smoothing not required - dbpcs = pcs - (zbot - bot) * (this%sgs(node) - DONE) - this%dbpcs(n, idelay) = dbpcs - ! - ! -- initialize effective stress for previous time step - this%dbes0(n, idelay) = this%dbes(n, idelay) - end do - end if - end do - ! - ! -- scale coarse-grained materials cr - do node = 1, nodes - top = this%dis%top(node) - bot = this%dis%bot(node) - ! - ! -- user-specified specific storage - if (this%istoragec == 1) then - ! - ! -- retain specific storage values since they are constant - if (this%lhead_based .EQV. .TRUE.) then - fact = DONE - ! - ! -- convert specific storage values since they are simulated to - ! be a function of the average effective stress - else - void = this%csub_calc_void(this%cg_theta(node)) - es = this%cg_es(node) - hcell = hnew(node) - znode = this%csub_calc_znode(top, bot, hcell) - fact = this%csub_calc_adjes(node, es, bot, znode) - fact = fact * (DONE + void) - end if - ! - ! -- user-specified compression indices - multiply by dlog10es - else - fact = dlog10es - end if - this%cg_ske_cr(node) = this%cg_ske_cr(node) * fact - ! - ! -- write error message if negative compression indices - if (fact <= DZERO) then - call this%dis%noder_to_string(node, cellid) - write(errmsg,'(4x,a,1x,a)') & - '****ERROR. NEGATIVE RECOMPRESSION INDEX CALCULATED FOR CELL', & - trim(adjustl(cellid)) - call store_error(errmsg) - end if - end do - ! - ! -- scale interbed cc and cr - do ib = 1, this%ninterbeds - idelay = this%idelay(ib) - node = this%nodelist(ib) - top = this%dis%top(node) - bot = this%dis%bot(node) - ! - ! -- user-specified specific storage - if (this%istoragec == 1) then - ! - ! -- retain specific storage values since they are constant - if (this%lhead_based .EQV. .TRUE.) then - fact = DONE - ! - ! -- convert specific storage values since they are simulated to - ! be a function of the average effective stress - else - void = this%csub_calc_void(this%theta(ib)) - es = this%cg_es(node) - hcell = hnew(node) - znode = this%csub_calc_znode(top, bot, hcell) - fact = this%csub_calc_adjes(node, es, bot, znode) - fact = fact * (DONE + void) - end if - ! - ! -- user-specified compression indices - multiply by dlog10es - else - fact = dlog10es - end if - this%ci(ib) = this%ci(ib) * fact - this%rci(ib) = this%rci(ib) * fact - ! - ! -- write error message if negative compression indices - if (fact <= DZERO) then - call this%dis%noder_to_string(node, cellid) - write(errmsg,'(4x,a,1x,i0,2(1x,a))') & - '****ERROR. NEGATIVE COMPRESSION INDICES CALCULATED FOR INTERBED', & - ib, 'IN CELL', trim(adjustl(cellid)) - call store_error(errmsg) - end if - end do - ! - ! -- write current stress and initial preconsolidation stress - if (this%iprpak == 1) then - ! -- set title - title = trim(adjustl(this%name)) // & - ' PACKAGE CALCULATED INITIAL INTERBED STRESSES AT THE CELL BOTTOM' - ! - ! -- determine the number of columns and rows - ntabrows = this%ninterbeds - ntabcols = 5 - if (this%inamedbound /= 0) then - ntabcols = ntabcols + 1 - end if - ! - ! -- setup table - call table_cr(this%inputtab, this%name, title) - call this%inputtab%table_df(ntabrows, ntabcols, this%iout) - ! - ! add columns - tag = 'INTERBED NUMBER' - call this%inputtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'CELLID' - call this%inputtab%initialize_column(tag, 20) - tag = 'GEOSTATIC STRESS' - call this%inputtab%initialize_column(tag, 16) - tag = 'EFFECTIVE STRESS' - call this%inputtab%initialize_column(tag, 16) - tag = 'PRECONSOLIDATION STRESS' - call this%inputtab%initialize_column(tag, 16) - if (this%inamedbound /= 0) then - tag = 'BOUNDNAME' - call this%inputtab%initialize_column(tag, LENBOUNDNAME, & - alignment=TABLEFT) - end if - ! - ! -- write the data - do ib = 1, this%ninterbeds - node = this%nodelist(ib) - call this%dis%noder_to_string(node, cellid) - ! - ! -- write the columns - call this%inputtab%add_term(ib) - call this%inputtab%add_term(cellid) - call this%inputtab%add_term(this%cg_gs(node)) - call this%inputtab%add_term(this%cg_es(node)) - call this%inputtab%add_term(this%pcs(ib)) - if (this%inamedbound /= 0) then - call this%inputtab%add_term(this%boundname(ib)) - end if - end do - ! - ! -- write effective stress and preconsolidation stress - ! for delay beds - ! -- set title - title = trim(adjustl(this%name)) // & - ' PACKAGE CALCULATED INITIAL DELAY INTERBED STRESSES' - ! - ! -- determine the number of columns and rows - ntabrows = 0 - do ib = 1, this%ninterbeds - idelay = this%idelay(ib) - if (idelay /= 0) then - ntabrows = ntabrows + this%ndelaycells - end if - end do - ntabcols = 6 - if (this%inamedbound /= 0) then - ntabcols = ntabcols + 1 - end if - ! - ! -- setup table - call table_cr(this%inputtab, this%name, title) - call this%inputtab%table_df(ntabrows, ntabcols, this%iout) - ! - ! add columns - tag = 'INTERBED NUMBER' - call this%inputtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'CELLID' - call this%inputtab%initialize_column(tag, 20) - tag = 'DELAY CELL' - call this%inputtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'GEOSTATIC STRESS' - call this%inputtab%initialize_column(tag, 16) - tag = 'EFFECTIVE STRESS' - call this%inputtab%initialize_column(tag, 16) - tag = 'PRECONSOLIDATION STRESS' - call this%inputtab%initialize_column(tag, 16) - if (this%inamedbound /= 0) then - tag = 'BOUNDNAME' - call this%inputtab%initialize_column(tag, LENBOUNDNAME, & - alignment=TABLEFT) - end if - ! - ! -- write the data - do ib = 1, this%ninterbeds - idelay = this%idelay(ib) - if (idelay /= 0) then - node = this%nodelist(ib) - call this%dis%noder_to_string(node, cellid) - ! - ! -- write the columns - do n = 1, this%ndelaycells - if (n == 1) then - call this%inputtab%add_term(ib) - call this%inputtab%add_term(cellid) - else - call this%inputtab%add_term(' ') - call this%inputtab%add_term(' ') - end if - call this%inputtab%add_term(n) - call this%inputtab%add_term(this%dbgeo(n, idelay)) - call this%inputtab%add_term(this%dbes(n, idelay)) - call this%inputtab%add_term(this%dbpcs(n, idelay)) - if (this%inamedbound /= 0) then - if (n == 1) then - call this%inputtab%add_term(this%boundname(ib)) - else - call this%inputtab%add_term(' ') - end if - end if - end do - end if - end do - ! - ! -- write calculated compression indices - if (this%istoragec == 1) then - if (this%lhead_based .EQV. .FALSE.) then - ! -- set title - title = trim(adjustl(this%name)) // & - ' PACKAGE COMPRESSION INDICES' - ! - ! -- determine the number of columns and rows - ntabrows = this%ninterbeds - ntabcols = 4 - if (this%inamedbound /= 0) then - ntabcols = ntabcols + 1 - end if - ! - ! -- setup table - call table_cr(this%inputtab, this%name, title) - call this%inputtab%table_df(ntabrows, ntabcols, this%iout) - ! - ! add columns - tag = 'INTERBED NUMBER' - call this%inputtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'CELLID' - call this%inputtab%initialize_column(tag, 20) - tag = 'CC' - call this%inputtab%initialize_column(tag, 16) - tag = 'CR' - call this%inputtab%initialize_column(tag, 16) - if (this%inamedbound /= 0) then - tag = 'BOUNDNAME' - call this%inputtab%initialize_column(tag, LENBOUNDNAME, & - alignment=TABLEFT) - end if - ! - ! -- write the data - do ib = 1, this%ninterbeds - fact = DONE / dlog10es - node = this%nodelist(ib) - call this%dis%noder_to_string(node, cellid) - ! - ! -- write the columns - call this%inputtab%add_term(ib) - call this%inputtab%add_term(cellid) - call this%inputtab%add_term(this%ci(ib) * fact) - call this%inputtab%add_term(this%rci(ib) * fact) - if (this%inamedbound /= 0) then - call this%inputtab%add_term(this%boundname(ib)) - end if - end do - end if - end if - end if - ! - ! -- terminate if any initialization errors have been detected - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- set initialized - this%initialized = 1 - ! - ! -- set flag to retain initial stresses for entire simulation - if (this%lhead_based .EQV. .TRUE.) then - this%iupdatestress = 0 - end if - ! - ! -- return - return - end subroutine csub_set_initial_state - - subroutine csub_fc(this, kiter, hold, hnew, njasln, amat, idxglo, rhs) -! ****************************************************************************** -! csub_fc -- Fill the solution amat and rhs with storage contribution terms -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use TdisModule, only: delt - ! -- dummy - class(GwfCsubType) :: this - integer(I4B),intent(in) :: kiter - real(DP), intent(in), dimension(:) :: hold - real(DP), intent(in), dimension(:) :: hnew - integer(I4B),intent(in) :: njasln - real(DP), dimension(njasln),intent(inout) :: amat - integer(I4B), intent(in),dimension(:) :: idxglo - real(DP),intent(inout),dimension(:) :: rhs - ! -- local - integer(I4B) :: ib - integer(I4B) :: node - integer(I4B) :: idiag - integer(I4B) :: idelay - real(DP) :: tled - real(DP) :: area - real(DP) :: hcell - real(DP) :: hcof - real(DP) :: rhsterm - real(DP) :: comp -! ------------------------------------------------------------------------------ - ! - ! -- update geostatic load calculation - call this%csub_cg_calc_stress(this%dis%nodes, hnew) - ! - ! -- formulate csub terms - if (this%gwfiss == 0) then - ! - ! -- initialize tled - tled = DONE / delt - ! - ! -- coarse-grained storage - do node = 1, this%dis%nodes - idiag = this%dis%con%ia(node) - area = this%dis%get_area(node) - ! - ! -- skip inactive cells - if (this%ibound(node) < 1) cycle - ! - ! -- update coarse-grained material properties - if (this%iupdatematprop /= 0) then - if (this%ieslag == 0) then - ! - ! -- calculate compaction - call this%csub_cg_calc_comp(node, hnew(node), hold(node), comp) - this%cg_comp(node) = comp - ! - ! -- update coarse-grained thickness and void ratio - call this%csub_cg_update(node) - end if - end if - ! - ! -- calculate coarse-grained storage terms - call this%csub_cg_fc(node, tled, area, hnew(node), hold(node), & - hcof, rhsterm) - ! - ! -- add coarse-grained storage terms to amat and rhs for coarse-grained storage - amat(idxglo(idiag)) = amat(idxglo(idiag)) + hcof - rhs(node) = rhs(node) + rhsterm - ! - ! -- calculate coarse-grained water compressibility - ! storage terms - if (this%brg /= DZERO) then - call this%csub_cg_wcomp_fc(node, tled, area, hnew(node), hold(node), & - hcof, rhsterm) - ! - ! -- add water compression storage terms to amat and rhs for - ! coarse-grained storage - amat(idxglo(idiag)) = amat(idxglo(idiag)) + hcof - rhs(node) = rhs(node) + rhsterm - end if - end do - ! - ! -- interbed storage - if (this%ninterbeds /= 0) then - ! - ! -- check that aquifer head is greater than or equal to the - ! top of each delay interbed - do ib = 1, this%ninterbeds - idelay = this%idelay(ib) - if (idelay == 0) then - cycle - end if - node = this%nodelist(ib) - hcell = hnew(node) - call this%csub_delay_chk(ib, hcell) - end do - ! - ! -- terminate if the aquifer head is below the top of delay interbeds - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- calculate the contribution of interbeds to the - ! groundwater flow equation - do ib = 1, this%ninterbeds - node = this%nodelist(ib) - idiag = this%dis%con%ia(node) - area = this%dis%get_area(node) - call this%csub_interbed_fc(ib, node, area, hnew(node), hold(node), & - hcof, rhsterm) - amat(idxglo(idiag)) = amat(idxglo(idiag)) + hcof - rhs(node) = rhs(node) + rhsterm - ! - ! -- calculate interbed water compressibility terms - if (this%brg /= DZERO) then - call this%csub_interbed_wcomp_fc(ib, node, tled, area, & - hnew(node), hold(node), & - hcof, rhsterm) - ! - ! -- add water compression storage terms to amat and rhs for interbed - amat(idxglo(idiag)) = amat(idxglo(idiag)) + hcof - rhs(node) = rhs(node) + rhsterm - end if - end do - end if - end if - ! - ! -- terminate if the head in the cell is below the top of the cell for - ! non-convertible cells or top of the interbed for delay beds or if - ! errors encountered when updating material properties - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- return - return - end subroutine csub_fc - - subroutine csub_fn(this, kiter, hold, hnew, njasln, amat, idxglo, rhs) -! ****************************************************************************** -! csub_fn -- Fill the solution amat and rhs with csub contribution newton -! term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use TdisModule, only: delt - ! -- dummy - class(GwfCsubType) :: this - integer(I4B),intent(in) :: kiter - real(DP), intent(in), dimension(:) :: hold - real(DP), intent(in), dimension(:) :: hnew - integer(I4B),intent(in) :: njasln - real(DP), dimension(njasln),intent(inout) :: amat - integer(I4B), intent(in),dimension(:) :: idxglo - real(DP),intent(inout),dimension(:) :: rhs - ! -- local - integer(I4B) :: node - integer(I4B) :: idiag - integer(I4B) :: ib - real(DP) :: tled - real(DP) :: area - real(DP) :: hcof - real(DP) :: rhsterm -! ------------------------------------------------------------------------------ - ! - ! -- formulate csub terms - if (this%gwfiss == 0) then - tled = DONE / delt - ! - ! -- coarse-grained storage - do node = 1, this%dis%nodes - idiag = this%dis%con%ia(node) - area = this%dis%get_area(node) - ! - ! -- skip inactive cells - if (this%ibound(node) < 1) cycle - ! - ! -- calculate coarse-grained storage newton terms - call this%csub_cg_fn(node, tled, area, & - hnew(node), hcof, rhsterm) - ! - ! -- add coarse-grained storage newton terms to amat and rhs for - ! coarse-grained storage - amat(idxglo(idiag)) = amat(idxglo(idiag)) + hcof - rhs(node) = rhs(node) + rhsterm - ! - ! -- calculate coarse-grained water compressibility storage - ! newton terms - if (this%brg /= DZERO) then - call this%csub_cg_wcomp_fn(node, tled, area, hnew(node), hold(node), & - hcof, rhsterm) - ! - ! -- add water compression storage newton terms to amat and rhs for - ! coarse-grained storage - amat(idxglo(idiag)) = amat(idxglo(idiag)) + hcof - rhs(node) = rhs(node) + rhsterm - end if - end do - ! - ! -- interbed storage - if (this%ninterbeds /= 0) then - ! - ! -- calculate the interbed newton terms for the - ! groundwater flow equation - do ib = 1, this%ninterbeds - node = this%nodelist(ib) - ! - ! -- skip inactive cells - if (this%ibound(node) < 1) cycle - ! - ! -- calculate interbed newton terms - idiag = this%dis%con%ia(node) - area = this%dis%get_area(node) - call this%csub_interbed_fn(ib, node, area, hnew(node), hold(node), & - hcof, rhsterm) - ! - ! -- add interbed newton terms to amat and rhs - amat(idxglo(idiag)) = amat(idxglo(idiag)) + hcof - rhs(node) = rhs(node) + rhsterm - ! - ! -- calculate interbed water compressibility terms - if (this%brg /= DZERO) then - call this%csub_interbed_wcomp_fn(ib, node, tled, area, & - hnew(node), hold(node), & - hcof, rhsterm) - ! - ! -- add interbed water compression newton terms to amat and rhs - amat(idxglo(idiag)) = amat(idxglo(idiag)) + hcof - rhs(node) = rhs(node) + rhsterm - end if - end do - end if - end if - ! - ! -- return - return - end subroutine csub_fn - - subroutine csub_cg_fc(this, node, tled, area, hcell, hcellold, hcof, rhs) -! ****************************************************************************** -! csub_cg_fc -- Formulate the HCOF and RHS coarse-grained storage terms -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - class(GwfCsubType) :: this - integer(I4B),intent(in) :: node - real(DP), intent(in) :: tled - real(DP), intent(in) :: area - real(DP), intent(in) :: hcell - real(DP), intent(in) :: hcellold - real(DP), intent(inout) :: hcof - real(DP), intent(inout) :: rhs - ! locals - real(DP) :: top - real(DP) :: bot - real(DP) :: tthk - real(DP) :: snold - real(DP) :: snnew - real(DP) :: sske - real(DP) :: rho1 -! ------------------------------------------------------------------------------ -! -! -- initialize variables - rhs = DZERO - hcof = DZERO - ! - ! -- aquifer elevations and thickness - top = this%dis%top(node) - bot = this%dis%bot(node) - tthk = this%cg_thickini(node) - ! - ! -- calculate hcof and rhs terms if coarse-grained materials present - if (tthk > DZERO) then - ! - ! -- calculate aquifer saturation - call this%csub_calc_sat(node, hcell, hcellold, snnew, snold) - ! - ! -- storage coefficients - call this%csub_cg_calc_sske(node, sske, hcell) - rho1 = sske * area * tthk * tled - ! - ! -- update sk and ske - this%cg_ske(node) = sske * tthk * snold - this%cg_sk(node) = sske * tthk * snnew - ! - ! -- calculate hcof and rhs term - hcof = -rho1 * snnew - rhs = rho1 * snold * this%cg_es0(node) - & - rho1 * snnew * (this%cg_gs(node) + bot) - end if - ! - ! -- return - return - end subroutine csub_cg_fc - - subroutine csub_cg_fn(this, node, tled, area, hcell, hcof, rhs) -! ****************************************************************************** -! csub_cg_fn -- Formulate coarse-grained storage newton terms -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - class(GwfCsubType) :: this - integer(I4B),intent(in) :: node - real(DP), intent(in) :: tled - real(DP), intent(in) :: area - real(DP), intent(in) :: hcell - real(DP), intent(inout) :: hcof - real(DP), intent(inout) :: rhs - ! locals - real(DP) :: top - real(DP) :: bot - real(DP) :: tthk - real(DP) :: satderv - real(DP) :: sske - real(DP) :: rho1 -! ------------------------------------------------------------------------------ -! -! -- initialize variables - rhs = DZERO - hcof = DZERO - ! - ! -- aquifer elevations and thickness - top = this%dis%top(node) - bot = this%dis%bot(node) - tthk = this%cg_thickini(node) - ! - ! -- calculate newton terms if coarse-grained materials present - if (tthk > DZERO) then - ! - ! -- calculate saturation derivative - satderv = this%csub_calc_sat_derivative(node, hcell) - ! - ! -- storage coefficients - call this%csub_cg_calc_sske(node, sske, hcell) - rho1 = sske * area * tthk * tled - ! - ! -- calculate hcof term - hcof = rho1 * (this%cg_gs(node) - hcell + bot) * satderv - ! - ! -- Add additional term if using lagged effective stress - if (this%ieslag /= 0) then - hcof = hcof - rho1 * this%cg_es0(node) * satderv - end if - ! - ! -- calculate rhs term - rhs = hcof * hcell - end if - ! - ! -- return - return - end subroutine csub_cg_fn - - subroutine csub_interbed_fc(this, ib, node, area, hcell, hcellold, hcof, rhs) -! ****************************************************************************** -! csub_cf -- Formulate the HCOF and RHS terms -! Subroutine: (1) skip if no ibcs -! (2) calculate hcof and rhs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - class(GwfCsubType) :: this - integer(I4B),intent(in) :: ib - integer(I4B),intent(in) :: node - real(DP), intent(in) :: area - real(DP), intent(in) :: hcell - real(DP), intent(in) :: hcellold - real(DP), intent(inout) :: hcof - real(DP), intent(inout) :: rhs - ! locals - character(len=20) :: cellid - character (len=LINELENGTH) :: errmsg - integer(I4B) :: idelaycalc - real(DP) :: snnew - real(DP) :: snold - real(DP) :: comp - real(DP) :: compi - real(DP) :: compe - real(DP) :: rho1 - real(DP) :: rho2 - real(DP) :: f - real(DP) :: top -! ------------------------------------------------------------------------------ -! -! -- initialize variables - rhs = DZERO - hcof = DZERO - comp = DZERO - compi = DZERO - compe = DZERO - ! - ! -- skip inactive and constant head cells - if (this%ibound(node) > 0) then - if (this%idelay(ib) == 0) then - ! - ! -- update material properties - if (this%iupdatematprop /= 0) then - if (this%ieslag == 0) then - ! - ! -- calculate compaction - call this%csub_nodelay_calc_comp(ib, hcell, hcellold, comp, & - rho1, rho2) - this%comp(ib) = comp - ! - ! -- update thickness and void ratio - call this%csub_nodelay_update(ib) - end if - end if - ! - ! -- calculate no-delay interbed rho1 and rho2 - call this%csub_nodelay_fc(ib, hcell, hcellold, rho1, hcof, rhs) - f = area - else - ! - ! -- calculate cell saturation - call this%csub_calc_sat(node, hcell, hcellold, snnew, snold) - ! - ! -- check that the delay bed should be evaluated - idelaycalc = this%csub_delay_eval(ib, node, hcell) - ! - ! -- calculate delay interbed hcof and rhs - if (idelaycalc > 0) then - ! - ! -- update material properties - if (this%iupdatematprop /= 0) then - if (this%ieslag == 0) then - ! - ! -- calculate compaction - call this%csub_delay_calc_comp(ib, hcell, hcellold, & - comp, compi, compe) - this%comp(ib) = comp - ! - ! -- update thickness and void ratio - call this%csub_delay_update(ib) - end if - end if - ! - ! -- calculate delay interbed hcof and rhs - call this%csub_delay_sln(ib, hcell) - call this%csub_delay_fc(ib, hcof, rhs) - ! -- create error message - else - if (idelaycalc < 0) then - call this%dis%noder_to_string(node, cellid) - write(errmsg,'(4x,a,1x,g0,1x,a,1x,a,1x,a,1x,g0,1x,a,1x,i0)') & - '****ERROR. HEAD (', hcell, ') IN NON-CONVERTIBLE CELL (', & - trim(adjustl(cellid)), ') DROPPED BELOW THE TOP OF THE CELL (', & - top, ') FOR DELAY INTERBED ', ib - call store_error(errmsg) - end if - end if - f = area * this%rnb(ib) * snnew - end if - rhs = rhs * f - hcof = -hcof * f - end if - ! - ! -- return - return - end subroutine csub_interbed_fc - - subroutine csub_interbed_fn(this, ib, node, area, hcell, hcellold, hcof, rhs) -! ****************************************************************************** -! csub_interbed_fn -- Formulate interbed newton terms -! Subroutine: (1) skip if no interbeds -! (2) calculate hcof and rhs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use TdisModule, only: delt - implicit none - class(GwfCsubType) :: this - integer(I4B),intent(in) :: ib - integer(I4B),intent(in) :: node - real(DP), intent(in) :: area - real(DP), intent(in) :: hcell - real(DP), intent(in) :: hcellold - real(DP), intent(inout) :: hcof - real(DP), intent(inout) :: rhs - ! -- locals - integer(I4B) :: idelay - integer(I4B) :: idelaycalc - real(DP) :: hcofn - real(DP) :: rhsn - real(DP) :: snnew - real(DP) :: snold - real(DP) :: satderv - real(DP) :: tled - real(DP) :: tthk - real(DP) :: f - real(DP) :: top - real(DP) :: bot - real(DP) :: rho1 - real(DP) :: rho2 - real(DP) :: dz - real(DP) :: c - real(DP) :: h1 - real(DP) :: hn -! ------------------------------------------------------------------------------ -! -! -- initialize variables - rhs = DZERO - hcof = DZERO - rhsn = DZERO - hcofn = DZERO - satderv = DZERO - idelay = this%idelay(ib) - top = this%dis%top(node) - bot = this%dis%bot(node) - ! - ! -- skip inactive and constant head cells - if (this%ibound(node) > 0) then - tled = DONE / delt - tthk = this%thickini(ib) - ! - ! -- calculate cell saturation - call this%csub_calc_sat(node, hcell, hcellold, snnew, snold) - ! - ! -- no-delay interbeds - if (idelay == 0) then - ! - ! -- initialize factor - f = DONE - ! - ! -- calculate the saturation derivative - satderv = this%csub_calc_sat_derivative(node, hcell) - ! - ! -- calculate storage coefficient - call this%csub_nodelay_fc(ib, hcell, hcellold, rho1, rho2, rhsn) - ! - ! -- calculate hcofn term - if (this%ielastic(ib) /= 0) then - hcofn = rho2 * (this%cg_gs(node) - hcell + bot) * satderv - else - hcofn = rho2 * (this%cg_gs(node) - hcell + bot - this%pcs(ib)) * & - satderv - end if - ! - ! -- Add additional term if using lagged effective stress - if (this%ieslag /= 0) then - if (this%ielastic(ib) /= 0) then - hcofn = hcofn - rho1 * this%cg_es0(node) * satderv - else - hcofn = hcofn - rho1 * (this%pcs(ib) - this%cg_es0(node)) * satderv - end if - end if - ! - ! -- delay interbeds - else - ! - ! -- calculate factor - f = this%rnb(ib) - ! - ! -- check that the delay bed should be evaluated - idelaycalc = this%csub_delay_eval(ib, node, hcell) - ! - ! -- calculate newton terms if delay bed is not stranded - ! newton terms are calculated the same if using the - ! head-based and effective-stress formulations - if (idelaycalc > 0) then - ! - ! calculate delay interbed terms - dz = this%dbdzini(1, idelay) - c = DTWO * this%kv(ib) / dz - h1 = this%dbh(1, idelay) - hn = this%dbh(this%ndelaycells, idelay) - ! - ! -- calculate the saturation derivative - satderv = this%csub_calc_sat_derivative(node, hcell) - ! - ! -- calculate the saturation derivative term - hcofn = satderv * c * area * (hn + h1 - DTWO * hcell) - end if - ! - ! -- update hcof and rhs - hcof = f * hcofn - rhs = f * hcofn * hcell - end if - end if - ! - ! -- return - return - end subroutine csub_interbed_fn - - subroutine define_listlabel(this) -! ****************************************************************************** -! define_listlabel -- Define the list heading that is written to iout when -! PRINT_INPUT option is used. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this -! ------------------------------------------------------------------------------ - ! - ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' - else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'SIG0' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif - ! - ! -- return - return - end subroutine define_listlabel - - subroutine csub_cg_calc_sske(this, n, sske, hcell) -! ****************************************************************************** -! csub_cg_calc_sske -- Calculate sske for a gwf cell. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: n - real(DP), intent(inout) :: sske - real(DP), intent(in) :: hcell - ! -- local variables - real(DP) :: top - real(DP) :: bot - real(DP) :: znode - real(DP) :: es - real(DP) :: es0 - real(DP) :: theta - real(DP) :: f - real(DP) :: f0 -! ------------------------------------------------------------------------------ - ! - ! -- initialize variables - sske = DZERO - ! - ! -- calculate factor for the head-based case - if (this%lhead_based .EQV. .TRUE.) then - f = DONE - f0 = DONE - ! - ! -- calculate factor for the effective stress case - else - top = this%dis%top(n) - bot = this%dis%bot(n) - znode = this%csub_calc_znode(top, bot, hcell) - es = this%cg_es(n) - es0 = this%cg_es0(n) - theta = this%cg_thetaini(n) - ! - ! -- calculate the compression index factors for the delay - ! node relative to the center of the cell based on the - ! current and previous head - call this%csub_calc_sfacts(n, bot, znode, theta, es, es0, f) - end if - sske = f * this%cg_ske_cr(n) - ! - ! -- return - return - end subroutine csub_cg_calc_sske - - subroutine csub_cg_calc_comp(this, node, hcell, hcellold, comp) -! ****************************************************************************** -! csub_cg_calc_comp -- Calculate coarse-grained compaction -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - class(GwfCsubType) :: this - integer(I4B),intent(in) :: node - real(DP), intent(in) :: hcell - real(DP), intent(in) :: hcellold - real(DP), intent(inout) :: comp - ! locals - real(DP) :: area - real(DP) :: tled - real(DP) :: hcof - real(DP) :: rhs -! ------------------------------------------------------------------------------ -! -! -- initialize variables - area = DONE - tled = DONE - ! - ! -- calculate terms - call this%csub_cg_fc(node, tled, area, hcell, hcellold, hcof, rhs) - ! - ! - calculate compaction - comp = hcof * hcell - rhs - ! - ! -- return - return - end subroutine csub_cg_calc_comp - - - subroutine csub_cg_update(this, node) -! ****************************************************************************** -! csub_cg_update -- Update material properties for coarse grained sediments. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - integer(I4B),intent(in) :: node - ! locals - character(len=LINELENGTH) :: errmsg - character(len=20) :: cellid - real(DP) :: comp - real(DP) :: thick - real(DP) :: theta -! ------------------------------------------------------------------------------ -! -! -- update thickness and theta - comp = this%cg_tcomp(node) + this%cg_comp(node) - call this%dis%noder_to_string(node, cellid) - if (ABS(comp) > DZERO) then - thick = this%cg_thickini(node) - theta = this%cg_thetaini(node) - call this%csub_adj_matprop(comp, thick, theta) - if (thick <= DZERO) then - write(errmsg,'(4x,a,1x,a,1x,a,1x,g0,1x,a)') & - '****ERROR. ADJUSTED THICKNESS FOR CELL', trim(adjustl(cellid)), & - 'IS <= 0 (', thick, ')' - call store_error(errmsg) - end if - if (theta <= DZERO) then - write(errmsg,'(4x,a,1x,a,1x,a,1x,g0,1x,a)') & - '****ERROR. ADJUSTED THETA FOR CELL', trim(adjustl(cellid)), & - 'IS <= 0 (', theta, ')' - call store_error(errmsg) - end if - this%cg_thick(node) = thick - this%cg_theta(node) = theta - end if - ! - ! -- return - return - end subroutine csub_cg_update - - - subroutine csub_cg_wcomp_fc(this, node, tled, area, hcell, hcellold, & - hcof, rhs) -! ****************************************************************************** -! csub_cg_wcomp_fc -- Calculate water compressibility term for a gwf cell. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - integer(I4B),intent(in) :: node - real(DP), intent(in) :: tled - real(DP), intent(in) :: area - real(DP), intent(in) :: hcell - real(DP), intent(in) :: hcellold - real(DP), intent(inout) :: hcof - real(DP), intent(inout) :: rhs - ! locals - real(DP) :: top - real(DP) :: bot - real(DP) :: tthk - real(DP) :: tthk0 - real(DP) :: snold - real(DP) :: snnew - real(DP) :: wc1 - real(DP) :: wc2 -! ------------------------------------------------------------------------------ -! -! -- initialize variables - rhs = DZERO - hcof = DZERO - ! - ! -- aquifer elevations and thickness - top = this%dis%top(node) - bot = this%dis%bot(node) - tthk = this%cg_thick(node) - tthk0 = this%cg_thick0(node) - ! - ! -- aquifer saturation - call this%csub_calc_sat(node, hcell, hcellold, snnew, snold) - ! - ! -- storage coefficients - wc1 = this%brg * area * tthk0 * this%cg_theta0(node) * tled - wc2 = this%brg * area * tthk * this%cg_theta(node) * tled - ! - ! -- calculate hcof term - hcof = -wc2 * snnew - ! - ! -- calculate rhs term - rhs = -wc1 * snold * hcellold - ! - ! -- return - return - end subroutine csub_cg_wcomp_fc - - - subroutine csub_cg_wcomp_fn(this, node, tled, area, hcell, hcellold, hcof, rhs) -! ****************************************************************************** -! csub_cg_wcomp_fn -- Calculate water compressibility newton-rephson terms for -! a gwf cell. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - integer(I4B),intent(in) :: node - real(DP), intent(in) :: tled - real(DP), intent(in) :: area - real(DP), intent(in) :: hcell - real(DP), intent(in) :: hcellold - real(DP), intent(inout) :: hcof - real(DP), intent(inout) :: rhs - ! locals - real(DP) :: top - real(DP) :: bot - real(DP) :: tthk - real(DP) :: tthk0 - real(DP) :: satderv - real(DP) :: f - real(DP) :: wc1 - real(DP) :: wc2 -! ------------------------------------------------------------------------------ -! -! -- initialize variables - rhs = DZERO - hcof = DZERO - ! - ! -- aquifer elevations and thickness - top = this%dis%top(node) - bot = this%dis%bot(node) - tthk = this%cg_thick(node) - ! - ! -- calculate saturation derivitive - satderv = this%csub_calc_sat_derivative(node, hcell) - ! - ! -- calculate water compressibility factor - f = this%brg * area * tled - ! - ! -- water compressibility coefficient - !wc2 = this%brg * area * tthk * this%cg_theta(node) * tled - wc2 = f * tthk * this%cg_theta(node) - ! - ! -- calculate hcof term - hcof = -wc2 * hcell * satderv - ! - ! -- Add additional term if using lagged effective stress - if (this%ieslag /= 0) then - tthk0 = this%cg_thick0(node) - !wc1 = this%brg * area * tthk0 * this%cg_theta0(node) * tled - wc1 = f * tthk0 * this%cg_theta0(node) - hcof = hcof + wc1 * hcellold * satderv - end if - ! - ! -- calculate rhs term - rhs = hcof * hcell - ! - ! -- return - return - end subroutine csub_cg_wcomp_fn - - - subroutine csub_interbed_wcomp_fc(this, ib, node, tled, area, & - hcell, hcellold, hcof, rhs) -! ****************************************************************************** -! csub_interbed_wcomp_fc -- Calculate water compressibility term for an -! interbed. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - integer(I4B),intent(in) :: ib - integer(I4B),intent(in) :: node - real(DP), intent(in) :: tled - real(DP), intent(in) :: area - real(DP), intent(in) :: hcell - real(DP), intent(in) :: hcellold - real(DP), intent(inout) :: hcof - real(DP), intent(inout) :: rhs - ! locals - integer(I4B) :: n - integer(I4B) :: idelay - real(DP) :: top - real(DP) :: bot - real(DP) :: snold - real(DP) :: snnew - real(DP) :: f - real(DP) :: fmult - real(DP) :: dz - real(DP) :: dz0 - real(DP) :: wc1 - real(DP) :: wc2 -! ------------------------------------------------------------------------------ -! -! -- initialize variables - rhs = DZERO - hcof = DZERO - ! - ! -- aquifer elevations and thickness - top = this%dis%top(node) - bot = this%dis%bot(node) - ! - ! -- calculate cell saturation - call this%csub_calc_sat(node, hcell, hcellold, snnew, snold) - ! - ! - idelay = this%idelay(ib) - f = this%brg * area * tled - ! - ! -- no-delay interbeds - if (idelay == 0) then - wc1 = f * this%theta0(ib) * this%thick0(ib) - wc2 = f * this%theta(ib) * this%thick(ib) - hcof = -wc2 * snnew - rhs = -wc1 * snold * hcellold - ! - ! -- delay interbeds - else - ! - ! -- calculate cell saturation - call this%csub_calc_sat(node, hcell, hcellold, snnew, snold) - ! - ! -- calculate contribution for each delay interbed cell - if (this%thick(ib) > DZERO) then - do n = 1, this%ndelaycells - fmult = DONE - dz = this%dbdz(n, idelay) - dz0 = this%dbdz0(n, idelay) - wc2 = fmult * f * dz * this%dbtheta(n, idelay) - wc1 = fmult * f * dz0 * this%dbtheta0(n, idelay) - rhs = rhs - (wc1 * snold * this%dbh0(n, idelay) - & - wc2 * snnew * this%dbh(n, idelay)) - end do - rhs = rhs * this%rnb(ib) * snnew - end if - end if - ! - ! -- return - return - end subroutine csub_interbed_wcomp_fc - - - subroutine csub_interbed_wcomp_fn(this, ib, node, tled, area, & - hcell, hcellold, hcof, rhs) -! ****************************************************************************** -! csub_interbed_wcomp_fn -- Calculate water compressibility newton-raphson -! terms for an interbed. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - integer(I4B),intent(in) :: ib - integer(I4B),intent(in) :: node - real(DP), intent(in) :: tled - real(DP), intent(in) :: area - real(DP), intent(in) :: hcell - real(DP), intent(in) :: hcellold - real(DP), intent(inout) :: hcof - real(DP), intent(inout) :: rhs - ! locals - integer(I4B) :: idelay - real(DP) :: top - real(DP) :: bot - real(DP) :: f - real(DP) :: wc1 - real(DP) :: wc2 - real(DP) :: satderv -! ------------------------------------------------------------------------------ -! -! -- initialize variables - rhs = DZERO - hcof = DZERO - ! - ! -- aquifer elevations and thickness - top = this%dis%top(node) - bot = this%dis%bot(node) - ! - ! - idelay = this%idelay(ib) - f = this%brg * area * tled - ! - ! -- no-delay interbeds - if (idelay == 0) then - ! - ! -- calculate saturation derivitive - satderv = this%csub_calc_sat_derivative(node, hcell) - ! - ! -- calculate the current water compressibility factor - wc2 = f * this%theta(ib) * this%thick(ib) - ! - ! -- calculate derivative term - hcof = -wc2 * hcell * satderv - ! - ! -- Add additional term if using lagged effective stress - if (this%ieslag /= 0) then - wc1 = f * this%theta0(ib) * this%thick0(ib) - hcof = hcof + wc1 * hcellold * satderv - end if - ! - ! -- set rhs - rhs = hcof * hcell - ! - ! -- delay interbeds - else - ! -- delay beds are not head dependent - end if - ! - ! -- return - return - end subroutine csub_interbed_wcomp_fn - - function csub_calc_void(this, theta) result(void) -! ****************************************************************************** -! csub_calc_void -- Calculate void ratio from the porosity -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - ! -- dummy - real(DP), intent(in) :: theta - ! -- local variables - real(DP) :: void -! ------------------------------------------------------------------------------ - void = theta / (DONE - theta) - ! - ! -- return - return - end function csub_calc_void - - - function csub_calc_theta(this, void) result(theta) -! ****************************************************************************** -! csub_calc_theta -- Calculate porosity from the void ratio -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - ! -- dummy - real(DP), intent(in) :: void - ! -- local variables - real(DP) :: theta -! ------------------------------------------------------------------------------ - theta = void / (DONE + void) - ! - ! -- return - return - end function csub_calc_theta - - - function csub_calc_interbed_thickness(this, ib) result(thick) -! ****************************************************************************** -! csub_calc_interbed_thickness -- Calculate interbed thickness -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - ! -- dummy - integer(I4B), intent(in) :: ib - ! -- local variables - integer(I4B) :: idelay - real(DP) :: thick -! ------------------------------------------------------------------------------ - idelay = this%idelay(ib) - thick = this%thick(ib) - if (idelay /= 0) then - thick = thick * this%rnb(ib) - end if - ! - ! -- return - return - end function csub_calc_interbed_thickness - - - function csub_calc_znode(this, z1, z0, z) result(znode) -! ****************************************************************************** -! csub_calc_znode -- Calculate elevation of the node between the specified -! elevation z and the bottom elevation z0. If z is greater -! the top elevation z1, the node elevation is halfway between -! the top (z1) and bottom (z0) elevations. if z is less than -! the bottom elevation (z0) the node elevation is set to z0. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - ! -- dummy - real(DP), intent(in) :: z1 - real(DP), intent(in) :: z0 - real(DP), intent(in) :: z - ! -- local variables - real(DP) :: znode - real(DP) :: v -! ------------------------------------------------------------------------------ - if (z > z1) then - v = z1 - else if (z < z0) then - v = z0 - else - v = z - end if - znode = (v + z0) * DHALF - ! - ! -- return - return - end function csub_calc_znode - - function csub_calc_adjes(this, node, es0, z0, z) result(es) -! ****************************************************************************** -! csub_calc_adjes -- Calculate the effective stress at specified elevation z -! using the provided effective stress (es0) calculated at -! elevation z0 (which is <= z) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - ! -- dummy - integer(I4B), intent(in) :: node - real(DP), intent(in) :: es0 - real(DP), intent(in) :: z0 - real(DP), intent(in) :: z - ! -- local variables - real(DP) :: es -! ------------------------------------------------------------------------------ - ! - ! -- adjust effective stress to vertical node position - es = es0 - (z - z0) * (this%sgs(node) - DONE) - ! - ! -- return - return - end function csub_calc_adjes - - function csub_delay_eval(this, ib, node, hcell) result(idelaycalc) -! ****************************************************************************** -! csub_delay_eval -- Determine if the delay interbed should be solved, -! is stranded, or is a run-time error -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - ! -- dummy - integer(I4B), intent(in) :: ib - integer(I4B), intent(in) :: node - real(DP), intent(in) :: hcell - ! -- local variables - integer(I4B) :: idelaycalc - real(DP) :: top -! ------------------------------------------------------------------------------ - idelaycalc = 1 - ! - ! -- non-convertible cell - if (this%stoiconv(node) == 0) then - top = this%dis%top(node) - ! -- run-time error - if (hcell < top) then - idelaycalc = -999 - end if - ! - ! -- convertible cell - else - top = this%dis%bot(node) + this%thickini(ib) - ! - ! -- stranded cell - if (hcell < top) then - idelaycalc = 0 - end if - end if - ! - ! -- return - return - end function csub_delay_eval - - - subroutine csub_calc_sat(this, node, hcell, hcellold, snnew, snold) -! ****************************************************************************** -! csub_calc_sat -- Calculate current and previous cell saturation for a cell. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: node - real(DP), intent(in) :: hcell - real(DP), intent(in) :: hcellold - real(DP), intent(inout) :: snnew - real(DP), intent(inout) :: snold - ! -- local variables - real(DP) :: top - real(DP) :: bot -! ------------------------------------------------------------------------------ - if (this%stoiconv(node) /= 0) then - top = this%dis%top(node) - bot = this%dis%bot(node) - snnew = sQuadraticSaturation(top, bot, hcell, this%satomega) - snold = sQuadraticSaturation(top, bot, hcellold, this%satomega) - else - snnew = DONE - snold = DONE - end if - if (this%ieslag /= 0) then - snold = snnew - end if - ! - ! -- return - return - end subroutine csub_calc_sat - - function csub_calc_sat_derivative(this, node, hcell) result(satderv) -! ****************************************************************************** -! csub_calc_sat_derivative -- Calculate current saturation derivative for a cell. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: node - real(DP), intent(in) :: hcell - ! -- local variables - real(DP) :: satderv - real(DP) :: top - real(DP) :: bot -! ------------------------------------------------------------------------------ - if (this%stoiconv(node) /= 0) then - top = this%dis%top(node) - bot = this%dis%bot(node) - satderv = sQuadraticSaturationDerivative(top, bot, hcell, this%satomega) - else - satderv = DZERO - end if - ! - ! -- return - return - end function csub_calc_sat_derivative - - subroutine csub_calc_sfacts(this, node, bot, znode, theta, es, es0, fact) -! ****************************************************************************** -! csub_calc_sfacts -- Calculate sske and factor for a gwf cell or -! interbed. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: node - real(DP), intent(in) :: bot - real(DP), intent(in) :: znode - real(DP), intent(in) :: theta - real(DP), intent(in) :: es - real(DP), intent(in) :: es0 - real(DP), intent(inout) :: fact - ! -- local variables - real(DP) :: esv - real(DP) :: void - real(DP) :: denom -! ------------------------------------------------------------------------------ - ! - ! -- initialize variables - fact = DZERO - if (this%ieslag /= 0) then - esv = es0 - else - esv = es - end if - ! - ! -- calculate storage factors for the effective stress case - void = this%csub_calc_void(theta) - denom = this%csub_calc_adjes(node, esv, bot, znode) - denom = denom * (DONE + void) - if (denom /= DZERO) then - fact = DONE / denom - end if - ! - ! -- return - return - end subroutine csub_calc_sfacts - - subroutine csub_adj_matprop(this, comp, thick, theta) -! ****************************************************************************** -! csub_adj_matprop -- Adjust theta and thickness based on compaction. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - real(DP), intent(in) :: comp - real(DP), intent(inout) :: thick - real(DP), intent(inout) :: theta - ! -- local variables - real(DP) :: strain - real(DP) :: void -! ------------------------------------------------------------------------------ - ! - ! -- initialize variables - strain = DZERO - void = this%csub_calc_void(theta) - ! - ! -- calculate strain - if (thick > DZERO) strain = -comp / thick - ! - ! -- update void ratio, theta, and thickness - void = void + strain * (DONE + void) - theta = this%csub_calc_theta(void) - thick = thick - comp - ! - ! -- return - return - end subroutine csub_adj_matprop - - subroutine csub_delay_sln(this, ib, hcell, update) -! ****************************************************************************** -! csub_delay_sln -- Calculate flow in delay interbeds. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib - real(DP), intent(in) :: hcell - logical, intent(in), optional :: update - ! -- local variables - logical :: lupdate - integer(I4B) :: n - integer(I4B) :: icnvg - integer(I4B) :: iter - integer(I4B) :: idelay - real(DP) :: dh - real(DP) :: dhmax - real(DP) :: dhmax0 - real(DP), parameter :: dclose = DHUNDRED * DPREC -! ------------------------------------------------------------------------------ - ! - ! -- initialize variables - if (present(update)) then - lupdate = update - else - lupdate = .true. - end if - ! - ! -- calculate geostatic and effective stress for each delay bed cell - call this%csub_delay_calc_stress(ib, hcell) - ! - ! -- terminate if the aquifer head is below the top of delay interbeds - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- solve for delay bed heads - if (this%thickini(ib) > DZERO) then - icnvg = 0 - iter = 0 - idelay = this%idelay(ib) - do - iter = iter + 1 - ! - ! -- assemble coefficients - call this%csub_delay_assemble(ib, hcell) - ! - ! -- solve for head change in delay interbed cells - call csub_delay_solve(this%ndelaycells, & - this%dbal, this%dbad, this%dbau, & - this%dbrhs, this%dbdh, this%dbaw) - ! - ! -- calculate maximum head change and update delay bed heads - dhmax = DZERO - do n = 1, this%ndelaycells - dh = this%dbdh(n) - this%dbh(n, idelay) - if (abs(dh) > abs(dhmax)) then - dhmax = dh - if (lupdate) then - this%dbdhmax(idelay) = dhmax - end if - end if - ! -- update delay bed heads - this%dbh(n, idelay) = this%dbdh(n) - end do - ! - ! -- update delay bed stresses - call this%csub_delay_calc_stress(ib, hcell) - ! - ! -- check delay bed convergence - if (abs(dhmax) < dclose) then - icnvg = 1 - else if (iter /= 1) then - if (abs(dhmax)-abs(dhmax0) < DPREC) then - icnvg = 1 - end if - end if - if (icnvg == 1) then - exit - end if - dhmax0 = dhmax - end do - end if - ! - ! -- return - return - end subroutine csub_delay_sln - - - subroutine csub_delay_calc_zcell(this, ib) -! ****************************************************************************** -! csub_delay_calc_zcell -- Calculate z for delay interbeds cells. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib - ! -- local variables - integer(I4B) :: n - integer(I4B) :: node - integer(I4B) :: idelay - real(DP) :: bot - real(DP) :: top - real(DP) :: znode - real(DP) :: dzz - real(DP) :: z - real(DP) :: zr - real(DP) :: b - real(DP) :: dz -! ------------------------------------------------------------------------------ - ! - ! -- initialize variables - idelay = this%idelay(ib) - node = this%nodelist(ib) - b = this%thickini(ib) - bot = this%dis%bot(node) - top = bot + b - ! - ! -- calculate znode based on assumption that the delay bed bottom - ! is equal to the cell bottom - znode = this%csub_calc_znode(top, bot, top) - dz = DHALF * this%dbdzini(1, idelay) - dzz = DHALF * b - z = znode + dzz - zr = dzz - ! - ! -- calculate z and z relative to znode for each delay - ! interbed node - do n = 1, this%ndelaycells - ! z of node relative to bottom of cell - z = z - dz - this%dbz(n, idelay) = z - z = z - dz - ! z relative to znode - zr = zr - dz - if (ABS(zr) < dz) then - zr = DZERO - end if - this%dbrelz(n, idelay) = zr - zr = zr - dz - end do - ! - ! -- return - return - - end subroutine csub_delay_calc_zcell - - subroutine csub_delay_chk(this, ib, hcell) -! ****************************************************************************** -! csub_delay_chk -- Check the head relative to the top of a delay interbed. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib - real(DP), intent(in) :: hcell - ! -- local variables - character(len=LINELENGTH) :: errmsg - character(len=20) :: cellid - integer(I4B) :: idelay - integer(I4B) :: node - real(DP) :: dzhalf - real(DP) :: top -! ------------------------------------------------------------------------------ - ! - ! -- initialize variables - idelay = this%idelay(ib) - node = this%nodelist(ib) - dzhalf = DHALF * this%dbdzini(1, idelay) - top = this%dbz(1, idelay) + dzhalf - ! - ! -- check that aquifer head is above the top of the interbed - if (hcell < top) then - call this%dis%noder_to_string(node, cellid) - write(errmsg, '(a,g0,a,1x,a,1x,a,1x,i0,1x,a,g0,a)') & - 'ERROR: HEAD (', hcell, ') IN CONVERTIBLE CELL', trim(adjustl(cellid)), & - 'IS LESS THAN THE TOP OF DELAY INTERBED', ib, & - '(', top,')' - call store_error(errmsg) - end if - ! - ! -- return - return - - end subroutine csub_delay_chk - - - subroutine csub_delay_calc_stress(this, ib, hcell) -! ****************************************************************************** -! csub_delay_calc_stress -- Calculate geostatic and effective stress in delay -! interbeds. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib - real(DP), intent(in) :: hcell - ! -- local variables - integer(I4B) :: n - integer(I4B) :: idelay - integer(I4B) :: node - real(DP) :: sigma - real(DP) :: topaq - real(DP) :: botaq - real(DP) :: dzhalf - real(DP) :: sadd - real(DP) :: sgm - real(DP) :: sgs - real(DP) :: h - real(DP) :: z - real(DP) :: top - real(DP) :: bot - real(DP) :: u -! ------------------------------------------------------------------------------ - ! - ! -- initialize variables - idelay = this%idelay(ib) - node = this%nodelist(ib) - sigma = this%cg_gs(node) - topaq = this%dis%top(node) - botaq = this%dis%bot(node) - dzhalf = DHALF * this%dbdzini(1, idelay) - top = this%dbz(1, idelay) + dzhalf - ! - ! -- calculate the geostatic load in the cell at the top of the interbed. - sgm = this%sgm(node) - sgs = this%sgs(node) - if (hcell > top) then - sadd = (top - botaq) * sgs - else if (hcell < botaq) then - sadd = (top - botaq) * sgm - else - sadd = ((top - hcell) * sgm) + ((hcell - botaq) * sgs) - end if - sigma = sigma - sadd - ! - ! -- calculate geostatic and effective stress for each interbed node. - do n = 1, this%ndelaycells - h = this%dbh(n, idelay) - ! - ! -- geostatic calculated at the bottom of the delay cell - z = this%dbz(n, idelay) - top = z + dzhalf - bot = z - dzhalf - if (h > top) then - sadd = (top - bot) * sgs - else if (h < bot) then - sadd = (top - bot) * sgm - else - sadd = ((top - h) * sgm) + ((h - bot) * sgs) - end if - sigma = sigma + sadd - u = h - bot - this%dbgeo(n, idelay) = sigma - this%dbes(n, idelay) = sigma - u - end do - ! - ! -- return - return - end subroutine csub_delay_calc_stress - - subroutine csub_delay_calc_ssksske(this, ib, n, hcell, ssk, sske) -! ****************************************************************************** -! csub_delay_calc_ssksske -- Calculate ssk and sske for a node in a delay -! interbed cell. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib - integer(I4B), intent(in) :: n - real(DP), intent(in) :: hcell - real(DP), intent(inout) :: ssk - real(DP), intent(inout) :: sske - ! -- local variables - integer(I4B) :: idelay - integer(I4B) :: ielastic - integer(I4B) :: node - real(DP) :: z1 - real(DP) :: z0 - real(DP) :: zcell - real(DP) :: znode - real(DP) :: zbot - real(DP) :: es - real(DP) :: es0 - real(DP) :: theta - real(DP) :: f - real(DP) :: f0 -! ------------------------------------------------------------------------------ - ! - ! -- initialize variables - sske = DZERO - ssk = DZERO - idelay = this%idelay(ib) - ielastic = this%ielastic(ib) - ! - ! -- calculate factor for the head-based case - if (this%lhead_based .EQV. .TRUE.) then - f = DONE - f0 = f - ! - ! -- calculate factor for the effective stress case - else - node = this%nodelist(ib) - theta = this%dbthetaini(n, idelay) - ! - ! -- set top and bottom of layer and elevation of - ! node relative to the bottom of the cell - z1 = this%dis%top(node) - z0 = this%dis%bot(node) - zbot = this%dbz(n, idelay) - DHALF * this%dbdzini(1, idelay) - ! - ! -- set location of delay node relative to the center - ! of the cell based on current head - zcell = this%csub_calc_znode(z1, z0, hcell) - znode = zcell + this%dbrelz(n, idelay) - ! - ! -- set the effective stress - es = this%dbes(n, idelay) - es0 = this%dbes0(n, idelay) - ! - ! -- calculate the compression index factors for the delay - ! node relative to the center of the cell based on the - ! current and previous head - call this%csub_calc_sfacts(node, zbot, znode, theta, es, es0, f) - end if - this%idbconvert(n, idelay) = 0 - sske = f * this%rci(ib) - ssk = f * this%rci(ib) - if (ielastic == 0) then - if (this%dbes(n, idelay) > this%dbpcs(n, idelay)) then - this%idbconvert(n, idelay) = 1 - ssk = f * this%ci(ib) - end if - end if - ! - ! -- return - return - end subroutine csub_delay_calc_ssksske - - subroutine csub_delay_assemble(this, ib, hcell) -! ****************************************************************************** -! csub_delay_assemble -- Assemble coefficients for delay interbeds cells. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use TdisModule, only: delt - ! -- dummy variables - class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib - real(DP), intent(in) :: hcell - ! -- local variables - integer(I4B) :: n - integer(I4B) :: node - integer(I4B) :: idelay - integer(I4B) :: ielastic - real(DP) :: dz - real(DP) :: dzhalf - real(DP) :: c - real(DP) :: c2 - real(DP) :: c3 - real(DP) :: fmult - real(DP) :: sske - real(DP) :: ssk - real(DP) :: z - real(DP) :: ztop - real(DP) :: zbot - real(DP) :: h - real(DP) :: aii - real(DP) :: r -! ------------------------------------------------------------------------------ - ! - ! -- initialize variables - idelay = this%idelay(ib) - ielastic = this%ielastic(ib) - node = this%nodelist(ib) - dz = this%dbdzini(1, idelay) - dzhalf = DHALF * dz - fmult = dz / delt - c = this%kv(ib) / dz - c2 = DTWO * c - c3 = DTHREE * c - ! - ! - do n = 1, this%ndelaycells - ! - ! -- current and previous delay cell states - z = this%dbz(n, idelay) - ztop = z + dzhalf - zbot = z - dzhalf - h = this%dbh(n, idelay) - ! - ! -- calculate ssk and sske - call this%csub_delay_calc_ssksske(ib, n, hcell, ssk, sske) - ! - ! -- calculate diagonal - aii = -ssk * fmult - ! - ! -- calculate right hand side - if (ielastic /= 0) then - r = -fmult * & - (ssk * (this%dbgeo(n, idelay) + zbot) - & - sske * this%dbes0(n, idelay)) - else - r = -fmult * & - (ssk * (this%dbgeo(n, idelay) + zbot - this%dbpcs(n, idelay)) + & - sske * (this%dbpcs(n, idelay) - this%dbes0(n, idelay))) - end if - ! - ! -- add connection to the gwf cell - if (n == 1 .or. n == this%ndelaycells) then - aii = aii - c3 - r = r - c2 * hcell - else - aii = aii - c2 - end if - ! - ! -- off diagonals - ! -- lower - if (n > 1) then - this%dbal(n) = c - end if - ! - ! -- upper - if (n < this%ndelaycells) then - this%dbau(n) = c - end if - ! - ! -- diagonal - this%dbad(n) = aii - ! - ! -- right hand side - this%dbrhs(n) = r - end do - ! - ! -- return - return - - end subroutine csub_delay_assemble - - subroutine csub_delay_solve(n, tl, td, tu, b, x, w) -! ****************************************************************************** -! csub_delay_solve -- Solve for head change in delay interbeds cells. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - integer(I4B), intent(in) :: n - real(DP), dimension(n), intent(in) :: tl - real(DP), dimension(n), intent(in) :: td - real(DP), dimension(n), intent(in) :: tu - real(DP), dimension(n), intent(in) :: b - real(DP), dimension(n), intent(inout) :: x - real(DP), dimension(n), intent(inout) :: w - ! -- local variables - integer(I4B) :: j - real(DP) :: bet - real(DP) :: beti -! ------------------------------------------------------------------------------ - ! - ! -- initialize variables - w(1) = DZERO - bet = td(1) - beti = DONE / bet - x(1) = b(1) * beti - ! - ! -- decomposition and forward substitution - do j = 2, n - w(j) = tu(j-1) * beti - bet = td(j) - tl(j) * w(j) - beti = DONE / bet - x(j) = (b(j) - tl(j) * x(j-1)) * beti - end do - ! - ! -- backsubstitution - do j = n-1, 1, -1 - x(j) = x(j) - w(j+1) * x(j+1) - end do - ! -- return - return - end subroutine csub_delay_solve - - subroutine csub_delay_calc_dstor(this, ib, hcell, stoe, stoi) -! ****************************************************************************** -! csub_delay_calc_dstor -- Calculate change in storage in a delay interbed. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy variables - class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib - real(DP), intent(inout) :: hcell - real(DP), intent(inout) :: stoe - real(DP), intent(inout) :: stoi - ! -- local variables - integer(I4B) :: idelay - integer(I4B) :: ielastic - integer(I4B) :: n - real(DP) :: sske - real(DP) :: ssk - real(DP) :: fmult - real(DP) :: v1 - real(DP) :: v2 - real(DP) :: ske - real(DP) :: sk - real(DP) :: z - real(DP) :: zbot - real(DP) :: dzhalf -! ------------------------------------------------------------------------------ - ! - ! -- initialize variables - idelay = this%idelay(ib) - ielastic = this%ielastic(ib) - stoe = DZERO - stoi = DZERO - ske = DZERO - sk = DZERO - ! - ! - if (this%thickini(ib) > DZERO) then - fmult = this%dbdzini(1, idelay) - dzhalf = DHALF * this%dbdzini(1, idelay) - do n = 1, this%ndelaycells - call this%csub_delay_calc_ssksske(ib, n, hcell, ssk, sske) - z = this%dbz(n, idelay) - zbot = z - dzhalf - if (ielastic /= 0) then - v1 = ssk * (this%dbgeo(n, idelay) - this%dbh(n, idelay) + zbot) - & - sske * this%dbes0(n, idelay) - v2 = DZERO - else - v1 = ssk * (this%dbgeo(n, idelay) - this%dbh(n, idelay) + zbot - & - this%dbpcs(n, idelay)) - v2 = sske * (this%dbpcs(n, idelay) - this%dbes0(n, idelay)) - end if - ! - ! -- calculate inelastic and elastic storage components - if (this%idbconvert(n, idelay) /= 0) then - stoi = stoi + v1 * fmult - stoe = stoe + v2 * fmult - else - stoe = stoe + (v1 + v2) * fmult - end if - ! - ! calculate inelastic and elastic storativity - ske = ske + sske * fmult - sk = sk + ssk * fmult - end do - end if - ! - ! -- save ske and sk - this%ske(ib) = ske - this%sk(ib) = sk - ! - ! -- return - return - end subroutine csub_delay_calc_dstor - - subroutine csub_delay_calc_comp(this, ib, hcell, hcellold, comp, compi, compe) -! ****************************************************************************** -! csub_delay_calc_comp -- Calculate compaction in a delay interbed. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib - real(DP), intent(in) :: hcell - real(DP), intent(in) :: hcellold - real(DP), intent(inout) :: comp - real(DP), intent(inout) :: compi - real(DP), intent(inout) :: compe - ! -- local variables - integer(I4B) :: idelay - integer(I4B) :: ielastic - integer(I4B) :: node - integer(I4B) :: n - real(DP) :: snnew - real(DP) :: snold - real(DP) :: sske - real(DP) :: ssk - real(DP) :: fmult - real(DP) :: v - real(DP) :: v1 - real(DP) :: v2 -! ------------------------------------------------------------------------------ - ! - ! -- initialize variables - idelay = this%idelay(ib) - ielastic = this%ielastic(ib) - node = this%nodelist(ib) - comp = DZERO - compi = DZERO - compe = DZERO - ! - ! -- calculate cell saturation - call this%csub_calc_sat(node, hcell, hcellold, snnew, snold) - ! - ! -- calculate compaction - if (this%thickini(ib) > DZERO) then - fmult = this%dbdzini(1, idelay) - do n = 1, this%ndelaycells - call this%csub_delay_calc_ssksske(ib, n, hcell, ssk, sske) - if (ielastic /= 0) then - v1 = ssk * this%dbes(n, idelay) - sske * this%dbes0(n, idelay) - v2 = DZERO - else - v1 = ssk * (this%dbes(n, idelay) - this%dbpcs(n, idelay)) - v2 = sske * (this%dbpcs(n, idelay) - this%dbes0(n, idelay)) - end if - v = (v1 + v2) * fmult - comp = comp + v - ! - ! -- save compaction data - this%dbcomp(n, idelay) = v * snnew - ! - ! -- calculate inelastic and elastic storage components - if (this%idbconvert(n, idelay) /= 0) then - compi = compi + v1 * fmult - compe = compe + v2 * fmult - else - compe = compe + (v1 + v2) * fmult - end if - end do - end if - ! - ! -- fill compaction - comp = comp * this%rnb(ib) * snnew - compi = compi * this%rnb(ib) * snnew - compe = compe * this%rnb(ib) * snnew - ! - ! -- return - return - end subroutine csub_delay_calc_comp - - subroutine csub_delay_update(this, ib) -! ****************************************************************************** -! csub_delay_update -- Update delay interbed thickness and porosity. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib - ! -- local variables - character(len=LINELENGTH) :: errmsg - integer(I4B) :: idelay - integer(I4B) :: n - real(DP) :: comp - real(DP) :: thick - real(DP) :: theta - real(DP) :: tthick - real(DP) :: wtheta -! ------------------------------------------------------------------------------ - ! - ! -- initialize variables - idelay = this%idelay(ib) - comp = DZERO - tthick = DZERO - wtheta = DZERO - ! - ! - do n = 1, this%ndelaycells - ! - ! -- initialize compaction for delay cell - comp = this%dbtcomp(n, idelay) + this%dbcomp(n, idelay) - ! - ! -- scale compaction by rnb to get the compaction for - ! the interbed system (as opposed to the full system) - comp = comp / this%rnb(ib) - ! - ! -- update thickness and theta - if (ABS(comp) > DZERO) then - thick = this%dbdzini(n, idelay) - theta = this%dbthetaini(n, idelay) - call this%csub_adj_matprop(comp, thick, theta) - if (thick <= DZERO) then - write(errmsg,'(4x,2(a,1x,i0,1x),a,1x,g0,1x,a)') & - '****ERROR. ADJUSTED THICKNESS FOR DELAY INTERBED (', & - ib, ') CELL (', n, ') IS <= 0 (', thick, ')' - call store_error(errmsg) - end if - if (theta <= DZERO) then - write(errmsg,'(4x,2(a,1x,i0,1x),a,1x,g0,1x,a)') & - '****ERROR. ADJUSTED THETA FOR DELAY INTERBED (', & - ib, ') CELL (', n, 'IS <= 0 (', theta, ')' - call store_error(errmsg) - end if - this%dbdz(n, idelay) = thick - this%dbtheta(n, idelay) = theta - tthick = tthick + thick - wtheta = wtheta + thick * theta - else - thick = this%dbdz(n, idelay) - theta = this%dbtheta(n, idelay) - tthick = tthick + thick - wtheta = wtheta + thick * theta - end if - end do - ! - ! -- calculate thickness weighted theta and save thickness and weighted - ! theta values for delay interbed - if (tthick > DZERO) then - wtheta = wtheta / tthick - else - tthick = DZERO - wtheta = DZERO - end if - this%thick(ib) = tthick - this%theta(ib) = wtheta - ! - ! -- return - return - end subroutine csub_delay_update - - subroutine csub_delay_fc(this, ib, hcof, rhs) -! ****************************************************************************** -! csub_delay_fc -- Calculate hcof and rhs for delay interbed contribution to -! GWF cell. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib - real(DP), intent(inout) :: hcof - real(DP), intent(inout) :: rhs - ! -- local variables - integer(I4B) :: idelay - real(DP) :: c1 - real(DP) :: c2 -! ------------------------------------------------------------------------------ - ! - ! -- initialize variables - idelay = this%idelay(ib) - hcof = DZERO - rhs = DZERO - if (this%thickini(ib) > DZERO) then - ! -- calculate terms for gwf matrix - c1 = DTWO * this%kv(ib) / this%dbdzini(1, idelay) - rhs = -c1 * this%dbh(1, idelay) - c2 = DTWO * & - this%kv(ib) / this%dbdzini(this%ndelaycells, idelay) - rhs = rhs - c2 * this%dbh(this%ndelaycells, idelay) - hcof = c1 + c2 - end if - ! - ! -- return - return - end subroutine csub_delay_fc - - function csub_calc_delay_flow(this, ib, n, hcell) result(q) -! ****************************************************************************** -! csub_calc_delay_flow -- Calculate flow across top or bottom of delay interbed -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfCsubType), intent(inout) :: this - ! -- dummy - integer(I4B), intent(in) :: ib - integer(I4B), intent(in) :: n - real(DP), intent(in) :: hcell - ! -- local variables - integer(I4B) :: idelay - real(DP) :: q - real(DP) :: c -! ------------------------------------------------------------------------------ - idelay = this%idelay(ib) - c = DTWO * this%kv(ib) / this%dbdzini(n, idelay) - q = c * (hcell - this%dbh(n, idelay)) - ! - ! -- return - return - end function csub_calc_delay_flow - - - ! - ! -- Procedures related to observations (type-bound) - logical function csub_obs_supported(this) - ! ****************************************************************************** - ! csub_obs_supported - ! -- Return true because csub package supports observations. - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - class(GwfCsubType) :: this - ! ------------------------------------------------------------------------------ - csub_obs_supported = .true. - return - end function csub_obs_supported - - - subroutine csub_df_obs(this) - ! ****************************************************************************** - ! csub_df_obs (implements bnd_df_obs) - ! -- Store observation type supported by csub package. - ! -- Overrides BndType%bnd_df_obs - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfCsubType) :: this - ! -- local - integer(I4B) :: indx - ! ------------------------------------------------------------------------------ - ! - ! -- Store obs type and assign procedure pointer - ! for csub observation type. - call this%obs%StoreObsType('csub', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for inelastic-csub observation type. - call this%obs%StoreObsType('inelastic-csub', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for elastic-csub observation type. - call this%obs%StoreObsType('elastic-csub', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for coarse-csub observation type. - call this%obs%StoreObsType('coarse-csub', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for csub-cell observation type. - call this%obs%StoreObsType('csub-cell', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for watercomp-csub observation type. - call this%obs%StoreObsType('wcomp-csub-cell', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for interbed ske observation type. - call this%obs%StoreObsType('ske', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for interbed sk observation type. - call this%obs%StoreObsType('sk', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for ske-cell observation type. - call this%obs%StoreObsType('ske-cell', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for sk-cell observation type. - call this%obs%StoreObsType('sk-cell', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for geostatic-stress-cell observation type. - call this%obs%StoreObsType('gstress-cell', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for effective-stress-cell observation type. - call this%obs%StoreObsType('estress-cell', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for total-compaction observation type. - call this%obs%StoreObsType('interbed-compaction', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for inelastic-compaction observation type. - call this%obs%StoreObsType('inelastic-compaction', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for inelastic-compaction observation type. - call this%obs%StoreObsType('elastic-compaction', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for coarse-compaction observation type. - call this%obs%StoreObsType('coarse-compaction', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for inelastic-compaction-cell observation type. - call this%obs%StoreObsType('inelastic-compaction-cell', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for elastic-compaction-cell observation type. - call this%obs%StoreObsType('elastic-compaction-cell', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for compaction-cell observation type. - call this%obs%StoreObsType('compaction-cell', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for interbed thickness observation type. - call this%obs%StoreObsType('thickness', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for coarse-thickness observation type. - call this%obs%StoreObsType('coarse-thickness', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for thickness-cell observation type. - call this%obs%StoreObsType('thickness-cell', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for interbed theta observation type. - call this%obs%StoreObsType('theta', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for coarse-theta observation type. - call this%obs%StoreObsType('coarse-theta', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for theta-cell observation type. - call this%obs%StoreObsType('theta-cell', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for preconstress-cell observation type. - call this%obs%StoreObsType('preconstress-cell', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for delay-preconstress observation type. - call this%obs%StoreObsType('delay-preconstress', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for delay-head observation type. - call this%obs%StoreObsType('delay-head', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for delay-gstress observation type. - call this%obs%StoreObsType('delay-gstress', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for delay-estress observation type. - call this%obs%StoreObsType('delay-estress', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for delay-compaction observation type. - call this%obs%StoreObsType('delay-compaction', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for delay-thickness observation type. - call this%obs%StoreObsType('delay-thickness', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for delay-theta observation type. - call this%obs%StoreObsType('delay-theta', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for delay-flowtop observation type. - call this%obs%StoreObsType('delay-flowtop', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for delay-flowbot observation type. - call this%obs%StoreObsType('delay-flowbot', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID - ! - return - end subroutine csub_df_obs - - - subroutine csub_bd_obs(this) - ! ************************************************************************** - ! csub_bd_obs - ! -- Calculate observations this time step and call - ! ObsType%SaveOneSimval for each GwfCsubType observation. - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - ! -- dummy - class(GwfCsubType), intent(inout) :: this - ! -- local - integer(I4B) :: i - integer(I4B) :: j - integer(I4B) :: n - integer(I4B) :: nn - integer(I4B) :: idelay - integer(I4B) :: ncol - integer(I4B) :: node - real(DP) :: v - real(DP) :: r - real(DP) :: f - character(len=100) :: msg - type(ObserveType), pointer :: obsrv => null() - !--------------------------------------------------------------------------- - ! - ! -- Fill simulated values for all csub observations - if (this%obs%npakobs > 0) then - call this%obs%obs_bd_clear() - do i = 1, this%obs%npakobs - obsrv => this%obs%pakobs(i)%obsrv - if (obsrv%BndFound) then - nn = size(obsrv%indxbnds) - if (obsrv%ObsTypeId == 'SKE' .or. & - obsrv%ObsTypeId == 'SK' .or. & - obsrv%ObsTypeId == 'SKE-CELL' .or. & - obsrv%ObsTypeId == 'SK-CELL' .or. & - obsrv%ObsTypeId == 'DELAY-HEAD' .or. & - obsrv%ObsTypeId == 'DELAY-PRECONSTRESS' .or. & - obsrv%ObsTypeId == 'DELAY-GSTRESS' .or. & - obsrv%ObsTypeId == 'DELAY-ESTRESS' .or. & - obsrv%ObsTypeId == 'PRECONSTRESS-CELL') then - if (this%gwfiss /= 0) then - call this%obs%SaveOneSimval(obsrv, DNODATA) - else - v = DZERO - do j = 1, nn - n = obsrv%indxbnds(j) - select case (obsrv%ObsTypeId) - case ('SKE') - v = this%ske(n) - case ('SK') - v = this%sk(n) - case ('SKE-CELL') - ! - ! -- add the coarse component - if (j == 1) then - v = this%cg_ske(n) - else - v = this%ske(n) - end if - case ('SK-CELL') - ! - ! -- add the coarse component - if (j == 1) then - v = this%cg_sk(n) - else - v = this%sk(n) - end if - case ('DELAY-HEAD', 'DELAY-PRECONSTRESS', & - 'DELAY-GSTRESS', 'DELAY-ESTRESS') - if (n > this%ndelaycells) then - r = real(n, DP) / real(this%ndelaycells, DP) - idelay = int(floor(r)) + 1 - ncol = mod(n, this%ndelaycells) - else - idelay = 1 - ncol = n - end if - select case(obsrv%ObsTypeId) - case ('DELAY-HEAD') - v = this%dbh(ncol, idelay) - case ('DELAY-PRECONSTRESS') - v = this%dbpcs(ncol, idelay) - case ('DELAY-GSTRESS') - v = this%dbgeo(ncol, idelay) - case ('DELAY-ESTRESS') - v = this%dbes(ncol, idelay) - end select - case ('PRECONSTRESS-CELL') - v = this%pcs(n) - case default - msg = 'Error: Unrecognized observation type: ' // & - trim(obsrv%ObsTypeId) - call store_error(msg) - end select - call this%obs%SaveOneSimval(obsrv, v) - end do - end if - else - v = DZERO - do j = 1, nn - n = obsrv%indxbnds(j) - select case (obsrv%ObsTypeId) - case ('CSUB') - v = this%storagee(n) + this%storagei(n) - case ('INELASTIC-CSUB') - v = this%storagei(n) - case ('ELASTIC-CSUB') - v = this%storagee(n) - case ('COARSE-CSUB') - v = this%cg_stor(n) - case ('WCOMP-CSUB-CELL') - v = this%cell_wcstor(n) - case ('CSUB-CELL') - ! - ! -- add the coarse component - if (j == 1) then - v = this%cg_stor(n) - else - v = this%storagee(n) + this%storagei(n) - end if - case ('THETA') - v = this%theta(n) - case ('COARSE-THETA') - v = this%cg_theta(n) - case ('THETA-CELL') - ! - ! -- add the coarse component - if (j == 1) then - f = this%cg_thick(n) / this%cell_thick(n) - v = f * this%cg_theta(n) - else - node = this%nodelist(n) - f = this%csub_calc_interbed_thickness(n) / this%cell_thick(node) - v = f * this%theta(n) - end if - case ('GSTRESS-CELL') - v = this%cg_gs(n) - case ('ESTRESS-CELL') - v = this%cg_es(n) - case ('INTERBED-COMPACTION') - v = this%tcomp(n) - case ('INELASTIC-COMPACTION') - v = this%tcompi(n) - case ('ELASTIC-COMPACTION') - v = this%tcompe(n) - case ('COARSE-COMPACTION') - v = this%cg_tcomp(n) - case ('INELASTIC-COMPACTION-CELL') - ! - ! -- no coarse inelastic component - if (j > 1) then - v = this%tcompi(n) - end if - case ('ELASTIC-COMPACTION-CELL') - ! - ! -- add the coarse component - if (j == 1) then - v = this%cg_tcomp(n) - else - v = this%tcompe(n) - end if - case ('COMPACTION-CELL') - ! - ! -- add the coarse component - if (j == 1) then - v = this%cg_tcomp(n) - else - v = this%tcomp(n) - end if - case ('THICKNESS') - idelay = this%idelay(n) - v = this%thick(n) - if (idelay /= 0) then - v = v * this%rnb(n) - end if - case ('COARSE-THICKNESS') - v = this%cg_thick(n) - case ('THICKNESS-CELL') - v = this%cell_thick(n) - case ('DELAY-COMPACTION', 'DELAY-THICKNESS', & - 'DELAY-THETA') - if (n > this%ndelaycells) then - r = real(n, DP) / real(this%ndelaycells, DP) - idelay = int(floor(r)) + 1 - ncol = mod(n, this%ndelaycells) - else - idelay = 1 - ncol = n - end if - select case(obsrv%ObsTypeId) - case ('DELAY-COMPACTION') - v = this%dbtcomp(ncol, idelay) - case ('DELAY-THICKNESS') - v = this%dbdz(ncol, idelay) - case ('DELAY-THETA') - v = this%dbtheta(ncol, idelay) - end select - case ('DELAY-FLOWTOP') - idelay = this%idelay(n) - v = this%dbflowtop(idelay) - case ('DELAY-FLOWBOT') - idelay = this%idelay(n) - v = this%dbflowbot(idelay) - case default - msg = 'Error: Unrecognized observation type: ' // & - trim(obsrv%ObsTypeId) - call store_error(msg) - end select - call this%obs%SaveOneSimval(obsrv, v) - end do - end if - else - call this%obs%SaveOneSimval(obsrv, DNODATA) - end if - end do - end if - ! - ! -- write summary of package block error messages - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - return - end subroutine csub_bd_obs - - - subroutine csub_rp_obs(this) - ! -- dummy - class(GwfCsubType), intent(inout) :: this - ! -- local - integer(I4B) :: i, j, n - integer(I4B) :: n2 - integer(I4B) :: idelay - class(ObserveType), pointer :: obsrv => null() - character(len=LENBOUNDNAME) :: bname - character(len=200) :: ermsg - ! - ! -- return if observations are not supported - if (.not. this%csub_obs_supported()) then - return - end if - ! - ! -- process each package observation - do i = 1, this%obs%npakobs - obsrv => this%obs%pakobs(i)%obsrv - ! - ! -- indxbnds needs to be deallocated and reallocated (using - ! ExpandArray) each stress period because list of boundaries - ! can change each stress period. - if (allocated(obsrv%indxbnds)) then - deallocate(obsrv%indxbnds) - end if - ! - ! -- initialize BndFound to .false. - obsrv%BndFound = .false. - ! - bname = obsrv%FeatureName - if (bname /= '') then - ! - ! -- Observation location(s) is(are) based on a boundary name. - ! Iterate through all boundaries to identify and store - ! corresponding index(indices) in bound array. - do j = 1, this%ninterbeds - if (this%boundname(j) == bname) then - obsrv%BndFound = .true. - obsrv%CurrentTimeStepEndValue = DZERO - call ExpandArray(obsrv%indxbnds) - n = size(obsrv%indxbnds) - obsrv%indxbnds(n) = j - end if - end do - ! - ! -- one value per cell - else if (obsrv%ObsTypeId == 'GSTRESS-CELL' .or. & - obsrv%ObsTypeId == 'ESTRESS-CELL' .or. & - obsrv%ObsTypeId == 'THICKNESS-CELL' .or. & - obsrv%ObsTypeId == 'COARSE-CSUB' .or. & - obsrv%ObsTypeId == 'WCOMP-CSUB-CELL' .or. & - obsrv%ObsTypeId == 'COARSE-COMPACTION' .or. & - obsrv%ObsTypeId == 'COARSE-THETA' .or. & - obsrv%ObsTypeId == 'COARSE-THICKNESS') then - obsrv%BndFound = .true. - obsrv%CurrentTimeStepEndValue = DZERO - call ExpandArray(obsrv%indxbnds) - n = size(obsrv%indxbnds) - obsrv%indxbnds(n) = obsrv%NodeNumber - else if (obsrv%ObsTypeId == 'DELAY-PRECONSTRESS' .or. & - obsrv%ObsTypeId == 'DELAY-HEAD' .or. & - obsrv%ObsTypeId == 'DELAY-GSTRESS' .or. & - obsrv%ObsTypeId == 'DELAY-ESTRESS' .or. & - obsrv%ObsTypeId == 'DELAY-COMPACTION' .or. & - obsrv%ObsTypeId == 'DELAY-THICKNESS' .or. & - obsrv%ObsTypeId == 'DELAY-THETA') then - if (this%ninterbeds > 0) then - n = obsrv%NodeNumber - idelay = this%idelay(n) - if (idelay /= 0) then - j = (idelay - 1) * this%ndelaycells + 1 - n2 = obsrv%NodeNumber2 - if (n2 < 1 .or. n2 > this%ndelaycells) then - write (ermsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & - 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & - ' interbed cell must be > 0 and <=', this%ndelaycells, & - '(specified value is ', n2, ')' - call store_error(ermsg) - else - j = (idelay - 1) * this%ndelaycells + n2 - end if - obsrv%BndFound = .true. - call ExpandArray(obsrv%indxbnds) - obsrv%indxbnds(1) = j - end if - end if - ! - ! -- interbed value - else if (obsrv%ObsTypeId == 'CSUB' .or. & - obsrv%ObsTypeId == 'INELASTIC-CSUB' .or. & - obsrv%ObsTypeId == 'ELASTIC-CSUB' .or. & - obsrv%ObsTypeId == 'SK' .or. & - obsrv%ObsTypeId == 'SKE' .or. & - obsrv%ObsTypeId == 'THICKNESS' .or. & - obsrv%ObsTypeId == 'THETA' .or. & - obsrv%ObsTypeId == 'INTERBED-COMPACTION' .or. & - obsrv%ObsTypeId == 'INELASTIC-COMPACTION' .or. & - obsrv%ObsTypeId == 'ELASTIC-COMPACTION') then - if (this%ninterbeds > 0) then - j = obsrv%NodeNumber - if (j < 1 .or. j > this%ninterbeds) then - write (ermsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & - 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & - ' interbed cell must be > 0 and <=', this%ninterbeds, & - '(specified value is ', j, ')' - call store_error(ermsg) - else - obsrv%BndFound = .true. - obsrv%CurrentTimeStepEndValue = DZERO - call ExpandArray(obsrv%indxbnds) - n = size(obsrv%indxbnds) - obsrv%indxbnds(n) = j - end if - end if - else if (obsrv%ObsTypeId == 'DELAY-FLOWTOP' .or. & - obsrv%ObsTypeId == 'DELAY-FLOWBOT') then - if (this%ninterbeds > 0) then - j = obsrv%NodeNumber - if (j < 1 .or. j > this%ninterbeds) then - write (ermsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & - 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & - ' interbed cell must be > 0 and <=', this%ninterbeds, & - '(specified value is ', j, ')' - call store_error(ermsg) - end if - idelay = this%idelay(j) - if (idelay /= 0) then - obsrv%BndFound = .true. - obsrv%CurrentTimeStepEndValue = DZERO - call ExpandArray(obsrv%indxbnds) - n = size(obsrv%indxbnds) - obsrv%indxbnds(n) = j - end if - end if - else - ! - ! -- Accumulate values in a single cell - ! -- Observation location is a single node number - ! -- save node number in first position - if (obsrv%ObsTypeId == 'CSUB-CELL' .or. & - obsrv%ObsTypeId == 'SKE-CELL' .or. & - obsrv%ObsTypeId == 'SK-CELL' .or. & - obsrv%ObsTypeId == 'THETA-CELL' .or. & - obsrv%ObsTypeId == 'INELASTIC-COMPACTION-CELL' .or. & - obsrv%ObsTypeId == 'ELASTIC-COMPACTION-CELL' .or. & - obsrv%ObsTypeId == 'COMPACTION-CELL') then - if (.NOT. obsrv%BndFound) then - obsrv%BndFound = .true. - obsrv%CurrentTimeStepEndValue = DZERO - call ExpandArray(obsrv%indxbnds) - n = size(obsrv%indxbnds) - obsrv%indxbnds(n) = obsrv%NodeNumber - end if - end if - jloop: do j = 1, this%ninterbeds - if (this%nodelist(j) == obsrv%NodeNumber) then - obsrv%BndFound = .true. - obsrv%CurrentTimeStepEndValue = DZERO - call ExpandArray(obsrv%indxbnds) - n = size(obsrv%indxbnds) - obsrv%indxbnds(n) = j - endif - end do jloop - endif - enddo - ! - if (count_errors() > 0) then - call store_error_unit(this%inunit) - call ustop() - endif - ! - return - end subroutine csub_rp_obs - ! - ! -- Procedures related to observations (NOT type-bound) - subroutine csub_process_obsID(obsrv, dis, inunitobs, iout) - ! -- This procedure is pointed to by ObsDataType%ProcesssIdPtr. It processes - ! the ID string of an observation definition for csub-package observations. - ! -- dummy - type(ObserveType), intent(inout) :: obsrv - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: inunitobs - integer(I4B), intent(in) :: iout - ! -- local - integer(I4B) :: nn1 - integer(I4B) :: nn2 - integer(I4B) :: icol, istart, istop - character(len=LINELENGTH) :: strng - character(len=LENBOUNDNAME) :: bndname - logical :: flag_string - !-------------------------------------------------------------------------- - ! - strng = obsrv%IDstring - ! - ! -- Extract reach number from strng and store it. - ! If 1st item is not an integer(I4B), it should be a - ! boundary name--deal with it. - icol = 1 - ! - ! -- get icsubno number or boundary name - if (obsrv%ObsTypeId=='CSUB' .or. & - obsrv%ObsTypeId == 'INELASTIC-CSUB' .or. & - obsrv%ObsTypeId == 'ELASTIC-CSUB' .or. & - obsrv%ObsTypeId=='SK' .or. & - obsrv%ObsTypeId=='SKE' .or. & - obsrv%ObsTypeId=='THETA' .or. & - obsrv%ObsTypeId=='THICKNESS' .or. & - obsrv%ObsTypeId == 'INTERBED-COMPACTION' .or. & - obsrv%ObsTypeId == 'INELASTIC-COMPACTION' .or. & - obsrv%ObsTypeId == 'ELASTIC-COMPACTION' .or. & - obsrv%ObsTypeId=='DELAY-HEAD' .or. & - obsrv%ObsTypeId=='DELAY-GSTRESS' .or. & - obsrv%ObsTypeId=='DELAY-ESTRESS' .or. & - obsrv%ObsTypeId=='DELAY-PRECONSTRESS' .or. & - obsrv%ObsTypeId=='DELAY-COMPACTION' .or. & - obsrv%ObsTypeId=='DELAY-THICKNESS' .or. & - obsrv%ObsTypeId=='DELAY-THETA' .or. & - obsrv%ObsTypeId=='DELAY-FLOWTOP' .or. & - obsrv%ObsTypeId=='DELAY-FLOWBOT') then - call extract_idnum_or_bndname(strng, icol, istart, istop, nn1, bndname) - else - nn1 = dis%noder_from_string(icol, istart, istop, inunitobs, & - iout, strng, flag_string) - end if - if (nn1 == NAMEDBOUNDFLAG) then - obsrv%FeatureName = bndname - else - if (obsrv%ObsTypeId=='DELAY-HEAD' .or. & - obsrv%ObsTypeId=='DELAY-GSTRESS' .or. & - obsrv%ObsTypeId=='DELAY-ESTRESS' .or. & - obsrv%ObsTypeId=='DELAY-PRECONSTRESS' .or. & - obsrv%ObsTypeId=='DELAY-COMPACTION' .or. & - obsrv%ObsTypeId=='DELAY-THICKNESS' .or. & - obsrv%ObsTypeId=='DELAY-THETA') then - call extract_idnum_or_bndname(strng, icol, istart, istop, nn2, bndname) - if (nn2 == NAMEDBOUNDFLAG) then - obsrv%FeatureName = bndname - ! -- reset nn1 - nn1 = nn2 - else - obsrv%NodeNumber2 = nn2 - end if - end if - endif - ! - ! -- store reach number (NodeNumber) - obsrv%NodeNumber = nn1 - ! - ! -- return - return - end subroutine csub_process_obsID - - ! - ! -- Procedure related to time series - subroutine csub_rp_ts(this) - ! - ! -- Assign tsLink%Text appropriately for - ! all time series in use by package. - ! In the CSUB package only the SIG0 variable - ! can be controlled by time series. - ! -- dummy - class(GwfCsubType), intent(inout) :: this - ! -- local - integer(I4B) :: i, nlinks - type(TimeSeriesLinkType), pointer :: tslink => null() - ! - ! -- process all timeseries links - nlinks = this%TsManager%boundtslinks%Count() - do i = 1, nlinks - tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) - if (associated(tslink)) then - if (tslink%JCol==1) then - tslink%Text = 'SIG0' - endif - endif - enddo - ! - return - end subroutine csub_rp_ts - -end module GwfCsubModule +module GwfCsubModule + use KindModule, only: I4B, DP + use ConstantsModule, only: DPREC, DZERO, DEM20, DEM15, DEM10, DEM8, DEM7, & + DEM6, DEM4, DP9, DHALF, DEM1, DONE, DTWO, DTHREE, & + DGRAVITY, DTEN, DHUNDRED, DNODATA, DHNOFLO, & + LENFTYPE, LENPACKAGENAME, & + LINELENGTH, LENBOUNDNAME, NAMEDBOUNDFLAG, & + LENBUDTXT, LENAUXNAME, LENORIGIN, LENPAKLOC, & + TABLEFT, TABCENTER, TABRIGHT, & + TABSTRING, TABUCSTRING, TABINTEGER, TABREAL + use GenericUtilitiesModule, only: is_same, sim_message + use SmoothingModule, only: sQuadraticSaturation, & + sQuadraticSaturationDerivative + use NumericalPackageModule, only: NumericalPackageType + use ObserveModule, only: ObserveType + use ObsModule, only: ObsType, obs_cr + use BlockParserModule, only: BlockParserType + use TimeSeriesLinkModule, only: TimeSeriesLinkType, & + GetTimeSeriesLinkFromList + use InputOutputModule, only: get_node, extract_idnum_or_bndname + use BaseDisModule, only: DisBaseType + use SimModule, only: count_errors, store_error, store_error_unit, ustop + use ArrayHandlersModule, only: ExpandArray + use SortModule, only: qsort, selectn + ! + use TimeSeriesLinkModule, only: TimeSeriesLinkType + use TimeSeriesManagerModule, only: TimeSeriesManagerType, tsmanager_cr + use ListModule, only: ListType + use TableModule, only: TableType, table_cr + ! + implicit none + ! + private + public :: csub_cr + public :: GwfCsubType + ! + character(len=LENBUDTXT), dimension(4) :: budtxt = & !text labels for budget terms + [' CSUB-CGELASTIC', & + ' CSUB-ELASTIC', ' CSUB-INELASTIC', & + ' CSUB-WATERCOMP'] + character(len=LENBUDTXT), dimension(6) :: comptxt = & !text labels for compaction terms + ['CSUB-COMPACTION', ' CSUB-INELASTIC', ' CSUB-ELASTIC', & + ' CSUB-INTERBED', ' CSUB-COARSE', ' CSUB-ZDISPLACE'] + + ! + ! -- local parameter - derivative of the log of effective stress + real(DP), parameter :: dlog10es = 0.4342942_DP + ! + ! CSUB type + type, extends(NumericalPackageType) :: GwfCsubType + character(len=LENBOUNDNAME), dimension(:), & + pointer, contiguous :: boundname => null() !vector of boundnames + character(len=LENBOUNDNAME), dimension(:) , & + pointer, contiguous :: sig0bname => null() !vector of sig0bnames + character(len=LENAUXNAME), allocatable, dimension(:) :: auxname !name for each auxiliary variable + character(len=500) :: listlabel = '' !title of table written for RP + character(len=LENORIGIN) :: stoname + integer(I4B), pointer :: istounit => null() + integer(I4B), pointer :: istrainib => null() + integer(I4B), pointer :: istrainsk => null() + integer(I4B), pointer :: ioutcomp => null() + integer(I4B), pointer :: ioutcompi => null() + integer(I4B), pointer :: ioutcompe => null() + integer(I4B), pointer :: ioutcompib => null() + integer(I4B), pointer :: ioutcomps => null() + integer(I4B), pointer :: ioutzdisp => null() + integer(I4B), pointer :: ipakcsv => null() + integer(I4B), pointer :: iupdatematprop => null() + integer(I4B), pointer :: istoragec => null() + integer(I4B), pointer :: icellf => null() + integer(I4B), pointer :: ispecified_pcs => null() + integer(I4B), pointer :: ispecified_dbh => null() + integer(I4B), pointer :: inamedbound => null() !flag to read boundnames + integer(I4B), pointer :: iconvchk => NULL() + integer(I4B), pointer :: naux => null() !number of auxiliary variables + integer(I4B), pointer :: ninterbeds => null() + integer(I4B), pointer :: maxsig0 => null() + integer(I4B), pointer :: nbound => null() !number of boundaries for current stress period + integer(I4B), pointer :: ncolbnd => null() !number of columns of the bound array + integer(I4B), pointer :: iscloc => null() !bound column to scale with SFAC + integer(I4B), pointer :: iauxmultcol => null() !column to use as multiplier for column iscloc + integer(I4B), pointer :: ndelaycells => null() + integer(I4B), pointer :: ndelaybeds => null() + integer(I4B), pointer :: initialized => null() + integer(I4B), pointer :: ieslag => null() + integer(I4B), pointer :: ipch => null() + logical, pointer :: lhead_based => null() + integer(I4B), pointer :: iupdatestress => null() + real(DP), pointer :: epsilon => null() !epsilon for stress smoothing + real(DP), pointer :: cc_crit => null() !convergence criteria for csub-gwf convergence check + real(DP), pointer :: gammaw => null() !product of fluid density, and gravity + real(DP), pointer :: beta => null() !water compressibility + real(DP), pointer :: brg => null() !product of gammaw and water compressibility + real(DP), pointer :: dbfact => null() + real(DP), pointer :: dbfacti => null() + real(DP), pointer :: satomega => null() !newton-raphson saturation omega + + integer(I4B), pointer :: gwfiss => NULL() !pointer to model iss flag + integer(I4B), pointer :: gwfiss0 => NULL() !iss flag for last stress period + integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !pointer to model ibound + integer(I4B), dimension(:), pointer, contiguous :: stoiconv => null() !pointer to iconvert in storage + real(DP), dimension(:), pointer, contiguous :: stosc1 => null() !pointer to sc1 in storage + real(DP), dimension(:), pointer, contiguous :: buff => null() !buff array + real(DP), dimension(:), pointer, contiguous :: buffusr => null() !buffusr array + integer, dimension(:), pointer, contiguous :: nodelist => null() !reduced node that the interbed is attached to + integer, dimension(:), pointer, contiguous :: unodelist => null() !user node that the interbed is attached to + ! + ! -- coarse-grained storage variables + real(DP), dimension(:), pointer, contiguous :: sgm => null() !specific gravity moist sediments + real(DP), dimension(:), pointer, contiguous :: sgs => null() !specific gravity saturated sediments + real(DP), dimension(:), pointer, contiguous :: cg_ske_cr => null() !coarse-grained specified storage + real(DP), dimension(:), pointer, contiguous :: cg_gs => null() !geostatic stress for a cell + real(DP), dimension(:), pointer, contiguous :: cg_es => null() !coarse-grained (aquifer) effective stress + real(DP), dimension(:), pointer, contiguous :: cg_es0 => null() !coarse-grained (aquifer) effective stress for the previous time step + real(DP), dimension(:), pointer, contiguous :: cg_pcs => null() !coarse-grained (aquifer) preconsolidation stress + real(DP), dimension(:), pointer, contiguous :: cg_comp => null() !coarse-grained (aquifer) incremental compaction + real(DP), dimension(:), pointer, contiguous :: cg_tcomp => null() !coarse-grained (aquifer) total compaction + real(DP), dimension(:), pointer, contiguous :: cg_stor => null() !coarse-grained (aquifer) storage + real(DP), dimension(:), pointer, contiguous :: cg_ske => null() !coarse-grained (aquifer) elastic storage coefficient + real(DP), dimension(:), pointer, contiguous :: cg_sk => null() !coarse-grained (aquifer) first storage coefficient + real(DP), dimension(:), pointer, contiguous :: cg_thickini => null() !initial coarse-grained (aquifer) thickness + real(DP), dimension(:), pointer, contiguous :: cg_thetaini => null() !initial coarse-grained (aquifer) porosity + real(DP), dimension(:), pointer, contiguous :: cg_thick => null() !current coarse-grained (aquifer) thickness + real(DP), dimension(:), pointer, contiguous :: cg_thick0 => null() !previous coarse-grained (aquifer) thickness + real(DP), dimension(:), pointer, contiguous :: cg_theta => null() !current coarse-grained (aquifer) porosity + real(DP), dimension(:), pointer, contiguous :: cg_theta0 => null() !previous coarse-grained (aquifer) porosity + ! + ! -- cell storage variables + real(DP), dimension(:), pointer, contiguous :: cell_wcstor => null() !cell water compressibility storage + real(DP), dimension(:), pointer, contiguous :: cell_thick => null() !cell compressible material thickness + ! + ! -- interbed variables + integer(I4B), dimension(:), pointer, contiguous :: idelay => null() !0 = nodelay, > 0 = delay + integer(I4B), dimension(:), pointer, contiguous :: ielastic => null() !0 = inelastic and elastic, > 0 = elastic + integer(I4B), dimension(:), pointer, contiguous :: iconvert => null() !0 = elastic, > 0 = inelastic + real(DP), dimension(:), pointer, contiguous :: ci => null() !compression index + real(DP), dimension(:), pointer, contiguous :: rci => null() !recompression index + real(DP), dimension(:), pointer, contiguous :: pcs => null() !preconsolidation stress + real(DP), dimension(:), pointer, contiguous :: rnb => null() !interbed system material factor + real(DP), dimension(:), pointer, contiguous :: kv => null() !vertical hydraulic conductivity of interbed + real(DP), dimension(:), pointer, contiguous :: h0 => null() !initial head in interbed + real(DP), dimension(:), pointer, contiguous :: comp => null() !interbed incremental compaction + real(DP), dimension(:), pointer, contiguous :: tcomp => null() !total interbed compaction + real(DP), dimension(:), pointer, contiguous :: tcompi => null() !total inelastic interbed compaction + real(DP), dimension(:), pointer, contiguous :: tcompe => null() !total elastic interbed compaction + real(DP), dimension(:), pointer, contiguous :: storagee => null() !elastic storage + real(DP), dimension(:), pointer, contiguous :: storagei => null() !inelastic storage + real(DP), dimension(:), pointer, contiguous :: ske => null() !elastic storage coefficient + real(DP), dimension(:), pointer, contiguous :: sk => null() !first storage coefficient + real(DP), dimension(:), pointer, contiguous :: thickini => null() !initial interbed thickness + real(DP), dimension(:), pointer, contiguous :: thetaini => null() !initial interbed theta + real(DP), dimension(:), pointer, contiguous :: thick => null() !current interbed thickness + real(DP), dimension(:), pointer, contiguous :: thick0 => null() !previous interbed thickness + real(DP), dimension(:), pointer, contiguous :: theta => null() !current interbed porosity + real(DP), dimension(:), pointer, contiguous :: theta0 => null() !previous interbed porosity + real(DP), dimension(:,:), pointer, contiguous :: auxvar => null() !auxiliary variable array + ! + ! -- delay interbed arrays + integer(I4B), dimension(:,:), pointer, contiguous :: idbconvert => null() !0 = elastic, > 0 = inelastic + real(DP), dimension(:), pointer, contiguous :: dbdhmax => null() !delay bed maximum head change + real(DP), dimension(:,:), pointer, contiguous :: dbz => null() !delay bed cell z + real(DP), dimension(:,:), pointer, contiguous :: dbrelz => null() !delay bed cell z relative to znode + real(DP), dimension(:,:), pointer, contiguous :: dbh => null() !delay bed cell h + real(DP), dimension(:,:), pointer, contiguous :: dbh0 => null() !delay bed cell previous h + real(DP), dimension(:,:), pointer, contiguous :: dbgeo => null() !delay bed cell geostatic stress + real(DP), dimension(:,:), pointer, contiguous :: dbes => null() !delay bed cell effective stress + real(DP), dimension(:,:), pointer, contiguous :: dbes0 => null() !delay bed cell previous effective stress + real(DP), dimension(:,:), pointer, contiguous :: dbpcs => null() !delay bed cell preconsolidation stress + real(DP), dimension(:), pointer, contiguous :: dbflowtop => null() !delay bed flow through interbed top + real(DP), dimension(:), pointer, contiguous :: dbflowbot => null() !delay bed flow through interbed bottom + real(DP), dimension(:,:), pointer, contiguous :: dbdzini => null() !initial delay bed cell thickness + real(DP), dimension(:,:), pointer, contiguous :: dbthetaini => null() !initial delay bed cell porosity + real(DP), dimension(:,:), pointer, contiguous :: dbdz => null() !delay bed dz + real(DP), dimension(:,:), pointer, contiguous :: dbdz0 => null() !delay bed previous dz + real(DP), dimension(:,:), pointer, contiguous :: dbtheta => null() !delay bed cell porosity + real(DP), dimension(:,:), pointer, contiguous :: dbtheta0 => null() !delay bed cell previous porosity + real(DP), dimension(:, :), pointer, contiguous :: dbcomp => null() !delay bed incremental compaction + real(DP), dimension(:, :), pointer, contiguous :: dbtcomp => null() !delay bed total interbed compaction + ! + ! -- delay interbed solution arrays + real(DP), dimension(:), pointer, contiguous :: dbal => null() !delay bed lower diagonal + real(DP), dimension(:), pointer, contiguous :: dbad => null() !delay bed diagonal + real(DP), dimension(:), pointer, contiguous :: dbau => null() !delay bed upper diagonal + real(DP), dimension(:), pointer, contiguous :: dbrhs => null() !delay bed right hand side + real(DP), dimension(:), pointer, contiguous :: dbdh => null() !delay bed dh + real(DP), dimension(:), pointer, contiguous :: dbaw => null() !delay bed work vector + ! + ! -- period data + integer(I4B), dimension(:), pointer, contiguous :: nodelistsig0 => null() !vector of reduced node numbers + real(DP), dimension(:,:), pointer, contiguous :: bound => null() !array of package specific boundary numbers + real(DP), dimension(:,:), pointer, contiguous :: auxvarsig0 => null() !auxiliary variable array + ! + ! -- timeseries + type(TimeSeriesManagerType), pointer :: TsManager => null() ! time series manager + ! + ! -- observation data + integer(I4B), pointer :: inobspkg => null() !unit number for obs package + type(ObsType), pointer :: obs => null() !observation package + ! + ! -- table objects + type(TableType), pointer :: inputtab => null() + type(TableType), pointer :: outputtab => null() + type(TableType), pointer :: pakcsvtab => null() + + contains + procedure :: define_listlabel + procedure :: read_options + procedure :: csub_ar + procedure :: csub_da + procedure :: csub_rp + procedure :: csub_ad + procedure :: csub_fc + procedure :: csub_fn + procedure :: csub_cc + procedure :: csub_fp + procedure :: bdcalc => csub_bdcalc + procedure :: bdsav => csub_bdsav + procedure :: read_dimensions => csub_read_dimensions + procedure, private :: csub_allocate_scalars + procedure, private :: csub_allocate_arrays + procedure, private :: csub_read_packagedata + ! + ! -- helper methods + procedure, private :: csub_calc_void + procedure, private :: csub_calc_theta + procedure, private :: csub_calc_znode + procedure, private :: csub_calc_adjes + procedure, private :: csub_calc_sat + procedure, private :: csub_calc_sat_derivative + procedure, private :: csub_calc_sfacts + procedure, private :: csub_adj_matprop + procedure, private :: csub_calc_interbed_thickness + procedure, private :: csub_calc_delay_flow + procedure, private :: csub_delay_eval + ! + ! -- stress methods + procedure, private :: csub_cg_calc_stress + procedure, private :: csub_cg_chk_stress + ! + ! -- initial states + procedure, private :: csub_set_initial_state + ! + ! -- coarse-grained coarse-grained methods + procedure, private :: csub_cg_update + procedure, private :: csub_cg_calc_comp + procedure, private :: csub_cg_calc_sske + procedure, private :: csub_cg_fc + procedure, private :: csub_cg_fn + procedure, private :: csub_cg_wcomp_fc + procedure, private :: csub_cg_wcomp_fn + ! + ! -- interbed methods + procedure, private :: csub_interbed_fc + procedure, private :: csub_interbed_fn + procedure, private :: csub_interbed_wcomp_fc + procedure, private :: csub_interbed_wcomp_fn + ! + ! -- no-delay interbed methods + procedure, private :: csub_nodelay_update + procedure, private :: csub_nodelay_fc + procedure, private :: csub_nodelay_calc_comp + ! + ! -- delay interbed methods + procedure, private :: csub_delay_chk + procedure, private :: csub_delay_calc_zcell + procedure, private :: csub_delay_calc_stress + procedure, private :: csub_delay_calc_ssksske + procedure, private :: csub_delay_calc_comp + procedure, private :: csub_delay_update + procedure, private :: csub_delay_calc_dstor + procedure, private :: csub_delay_fc + procedure, private :: csub_delay_sln + procedure, private :: csub_delay_assemble + ! + ! -- methods for observations + procedure, public :: csub_obs_supported + procedure, public :: csub_df_obs + procedure, private :: csub_rp_obs + procedure, private :: csub_bd_obs + ! + ! -- method for time series + procedure, private :: csub_rp_ts + end type GwfCsubType + +contains + + subroutine csub_cr(csubobj, name_model, istounit, stoname, inunit, iout) +! ****************************************************************************** +! csub_cr -- Create a New CSUB Object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + implicit none + type(GwfCsubType), pointer :: csubobj + character(len=*), intent(in) :: name_model + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: istounit + character(len=*), intent(in) :: stoname + integer(I4B), intent(in) :: iout + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- allocate the object and assign values to object variables + allocate(csubobj) + + ! -- create name and origin + call csubobj%set_names(1, name_model, 'CSUB', 'CSUB') + ! + ! -- Allocate scalars + call csubobj%csub_allocate_scalars() + ! + ! -- Set variables + csubobj%istounit = istounit + csubobj%stoname = stoname + csubobj%inunit = inunit + csubobj%iout = iout + ! + ! -- Initialize block parser + call csubobj%parser%Initialize(csubobj%inunit, csubobj%iout) + ! + ! -- return + return + end subroutine csub_cr + + + subroutine csub_allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars -- allocate scalar members +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GwfCsubType), intent(inout) :: this +! ------------------------------------------------------------------------------ + ! + ! -- call standard NumericalPackageType allocate scalars + call this%NumericalPackageType%allocate_scalars() + ! + ! -- allocate the object and assign values to object variables + call mem_allocate(this%istounit, 'ISTOUNIT', this%origin) + call mem_allocate(this%inobspkg, 'INOBSPKG', this%origin) + call mem_allocate(this%ninterbeds, 'NINTERBEDS', this%origin) + call mem_allocate(this%maxsig0, 'MAXSIG0', this%origin) + call mem_allocate(this%nbound, 'NBOUND', this%origin) + call mem_allocate(this%ncolbnd, 'NCOLBND', this%origin) + call mem_allocate(this%iscloc, 'ISCLOC', this%origin) + call mem_allocate(this%iauxmultcol, 'IAUXMULTCOL', this%origin) + call mem_allocate(this%ndelaycells, 'NDELAYCELLS', this%origin) + call mem_allocate(this%ndelaybeds, 'NDELAYBEDS', this%origin) + call mem_allocate(this%initialized, 'INITIALIZED', this%origin) + call mem_allocate(this%ieslag, 'IESLAG', this%origin) + call mem_allocate(this%ipch, 'IPCH', this%origin) + call mem_allocate(this%lhead_based, 'LHEAD_BASED', this%origin) + call mem_allocate(this%iupdatestress, 'IUPDATESTRESS', this%origin) + call mem_allocate(this%ispecified_pcs, 'ISPECIFIED_PCS', this%origin) + call mem_allocate(this%ispecified_dbh, 'ISPECIFIED_DBH', this%origin) + call mem_allocate(this%inamedbound, 'INAMEDBOUND', this%origin) + call mem_allocate(this%iconvchk, 'ICONVCHK', this%origin) + call mem_allocate(this%naux, 'NAUX', this%origin) + call mem_allocate(this%istoragec, 'ISTORAGEC', this%origin) + call mem_allocate(this%istrainib, 'ISTRAINIB', this%origin) + call mem_allocate(this%istrainsk, 'ISTRAINSK', this%origin) + call mem_allocate(this%ioutcomp, 'IOUTCOMP', this%origin) + call mem_allocate(this%ioutcompi, 'IOUTCOMPI', this%origin) + call mem_allocate(this%ioutcompe, 'IOUTCOMPE', this%origin) + call mem_allocate(this%ioutcompib, 'IOUTCOMPIB', this%origin) + call mem_allocate(this%ioutcomps, 'IOUTCOMPS', this%origin) + call mem_allocate(this%ioutzdisp, 'IOUTZDISP', this%origin) + call mem_allocate(this%ipakcsv, 'IPAKCSV', this%origin) + call mem_allocate(this%iupdatematprop, 'IUPDATEMATPROP', this%origin) + call mem_allocate(this%epsilon, 'EPSILON', this%origin) + call mem_allocate(this%cc_crit, 'CC_CRIT', this%origin) + call mem_allocate(this%gammaw, 'GAMMAW', this%origin) + call mem_allocate(this%beta, 'BETA', this%origin) + call mem_allocate(this%brg, 'BRG', this%origin) + call mem_allocate(this%satomega, 'SATOMEGA', this%origin) + call mem_allocate(this%icellf, 'ICELLF', this%origin) + call mem_allocate(this%gwfiss0, 'GWFISS0', this%origin) + ! + ! -- allocate TS object + allocate(this%TsManager) + ! + ! -- Allocate text strings + allocate(this%auxname(0)) + ! + ! -- initialize values + this%istounit = 0 + this%inobspkg = 0 + this%ninterbeds = 0 + this%maxsig0 = 0 + this%nbound = 0 + this%ncolbnd = 1 + this%iscloc = 0 + this%iauxmultcol = 0 + this%ndelaycells = 19 + this%ndelaybeds = 0 + this%initialized = 0 + this%ieslag = 0 + this%ipch = 0 + this%lhead_based = .FALSE. + this%iupdatestress = 1 + this%ispecified_pcs = 0 + this%ispecified_dbh = 0 + this%inamedbound = 0 + this%iconvchk = 1 + this%naux = 0 + this%istoragec = 1 + this%istrainib = 0 + this%istrainsk = 0 + this%ioutcomp = 0 + this%ioutcompi = 0 + this%ioutcompe = 0 + this%ioutcompib = 0 + this%ioutcomps = 0 + this%ioutzdisp = 0 + this%ipakcsv = 0 + this%iupdatematprop = 0 + this%epsilon = DZERO + this%cc_crit = DEM7 + this%gammaw = DGRAVITY * 1000._DP + this%beta = 4.6512e-10_DP + this%brg = this%gammaw * this%beta + ! + ! -- set omega value used for saturation calculations + if (this%inewton /= 0) then + this%satomega = DEM6 + this%epsilon = DHALF * DEM6 + else + this%satomega = DZERO + end if + this%icellf = 0 + this%ninterbeds = 0 + this%gwfiss0 = 0 + ! + ! -- return + return + end subroutine csub_allocate_scalars + + subroutine csub_cc(this, kiter, iend, icnvgmod, nodes, hnew, hold, & + cpak, dpak) +! ************************************************************************** +! csub_cc -- Final convergence check for package +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + use TdisModule, only: totim, kstp, kper, delt + ! -- dummy + class(GwfCsubType) :: this + integer(I4B), intent(in) :: kiter + integer(I4B), intent(in) :: iend + integer(I4B), intent(in) :: icnvgmod + integer(I4B), intent(in) :: nodes + real(DP), dimension(nodes), intent(in) :: hnew + real(DP), dimension(nodes), intent(in) :: hold + character(len=LENPAKLOC), intent(inout) :: cpak + real(DP), intent(inout) :: dpak + ! -- local + character(len=LINELENGTH) :: tag + character(len=LENPAKLOC) :: cloc + integer(I4B) :: icheck + integer(I4B) :: ipakfail + integer(I4B) :: ntabrows + integer(I4B) :: ntabcols + integer(I4B) :: ib + integer(I4B) :: node + integer(I4B) :: idelay + integer(I4B) :: locdhmax + integer(I4B) :: locrmax + integer(I4B) :: ifirst + real(DP) :: dhmax + real(DP) :: rmax + real(DP) :: dh + real(DP) :: area + real(DP) :: hcell + real(DP) :: hcellold + real(DP) :: snnew + real(DP) :: snold + real(DP) :: stoe + real(DP) :: stoi + real(DP) :: tled + real(DP) :: hcof + real(DP) :: rhs + real(DP) :: v1 + real(DP) :: v2 + real(DP) :: df + ! format +! -------------------------------------------------------------------------- + ! + ! -- initialize local variables + icheck = this%iconvchk + ipakfail = 0 + locdhmax = 0 + locrmax = 0 + dhmax = DZERO + rmax = DZERO + ifirst = 1 + ! + ! -- additional checks to see if convergence needs to be checked + ! -- no convergence check for steady-state stress periods + if (this%gwfiss /= 0) then + icheck = 0 + else + ! + ! -- if not saving package convergence data on check convergence if + ! the model is considered converged + if (this%ipakcsv == 0) then + if (icnvgmod == 0) then + icheck = 0 + end if + else + ! + ! -- header for package csv + if (.not. associated(this%pakcsvtab)) then + ! + ! -- determine the number of columns and rows + ntabrows = 1 + ntabcols = 8 + ! + ! -- setup table + call table_cr(this%pakcsvtab, this%name, '') + call this%pakcsvtab%table_df(ntabrows, ntabcols, this%ipakcsv, & + lineseparator=.FALSE., separator=',', & + finalize=.FALSE.) + ! + ! -- add columns to package csv + tag = 'totim' + call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'kper' + call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'kstp' + call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'nouter' + call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'dvmax' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + tag = 'dvmax_loc' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + tag = 'dstoragemax' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + tag = 'dstoragemax_loc' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + end if + end if + end if + ! + ! -- perform package convergence check + if (icheck /= 0) then + if (DELT > DZERO) then + tled = DONE / DELT + else + tled = DZERO + end if + final_check: do ib = 1, this%ninterbeds + idelay = this%idelay(ib) + ! + ! -- skip nodelay interbeds + if (idelay == 0) cycle + ! + ! -- evaluate the maximum head change in the interbed + dh = this%dbdhmax(idelay) + ! + ! -- evaluate difference between storage changes + ! in the interbed and exchange between the interbed + ! and the gwf cell + node = this%nodelist(ib) + area = this%dis%get_area(node) + hcell = hnew(node) + hcellold = hold(node) + ! + ! -- calculate cell saturation + call this%csub_calc_sat(node, hcell, hcellold, snnew, snold) + ! + ! -- calculate the change in storage + call this%csub_delay_calc_dstor(ib, hcell, stoe, stoi) + v1 = (stoe + stoi) * area * this%rnb(ib) * snnew * tled + ! + ! -- calculate the flow between the interbed and the cell + call this%csub_delay_fc(ib, hcof, rhs) + v2 = (-hcof * hcell - rhs) * area * this%rnb(ib) * snnew + ! + ! -- calculate the difference between the interbed change in + ! storage and the flow between the interbed and the cell + df = v2 - v1 + ! + ! -- normalize by cell area and convert to a depth + df = df * delt / area + ! + ! -- evaluate magnitude of differences + if (ifirst == 1) then + ifirst = 0 + locdhmax = ib + dhmax = dh + locrmax = ib + rmax = df + else + if (abs(dh) > abs(dhmax)) then + locdhmax = ib + dhmax = dh + end if + if (abs(df) > abs(rmax)) then + locrmax = ib + rmax = df + end if + end if + end do final_check + ! + ! -- set dpak and cpak + ! -- update head error + if (abs(dhmax) > abs(dpak)) then + dpak = dhmax + write(cloc, "(a,'-(',i0,')-',a)") trim(this%name), locdhmax, 'head' + cpak = cloc + end if + ! + ! -- update storage error + if (abs(rmax) > abs(dpak)) then + dpak = rmax + write(cloc, "(a,'-(',i0,')-',a)") trim(this%name), locrmax, 'storage' + cpak = cloc + end if + ! + ! -- write convergence data to package csv + if (this%ipakcsv /= 0) then + ! + ! -- write the data + call this%pakcsvtab%add_term(totim) + call this%pakcsvtab%add_term(kper) + call this%pakcsvtab%add_term(kstp) + call this%pakcsvtab%add_term(kiter) + call this%pakcsvtab%add_term(dhmax) + call this%pakcsvtab%add_term(locdhmax) + call this%pakcsvtab%add_term(rmax) + call this%pakcsvtab%add_term(locrmax) + ! + ! -- finalize the package csv + if (iend == 1) then + call this%pakcsvtab%finalize_table() + end if + end if + end if + ! + ! -- return + return + end subroutine csub_cc + + subroutine csub_bdcalc(this, nodes, hnew, hold, isuppress_output, & + model_budget) +! ****************************************************************************** +! csub_bd -- calculate budget for coarse-grained storage, interbeds, and water +! compression +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: delt + use ConstantsModule, only: LENBOUNDNAME, DZERO, DONE + use BudgetModule, only: BudgetType + ! -- dummy + class(GwfCsubType) :: this + integer(I4B), intent(in) :: nodes + real(DP), intent(in), dimension(nodes) :: hnew + real(DP), intent(in), dimension(nodes) :: hold + integer(I4B), intent(in) :: isuppress_output + type(BudgetType), intent(inout) :: model_budget + ! -- local + integer(I4B) :: ib + integer(I4B) :: idelay + integer(I4B) :: ielastic + integer(I4B) :: iconvert + integer(I4B) :: node + integer(I4B) :: nn + integer(I4B) :: n + real(DP) :: es + real(DP) :: pcs + real(DP) :: rho1 + real(DP) :: rho2 + real(DP) :: tled + real(DP) :: tledm + real(DP) :: es0 + real(DP) :: rrate + real(DP) :: ratein + real(DP) :: rateout + real(DP) :: comp + real(DP) :: compi + real(DP) :: compe + real(DP) :: area + real(DP) :: h + real(DP) :: h0 + real(DP) :: snnew + real(DP) :: snold + real(DP) :: hcof + real(DP) :: rhs + real(DP) :: stoe + real(DP) :: stoi + real(DP) :: b + real(DP) :: q + real(DP) :: ratecgin + real(DP) :: ratecgout + real(DP) :: rateibein + real(DP) :: rateibeout + real(DP) :: rateibiin + real(DP) :: rateibiout + real(DP) :: rratewc + real(DP) :: ratewcin + real(DP) :: ratewcout + ! -- for observations + integer(I4B) :: iprobslocal + ! -- formats +! -------------------------------------------------------------------------- + ! + ! -- Suppress saving of simulated values; they + ! will be saved at end of this procedure. + iprobslocal = 0 + ratein = DZERO + rateout= DZERO + ratewcin = DZERO + ratewcout = DZERO + ! + ! -- coarse-grained coarse-grained storage + ratecgin = DZERO + ratecgout= DZERO + do node = 1, this%dis%nodes + area = this%dis%get_area(node) + comp = DZERO + rrate = DZERO + rratewc = DZERO + if (this%gwfiss == 0) then + if (DELT > DZERO) then + tled = DONE / DELT + else + tled = DZERO + end if + if (this%ibound(node) > 0 .and. this%cg_thickini(node) > DZERO) then + ! + ! -- calculate coarse-grained storage terms + call this%csub_cg_fc(node, tled, area, hnew(node), hold(node), & + hcof, rhs) + rrate = hcof * hnew(node) - rhs + ! + ! -- calculate compaction + call this%csub_cg_calc_comp(node, hnew(node), hold(node), comp) + ! + ! -- budget terms + if (rrate < DZERO) then + ratecgout = ratecgout - rrate + else + ratecgin = ratecgin + rrate + end if + ! + ! -- calculate coarse-grained water compressibility storage terms + call this%csub_cg_wcomp_fc(node, tled, area, hnew(node), hold(node), & + hcof, rhs) + rratewc = hcof * hnew(node) - rhs + ! + ! -- water compressibility budget terms + if (rratewc < DZERO) then + ratewcout = ratewcout - rratewc + else + ratewcin = ratewcin + rratewc + end if + end if + end if + ! + ! -- update coarse-grained storage and water + ! compresion variables + this%cg_stor(node) = rrate + this%cell_wcstor(node) = rratewc + this%cell_thick(node) = this%cg_thick(node) + ! + ! -- update incremental coarse-grained compaction + this%cg_comp(node) = comp + ! + ! + ! -- update states if required + if (isuppress_output == 0) then + ! + ! -- calculate strain and change in coarse-grained void ratio and thickness + if (this%iupdatematprop /= 0) then + call this%csub_cg_update(node) + end if + ! + ! -- update total compaction + this%cg_tcomp(node) = this%cg_tcomp(node) + comp + end if + end do + ! + ! -- interbed storage + rateibein = DZERO + rateibeout = DZERO + rateibiin = DZERO + rateibiout = DZERO + + tled = DONE + do ib = 1, this%ninterbeds + rratewc = DZERO + idelay = this%idelay(ib) + ielastic = this%ielastic(ib) + ! + ! -- calculate interbed thickness + ! -- no delay interbeds + if (idelay == 0) then + b = this%thick(ib) + ! -- delay interbeds + else + b = this%thick(ib) * this%rnb(ib) + end if + ! + ! -- set variables required for no-delay and delay interbeds + node = this%nodelist(ib) + area = this%dis%get_area(node) + ! + ! -- add interbed thickness to cell thickness + this%cell_thick(node) = this%cell_thick(node) + b + ! + ! -- update budget terms if transient stress period + if (this%gwfiss == 0) then + if (DELT > DZERO) then + tledm = DONE / DELT + else + tledm = DZERO + end if + ! + ! -- skip inactive and constant head cells + if (this%ibound(node) < 1) cycle + ! + ! -- no delay interbeds + if (idelay == 0) then + iconvert = this%iconvert(ib) + stoi = DZERO + ! + ! -- calculate compaction + call this%csub_nodelay_calc_comp(ib, hnew(node), hold(node), comp, & + rho1, rho2) + ! + ! -- interbed stresses + es = this%cg_es(node) + pcs = this%pcs(ib) + es0 = this%cg_es0(node) + ! + ! -- calculate inelastic and elastic compaction + if (ielastic > 0 .or. iconvert == 0) then + stoe = comp + else + stoi = -pcs * rho2 + (rho2 * es) + stoe = pcs * rho1 - (rho1 * es0) + end if + compe = stoe + compi = stoi + stoe = stoe * area + stoi = stoi * area + this%storagee(ib) = stoe * tledm + this%storagei(ib) = stoi * tledm + ! + ! -- update compaction + this%comp(ib) = comp + ! + ! -- update states if required + if (isuppress_output == 0) then + ! + ! -- calculate strain and change in interbed void ratio and thickness + if (this%iupdatematprop /= 0) then + call this%csub_nodelay_update(ib) + end if + ! + ! -- update total compaction + this%tcomp(ib) = this%tcomp(ib) + comp + this%tcompe(ib) = this%tcompe(ib) + compe + this%tcompi(ib) = this%tcompi(ib) + compi + end if + ! + ! -- delay interbeds + else + h = hnew(node) + h0 = hold(node) + ! + ! -- calculate cell saturation + call this%csub_calc_sat(node, h, h0, snnew, snold) + ! + ! -- calculate inelastic and elastic storage contributions + call this%csub_delay_calc_dstor(ib, h, stoe, stoi) + this%storagee(ib) = stoe * area * this%rnb(ib) * snnew * tledm + this%storagei(ib) = stoi * area * this%rnb(ib) * snnew * tledm + ! + ! -- calculate flow across the top and bottom of the delay interbed + q = this%csub_calc_delay_flow(ib, 1, h) * area * this%rnb(ib) + this%dbflowtop(idelay) = q + nn = this%ndelaycells + q = this%csub_calc_delay_flow(ib, nn, h) * area * this%rnb(ib) + this%dbflowbot(idelay) = q + ! + ! -- update states if required + if (isuppress_output == 0) then + ! + ! -- calculate sum of compaction in delay interbed + call this%csub_delay_calc_comp(ib, h, h0, comp, compi, compe) + ! + ! - calculate strain and change in interbed void ratio and thickness + if (this%iupdatematprop /= 0) then + call this%csub_delay_update(ib) + end if + ! + ! -- update total compaction for interbed + this%tcomp(ib) = this%tcomp(ib) + comp + this%tcompi(ib) = this%tcompi(ib) + compi + this%tcompe(ib) = this%tcompe(ib) + compe + ! + ! -- update total compaction for each delay bed cell + do n = 1, this%ndelaycells + this%dbtcomp(n, idelay) = this%dbtcomp(n, idelay) + this%dbcomp(n, idelay) + end do + end if + end if + ! + ! -- budget terms + if (this%storagee(ib) < DZERO) then + rateibeout = rateibeout - this%storagee(ib) + else + rateibein = rateibein + this%storagee(ib) + end if + if (this%storagei(ib) < DZERO) then + rateibiout = rateibiout - this%storagei(ib) + else + rateibiin = rateibiin + this%storagei(ib) + end if + ! + ! -- interbed water compressibility + call this%csub_interbed_wcomp_fc(ib, node, tledm, area, & + hnew(node), hold(node), hcof, rhs) + rratewc = hcof * hnew(node) - rhs + this%cell_wcstor(node) = this%cell_wcstor(node) + rratewc + ! + ! -- water compressibility budget terms + if (rratewc < DZERO) then + ratewcout = ratewcout - rratewc + else + ratewcin = ratewcin + rratewc + end if + else + this%storagee(ib) = DZERO + this%storagei(ib) = DZERO + if (idelay /= 0) then + this%dbflowtop(idelay) = DZERO + this%dbflowbot(idelay) = DZERO + end if + end if + end do + ! + ! -- Add contributions to model budget + ! + ! -- interbed elastic storage + call model_budget%addentry(ratecgin, ratecgout, delt, budtxt(1), & + isuppress_output, ' CSUB') + if (this%ninterbeds > 0) then + ! + ! -- interbed elastic storage + call model_budget%addentry(rateibein, rateibeout, delt, budtxt(2), & + isuppress_output, ' CSUB') + ! + ! -- interbed elastic storage + call model_budget%addentry(rateibiin, rateibiout, delt, budtxt(3), & + isuppress_output, ' CSUB') + end if + call model_budget%addentry(ratewcin, ratewcout, delt, budtxt(4), & + isuppress_output, ' CSUB') + ! + ! -- For continuous observations, save simulated values. + if (this%obs%npakobs > 0) then + call this%csub_bd_obs() + end if + ! + ! -- terminate if errors encountered when updating material properties + if (this%iupdatematprop /= 0) then + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + end if + ! + ! -- return + return + + end subroutine csub_bdcalc + + subroutine csub_bdsav(this, idvfl, icbcfl, icbcun) +! ****************************************************************************** +! sto_bdsav -- Save budget terms +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfCsubType) :: this + integer(I4B), intent(in) :: idvfl + integer(I4B), intent(in) :: icbcfl + integer(I4B), intent(in) :: icbcun + ! -- local + character(len=1) :: cdatafmp=' ', editdesc=' ' + integer(I4B) :: ibinun + integer(I4B) :: iprint, nvaluesp, nwidthp + integer(I4B) :: ib + integer(I4B) :: node + integer(I4B) :: nodem + integer(I4B) :: nodeu + integer(I4B) :: i + integer(I4B) :: k + integer(I4B) :: ncpl + integer(I4B) :: nlay + integer(I4B) :: naux + real(DP) :: dinact + real(DP) :: Q + +! ------------------------------------------------------------------------------ + ! + ! -- Set unit number for binary output + if(this%ipakcb < 0) then + ibinun = icbcun + elseif(this%ipakcb == 0) then + ibinun = 0 + else + ibinun = this%ipakcb + endif + if(icbcfl == 0) ibinun = 0 + ! + ! -- Record the storage rates if requested + if (ibinun /= 0) then + iprint = 0 + dinact = DZERO + ! + ! -- coarse-grained storage (sske) + call this%dis%record_array(this%cg_stor, this%iout, iprint, -ibinun, & + budtxt(1), cdatafmp, nvaluesp, & + nwidthp, editdesc, dinact) + if (this%ninterbeds > 0) then + naux = 0 + ! -- interbed elastic storage + call this%dis%record_srcdst_list_header(budtxt(2), this%name_model, & + this%name_model, this%name_model, this%name, naux, & + this%auxname, ibinun, this%ninterbeds, this%iout) + do ib = 1, this%ninterbeds + q = this%storagee(ib) + node = this%nodelist(ib) + call this%dis%record_mf6_list_entry(ibinun, node, node, q, naux, & + this%auxvar(:,ib)) + end do + ! -- interbed inelastic storage + call this%dis%record_srcdst_list_header(budtxt(3), this%name_model, & + this%name_model, this%name_model, this%name, naux, & + this%auxname, ibinun, this%ninterbeds, this%iout) + do ib = 1, this%ninterbeds + q = this%storagei(ib) + node = this%nodelist(ib) + call this%dis%record_mf6_list_entry(ibinun, node, node, q, naux, & + this%auxvar(:,ib)) + end do + end if + ! + ! -- water compressibility + call this%dis%record_array(this%cell_wcstor, this%iout, iprint, -ibinun, & + budtxt(4), cdatafmp, nvaluesp, & + nwidthp, editdesc, dinact) + end if + ! + ! -- Save compaction results + ! + ! -- Set unit number for binary compaction and z-displacement output + if(this%ioutcomp /= 0 .or. this%ioutzdisp /= 0) then + ibinun = 1 + else + ibinun = 0 + endif + if(idvfl == 0) ibinun = 0 + ! + ! -- save compaction results + if (ibinun /= 0) then + iprint = 0 + dinact = DHNOFLO + ! + ! -- fill buff with total compaction + do node = 1, this%dis%nodes + this%buff(node) = this%cg_tcomp(node) + end do + do ib = 1, this%ninterbeds + node = this%nodelist(ib) + this%buff(node) = this%buff(node) + this%tcomp(ib) + end do + ! + ! -- write compaction data to binary file + if (this%ioutcomp /= 0) then + ibinun = this%ioutcomp + call this%dis%record_array(this%buff, this%iout, iprint, ibinun, & + comptxt(1), cdatafmp, nvaluesp, & + nwidthp, editdesc, dinact) + end if + ! + ! -- calculate z-displacement (subsidence) and write data to binary file + if (this%ioutzdisp /= 0) then + ibinun = this%ioutzdisp + ! + ! -- initialize buffusr + do nodeu = 1, this%dis%nodesuser + this%buffusr(nodeu) = DZERO + end do + ! + ! -- fill buffusr with buff + do node = 1, this%dis%nodes + nodeu = this%dis%get_nodeuser(node) + this%buffusr(nodeu) = this%buff(node) + end do + ! + ! -- calculate z-displacement + ncpl = this%dis%get_ncpl() + ! + ! -- disu + if (this%dis%ndim == 1) then + ! TO DO - + ! -- disv or dis + else + nlay = this%dis%nodesuser / ncpl + do k = nlay - 1, 1, -1 + do i = 1, ncpl + node = (k - 1) * ncpl + i + nodem = k * ncpl + i + this%buffusr(node) = this%buffusr(node) + this%buffusr(nodem) + end do + end do + end if + ! + ! -- fill buff with data from buffusr + do nodeu = 1, this%dis%nodesuser + node = this%dis%get_nodenumber_idx1(nodeu, 1) + if (node /= 0) then + this%buff(node) = this%buffusr(nodeu) + end if + end do + ! + ! -- write z-displacement + call this%dis%record_array(this%buff, this%iout, iprint, ibinun, & + comptxt(6), cdatafmp, nvaluesp, & + nwidthp, editdesc, dinact) + + end if + end if + ! + ! -- Set unit number for binary inelastic interbed compaction + if(this%ioutcompi /= 0) then + ibinun = this%ioutcompi + else + ibinun = 0 + endif + if(idvfl == 0) ibinun = 0 + ! + ! -- save inelastic interbed compaction results + if(ibinun /= 0) then + iprint = 0 + dinact = DHNOFLO + ! + ! -- fill buff with inelastic interbed compaction + do node = 1, this%dis%nodes + this%buff(node) = DZERO + end do + do ib = 1, this%ninterbeds + node = this%nodelist(ib) + this%buff(node) = this%buff(node) + this%tcompi(ib) + end do + ! + ! -- write inelastic interbed compaction data to binary file + call this%dis%record_array(this%buff, this%iout, iprint, ibinun, & + comptxt(2), cdatafmp, nvaluesp, & + nwidthp, editdesc, dinact) + end if + ! + ! -- Set unit number for binary elastic interbed compaction + if(this%ioutcompe /= 0) then + ibinun = this%ioutcompe + else + ibinun = 0 + endif + if(idvfl == 0) ibinun = 0 + ! + ! -- save elastic interbed compaction results + if(ibinun /= 0) then + iprint = 0 + dinact = DHNOFLO + ! + ! -- fill buff with elastic interbed compaction + do node = 1, this%dis%nodes + this%buff(node) = DZERO + end do + do ib = 1, this%ninterbeds + node = this%nodelist(ib) + this%buff(node) = this%buff(node) + this%tcompe(ib) + end do + ! + ! -- write elastic interbed compaction data to binary file + call this%dis%record_array(this%buff, this%iout, iprint, ibinun, & + comptxt(3), cdatafmp, nvaluesp, & + nwidthp, editdesc, dinact) + end if + ! + ! -- Set unit number for binary interbed compaction + if(this%ioutcompib /= 0) then + ibinun = this%ioutcompib + else + ibinun = 0 + endif + if(idvfl == 0) ibinun = 0 + ! + ! -- save interbed compaction results + if(ibinun /= 0) then + iprint = 0 + dinact = DHNOFLO + ! + ! -- fill buff with interbed compaction + do node = 1, this%dis%nodes + this%buff(node) = DZERO + end do + do ib = 1, this%ninterbeds + node = this%nodelist(ib) + this%buff(node) = this%buff(node) + this%tcompe(ib) + this%tcompi(ib) + end do + ! + ! -- write interbed compaction data to binary file + call this%dis%record_array(this%buff, this%iout, iprint, ibinun, & + comptxt(4), cdatafmp, nvaluesp, & + nwidthp, editdesc, dinact) + end if + ! + ! -- Set unit number for binary coarse-grained compaction + if(this%ioutcomps /= 0) then + ibinun = this%ioutcomps + else + ibinun = 0 + endif + if(idvfl == 0) ibinun = 0 + ! + ! -- save coarse-grained compaction results + if(ibinun /= 0) then + iprint = 0 + dinact = DHNOFLO + ! + ! -- fill buff with coarse-grained compaction + do node = 1, this%dis%nodes + this%buff(node) = this%cg_tcomp(node) + end do + ! + ! -- write coarse-grained compaction data to binary file + call this%dis%record_array(this%buff, this%iout, iprint, ibinun, & + comptxt(5), cdatafmp, nvaluesp, & + nwidthp, editdesc, dinact) + end if + ! + ! -- Save observations. + if (this%obs%npakobs > 0) then + call this%obs%obs_ot() + end if + ! + ! -- check that final effective stress values for the time step + ! are greater than zero + if (this%gwfiss == 0) then + call this%csub_cg_chk_stress() + end if + ! + ! -- Return + return + end subroutine csub_bdsav + + subroutine csub_fp(this) +! ************************************************************************** +! csub_cc -- Final processing for package +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + ! -- dummy + class(GwfCsubType) :: this + ! -- local + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: tag + character(len=LINELENGTH) :: msg + character(len=10) :: ctype + character(len=20) :: cellid + character(len=10) :: cflag + integer(I4B) :: i + integer(I4B) :: ib + integer(I4B) :: i0 + integer(I4B) :: i1 + integer(I4B) :: node + integer(I4B) :: nn + integer(I4B) :: idelay + integer(I4B) :: iexceed + integer(I4B), parameter :: ncells = 20 + integer(I4B) :: nlen + integer(I4B) :: ntabrows + integer(I4B) :: ntabcols + integer(I4B) :: ipos + real(DP) :: b0 + real(DP) :: b1 + real(DP) :: strain + real(DP) :: pctcomp + integer(I4B), dimension(:), allocatable :: imap_sel + integer(I4B), dimension(:), allocatable :: locs + real(DP), dimension(:), allocatable :: pctcomp_arr + ! format +! -------------------------------------------------------------------------- + ! + ! -- initialize locs + allocate(locs(this%dis%ndim)) + ! + ! -- calculate and report strain for interbeds + if (this%ninterbeds > 0) then + nlen = min(ncells,this%ninterbeds) + allocate(imap_sel(nlen)) + allocate(pctcomp_arr(this%ninterbeds)) + iexceed = 0 + do ib = 1, this%ninterbeds + idelay = this%idelay(ib) + b0 = this%thickini(ib) + strain = this%tcomp(ib) / b0 + pctcomp = DHUNDRED * strain + pctcomp_arr(ib) = pctcomp + if (pctcomp >= DONE) then + iexceed = iexceed + 1 + end if + end do + call selectn(imap_sel, pctcomp_arr, reverse=.TRUE.) + ! + ! -- summary interbed strain table + i0 = max(1, this%ninterbeds-ncells+1) + i1 = this%ninterbeds + msg = '' + if (iexceed /= 0) then + write(msg,'(1x,a,1x,i0,1x,a,1x,i0,1x,a)') & + 'LARGEST', (i1 - i0 + 1), 'OF', this%ninterbeds, & + 'INTERBED STRAIN VALUES SHOWN' + call sim_message(msg, this%iout, skipbefore=1) + ! + ! -- interbed strain data + ! -- set title + title = trim(adjustl(this%name)) // ' PACKAGE INTERBED STRAIN SUMMARY' + ! + ! -- determine the number of columns and rows + ntabrows = nlen + ntabcols = 9 + ! + ! -- setup table + call table_cr(this%outputtab, this%name, title) + call this%outputtab%table_df(ntabrows, ntabcols, this%iout) + ! + ! add columns + tag = 'INTERBED NUMBER' + call this%outputtab%initialize_column(tag, 10, alignment=TABCENTER) + tag = 'INTERBED TYPE' + call this%outputtab%initialize_column(tag, 10, alignment=TABCENTER) + tag = 'CELLID' + call this%outputtab%initialize_column(tag, 20, alignment=TABLEFT) + tag = 'INITIAL THICKNESS' + call this%outputtab%initialize_column(tag, 12, alignment=TABCENTER) + tag = 'FINAL THICKNESS' + call this%outputtab%initialize_column(tag, 12, alignment=TABCENTER) + tag = 'TOTAL COMPACTION' + call this%outputtab%initialize_column(tag, 12, alignment=TABCENTER) + tag = 'FINAL STRAIN' + call this%outputtab%initialize_column(tag, 12, alignment=TABCENTER) + tag = 'PERCENT COMPACTION' + call this%outputtab%initialize_column(tag, 12, alignment=TABCENTER) + tag = 'FLAG' + call this%outputtab%initialize_column(tag, 10, alignment=TABCENTER) + ! + ! -- write data + do i = 1, nlen + ib = imap_sel(i) + idelay = this%idelay(ib) + b0 = this%thickini(ib) + b1 = this%csub_calc_interbed_thickness(ib) + if (idelay == 0) then + ctype = 'no-delay' + else + ctype = 'delay' + b0 = b0 * this%rnb(ib) + end if + strain = this%tcomp(ib) / b0 + pctcomp = DHUNDRED * strain + if (pctcomp >= 5.0_DP) then + cflag = '**>=5%' + else if (pctcomp >= DONE) then + cflag = '*>=1%' + else + cflag = '' + end if + node = this%nodelist(ib) + call this%dis%noder_to_string(node, cellid) + ! + ! -- fill table line + call this%outputtab%add_term(ib) + call this%outputtab%add_term(ctype) + call this%outputtab%add_term(cellid) + call this%outputtab%add_term(b0) + call this%outputtab%add_term(b1) + call this%outputtab%add_term(this%tcomp(ib)) + call this%outputtab%add_term(strain) + call this%outputtab%add_term(pctcomp) + call this%outputtab%add_term(cflag) + end do + write(this%iout, '(/1X,A,1X,I0,1X,A,1X,I0,1X,A,/1X,A,/1X,A)') & + 'PERCENT COMPACTION IS GREATER THAN OR EQUAL TO 1 PERCENT IN', & + iexceed, 'OF', this%ninterbeds, 'INTERBED(S).', & + 'USE THE STRAIN_CSV_INTERBED OPTION TO OUTPUT A CSV ' // & + 'FILE WITH PERCENT COMPACTION ', 'VALUES FOR ALL INTERBEDS.' + else + msg = 'PERCENT COMPACTION WAS LESS THAN 1 PERCENT IN ALL INTERBEDS' + write(this%iout, '(/1X,A)') trim(adjustl(msg)) + end if + ! + ! -- write csv file + if (this%istrainib /= 0) then + ! + ! -- determine the number of columns and rows + ntabrows = this%ninterbeds + ntabcols = 7 + if (this%dis%ndim > 1) then + ntabcols = ntabcols + 1 + end if + ntabcols = ntabcols + this%dis%ndim + ! + ! -- setup table + call table_cr(this%outputtab, this%name, '') + call this%outputtab%table_df(ntabrows, ntabcols, this%istrainib, & + lineseparator=.FALSE., separator=',') + ! + ! add columns + tag = 'INTERBED_NUMBER' + call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) + tag = 'INTERBED_TYPE' + call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) + tag = 'NODE' + call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) + if (this%dis%ndim == 2) then + tag = 'LAYER' + call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) + tag = 'ICELL2D' + call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) + else + tag = 'LAYER' + call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) + tag = 'ROW' + call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) + tag = 'COLUMN' + call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) + end if + tag = 'INITIAL_THICKNESS' + call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) + tag = 'FINAL_THICKNESS' + call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) + tag = 'TOTAL_COMPACTION' + call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) + tag = 'TOTAL_STRAIN' + call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) + tag = 'PERCENT_COMPACTION' + call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) + ! + ! -- write data + do ib = 1, this%ninterbeds + idelay = this%idelay(ib) + b0 = this%thickini(ib) + b1 = this%csub_calc_interbed_thickness(ib) + if (idelay == 0) then + ctype = 'no-delay' + else + ctype = 'delay' + b0 = b0 * this%rnb(ib) + end if + strain = this%tcomp(ib) / b0 + pctcomp = DHUNDRED * strain + node = this%nodelist(ib) + call this%dis%noder_to_array(node, locs) + ! + ! -- fill table line + call this%outputtab%add_term(ib) + call this%outputtab%add_term(ctype) + if (this%dis%ndim > 1) then + call this%outputtab%add_term(this%dis%get_nodeuser(node)) + end if + do ipos = 1, this%dis%ndim + call this%outputtab%add_term(locs(ipos)) + end do + call this%outputtab%add_term(b0) + call this%outputtab%add_term(b1) + call this%outputtab%add_term(this%tcomp(ib)) + call this%outputtab%add_term(strain) + call this%outputtab%add_term(pctcomp) + end do + end if + ! + ! -- deallocate temporary storage + deallocate(imap_sel) + deallocate(pctcomp_arr) + end if + ! + ! -- calculate and report strain for coarse-grained materials + nlen = min(ncells,this%dis%nodes) + allocate(imap_sel(nlen)) + allocate(pctcomp_arr(this%dis%nodes)) + iexceed = 0 + do node = 1, this%dis%nodes + strain = DZERO + if (this%cg_thickini(node) > DZERO) then + strain = this%cg_tcomp(node) / this%cg_thickini(node) + end if + pctcomp = DHUNDRED * strain + pctcomp_arr(node) = pctcomp + if (pctcomp >= DONE) then + iexceed = iexceed + 1 + end if + end do + call selectn(imap_sel, pctcomp_arr, reverse=.TRUE.) + ! + ! -- summary coarse-grained strain table + i0 = max(1, this%dis%nodes-ncells+1) + i1 = this%dis%nodes + msg = '' + if (iexceed /= 0) then + write(msg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & + 'LARGEST ', (i1 - i0 + 1), 'OF', this%dis%nodes, & + 'CELL COARSE-GRAINED VALUES SHOWN' + call sim_message(msg, this%iout, skipbefore=1) + ! + ! -- set title + title = trim(adjustl(this%name)) // & + ' PACKAGE COARSE-GRAINED STRAIN SUMMARY' + ! + ! -- determine the number of columns and rows + ntabrows = nlen + ntabcols = 7 + ! + ! -- setup table + call table_cr(this%outputtab, this%name, title) + call this%outputtab%table_df(ntabrows, ntabcols, this%iout) + ! + ! add columns + tag = 'CELLID' + call this%outputtab%initialize_column(tag, 20, alignment=TABLEFT) + tag = 'INITIAL THICKNESS' + call this%outputtab%initialize_column(tag, 12, alignment=TABCENTER) + tag = 'FINAL THICKNESS' + call this%outputtab%initialize_column(tag, 12, alignment=TABCENTER) + tag = 'TOTAL COMPACTION' + call this%outputtab%initialize_column(tag, 12, alignment=TABCENTER) + tag = 'FINAL STRAIN' + call this%outputtab%initialize_column(tag, 12, alignment=TABCENTER) + tag = 'PERCENT COMPACTION' + call this%outputtab%initialize_column(tag, 12, alignment=TABCENTER) + tag = 'FLAG' + call this%outputtab%initialize_column(tag, 10, alignment=TABCENTER) + ! -- write data + do nn = 1, nlen + node = imap_sel(nn) + if (this%cg_thickini(node) > DZERO) then + strain = this%cg_tcomp(node) / this%cg_thickini(node) + else + strain = DZERO + end if + pctcomp = DHUNDRED * strain + if (pctcomp >= 5.0_DP) then + cflag = '**>=5%' + else if (pctcomp >= DONE) then + cflag = '*>=1%' + else + cflag = '' + end if + call this%dis%noder_to_string(node, cellid) + ! + ! -- fill table line + call this%outputtab%add_term(cellid) + call this%outputtab%add_term(this%cg_thickini(node)) + call this%outputtab%add_term(this%cg_thick(node)) + call this%outputtab%add_term(this%cg_tcomp(node)) + call this%outputtab%add_term(strain) + call this%outputtab%add_term(pctcomp) + call this%outputtab%add_term(cflag) + end do + write(this%iout, '(/1X,A,1X,I0,1X,A,1X,I0,1X,A,/1X,A,/1X,A)') & + 'COARSE-GRAINED STORAGE PERCENT COMPACTION IS GREATER THAN OR ' // & + 'EQUAL TO 1 PERCENT IN', iexceed, 'OF', this%dis%nodes, 'CELL(S).', & + 'USE THE STRAIN_CSV_COARSE OPTION TO OUTPUT A CSV ' // & + 'FILE WITH PERCENT COMPACTION ', 'VALUES FOR ALL CELLS.' + else + msg = 'COARSE-GRAINED STORAGE PERCENT COMPACTION WAS LESS THAN ' // & + '1 PERCENT IN ALL CELLS ' + write(this%iout, '(/1X,A)') trim(adjustl(msg)) + end if + ! + ! -- write csv file + if (this%istrainsk /= 0) then + ! + ! -- determine the number of columns and rows + ntabrows = this%dis%nodes + ntabcols = 5 + if (this%dis%ndim > 1) then + ntabcols = ntabcols + 1 + end if + ntabcols = ntabcols + this%dis%ndim + ! + ! -- setup table + call table_cr(this%outputtab, this%name, '') + call this%outputtab%table_df(ntabrows, ntabcols, this%istrainsk, & + lineseparator=.FALSE., separator=',') + ! + ! add columns + tag = 'NODE' + call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) + if (this%dis%ndim == 2) then + tag = 'LAYER' + call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) + tag = 'ICELL2D' + call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) + else + tag = 'LAYER' + call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) + tag = 'ROW' + call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) + tag = 'COLUMN' + call this%outputtab%initialize_column(tag, 10, alignment=TABRIGHT) + end if + tag = 'INITIAL_THICKNESS' + call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) + tag = 'FINAL_THICKNESS' + call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) + tag = 'TOTAL_COMPACTION' + call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) + tag = 'TOTAL_STRAIN' + call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) + tag = 'PERCENT_COMPACTION' + call this%outputtab%initialize_column(tag, 20, alignment=TABRIGHT) + ! + ! -- write data + do node = 1, this%dis%nodes + if (this%cg_thickini(node) > DZERO) then + strain = this%cg_tcomp(node) / this%cg_thickini(node) + else + strain = DZERO + end if + pctcomp = DHUNDRED * strain + call this%dis%noder_to_array(node, locs) + ! + ! -- fill table line + if (this%dis%ndim > 1) then + call this%outputtab%add_term(this%dis%get_nodeuser(node)) + end if + do ipos = 1, this%dis%ndim + call this%outputtab%add_term(locs(ipos)) + end do + call this%outputtab%add_term(this%cg_thickini(node)) + call this%outputtab%add_term(this%cg_thick(node)) + call this%outputtab%add_term(this%cg_tcomp(node)) + call this%outputtab%add_term(strain) + call this%outputtab%add_term(pctcomp) + end do + end if + ! + ! -- deallocate temporary storage + deallocate(imap_sel) + deallocate(locs) + deallocate(pctcomp_arr) + ! + ! -- return + return + end subroutine csub_fp + + subroutine csub_read_packagedata(this) +! ****************************************************************************** +! pak1read_dimensions -- Read the dimensions for this package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use MemoryManagerModule, only: mem_allocate, mem_setptr +! use SimModule, only: ustop, store_error, count_errors, store_error_unit + use TimeSeriesManagerModule, only: read_single_value_or_time_series + ! -- dummy + class(GwfCsubType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + character(len=LINELENGTH) :: cellid + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: tag + character(len=20) :: scellid + character(len=10) :: text + character(len=LENBOUNDNAME) :: bndName, bndNameTemp + character(len=7) :: cdelay + character(len=9) :: cno + integer(I4B) :: ival + logical :: isfound, endOfBlock + integer(I4B) :: n + integer(I4B) :: nn + integer(I4B) :: ib + integer(I4B) :: itmp + integer(I4B) :: ierr + integer(I4B) :: ndelaybeds + integer(I4B) :: idelay + integer(I4B) :: ntabrows + integer(I4B) :: ntabcols + real(DP) :: rval + real(DP) :: top + real(DP) :: bot + real(DP) :: baq + real(DP) :: q + integer, allocatable, dimension(:) :: nboundchk + ! + ! -- initialize temporary variables + ndelaybeds = 0 + ! + ! -- allocate temporary arrays + allocate(nboundchk(this%ninterbeds)) + do n = 1, this%ninterbeds + nboundchk(n) = 0 + end do + ! + call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & + supportopenclose=.true.) + ! + ! -- parse locations block if detected + if (isfound) then + write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%name))// & + ' PACKAGEDATA' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + ! -- read interbed number + itmp = this%parser%GetInteger() + + if (itmp < 1 .or. itmp > this%ninterbeds) then + write(errmsg,'(4x,a,1x,i0,1x,a,1x,i0)') & + '****ERROR. INTERBED NUMBER (', itmp, ') MUST BE > 0 and <= ', & + this%ninterbeds + call store_error(errmsg) + cycle + end if + + ! -- increment nboundchk + nboundchk(itmp) = nboundchk(itmp) + 1 + + ! -- read cellid + call this%parser%GetCellid(this%dis%ndim, cellid) + nn = this%dis%noder_from_cellid(cellid, & + this%parser%iuactive, this%iout) + n = this%dis%nodeu_from_cellid(cellid, & + this%parser%iuactive, this%iout) + top = this%dis%top(nn) + bot = this%dis%bot(nn) + baq = top - bot + ! -- determine if a valid cell location was provided + if (nn < 1) then + write(errmsg,'(4x,a,1x,i4,1x)') & + '****ERROR. INVALID cellid FOR PACKAGEDATA ENTRY', itmp + call store_error(errmsg) + end if + + ! -- set nodelist and unodelist + this%nodelist(itmp) = nn + this%unodelist(itmp) = n + + ! -- get cdelay + call this%parser%GetStringCaps(cdelay) + select case (cdelay) + case ('NODELAY') + ival = 0 + case ('DELAY') + ndelaybeds = ndelaybeds + 1 + ival = ndelaybeds + case default + write(errmsg,'(4x,a,1x,a,1x,i0,1x)') & + '****ERROR. INVALID CDELAY ', trim(adjustl(cdelay)), & + ' FOR PACKAGEDATA ENTRY', itmp + call store_error(errmsg) + cycle + end select + idelay = ival + this%idelay(itmp) = ival + + ! -- get initial preconsolidation stress + this%pcs(itmp) = this%parser%GetDouble() + + ! -- get thickness or cell fraction + rval = this%parser%GetDouble() + if (this%icellf == 0) then + if (rval < DZERO .or. rval > baq) then + write(errmsg,'(4x,a,1x,g0,1x,a,1x,g0,1x,a,1x,i0)') & + '****ERROR. thick (', rval,') MUST BE >= 0 AND <= ', baq, & + 'FOR PACKAGEDATA ENTRY', itmp + call store_error(errmsg) + end if + else + if (rval < DZERO .or. rval > DONE) then + write(errmsg,'(4x,a,1x,i0)') & + '****ERROR. frac MUST BE >= 0 AND <= 1 FOR PACKAGEDATA ENTRY', & + itmp + call store_error(errmsg) + end if + rval = rval * baq + end if + this%thickini(itmp) = rval + if (this%iupdatematprop /= 0) then + this%thick(itmp) = rval + end if + + ! -- get rnb + rval = this%parser%GetDouble() + if (idelay > 0) then + if (rval < DONE) then + write(errmsg,'(4x,a,1x,g0,1x,a,1x,a,1x,i0)') & + '****ERROR. rnb (', rval,') MUST BE >= 1.', & + 'FOR PACKAGEDATA ENTRY', itmp + call store_error(errmsg) + end if + else + rval = DONE + end if + this%rnb(itmp) = rval + ! + ! -- get skv or ci + rval = this%parser%GetDouble() + if (rval < DZERO) then + write(errmsg,'(4x,a,1x,i0)') & + '****ERROR. (skv,ci) MUST BE > 0 FOR PACKAGEDATA ENTRY', itmp + call store_error(errmsg) + end if + this%ci(itmp) = rval + ! + ! -- get ske or rci + rval = this%parser%GetDouble() + if (rval < DZERO) then + write(errmsg,'(4x,a,1x,i0)') & + '****ERROR. (ske,rci) MUST BE > 0 FOR PACKAGEDATA ENTRY', itmp + call store_error(errmsg) + end if + this%rci(itmp) = rval + ! + ! -- set ielastic + if (this%ci(itmp) == this%rci(itmp)) then + this%ielastic(itmp) = 1 + else + this%ielastic(itmp) = 0 + end if + ! + ! -- get porosity + rval = this%parser%GetDouble() + this%thetaini(itmp) = rval + if (this%iupdatematprop /= 0) then + this%theta(itmp) = rval + end if + if (rval <= DZERO .or. rval > DONE) then + write(errmsg,'(4x,a,1x,a,1x,i0)') & + '****ERROR. theta MUST BE > 0 and <= 1 FOR PACKAGEDATA ENTRY', & + 'ENTRY', itmp + call store_error(errmsg) + end if + ! + ! -- get kv + rval = this%parser%GetDouble() + if (idelay > 0) then + if (rval <= 0.0) then + write(errmsg,'(4x,a,1x,i0,1x)') & + '****ERROR. kv MUST BE > 0 FOR PACKAGEDATA ENTRY', itmp + call store_error(errmsg) + end if + end if + this%kv(itmp) = rval + + ! -- get h0 + rval = this%parser%GetDouble() + this%h0(itmp) = rval + + ! -- get bound names + write (cno,'(i9.9)') nn + bndName = 'nsystem' // cno + if (this%inamedbound /= 0) then + call this%parser%GetStringCaps(bndNameTemp) + if (bndNameTemp /= '') then + bndName = bndNameTemp(1:16) + else + write(errmsg,'(4x,2(a,1x),i4)') & + '****ERROR. BOUNDNAME MUST BE SPECIFIED FOR ', & + 'PACKAGEDATA ENTRY', itmp + call store_error(errmsg) + end if + end if + this%boundname(itmp) = bndName + end do + write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%name))//' PACKAGEDATA' + end if + ! + ! -- write summary of interbed data + if (this%iprpak == 1) then + ! -- set title + title = trim(adjustl(this%name)) // ' PACKAGE INTERBED DATA' + ! + ! -- determine the number of columns and rows + ntabrows = this%ninterbeds + ntabcols = 11 + if (this%inamedbound /= 0) then + ntabcols = ntabcols + 1 + end if + ! + ! -- setup table + call table_cr(this%inputtab, this%name, title) + call this%inputtab%table_df(ntabrows, ntabcols, this%iout) + ! + ! add columns + tag = 'INTERBED' + call this%inputtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'CELLID' + call this%inputtab%initialize_column(tag, 20, alignment=TABCENTER) + tag = 'CDELAY' + call this%inputtab%initialize_column(tag, 10, alignment=TABCENTER) + tag = 'PCS' + call this%inputtab%initialize_column(tag, 10, alignment=TABCENTER) + tag = 'THICK' + call this%inputtab%initialize_column(tag, 10, alignment=TABCENTER) + tag = 'RNB' + call this%inputtab%initialize_column(tag, 10, alignment=TABCENTER) + tag = 'SSV_CC' + call this%inputtab%initialize_column(tag, 10, alignment=TABCENTER) + tag = 'SSV_CR' + call this%inputtab%initialize_column(tag, 10, alignment=TABCENTER) + tag = 'THETA' + call this%inputtab%initialize_column(tag, 10, alignment=TABCENTER) + tag = 'KV' + call this%inputtab%initialize_column(tag, 10, alignment=TABCENTER) + tag = 'H0' + call this%inputtab%initialize_column(tag, 10, alignment=TABCENTER) + if (this%inamedbound /= 0) then + tag = 'BOUNDNAME' + call this%inputtab%initialize_column(tag, LENBOUNDNAME, & + alignment=TABLEFT) + end if + ! + ! -- write the data + do ib = 1, this%ninterbeds + call this%dis%noder_to_string(this%nodelist(ib), scellid) + if (this%idelay(ib) == 0) then + text = 'NODELAY' + else + text = 'DELAY' + end if + call this%inputtab%add_term(ib) + call this%inputtab%add_term(scellid) + call this%inputtab%add_term(text) + call this%inputtab%add_term(this%pcs(ib)) + call this%inputtab%add_term(this%thickini(ib)) + call this%inputtab%add_term(this%rnb(ib)) + call this%inputtab%add_term(this%ci(ib)) + call this%inputtab%add_term(this%rci(ib)) + call this%inputtab%add_term(this%thetaini(ib)) + if (this%idelay(ib) == 0) then + call this%inputtab%add_term('-') + call this%inputtab%add_term('-') + else + call this%inputtab%add_term(this%kv(ib)) + call this%inputtab%add_term(this%h0(ib)) + end if + if (this%inamedbound /= 0) then + call this%inputtab%add_term(this%boundname(ib)) + end if + end do + end if + ! + ! -- Check to make sure that every interbed is specified and that no + ! interbed is specified more than once. + do ib = 1, this%ninterbeds + if (nboundchk(ib) == 0) then + write(errmsg, '(a, i0, a)') 'ERROR: INFORMATION FOR INTERBED ', ib, & + ' NOT SPECIFIED IN PACKAGEDATA BLOCK.' + call store_error(errmsg) + else if (nboundchk(ib) > 1) then + write(errmsg, '(a, i0, i0)') 'ERROR: INFORMATION SPECIFIED ', & + nboundchk(ib), ' TIMES FOR INTERBED ', ib + call store_error(errmsg) + endif + end do + deallocate(nboundchk) + ! + ! -- set the number of delay interbeds + this%ndelaybeds = ndelaybeds + ! + ! -- process delay interbeds + if (ndelaybeds > 0) then + ! + ! -- reallocate and initialize delay interbed arrays + if (ierr == 0) then + call mem_allocate(this%idbconvert, this%ndelaycells, ndelaybeds, & + 'idbconvert', trim(this%origin)) + call mem_allocate(this%dbdhmax, ndelaybeds, & + 'dbdhmax', trim(this%origin)) + call mem_allocate(this%dbz, this%ndelaycells, ndelaybeds, & + 'dbz', trim(this%origin)) + call mem_allocate(this%dbrelz, this%ndelaycells, ndelaybeds, & + 'dbrelz', trim(this%origin)) + call mem_allocate(this%dbh, this%ndelaycells, ndelaybeds, & + 'dbh', trim(this%origin)) + call mem_allocate(this%dbh0, this%ndelaycells, ndelaybeds, & + 'dbh0', trim(this%origin)) + call mem_allocate(this%dbgeo, this%ndelaycells, ndelaybeds, & + 'dbgeo', trim(this%origin)) + call mem_allocate(this%dbes, this%ndelaycells, ndelaybeds, & + 'dbes', trim(this%origin)) + call mem_allocate(this%dbes0, this%ndelaycells, ndelaybeds, & + 'dbes0', trim(this%origin)) + call mem_allocate(this%dbpcs, this%ndelaycells, ndelaybeds, & + 'dbpcs', trim(this%origin)) + call mem_allocate(this%dbflowtop, ndelaybeds, & + 'dbflowtop', trim(this%origin)) + call mem_allocate(this%dbflowbot, ndelaybeds, & + 'dbflowbot', trim(this%origin)) + call mem_allocate(this%dbdzini, this%ndelaycells, ndelaybeds, & + 'dbdzini', trim(this%origin)) + call mem_allocate(this%dbthetaini, this%ndelaycells, ndelaybeds, & + 'dbthetaini', trim(this%origin)) + call mem_allocate(this%dbcomp, this%ndelaycells, ndelaybeds, & + 'dbcomp', trim(this%origin)) + call mem_allocate(this%dbtcomp, this%ndelaycells, ndelaybeds, & + 'dbtcomp', trim(this%origin)) + ! + ! -- allocate delay bed arrays + if (this%iupdatematprop == 0) then + call mem_setptr(this%dbdz, 'dbdzini', trim(this%origin)) + call mem_setptr(this%dbdz0, 'dbdzini', trim(this%origin)) + call mem_setptr(this%dbtheta, 'dbthetaini', trim(this%origin)) + call mem_setptr(this%dbtheta0, 'dbthetaini', trim(this%origin)) + else + call mem_allocate(this%dbdz, this%ndelaycells, ndelaybeds, & + 'dbdz', trim(this%origin)) + call mem_allocate(this%dbdz0, this%ndelaycells, ndelaybeds, & + 'dbdz0', trim(this%origin)) + call mem_allocate(this%dbtheta, this%ndelaycells, ndelaybeds, & + 'dbtheta', trim(this%origin)) + call mem_allocate(this%dbtheta0, this%ndelaycells, ndelaybeds, & + 'dbtheta0', trim(this%origin)) + end if + ! + ! -- allocate delay interbed solution arrays + call mem_allocate(this%dbal, this%ndelaycells, & + 'dbal', trim(this%origin)) + call mem_allocate(this%dbad, this%ndelaycells, & + 'dbad', trim(this%origin)) + call mem_allocate(this%dbau, this%ndelaycells, & + 'dbau', trim(this%origin)) + call mem_allocate(this%dbrhs, this%ndelaycells, & + 'dbrhs', trim(this%origin)) + call mem_allocate(this%dbdh, this%ndelaycells, & + 'dbdh', trim(this%origin)) + call mem_allocate(this%dbaw, this%ndelaycells, & + 'dbaw', trim(this%origin)) + ! + ! -- initialize delay bed storage + do ib = 1, this%ninterbeds + idelay = this%idelay(ib) + if (idelay == 0) then + cycle + end if + ! + ! -- initialize delay interbed variables + do n = 1, this%ndelaycells + rval = this%thickini(ib) / real(this%ndelaycells, DP) + this%dbdzini(n, idelay) = rval + this%dbh(n, idelay) = this%h0(ib) + this%dbh0(n, idelay) = this%h0(ib) + this%dbthetaini(n, idelay) = this%thetaini(ib) + this%dbgeo(n, idelay) = DZERO + this%dbes(n, idelay) = DZERO + this%dbes0(n, idelay) = DZERO + this%dbpcs(n, idelay) = this%pcs(ib) + this%dbcomp(n, idelay) = DZERO + this%dbtcomp(n, idelay) = DZERO + if (this%iupdatematprop /= 0) then + this%dbdz(n, idelay) = this%dbdzini(n, idelay) + this%dbdz0(n, idelay) = this%dbdzini(n, idelay) + this%dbtheta(n, idelay) = this%theta(ib) + this%dbtheta0(n, idelay) = this%theta(ib) + end if + end do + ! + ! -- initialize elevation of delay bed cells + call this%csub_delay_calc_zcell(ib) + + end do + ! + ! -- initialize delay bed solution arrays + do n = 1, this%ndelaycells + this%dbal(n) = DZERO + this%dbad(n) = DZERO + this%dbau(n) = DZERO + this%dbrhs(n) = DZERO + this%dbdh(n) = DZERO + this%dbaw(n) = DZERO + end do + end if + end if + ! + ! -- check that ndelaycells is odd when using + ! the effective stress formulation + if (ndelaybeds > 0) then + q = MOD(real(this%ndelaycells, DP), DTWO) + if (q == DZERO) then + write(errmsg, '(a,1x,i0,2(1x,a))') & + 'ERROR: NDELAYCELLS (', this%ndelaycells, ') MUST BE AN', & + 'ODD NUMBER WHEN USING THE EFFECTIVE STRESS FORMULATION.' + call store_error(errmsg) + end if + end if + ! + ! -- return + return + end subroutine csub_read_packagedata + + subroutine read_options(this) +! ****************************************************************************** +! read_options -- set options +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: MAXCHARLEN, DZERO + use OpenSpecModule, only: access, form + use InputOutputModule, only: urword, getunit, urdaux, openfile + implicit none + ! -- dummy + class(GwfCsubType), intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + character(len=LINELENGTH) :: keyword + character(len=LINELENGTH) :: line + character(len=MAXCHARLEN) :: fname + logical :: isfound + logical :: endOfBlock + integer(I4B) :: lloc + integer(I4B) :: istart + integer(I4B) :: istop + integer(I4B) :: ierr + integer(I4B) :: inobs + integer(I4B) :: ibrg + integer(I4B) :: ieslag + integer(I4B) :: isetgamma + ! -- formats + character(len=*), parameter :: fmtts = & + "(4x, 'TIME-SERIES DATA WILL BE READ FROM FILE: ', a)" + character(len=*),parameter :: fmtflow = & + "(4x, 'FLOWS WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" + character(len=*),parameter :: fmtflow2 = & + "(4x, 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL')" + character(len=*),parameter :: fmtssessv = & + "(4x, 'USING SSE AND SSV INSTEAD OF CR AND CC.')" + character(len=*),parameter :: fmtoffset = & + "(4x, 'INITIAL_STRESS TREATED AS AN OFFSET.')" + character(len=*),parameter :: fmtopt = & + "(4x, A)" + character(len=*),parameter :: fmtopti = & + "(4x, A, 1X, I0)" + character(len=*),parameter :: fmtoptr = & + "(4x, A, 1X, G0)" + character(len=*),parameter :: fmtfileout = & + "(4x, 'CSUB ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" +! ----------------------------------------------------------------------------- + ! + ! -- initialize variables + ibrg = 0 + ieslag = 0 + isetgamma = 0 + ! + ! -- get options block + call this%parser%GetBlock('OPTIONS', isfound, ierr, blockRequired=.false.) + ! + ! -- parse options block if detected + if (isfound) then + write(this%iout,'(1x,a)')'PROCESSING CSUB OPTIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case('AUX', 'AUXILIARY') + call this%parser%GetRemainingLine(line) + lloc = 1 + call urdaux(this%naux, this%parser%iuactive, this%iout, lloc, & + istart, istop, this%auxname, line, this%name) + case ('SAVE_FLOWS') + this%ipakcb = -1 + write(this%iout, fmtflow2) + case ('PRINT_INPUT') + this%iprpak = 1 + write(this%iout,'(4x,a)') 'LISTS OF '//trim(adjustl(this%name))// & + ' CELLS WILL BE PRINTED.' + case ('PRINT_FLOWS') + this%iprflow = 1 + write(this%iout,'(4x,a)') trim(adjustl(this%name))// & + ' FLOWS WILL BE PRINTED TO LISTING FILE.' + case ('BOUNDNAMES') + this%inamedbound = 1 + write(this%iout,'(4x,a)') trim(adjustl(this%name))// & + ' BOUNDARIES HAVE NAMES IN LAST COLUMN.' ! user specified boundnames + case ('TS6') + call this%parser%GetStringCaps(keyword) + if(trim(adjustl(keyword)) /= 'FILEIN') then + errmsg = 'TS6 keyword must be followed by "FILEIN" ' // & + 'then by filename.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + call this%parser%GetString(fname) + write(this%iout,fmtts)trim(fname) + call this%TsManager%add_tsfile(fname, this%inunit) + case ('OBS6') + call this%parser%GetStringCaps(keyword) + if(trim(adjustl(keyword)) /= 'FILEIN') then + errmsg = 'OBS6 keyword must be followed by "FILEIN" ' // & + 'then by filename.' + call store_error(errmsg) + endif + if (this%obs%active) then + errmsg = 'Multiple OBS6 keywords detected in OPTIONS block. ' // & + 'Only one OBS6 entry allowed for a package.' + call store_error(errmsg) + endif + this%obs%active = .true. + call this%parser%GetString(this%obs%inputFilename) + inobs = GetUnit() + call openfile(inobs, this%iout, this%obs%inputFilename, 'OBS') + this%obs%inUnitObs = inobs + this%inobspkg = inobs + + call this%obs%obs_df(this%iout, this%name, this%filtyp, this%dis) + call this%csub_df_obs() + ! + ! -- CSUB specific options + case ('GAMMAW') + this%gammaw = this%parser%GetDouble() + ibrg = 1 + case ('BETA') + this%beta = this%parser%GetDouble() + ibrg = 1 + case ('HEAD_BASED') + this%ipch = 1 + this%lhead_based = .TRUE. + case ('INITIAL_PRECONSOLIDATION_HEAD') + this%ipch = 1 + case ('NDELAYCELLS') + this%ndelaycells = this%parser%GetInteger() + ! + ! -- compression indicies (CR amd CC) will be specified instead of + ! storage coefficients (SSE and SSV) + case ('COMPRESSION_INDICES') + this%istoragec = 0 + ! + ! -- variable thickness and void ratio + case ('UPDATE_MATERIAL_PROPERTIES') + this%iupdatematprop = 1 + ! + ! -- cell fraction will be specified instead of interbed thickness + case ('CELL_FRACTION') + this%icellf = 1 + ! + ! -- specified initial pcs and delay bed heads + case ('SPECIFIED_INITIAL_INTERBED_STATE') + this%ispecified_pcs = 1 + this%ispecified_dbh = 1 + ! + ! -- specified initial pcs + case ('SPECIFIED_INITIAL_PRECONSOLIDATION_STRESS') + this%ispecified_pcs = 1 + ! + ! -- specified initial delay bed heads + case ('SPECIFIED_INITIAL_DELAY_HEAD') + this%ispecified_dbh = 1 + ! + ! -- lag the effective stress used to calculate storage properties + case ('EFFECTIVE_STRESS_LAG') + ieslag = 1 + ! + ! -- strain table options + case ('STRAIN_CSV_INTERBED') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%istrainib = getunit() + call openfile(this%istrainib, this%iout, fname, 'CSV_OUTPUT', & + filstat_opt='REPLACE') + write(this%iout,fmtfileout) & + 'INTERBED STRAIN CSV', fname, this%istrainib + else + errmsg = 'OPTIONAL STRAIN_CSV_INTERBED KEYWORD MUST BE ' // & + 'FOLLOWED BY FILEOUT' + call store_error(errmsg) + end if + case ('STRAIN_CSV_COARSE') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%istrainsk = getunit() + call openfile(this%istrainsk, this%iout, fname, 'CSV_OUTPUT', & + filstat_opt='REPLACE') + write(this%iout,fmtfileout) & + 'COARSE STRAIN CSV', fname, this%istrainsk + else + errmsg = 'OPTIONAL STRAIN_CSV_COARSE KEYWORD MUST BE ' // & + 'FOLLOWED BY FILEOUT' + call store_error(errmsg) + end if + ! + ! -- compaction output + case ('COMPACTION') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ioutcomp = getunit() + call openfile(this%ioutcomp, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE') + write(this%iout,fmtfileout) & + 'COMPACTION', fname, this%ioutcomp + else + errmsg = 'OPTIONAL COMPACTION KEYWORD MUST BE ' // & + 'FOLLOWED BY FILEOUT' + call store_error(errmsg) + end if + case ('COMPACTION_INELASTIC') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ioutcompi = getunit() + call openfile(this%ioutcompi, this%iout, fname, & + 'DATA(BINARY)', form, access, 'REPLACE') + write(this%iout,fmtfileout) & + 'COMPACTION_INELASTIC', fname, this%ioutcompi + else + errmsg = 'OPTIONAL COMPACTION_INELASTIC KEYWORD MUST BE ' // & + 'FOLLOWED BY FILEOUT' + call store_error(errmsg) + end if + case ('COMPACTION_ELASTIC') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ioutcompe = getunit() + call openfile(this%ioutcompe, this%iout, fname, & + 'DATA(BINARY)', form, access, 'REPLACE') + write(this%iout,fmtfileout) & + 'COMPACTION_ELASTIC', fname, this%ioutcompe + else + errmsg = 'OPTIONAL COMPACTION_ELASTIC KEYWORD MUST BE ' // & + 'FOLLOWED BY FILEOUT' + call store_error(errmsg) + end if + case ('COMPACTION_INTERBED') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ioutcompib = getunit() + call openfile(this%ioutcompib, this%iout, fname, & + 'DATA(BINARY)', form, access, 'REPLACE') + write(this%iout,fmtfileout) & + 'COMPACTION_INTERBED', fname, this%ioutcompib + else + errmsg = 'OPTIONAL COMPACTION_INTERBED KEYWORD MUST BE ' // & + 'FOLLOWED BY FILEOUT' + call store_error(errmsg) + end if + case ('COMPACTION_COARSE') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ioutcomps = getunit() + call openfile(this%ioutcomps, this%iout, fname, & + 'DATA(BINARY)', form, access, 'REPLACE') + write(this%iout,fmtfileout) & + 'COMPACTION_COARSE', fname, this%ioutcomps + else + errmsg = 'OPTIONAL COMPACTION_COARSE KEYWORD MUST BE ' // & + 'FOLLOWED BY FILEOUT' + call store_error(errmsg) + end if + ! + ! -- zdisplacement output + case ('ZDISPLACEMENT') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ioutzdisp = getunit() + call openfile(this%ioutzdisp, this%iout, fname, & + 'DATA(BINARY)', form, access, 'REPLACE') + write(this%iout,fmtfileout) & + 'ZDISPLACEMENT', fname, this%ioutzdisp + else + errmsg = 'OPTIONAL ZDISPLACEMENT KEYWORD MUST BE ' // & + 'FOLLOWED BY FILEOUT' + call store_error(errmsg) + end if + ! -- package convergence + case('PACKAGE_CONVERGENCE') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ipakcsv = getunit() + call openfile(this%ipakcsv, this%iout, fname, 'CSV', & + filstat_opt='REPLACE') + write(this%iout,fmtfileout) 'PACKAGE_CONVERGENCE', fname, this%ipakcsv + else + call store_error('OPTIONAL PACKAGE_CONVERGENCE KEYWORD MUST BE ' // & + 'FOLLOWED BY FILEOUT') + end if + ! + ! -- right now these 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_FINAL_CHECK') + call this%parser%DevOpt() + this%iconvchk = 0 + write(this%iout, '(4x,a)') & + 'A FINAL CONVERGENCE CHECK OF THE CHANGE IN DELAY INTERBED ' // & + 'HEADS AND FLOWS WILL NOT BE MADE' + + ! + ! default case + case default + write(errmsg,'(4x,a,3(1x,a))') '****ERROR. UNKNOWN ', & + trim(adjustl(this%name)), & + 'OPTION: ', trim(keyword) + call store_error(errmsg) + end select + end do + write(this%iout,'(1x,a)') 'END OF ' // & + trim(adjustl(this%name)) // ' OPTIONS' + end if + ! + ! -- write messages for options + write(this%iout, '(//2(1X,A))') trim(adjustl(this%name)), & + 'PACKAGE SETTINGS' + write(this%iout, fmtopti) 'NUMBER OF DELAY CELLS =', & + this%ndelaycells + if (this%lhead_based .EQV. .TRUE.) then + write(this%iout, '(4x,a)') & + 'HEAD-BASED FORMULATION' + else + write(this%iout, '(4x,a)') & + 'EFFECTIVE-STRESS FORMULATION' + end if + if (this%istoragec == 0) then + write(this%iout, '(4x,a,1(/,6x,a))') & + 'COMPRESSION INDICES WILL BE SPECIFIED INSTEAD OF ELASTIC AND', & + 'INELASTIC SPECIFIC STORAGE COEFFICIENTS' + else + write(this%iout, '(4x,a,1(/,6x,a))') & + 'ELASTIC AND INELASTIC SPECIFIC STORAGE COEFFICIENTS WILL BE ', & + 'SPECIFIED' + end if + if (this%iupdatematprop /= 1) then + write(this%iout, '(4x,a,1(/,6x,a))') & + 'THICKNESS AND VOID RATIO WILL NOT BE ADJUSTED DURING THE', & + 'SIMULATION' + else + write(this%iout, '(4x,a)') & + 'THICKNESS AND VOID RATIO WILL BE ADJUSTED DURING THE SIMULATION' + end if + if (this%icellf /= 1) then + write(this%iout, '(4x,a)') & + 'INTERBED THICKNESS WILL BE SPECIFIED AS A THICKNESS' + else + write(this%iout,'(4x,a,1(/,6x,a))') & + 'INTERBED THICKNESS WILL BE SPECIFIED AS A AS A CELL FRACTION' + end if + if (this%ispecified_pcs /= 1) then + if (this%ipch /= 0) then + write(this%iout, '(4x,a,1(/,6x,a))') & + 'PRECONSOLIDATION HEAD WILL BE SPECIFIED RELATIVE TO INITIAL', & + 'STRESS CONDITIONS' + else + write(this%iout, '(4x,a,1(/,6x,a))') & + 'PRECONSOLIDATION STRESS WILL BE SPECIFIED RELATIVE TO INITIAL', & + 'STRESS CONDITIONS' + end if + else + if (this%ipch /= 0) then + write(this%iout, '(4x,a,1(/,6x,a))') & + 'PRECONSOLIDATION HEAD WILL BE SPECIFIED AS ABSOLUTE VALUES', & + 'INSTEAD OF RELATIVE TO INITIAL HEAD CONDITIONS' + else + write(this%iout, '(4x,a,1(/,6x,a))') & + 'PRECONSOLIDATION STRESS WILL BE SPECIFIED AS ABSOLUTE VALUES', & + 'INSTEAD OF RELATIVE TO INITIAL STRESS CONDITIONS' + end if + end if + if (this%ispecified_dbh /= 1) then + write(this%iout, '(4x,a,1(/,6x,a))') & + 'DELAY INTERBED HEADS WILL BE SPECIFIED RELATIVE TO INITIAL ', & + 'GWF HEADS' + else + write(this%iout, '(4x,a,1(/,6x,a))') & + 'DELAY INTERBED HEADS WILL BE SPECIFIED AS ABSOLUTE VALUES INSTEAD', & + 'OF RELATIVE TO INITIAL GWF HEADS' + end if + ! + ! -- process effective_stress_lag, if effective stress formulation + if (this%lhead_based .EQV. .FALSE.) then + if (ieslag /= 0) then + write(this%iout, '(4x,a,1(/,6x,a))') & + 'SPECIFIC STORAGE VALUES WILL BE CALCULATED USING THE EFFECTIVE', & + 'STRESS FROM THE PREVIOUS TIME STEP' + else + write(this%iout, '(4x,a,1(/,6x,a))') & + 'SPECIFIC STORAGE VALUES WILL BE CALCULATED USING THE CURRENT', & + 'EFFECTIVE STRESS' + end if + else + if (ieslag /= 0) then + ieslag = 0 + write(this%iout, '(4x,a,2(/,6x,a))') & + 'EFFECTIVE_STRESS_LAG HAS BEEN SPECIFIED BUT HAS NO EFFECT WHEN USING',& + 'THE HEAD-BASED FORMULATION (HEAD_BASED HAS BEEN SPECIFIED IN THE', & + 'OPTIONS BLOCK)' + end if + end if + this%ieslag = ieslag + ! + ! -- recalculate BRG if necessary and output + ! water compressibility values + if (ibrg /= 0) then + this%brg = this%gammaw * this%beta + end if + write(this%iout, fmtoptr) 'GAMMAW =', this%gammaw + write(this%iout, fmtoptr) 'BETA =', this%beta + write(this%iout, fmtoptr) 'GAMMAW * BETA =', this%brg + ! + ! -- terminate if errors encountered in reach block + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- return + return + end subroutine read_options + + subroutine csub_allocate_arrays(this) +! ****************************************************************************** +! allocate_arrays -- Allocate Package Members +! Subroutine: (1) allocate +! (2) initialize +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use MemoryManagerModule, only: mem_allocate, mem_setptr + implicit none + class(GwfCsubType), intent(inout) :: this + ! -- local variables + character(len=LENORIGIN) :: stoname + integer(I4B) :: j + integer(I4B) :: n + integer(I4B) :: iblen + integer(I4B) :: ilen + integer(I4B) :: naux + + ! -- grid based data + if (this%ioutcomp == 0 .and. this%ioutcompi == 0 .and. & + this%ioutcompe == 0 .and. this%ioutcompib == 0 .and. & + this%ioutcomps == 0 .and. this%ioutzdisp == 0) then + call mem_allocate(this%buff, 1, 'BUFF', trim(this%origin)) + else + call mem_allocate(this%buff, this%dis%nodes, 'BUFF', trim(this%origin)) + end if + if (this%ioutcomp == 0 .and. this%ioutzdisp == 0) then + call mem_allocate(this%buffusr, 1, 'buffusr', trim(this%origin)) + else + call mem_allocate(this%buffusr, this%dis%nodesuser, 'buffusr', & + trim(this%origin)) + end if + call mem_allocate(this%sgm, this%dis%nodes, 'sgm', trim(this%origin)) + call mem_allocate(this%sgs, this%dis%nodes, 'sgs', trim(this%origin)) + call mem_allocate(this%cg_ske_cr, this%dis%nodes, 'cg_ske_cr', & + trim(this%origin)) + call mem_allocate(this%cg_es, this%dis%nodes, 'cg_es', trim(this%origin)) + call mem_allocate(this%cg_es0, this%dis%nodes, 'cg_es0', trim(this%origin)) + call mem_allocate(this%cg_pcs, this%dis%nodes, 'cg_pcs', trim(this%origin)) + call mem_allocate(this%cg_comp, this%dis%nodes, 'cg_comp', trim(this%origin)) + call mem_allocate(this%cg_tcomp, this%dis%nodes, 'cg_tcomp', & + trim(this%origin)) + call mem_allocate(this%cg_stor, this%dis%nodes, 'cg_stor', trim(this%origin)) + call mem_allocate(this%cg_ske, this%dis%nodes, 'cg_ske', trim(this%origin)) + call mem_allocate(this%cg_sk, this%dis%nodes, 'cg_sk', trim(this%origin)) + call mem_allocate(this%cg_thickini, this%dis%nodes, 'cg_thickini', & + trim(this%origin)) + call mem_allocate(this%cg_thetaini, this%dis%nodes, 'cg_thetaini', & + trim(this%origin)) + if (this%iupdatematprop == 0) then + call mem_setptr(this%cg_thick, 'cg_thickini', trim(this%origin)) + call mem_setptr(this%cg_thick0, 'cg_thickini', trim(this%origin)) + call mem_setptr(this%cg_theta, 'cg_thetaini', trim(this%origin)) + call mem_setptr(this%cg_theta0, 'cg_thetaini', trim(this%origin)) + else + call mem_allocate(this%cg_thick, this%dis%nodes, 'cg_thick', & + trim(this%origin)) + call mem_allocate(this%cg_thick0, this%dis%nodes, 'cg_thick0', & + trim(this%origin)) + call mem_allocate(this%cg_theta, this%dis%nodes, 'cg_theta', & + trim(this%origin)) + call mem_allocate(this%cg_theta0, this%dis%nodes, 'cg_theta0', & + trim(this%origin)) + end if + ! + ! -- cell storage data + call mem_allocate(this%cell_wcstor, this%dis%nodes, 'cell_wcstor', & + trim(this%origin)) + call mem_allocate(this%cell_thick, this%dis%nodes, 'cell_thick', & + trim(this%origin)) + ! + ! -- interbed data + iblen = 1 + if (this%ninterbeds > 0) then + iblen = this%ninterbeds + end if + naux = 1 + if (this%naux > 0) then + naux = this%naux + end if + call mem_allocate(this%auxvar, naux, iblen, 'AUXVAR', this%origin) + do n = 1, iblen + do j = 1, naux + this%auxvar(j, n) = DZERO + end do + end do + call mem_allocate(this%unodelist, iblen, 'unodelist', trim(this%origin)) + call mem_allocate(this%nodelist, iblen, 'nodelist', trim(this%origin)) + call mem_allocate(this%cg_gs, this%dis%nodes, 'cg_gs', trim(this%origin)) + call mem_allocate(this%pcs, iblen, 'pcs', trim(this%origin)) + call mem_allocate(this%rnb, iblen, 'rnb', trim(this%origin)) + call mem_allocate(this%kv, iblen, 'kv', trim(this%origin)) + call mem_allocate(this%h0, iblen, 'h0', trim(this%origin)) + call mem_allocate(this%ci, iblen, 'ci', trim(this%origin)) + call mem_allocate(this%rci, iblen, 'rci', trim(this%origin)) + call mem_allocate(this%idelay, iblen, 'idelay', trim(this%origin)) + call mem_allocate(this%ielastic, iblen, 'ielastic', trim(this%origin)) + call mem_allocate(this%iconvert, iblen, 'iconvert', trim(this%origin)) + call mem_allocate(this%comp, iblen, 'comp', trim(this%origin)) + call mem_allocate(this%tcomp, iblen, 'tcomp', trim(this%origin)) + call mem_allocate(this%tcompi, iblen, 'tcompi', trim(this%origin)) + call mem_allocate(this%tcompe, iblen, 'tcompe', trim(this%origin)) + call mem_allocate(this%storagee, iblen, 'storagee', trim(this%origin)) + call mem_allocate(this%storagei, iblen, 'storagei', trim(this%origin)) + call mem_allocate(this%ske, iblen, 'ske', trim(this%origin)) + call mem_allocate(this%sk, iblen, 'sk', trim(this%origin)) + call mem_allocate(this%thickini, iblen, 'thickini', trim(this%origin)) + call mem_allocate(this%thetaini, iblen, 'thetaini', trim(this%origin)) + if (this%iupdatematprop == 0) then + call mem_setptr(this%thick, 'thickini', trim(this%origin)) + call mem_setptr(this%thick0, 'thickini', trim(this%origin)) + call mem_setptr(this%theta, 'thetaini', trim(this%origin)) + call mem_setptr(this%theta0, 'thetaini', trim(this%origin)) + else + call mem_allocate(this%thick, iblen, 'thick', trim(this%origin)) + call mem_allocate(this%thick0, iblen, 'thick0', trim(this%origin)) + call mem_allocate(this%theta, iblen, 'theta', trim(this%origin)) + call mem_allocate(this%theta0, iblen, 'theta0', trim(this%origin)) + end if + ! + ! -- delay bed storage - allocated in csub_read_packagedata + ! after number of delay beds is defined + ! + ! -- allocate boundname + allocate(this%boundname(this%ninterbeds)) + ! + ! -- allocate the nodelist and bound arrays + if (this%maxsig0 > 0) then + ilen = this%maxsig0 + else + ilen = 1 + end if + call mem_allocate(this%nodelistsig0, ilen, 'NODELISTSIG0', this%origin) + this%nodelistsig0 = 0 + call mem_allocate(this%bound, this%ncolbnd, ilen, 'BOUND', & + this%origin) + call mem_allocate(this%auxvarsig0, this%naux, ilen, 'AUXVARSIG0', & + this%origin) + ! + ! -- Allocate sig0boundname + allocate(this%sig0bname(ilen)) + ! + ! -- set pointers to gwf variables + call mem_setptr(this%gwfiss, 'ISS', trim(this%name_model)) + ! + ! -- set pointers to variables in the storage package + stoname = trim(this%name_model) // ' ' // trim(this%stoname) + call mem_setptr(this%stoiconv, 'ICONVERT', trim(stoname)) + call mem_setptr(this%stosc1, 'SC1', trim(stoname)) + ! + ! -- initialize variables that are not specified by user + do n = 1, this%dis%nodes + this%cg_gs(n) = DZERO + this%cg_es(n) = DZERO + this%cg_comp(n) = DZERO + this%cg_tcomp(n) = DZERO + this%cell_wcstor(n) = DZERO + end do + do n = 1, this%ninterbeds + this%theta(n) = DZERO + this%tcomp(n) = DZERO + this%tcompi(n) = DZERO + this%tcompe(n) = DZERO + end do + ! + ! -- return + return + + end subroutine csub_allocate_arrays + + subroutine csub_da(this) +! ****************************************************************************** +! csub_da -- Deallocate variables +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + implicit none + ! -- dummy + class(GwfCsubType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Deallocate arrays if package is active + if(this%inunit > 0) then + call mem_deallocate(this%unodelist) + call mem_deallocate(this%nodelist) + call mem_deallocate(this%idelay) + call mem_deallocate(this%ielastic) + call mem_deallocate(this%iconvert) + ! + ! -- grid-based storage data + call mem_deallocate(this%buff) + call mem_deallocate(this%buffusr) + call mem_deallocate(this%sgm) + call mem_deallocate(this%sgs) + call mem_deallocate(this%cg_ske_cr) + call mem_deallocate(this%cg_gs) + call mem_deallocate(this%cg_es) + call mem_deallocate(this%cg_es0) + call mem_deallocate(this%cg_pcs) + call mem_deallocate(this%cg_comp) + call mem_deallocate(this%cg_tcomp) + call mem_deallocate(this%cg_stor) + call mem_deallocate(this%cg_ske) + call mem_deallocate(this%cg_sk) + if (this%iupdatematprop == 0) then + nullify(this%cg_thick) + nullify(this%cg_thick0) + nullify(this%cg_theta) + nullify(this%cg_theta0) + else + call mem_deallocate(this%cg_thick) + call mem_deallocate(this%cg_thick0) + call mem_deallocate(this%cg_theta) + call mem_deallocate(this%cg_theta0) + end if + call mem_deallocate(this%cg_thickini) + call mem_deallocate(this%cg_thetaini) + ! + ! -- cell storage + call mem_deallocate(this%cell_wcstor) + call mem_deallocate(this%cell_thick) + ! + ! -- interbed storage + deallocate(this%boundname) + deallocate(this%sig0bname) + deallocate(this%auxname) + call mem_deallocate(this%auxvar) + call mem_deallocate(this%ci) + call mem_deallocate(this%rci) + call mem_deallocate(this%pcs) + !call mem_deallocate(this%thick) + !call mem_deallocate(this%theta) + call mem_deallocate(this%rnb) + call mem_deallocate(this%kv) + call mem_deallocate(this%h0) + call mem_deallocate(this%comp) + call mem_deallocate(this%tcomp) + call mem_deallocate(this%tcompi) + call mem_deallocate(this%tcompe) + call mem_deallocate(this%storagee) + call mem_deallocate(this%storagei) + call mem_deallocate(this%ske) + call mem_deallocate(this%sk) + if (this%iupdatematprop == 0) then + nullify(this%thick) + nullify(this%thick0) + nullify(this%theta) + nullify(this%theta0) + else + call mem_deallocate(this%thick) + call mem_deallocate(this%thick0) + call mem_deallocate(this%theta) + call mem_deallocate(this%theta0) + end if + call mem_deallocate(this%thickini) + call mem_deallocate(this%thetaini) + ! + ! -- delay bed storage + if (this%ndelaybeds > 0) then + if (this%iupdatematprop == 0) then + nullify(this%dbdz) + nullify(this%dbdz0) + nullify(this%dbtheta) + nullify(this%dbtheta0) + else + call mem_deallocate(this%dbdz) + call mem_deallocate(this%dbdz0) + call mem_deallocate(this%dbtheta) + call mem_deallocate(this%dbtheta0) + end if + call mem_deallocate(this%idbconvert) + call mem_deallocate(this%dbdhmax) + call mem_deallocate(this%dbz) + call mem_deallocate(this%dbrelz) + call mem_deallocate(this%dbh) + call mem_deallocate(this%dbh0) + call mem_deallocate(this%dbgeo) + call mem_deallocate(this%dbes) + call mem_deallocate(this%dbes0) + call mem_deallocate(this%dbpcs) + call mem_deallocate(this%dbflowtop) + call mem_deallocate(this%dbflowbot) + call mem_deallocate(this%dbdzini) + call mem_deallocate(this%dbthetaini) + call mem_deallocate(this%dbcomp) + call mem_deallocate(this%dbtcomp) + ! + ! -- delay interbed solution arrays + call mem_deallocate(this%dbal) + call mem_deallocate(this%dbad) + call mem_deallocate(this%dbau) + call mem_deallocate(this%dbrhs) + call mem_deallocate(this%dbdh) + call mem_deallocate(this%dbaw) + end if + ! + ! -- period data + call mem_deallocate(this%nodelistsig0) + call mem_deallocate(this%bound) + call mem_deallocate(this%auxvarsig0) + ! + ! -- pointers to gwf variables + nullify(this%gwfiss) + ! + ! -- pointers to storage variables + nullify(this%stoiconv) + nullify(this%stosc1) + ! + ! -- input table + if (this%iprpak > 0) then + call this%inputtab%table_da() + deallocate(this%inputtab) + nullify(this%inputtab) + end if + ! + ! -- output table + if (this%istrainib > 0 .or. this%istrainsk > 0) then + call this%outputtab%table_da() + deallocate(this%outputtab) + nullify(this%outputtab) + end if + end if + ! + ! -- package csv table + if (this%ipakcsv > 0) then + call this%pakcsvtab%table_da() + deallocate(this%pakcsvtab) + nullify(this%pakcsvtab) + end if + ! + ! -- deallocate scalars + call mem_deallocate(this%istounit) + call mem_deallocate(this%inobspkg) + call mem_deallocate(this%ninterbeds) + call mem_deallocate(this%maxsig0) + call mem_deallocate(this%nbound) + call mem_deallocate(this%ncolbnd) + call mem_deallocate(this%iscloc) + call mem_deallocate(this%iauxmultcol) + call mem_deallocate(this%ndelaycells) + call mem_deallocate(this%ndelaybeds) + call mem_deallocate(this%initialized) + call mem_deallocate(this%ieslag) + call mem_deallocate(this%ipch) + call mem_deallocate(this%lhead_based) + call mem_deallocate(this%iupdatestress) + call mem_deallocate(this%ispecified_pcs) + call mem_deallocate(this%ispecified_dbh) + call mem_deallocate(this%inamedbound) + call mem_deallocate(this%iconvchk) + call mem_deallocate(this%naux) + call mem_deallocate(this%istoragec) + call mem_deallocate(this%istrainib) + call mem_deallocate(this%istrainsk) + call mem_deallocate(this%ioutcomp) + call mem_deallocate(this%ioutcompi) + call mem_deallocate(this%ioutcompe) + call mem_deallocate(this%ioutcompib) + call mem_deallocate(this%ioutcomps) + call mem_deallocate(this%ioutzdisp) + call mem_deallocate(this%ipakcsv) + call mem_deallocate(this%iupdatematprop) + call mem_deallocate(this%epsilon) + call mem_deallocate(this%cc_crit) + call mem_deallocate(this%gammaw) + call mem_deallocate(this%beta) + call mem_deallocate(this%brg) + call mem_deallocate(this%satomega) + call mem_deallocate(this%icellf) + call mem_deallocate(this%gwfiss0) + ! + ! -- deallocate methods on objects + if(this%inunit > 0) then + call this%obs%obs_da() + call this%TsManager%da() + ! + ! -- deallocate objects + deallocate(this%obs) + deallocate(this%TsManager) + end if + ! + ! -- nullify TsManager + nullify(this%TsManager) + ! + ! -- deallocate parent + call this%NumericalPackageType%da() + ! + ! -- Return + return + end subroutine csub_da + + subroutine csub_read_dimensions(this) +! ****************************************************************************** +! pak1read_dimensions -- Read the dimensions for this package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH, LENBOUNDNAME + use KindModule, only: I4B +! use SimModule, only: ustop, store_error, count_errors + ! -- dummy + class(GwfCsubType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + character(len=LENBOUNDNAME) :: keyword + integer(I4B) :: ierr + logical :: isfound, endOfBlock + ! -- format +! ------------------------------------------------------------------------------ + ! + ! -- initialize dimensions to -1 + this%ninterbeds = -1 + ! + ! -- 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 '//trim(adjustl(this%name))// & + ' DIMENSIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('NINTERBEDS') + this%ninterbeds = this%parser%GetInteger() + write(this%iout,'(4x,a,i7)')'NINTERBEDS = ', this%ninterbeds + case ('MAXSIG0') + this%maxsig0 = this%parser%GetInteger() + write(this%iout,'(4x,a,i7)')'MAXSIG0 = ', this%maxsig0 + case default + write(errmsg,'(4x,a,a)') & + '****ERROR. UNKNOWN '//trim(this%name)//' DIMENSION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + end do + write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%name))//' DIMENSIONS' + else + call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') + call ustop() + end if + ! + ! -- verify dimensions were set correctly + if (this%ninterbeds < 0) then + write(errmsg, '(1x,a)') & + 'ERROR: ninterbeds WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.' + call store_error(errmsg) + end if + ! + ! -- stop if errors were encountered in the DIMENSIONS block + ierr = count_errors() + if (ierr > 0) then + call ustop() + end if + + ! -- Call define_listlabel to construct the list label that is written + ! when PRINT_INPUT option is used. + call this%define_listlabel() + ! + ! -- return + return + end subroutine csub_read_dimensions + + subroutine csub_ar(this, dis, ibound) +! ****************************************************************************** +! csub_ar -- Allocate and Read +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_setptr + use ConstantsModule, only: LINELENGTH + use KindModule, only: I4B + use InputOutputModule, only: urword, uget_block, u8rdcom, & + uterminate_block + implicit none + ! -- dummy + class(GwfCsubType),intent(inout) :: this + class(DisBaseType), pointer, intent(in) :: dis + integer(I4B), dimension(:), pointer, contiguous :: ibound + ! -- local + logical :: isfound, endOfBlock + character(len=LINELENGTH) :: line + character(len=LINELENGTH) :: errmsg + character(len=LINELENGTH) :: keyword + character(len=20) :: cellid + integer(I4B) :: iske + integer(I4B) :: istheta + integer(I4B) :: isgm + integer(I4B) :: isgs + integer(I4B) :: idelay + integer(I4B) :: ierr + integer(I4B) :: lloc + integer(I4B) :: istart + integer(I4B) :: istop + integer(I4B) :: ib + integer(I4B) :: node + integer(I4B) :: istoerr + real(DP) :: top + real(DP) :: bot + real(DP) :: thick + real(DP) :: cg_ske_cr + real(DP) :: theta + real(DP) :: v + ! -- format + character(len=*), parameter :: fmtcsub = & + "(1x,/1x,'CSUB -- COMPACTION PACKAGE, VERSION 1, 12/15/2019', & + &' INPUT READ FROM UNIT ', i0, //)" +! ------------------------------------------------------------------------------ + ! + ! --print a message identifying the csub package. + write(this%iout, fmtcsub) this%inunit + ! + ! -- store pointers to arguments that were passed in + this%dis => dis + this%ibound => ibound + ! + ! -- Create time series managers + call tsmanager_cr(this%TsManager, this%iout) + ! + ! -- create obs package + call obs_cr(this%obs, this%inobspkg) + ! + ! -- Read csub options + call this%read_options() + ! + ! -- Now that time series will have been read, need to call the df + ! routine to define the manager + call this%tsmanager%tsmanager_df() + ! + ! -- Read the csub dimensions + call this%read_dimensions() + ! + ! - observation data + call this%obs%obs_ar() + ! + ! -- terminate if errors dimensions block data + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + + ! -- Allocate arrays in + call this%csub_allocate_arrays() + ! + ! -- initialize local variables + iske = 0 + istheta = 0 + isgm = 0 + isgs = 0 + ! + ! -- read griddata block + call this%parser%GetBlock('GRIDDATA', isfound, ierr) + if (isfound) then + 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 ('CG_SKE_CR') + call this%dis%read_grid_array(line, lloc, istart, istop, & + this%iout, this%parser%iuactive, & + this%cg_ske_cr, 'CG_SKE_CR') + iske = 1 + case ('CG_THETA') + call this%dis%read_grid_array(line, lloc, istart, istop, & + this%iout, this%parser%iuactive, & + this%cg_thetaini, 'CG_THETA') + istheta = 1 + case ('SGM') + call this%dis%read_grid_array(line, lloc, istart, istop, & + this%iout, this%parser%iuactive, & + this%sgm, 'SGM') + isgm = 1 + case ('SGS') + call this%dis%read_grid_array(line, lloc, istart, istop, & + this%iout, this%parser%iuactive, & + this%sgs, 'SGS') + isgs = 1 + case default + write(errmsg,'(4x,a,a)')'ERROR. UNKNOWN GRIDDATA TAG: ', & + trim(keyword) + call store_error(errmsg) + end select + end do + else + call store_error('ERROR. REQUIRED GRIDDATA BLOCK NOT FOUND.') + end if + ! + ! -- detemine if cg_ske and cg_theta have been specified + if (iske == 0) then + write(errmsg,'(4x,a)') 'ERROR. cg_SKE GRIDDATA MUST BE SPECIFIED' + call store_error(errmsg) + end if + if (istheta == 0) then + write(errmsg,'(4x,a)') 'ERROR. cg_THETA GRIDDATA MUST BE SPECIFIED' + call store_error(errmsg) + end if + ! + ! -- determine if sgm and sgs have been specified, if not assign default values + if (isgm == 0) then + do node = 1, this%dis%nodes + this%sgm(node) = 1.7D0 + end do + end if + if (isgs == 0) then + do node = 1, this%dis%nodes + this%sgs(node) = 2.0D0 + end do + end if + ! + ! -- evaluate the coarse-grained material properties and if + ! non-zero specific storage values are specified in the + ! STO package + istoerr = 0 + do node = 1, this%dis%nodes + call this%dis%noder_to_string(node, cellid) + cg_ske_cr = this%cg_ske_cr(node) + theta = this%cg_thetaini(node) + ! + ! -- coarse-grained storage error condition + if (cg_ske_cr < DZERO) then + write(errmsg,'(4x,a,g0,a,1x,a,1x,a)') & + 'ERROR. COARSE-GRAINED MATERIAL cg_ske_cr (', cg_ske_cr, ') IS LESS', & + 'THAN ZERO IN CELL', trim(adjustl(cellid)) + end if + ! + ! -- storage (STO) package error condition + if (this%stosc1(node) /= DZERO) then + istoerr = 1 + end if + ! + ! -- porosity error condition + if (theta > DONE .or. theta < DZERO) then + write(errmsg,'(4x,a,g0,a,1x,a,1x,a)') & + 'ERROR. COARSE-GRAINED MATERIAL THETA (', theta, ') IS LESS', & + 'THAN ZERO OR GREATER THAN 1 IN CELL', trim(adjustl(cellid)) + end if + end do + ! + ! -- write single message if storage (STO) package has non-zero specific + ! storage values + if (istoerr /= 0) then + write(errmsg,'(4x,a,3(1x,a))') & + 'ERROR. SPECIFIC STORAGE VALUES IN THE STORAGE (STO) PACKAGE MUST', & + 'BE ZERO IN ALL ACTIVE CELLS WHEN USING THE', trim(adjustl(this%name)), & + 'PACKAGE' + call store_error(errmsg) + end if + ! + ! -- read interbed data + if (this%ninterbeds > 0) then + call this%csub_read_packagedata() + end if + ! + ! -- calculate the coarse-grained material thickness without the interbeds + do node = 1, this%dis%nodes + top = this%dis%top(node) + bot = this%dis%bot(node) + this%cg_thickini(node) = top - bot + this%cell_thick(node) = top - bot + end do + ! + ! -- subtract the interbed thickness from aquifer thickness + do ib = 1, this%ninterbeds + node = this%nodelist(ib) + idelay = this%idelay(ib) + if (idelay == 0) then + v = this%thickini(ib) + else + v = this%rnb(ib) * this%thickini(ib) + end if + this%cg_thickini(node) = this%cg_thickini(node) - v + end do + ! + ! -- evaluate if any cg_thick values are less than 0 + do node = 1, this%dis%nodes + thick = this%cg_thickini(node) + if (thick < DZERO) then + call this%dis%noder_to_string(node, cellid) + write(errmsg,'(4x,a,1x,g0,a,1x,a,1x,a)') & + 'ERROR. AQUIFER THICKNESS IS LESS THAN ZERO (', & + thick, ')', 'in cell', trim(adjustl(cellid)) + call store_error(errmsg) + end if + end do + ! + ! -- terminate if errors griddata, packagedata blocks, TDIS, or STO data + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- set current coarse-grained thickness (cg_thick) and + ! current coarse-grained porosity (cg_theta). Only needed + ! if updating material properties + if (this%iupdatematprop /= 0) then + do node = 1, this%dis%nodes + this%cg_thick(node) = this%cg_thickini(node) + this%cg_theta(node) = this%cg_thetaini(node) + end do + end if + ! + ! -- return + return + end subroutine csub_ar + + + subroutine csub_cg_calc_stress(this, nodes, hnew) +! ****************************************************************************** +! csub_cg_calc_stress -- calculate the geostatic stress for every gwf node +! in the model +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + class(GwfCsubType) :: this + integer(I4B), intent(in) :: nodes + real(DP), dimension(nodes), intent(in) :: hnew + ! -- local + integer(I4B) :: node + integer(I4B) :: ii + integer(I4B) :: nn + integer(I4B) :: m + integer(I4B) :: iis + real(DP) :: gs + real(DP) :: top + real(DP) :: bot + real(DP) :: thick + real(DP) :: va_scale + real(DP) :: hcell + real(DP) :: gs_conn + real(DP) :: area_node + real(DP) :: area_conn + real(DP) :: es + real(DP) :: hs + real(DP) :: hwva + real(DP) :: sadd + +! ------------------------------------------------------------------------------ + ! + ! -- calculate geostatic stress if necessary + if (this%iupdatestress /= 0) then + do node = 1, this%dis%nodes + ! + ! -- calculate geostatic stress for this node + ! this represents the geostatic stress component + ! for the cell + top = this%dis%top(node) + bot = this%dis%bot(node) + thick = top - bot + ! + ! -- calculate cell contribution to geostatic stress + if (this%ibound(node) /= 0) then + hcell = hnew(node) + else + hcell = bot + end if + if (hcell < bot) then + gs = thick * this%sgm(node) + else if (hcell < top) then + gs = (top - hcell) * this%sgm(node) + (hcell - bot) * this%sgs(node) + else + gs = thick * this%sgs(node) + end if + ! + ! -- cell contribution to geostatic stress + this%cg_gs(node) = gs + end do + ! + ! -- add user specified overlying geostatic stress + do nn = 1, this%nbound + node = this%nodelistsig0(nn) + sadd = this%bound(1, nn) + this%cg_gs(node) = this%cg_gs(node) + sadd + end do + ! + ! -- calculate geostatic stress above cell + do node = 1, this%dis%nodes + ! + ! -- area of cell + area_node = this%dis%get_area(node) + ! + ! -- geostatic stress of cell + gs = this%cg_gs(node) + ! + ! -- Add geostatic stress of overlying cells (ihc=0) + ! m < node = m is vertically above node + do ii = this%dis%con%ia(node) + 1, this%dis%con%ia(node + 1) - 1 + ! + ! -- Set the m cell number + m = this%dis%con%ja(ii) + iis = this%dis%con%jas(ii) + ! + ! -- vertical connection + if (this%dis%con%ihc(iis) == 0) then + ! + ! -- node has an overlying cell + if (m < node) then + ! + ! -- dis and disv discretization + if (this%dis%ndim /= 1) then + gs = gs + this%cg_gs(m) + ! + ! -- disu discretization + ! *** this needs to be checked *** + else + area_conn = this%dis%get_area(m) + hwva = this%dis%con%hwva(iis) + va_scale = this%dis%con%hwva(iis) / this%dis%get_area(m) + gs_conn = this%cg_gs(m) + gs = gs + (gs_conn * va_scale) + end if + + end if + end if + end do + ! + ! -- geostatic stress for cell with geostatic stress + ! of overlying cells + this%cg_gs(node) = gs + end do + end if + ! + ! -- save effective stress from the last iteration and + ! calculate the new effective stress for a cell + do node = 1, this%dis%nodes + top = this%dis%top(node) + bot = this%dis%bot(node) + if (this%ibound(node) /= 0) then + hcell = hnew(node) + if (hcell < bot) then + hcell = bot + end if + else + hcell = bot + end if + hs = hcell - bot + ! + ! -- calculate effective stress + es = this%cg_gs(node) - hs + this%cg_es(node) = es + end do + ! + ! -- return + return + + end subroutine csub_cg_calc_stress + + + subroutine csub_cg_chk_stress(this) +! ****************************************************************************** +! csub_cg_chk_stress -- check that the effective stress for every gwf node +! in the model is a positive value +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + class(GwfCsubType) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + character(len=20) :: cellid + integer(I4B) :: ierr + integer(I4B) :: node + real(DP) :: gs + real(DP) :: bot + real(DP) :: hcell + real(DP) :: es + real(DP) :: u + +! ------------------------------------------------------------------------------ + ! + ! -- initialize variables + ierr = 0 + ! + ! -- check geostatic stress if necessary + ! + ! -- save effective stress from the last iteration and + ! calculate the new effective stress for a cell + do node = 1, this%dis%nodes + if (this%ibound(node) < 1) cycle + bot = this%dis%bot(node) + gs = this%cg_gs(node) + es = this%cg_es(node) + u = DZERO + if (this%ibound(node) /= 0) then + u = gs - es + end if + hcell = u + bot + if (this%lhead_based .EQV. .FALSE.) then + if (es < DEM6) then + ierr = ierr + 1 + call this%dis%noder_to_string(node, cellid) + write(errmsg, '(a,g0.7,a,1x,a)') & + 'ERROR: SMALL TO NEGATIVE EFFECTIVE STRESS (', es, ') IN CELL', & + trim(adjustl(cellid)) + call store_error(errmsg) + write(errmsg, '(4x,a,1x,g0.7,3(1x,a,1x,g0.7),1x,a)') & + '(', es, '=', this%cg_gs(node), '- (', hcell, '-', bot, ')' + call store_error(errmsg) + end if + end if + end do + ! + ! -- write a summary error message + if (ierr > 0) then + write(errmsg, '(a,1x,i0,3(1x,a))') & + 'ERROR SOLUTION: SMALL TO NEGATIVE EFFECTIVE STRESS VALUES IN', ierr, & + 'CELLS CAN BE ELIMINATED BY INCREASING STORAGE VALUES AND/OR ', & + 'ADDING/MODIFYINGSTRESS BOUNDARIES TO PREVENT WATER-LEVELS FROM', & + 'EXCEEDING THE TOP OF THE MODEL' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- return + return + + end subroutine csub_cg_chk_stress + + + subroutine csub_nodelay_update(this, i) +! ****************************************************************************** +! csub_nodelay_update -- Update material properties for no-delay interbeds. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + integer(I4B),intent(in) :: i + ! locals + character(len=LINELENGTH) :: errmsg + real(DP) :: comp + real(DP) :: thick + real(DP) :: theta +! ------------------------------------------------------------------------------ +! +! -- update thickness and theta + comp = this%tcomp(i) + this%comp(i) + if (ABS(comp) > DZERO) then + thick = this%thickini(i) + theta = this%thetaini(i) + call this%csub_adj_matprop(comp, thick, theta) + if (thick <= DZERO) then + write(errmsg,'(4x,2a,1x,i0,1x,a,1x,g0,1x,a)') & + '****ERROR. ADJUSTED THICKNESS FOR NO-DELAY ', & + 'INTERBED', i, 'IS <= 0 (', thick, ')' + call store_error(errmsg) + end if + if (theta <= DZERO) then + write(errmsg,'(4x,2a,1x,i0,1x,a,1x,g0,1x,a)') & + '****ERROR. ADJUSTED THETA FOR NO-DELAY ', & + 'INTERBED (', i, ') IS <= 0 (', theta, ')' + call store_error(errmsg) + end if + this%thick(i) = thick + this%theta(i) = theta + end if + ! + ! -- return + return + end subroutine csub_nodelay_update + + + subroutine csub_nodelay_fc(this, ib, hcell, hcellold, rho1, rho2, rhs, & + argtled) +! ****************************************************************************** +! csub_nodelay_fc -- Calculate rho1, rho2, and rhs for no-delay interbeds +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use TdisModule, only: delt + implicit none + ! -- dummy variables + class(GwfCsubType) :: this + integer(I4B), intent(in) :: ib + real(DP), intent(in) :: hcell + real(DP), intent(in) :: hcellold + real(DP), intent(inout) :: rho1 + real(DP), intent(inout) :: rho2 + real(DP), intent(inout) :: rhs + real(DP), intent(in), optional :: argtled + ! -- local variables + integer(I4B) :: node + real(DP) :: tled + real(DP) :: top + real(DP) :: bot + real(DP) :: thick + real(DP) :: znode + real(DP) :: snold + real(DP) :: snnew + real(DP) :: sto_fac + real(DP) :: sto_fac0 + real(DP) :: area + real(DP) :: theta + real(DP) :: es + real(DP) :: es0 + real(DP) :: f + real(DP) :: f0 +! ------------------------------------------------------------------------------ + if (present(argtled)) then + tled = argtled + else + tled = DONE / delt + endif + node = this%nodelist(ib) + area = this%dis%get_area(node) + bot = this%dis%bot(node) + top = this%dis%top(node) + thick = this%thickini(ib) + ! + ! -- set iconvert + this%iconvert(ib) = 0 + ! + ! -- aquifer saturation + call this%csub_calc_sat(node, hcell, hcellold, snnew, snold) + if (this%lhead_based .EQV. .TRUE.) then + f = DONE + f0 = DONE + else + znode = this%csub_calc_znode(top, bot, hcell) + es = this%cg_es(node) + es0 = this%cg_es0(node) + theta = this%thetaini(ib) + ! + ! -- calculate the compression index factors for the delay + ! node relative to the center of the cell based on the + ! current and previous head + call this%csub_calc_sfacts(node, bot, znode, theta, es, es0, f) + end if + sto_fac = tled * snnew * thick * f + sto_fac0 = tled * snold * thick * f + ! + ! -- calculate rho1 and rho2 + rho1 = this%rci(ib) * sto_fac0 + rho2 = this%rci(ib) * sto_fac + if (this%cg_es(node) > this%pcs(ib)) then + this%iconvert(ib) = 1 + rho2 = this%ci(ib) * sto_fac + end if + if (this%ielastic(ib) /= 0) then + rhs = rho1 * this%cg_es0(node) - & + rho2 * (this%cg_gs(node) + bot) + else + rhs = -rho2 * (this%cg_gs(node) + bot) + & + (this%pcs(ib) * (rho2 - rho1)) + & + (rho1 * this%cg_es0(node)) + end if + ! + ! -- save ske and sk + this%ske(ib) = rho1 + this%sk(ib) = rho2 + ! + ! -- return + return + + end subroutine csub_nodelay_fc + + subroutine csub_nodelay_calc_comp(this, ib, hcell, hcellold, comp, rho1, rho2) +! ****************************************************************************** +! csub_nodelay_calc_comp -- Calculate compaction, rho1, and rho2 for no-delay +! interbeds +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + ! -- dummy variables + class(GwfCsubType) :: this + integer(I4B), intent(in) :: ib + real(DP), intent(in) :: hcell + real(DP), intent(in) :: hcellold + real(DP), intent(inout) :: comp + real(DP), intent(inout) :: rho1 + real(DP), intent(inout) :: rho2 + ! -- local variables + integer(I4B) :: node + real(DP) :: es + real(DP) :: es0 + real(DP) :: pcs + real(DP) :: tled + real(DP) :: rhs +! ------------------------------------------------------------------------------ + ! + ! -- initialize variables + node = this%nodelist(ib) + tled = DONE + es = this%cg_es(node) + es0 = this%cg_es0(node) + pcs = this%pcs(ib) + ! + ! -- calculate no-delay interbed rho1 and rho2 + call this%csub_nodelay_fc(ib, hcell, hcellold, rho1, rho2, rhs, argtled=tled) + ! + ! -- calculate no-delay interbed compaction + if (this%ielastic(ib) /= 0) then + comp = rho2 * es - rho1 * es0 + else + comp = -pcs * (rho2 - rho1) - (rho1 * es0) + (rho2 * es) + end if + ! + ! -- return + return + + end subroutine csub_nodelay_calc_comp + + + subroutine csub_rp(this) +! ****************************************************************************** +! csub_rp -- Read and Prepare +! Subroutine: (1) read itmp +! (2) read new boundaries if itmp>0 +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use TdisModule, only: kper, nper +! use SimModule, only: store_error, ustop, count_errors + implicit none + ! -- dummy + class(GwfCsubType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: line, errmsg + integer(I4B) :: ierr + integer(I4B) :: nlist + logical :: isfound + ! -- formats + character(len=*),parameter :: fmtblkerr = & + "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + character(len=*),parameter :: fmtlsp = & + "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" +! ------------------------------------------------------------------------------ + ! + if(this%inunit == 0) return + ! + ! -- get stress period data + if (this%ionper < kper) then + ! + ! -- get period block + call this%parser%GetBlock('PERIOD', isfound, ierr, & + supportOpenClose=.true.) + if (isfound) then + ! + ! -- read ionper and check for increasing period numbers + call this%read_check_ionper() + else + ! + ! -- PERIOD block not found + if (ierr < 0) then + ! -- End of file found; data applies for remainder of simulation. + this%ionper = nper + 1 + else + ! -- Found invalid block + call this%parser%GetCurrentLine(line) + write(errmsg, fmtblkerr) adjustl(trim(line)) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end if + endif + end if + ! + ! -- read data if ionper == kper + if(this%ionper == kper) then + nlist = -1 + ! -- Remove all time-series and time-array-series links associated with + ! this package. + call this%TsManager%Reset(this%name) + ! + ! -- Read data as a list + call this%dis%read_list(this%parser%iuactive, this%iout, & + this%iprpak, nlist, this%inamedbound, & + this%iauxmultcol, this%nodelistsig0, & + this%bound, this%auxvarsig0, this%auxname, & + this%sig0bname, this%listlabel, & + this%name, this%tsManager, this%iscloc) + this%nbound = nlist + ! + ! Define the tsLink%Text value(s) appropriately. + ! E.g. for CSUB package, entry 1, assign tsLink%Text = 'SIG0' + call this%csub_rp_ts() + ! + ! -- Terminate the block + call this%parser%terminateblock() + ! + else + write(this%iout,fmtlsp) trim(this%filtyp) + endif + + ! + ! -- terminate if errors encountered in reach block + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- read observations + call this%csub_rp_obs() + ! + ! -- return + return + end subroutine csub_rp + + subroutine csub_ad(this, nodes, hnew) +! ****************************************************************************** +! csub_ad -- Advance csub data +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use TdisModule, only: nper, kper + ! -- dummy + class(GwfCsubType) :: this + integer(I4B), intent(in) :: nodes + real(DP), dimension(nodes), intent(in) :: hnew + ! -- local + character(len=LINELENGTH) :: errmsg + integer(I4B) :: ib + integer(I4B) :: n + integer(I4B) :: idelay + integer(I4B) :: node + real(DP) :: h + real(DP) :: es + real(DP) :: pcs +! ------------------------------------------------------------------------------ + ! + ! -- evaluate if steady-state stress periods are specified for more + ! than the first and last stress period if interbeds are simulated + if (this%ninterbeds > 0) then + if (kper > 1 .and. kper < nper) then + if (this%gwfiss /= 0) then + write(errmsg, '(1x,a,i0,a,1x,a,1x,a,1x,i0,1x,a)') & + 'ERROR: Only the first and last (', nper, ')', & + 'stress period can be steady if interbeds are simulated.', & + 'Stress period', kper, 'has been defined to be steady state.' + call store_error(errmsg) + call ustop() + end if + end if + end if + ! + ! -- set initial states + if (this%initialized == 0) then + if (this%gwfiss == 0) then + call this%csub_set_initial_state(nodes, hnew) + end if + end if + ! + ! -- update state variables + ! + ! -- coarse-grained materials + do node = 1, nodes + this%cg_comp(node) = DZERO + this%cg_es0(node) = this%cg_es(node) + if (this%iupdatematprop /= 0) then + this%cg_thick0(node) = this%cg_thick(node) + this%cg_theta0(node) = this%cg_theta(node) + end if + end do + ! + ! -- interbeds + do ib = 1, this%ninterbeds + idelay = this%idelay(ib) + ! + ! -- update common terms for no-delay and delay interbeds + this%comp(ib) = DZERO + node = this%nodelist(ib) + if (this%initialized /= 0) then + es = this%cg_es(node) + pcs = this%pcs(ib) + if (es > pcs) then + this%pcs(ib) = es + end if + end if + if (this%iupdatematprop /= 0) then + this%thick0(ib) = this%thick(ib) + this%theta0(ib) = this%theta(ib) + end if + ! + ! -- update delay interbed terms + if (idelay /= 0) then + ! + ! -- update state if previous period was steady state + if (kper > 1) then + if (this%gwfiss0 /= 0) then + node = this%nodelist(ib) + h = hnew(node) + do n = 1, this%ndelaycells + this%dbh(n, idelay) = h + end do + end if + end if + ! + ! -- update preconsolidation stress, stresses, head, dbdz0, and theta0 + do n = 1, this%ndelaycells + ! update preconsolidation stress + if (this%initialized /= 0) then + if (this%dbes(n, idelay) > this%dbpcs(n, idelay)) then + this%dbpcs(n, idelay) = this%dbes(n, idelay) + end if + end if + this%dbh0(n, idelay) = this%dbh(n, idelay) + this%dbes0(n, idelay) = this%dbes(n, idelay) + if (this%iupdatematprop /= 0) then + this%dbdz0(n, idelay) = this%dbdz(n, idelay) + this%dbtheta0(n, idelay) = this%dbtheta(n, idelay) + end if + end do + end if + end do + ! + ! -- set gwfiss0 + this%gwfiss0 = this%gwfiss + ! + ! -- Advance the time series managers + call this%TsManager%ad() + ! + ! -- For each observation, push simulated value and corresponding + ! simulation time from "current" to "preceding" and reset + ! "current" value. + call this%obs%obs_ad() + ! + ! -- return + return + end subroutine csub_ad + + subroutine csub_set_initial_state(this, nodes, hnew) +! ****************************************************************************** +! csub_set_initial_state -- Set initial state for coarse-grained materials +! and interbeds +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType) :: this + integer(I4B), intent(in) :: nodes + real(DP), dimension(nodes), intent(in) :: hnew + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: tag + character(len=20) :: cellid + character (len=LINELENGTH) :: errmsg + integer(I4B) :: ib + integer(I4B) :: node + integer(I4B) :: n + integer(I4B) :: idelay + integer(I4B) :: ntabrows + integer(I4B) :: ntabcols + real(DP) :: pcs0 + real(DP) :: pcs + real(DP) :: fact + real(DP) :: top + real(DP) :: bot + real(DP) :: void + real(DP) :: es + real(DP) :: znode + real(DP) :: hcell + real(DP) :: dzhalf + real(DP) :: zbot + real(DP) :: dbpcs +! ------------------------------------------------------------------------------ + ! + ! -- update geostatic load calculation + call this%csub_cg_calc_stress(nodes, hnew) + ! + ! -- initialize coarse-grained material effective stress + ! for the previous time step and the previous iteration + do node = 1, nodes + this%cg_es0(node) = this%cg_es(node) + end do + ! + ! -- check that aquifer head is greater than or equal to the + ! top of each delay interbed + do ib = 1, this%ninterbeds + idelay = this%idelay(ib) + if (idelay == 0) then + cycle + end if + node = this%nodelist(ib) + hcell = hnew(node) + call this%csub_delay_chk(ib, hcell) + end do + ! + ! -- initialize interbed initial states + do ib = 1, this%ninterbeds + idelay = this%idelay(ib) + node = this%nodelist(ib) + top = this%dis%top(node) + bot = this%dis%bot(node) + hcell = hnew(node) + pcs = this%pcs(ib) + pcs0 = pcs + if (this%ispecified_pcs == 0) then + ! relative pcs...subtract head (u) from sigma' + if (this%ipch /= 0) then + pcs = this%cg_es(node) - pcs0 + else + pcs = this%cg_es(node) + pcs0 + end if + else + ! specified pcs...substract head (u) from sigma + if (this%ipch /= 0) then + pcs = this%cg_gs(node) - (pcs0 - bot) + end if + if (pcs < this%cg_es(node)) then + pcs = this%cg_es(node) + end if + end if + this%pcs(ib) = pcs + ! + ! -- delay bed initial states + if (idelay /= 0) then + dzhalf = DHALF * this%dbdzini(1, idelay) + ! + ! -- fill delay bed head with aquifer head or offset from aquifer head + ! heads need to be filled first since used to calculate + ! the effective stress for each delay bed + do n = 1, this%ndelaycells + if (this%ispecified_dbh == 0) then + this%dbh(n, idelay) = hcell + this%dbh(n, idelay) + else + this%dbh(n, idelay) = hcell + end if + this%dbh0(n, idelay) = this%dbh(n, idelay) + end do + ! + ! -- fill delay bed effective stress + call this%csub_delay_calc_stress(ib, hcell) + ! + ! -- fill delay bed pcs + pcs = this%pcs(ib) + do n = 1, this%ndelaycells + zbot = this%dbz(n, idelay) - dzhalf + ! -- adjust pcs to bottom of each delay bed cell + ! not using csub_calc_adjes() since smoothing not required + dbpcs = pcs - (zbot - bot) * (this%sgs(node) - DONE) + this%dbpcs(n, idelay) = dbpcs + ! + ! -- initialize effective stress for previous time step + this%dbes0(n, idelay) = this%dbes(n, idelay) + end do + end if + end do + ! + ! -- scale coarse-grained materials cr + do node = 1, nodes + top = this%dis%top(node) + bot = this%dis%bot(node) + ! + ! -- user-specified specific storage + if (this%istoragec == 1) then + ! + ! -- retain specific storage values since they are constant + if (this%lhead_based .EQV. .TRUE.) then + fact = DONE + ! + ! -- convert specific storage values since they are simulated to + ! be a function of the average effective stress + else + void = this%csub_calc_void(this%cg_theta(node)) + es = this%cg_es(node) + hcell = hnew(node) + znode = this%csub_calc_znode(top, bot, hcell) + fact = this%csub_calc_adjes(node, es, bot, znode) + fact = fact * (DONE + void) + end if + ! + ! -- user-specified compression indices - multiply by dlog10es + else + fact = dlog10es + end if + this%cg_ske_cr(node) = this%cg_ske_cr(node) * fact + ! + ! -- write error message if negative compression indices + if (fact <= DZERO) then + call this%dis%noder_to_string(node, cellid) + write(errmsg,'(4x,a,1x,a)') & + '****ERROR. NEGATIVE RECOMPRESSION INDEX CALCULATED FOR CELL', & + trim(adjustl(cellid)) + call store_error(errmsg) + end if + end do + ! + ! -- scale interbed cc and cr + do ib = 1, this%ninterbeds + idelay = this%idelay(ib) + node = this%nodelist(ib) + top = this%dis%top(node) + bot = this%dis%bot(node) + ! + ! -- user-specified specific storage + if (this%istoragec == 1) then + ! + ! -- retain specific storage values since they are constant + if (this%lhead_based .EQV. .TRUE.) then + fact = DONE + ! + ! -- convert specific storage values since they are simulated to + ! be a function of the average effective stress + else + void = this%csub_calc_void(this%theta(ib)) + es = this%cg_es(node) + hcell = hnew(node) + znode = this%csub_calc_znode(top, bot, hcell) + fact = this%csub_calc_adjes(node, es, bot, znode) + fact = fact * (DONE + void) + end if + ! + ! -- user-specified compression indices - multiply by dlog10es + else + fact = dlog10es + end if + this%ci(ib) = this%ci(ib) * fact + this%rci(ib) = this%rci(ib) * fact + ! + ! -- write error message if negative compression indices + if (fact <= DZERO) then + call this%dis%noder_to_string(node, cellid) + write(errmsg,'(4x,a,1x,i0,2(1x,a))') & + '****ERROR. NEGATIVE COMPRESSION INDICES CALCULATED FOR INTERBED', & + ib, 'IN CELL', trim(adjustl(cellid)) + call store_error(errmsg) + end if + end do + ! + ! -- write current stress and initial preconsolidation stress + if (this%iprpak == 1) then + ! -- set title + title = trim(adjustl(this%name)) // & + ' PACKAGE CALCULATED INITIAL INTERBED STRESSES AT THE CELL BOTTOM' + ! + ! -- determine the number of columns and rows + ntabrows = this%ninterbeds + ntabcols = 5 + if (this%inamedbound /= 0) then + ntabcols = ntabcols + 1 + end if + ! + ! -- setup table + call table_cr(this%inputtab, this%name, title) + call this%inputtab%table_df(ntabrows, ntabcols, this%iout) + ! + ! add columns + tag = 'INTERBED NUMBER' + call this%inputtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'CELLID' + call this%inputtab%initialize_column(tag, 20) + tag = 'GEOSTATIC STRESS' + call this%inputtab%initialize_column(tag, 16) + tag = 'EFFECTIVE STRESS' + call this%inputtab%initialize_column(tag, 16) + tag = 'PRECONSOLIDATION STRESS' + call this%inputtab%initialize_column(tag, 16) + if (this%inamedbound /= 0) then + tag = 'BOUNDNAME' + call this%inputtab%initialize_column(tag, LENBOUNDNAME, & + alignment=TABLEFT) + end if + ! + ! -- write the data + do ib = 1, this%ninterbeds + node = this%nodelist(ib) + call this%dis%noder_to_string(node, cellid) + ! + ! -- write the columns + call this%inputtab%add_term(ib) + call this%inputtab%add_term(cellid) + call this%inputtab%add_term(this%cg_gs(node)) + call this%inputtab%add_term(this%cg_es(node)) + call this%inputtab%add_term(this%pcs(ib)) + if (this%inamedbound /= 0) then + call this%inputtab%add_term(this%boundname(ib)) + end if + end do + ! + ! -- write effective stress and preconsolidation stress + ! for delay beds + ! -- set title + title = trim(adjustl(this%name)) // & + ' PACKAGE CALCULATED INITIAL DELAY INTERBED STRESSES' + ! + ! -- determine the number of columns and rows + ntabrows = 0 + do ib = 1, this%ninterbeds + idelay = this%idelay(ib) + if (idelay /= 0) then + ntabrows = ntabrows + this%ndelaycells + end if + end do + ntabcols = 6 + if (this%inamedbound /= 0) then + ntabcols = ntabcols + 1 + end if + ! + ! -- setup table + call table_cr(this%inputtab, this%name, title) + call this%inputtab%table_df(ntabrows, ntabcols, this%iout) + ! + ! add columns + tag = 'INTERBED NUMBER' + call this%inputtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'CELLID' + call this%inputtab%initialize_column(tag, 20) + tag = 'DELAY CELL' + call this%inputtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'GEOSTATIC STRESS' + call this%inputtab%initialize_column(tag, 16) + tag = 'EFFECTIVE STRESS' + call this%inputtab%initialize_column(tag, 16) + tag = 'PRECONSOLIDATION STRESS' + call this%inputtab%initialize_column(tag, 16) + if (this%inamedbound /= 0) then + tag = 'BOUNDNAME' + call this%inputtab%initialize_column(tag, LENBOUNDNAME, & + alignment=TABLEFT) + end if + ! + ! -- write the data + do ib = 1, this%ninterbeds + idelay = this%idelay(ib) + if (idelay /= 0) then + node = this%nodelist(ib) + call this%dis%noder_to_string(node, cellid) + ! + ! -- write the columns + do n = 1, this%ndelaycells + if (n == 1) then + call this%inputtab%add_term(ib) + call this%inputtab%add_term(cellid) + else + call this%inputtab%add_term(' ') + call this%inputtab%add_term(' ') + end if + call this%inputtab%add_term(n) + call this%inputtab%add_term(this%dbgeo(n, idelay)) + call this%inputtab%add_term(this%dbes(n, idelay)) + call this%inputtab%add_term(this%dbpcs(n, idelay)) + if (this%inamedbound /= 0) then + if (n == 1) then + call this%inputtab%add_term(this%boundname(ib)) + else + call this%inputtab%add_term(' ') + end if + end if + end do + end if + end do + ! + ! -- write calculated compression indices + if (this%istoragec == 1) then + if (this%lhead_based .EQV. .FALSE.) then + ! -- set title + title = trim(adjustl(this%name)) // & + ' PACKAGE COMPRESSION INDICES' + ! + ! -- determine the number of columns and rows + ntabrows = this%ninterbeds + ntabcols = 4 + if (this%inamedbound /= 0) then + ntabcols = ntabcols + 1 + end if + ! + ! -- setup table + call table_cr(this%inputtab, this%name, title) + call this%inputtab%table_df(ntabrows, ntabcols, this%iout) + ! + ! add columns + tag = 'INTERBED NUMBER' + call this%inputtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'CELLID' + call this%inputtab%initialize_column(tag, 20) + tag = 'CC' + call this%inputtab%initialize_column(tag, 16) + tag = 'CR' + call this%inputtab%initialize_column(tag, 16) + if (this%inamedbound /= 0) then + tag = 'BOUNDNAME' + call this%inputtab%initialize_column(tag, LENBOUNDNAME, & + alignment=TABLEFT) + end if + ! + ! -- write the data + do ib = 1, this%ninterbeds + fact = DONE / dlog10es + node = this%nodelist(ib) + call this%dis%noder_to_string(node, cellid) + ! + ! -- write the columns + call this%inputtab%add_term(ib) + call this%inputtab%add_term(cellid) + call this%inputtab%add_term(this%ci(ib) * fact) + call this%inputtab%add_term(this%rci(ib) * fact) + if (this%inamedbound /= 0) then + call this%inputtab%add_term(this%boundname(ib)) + end if + end do + end if + end if + end if + ! + ! -- terminate if any initialization errors have been detected + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- set initialized + this%initialized = 1 + ! + ! -- set flag to retain initial stresses for entire simulation + if (this%lhead_based .EQV. .TRUE.) then + this%iupdatestress = 0 + end if + ! + ! -- return + return + end subroutine csub_set_initial_state + + subroutine csub_fc(this, kiter, hold, hnew, njasln, amat, idxglo, rhs) +! ****************************************************************************** +! csub_fc -- Fill the solution amat and rhs with storage contribution terms +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use TdisModule, only: delt + ! -- dummy + class(GwfCsubType) :: this + integer(I4B),intent(in) :: kiter + real(DP), intent(in), dimension(:) :: hold + real(DP), intent(in), dimension(:) :: hnew + integer(I4B),intent(in) :: njasln + real(DP), dimension(njasln),intent(inout) :: amat + integer(I4B), intent(in),dimension(:) :: idxglo + real(DP),intent(inout),dimension(:) :: rhs + ! -- local + integer(I4B) :: ib + integer(I4B) :: node + integer(I4B) :: idiag + integer(I4B) :: idelay + real(DP) :: tled + real(DP) :: area + real(DP) :: hcell + real(DP) :: hcof + real(DP) :: rhsterm + real(DP) :: comp +! ------------------------------------------------------------------------------ + ! + ! -- update geostatic load calculation + call this%csub_cg_calc_stress(this%dis%nodes, hnew) + ! + ! -- formulate csub terms + if (this%gwfiss == 0) then + ! + ! -- initialize tled + tled = DONE / delt + ! + ! -- coarse-grained storage + do node = 1, this%dis%nodes + idiag = this%dis%con%ia(node) + area = this%dis%get_area(node) + ! + ! -- skip inactive cells + if (this%ibound(node) < 1) cycle + ! + ! -- update coarse-grained material properties + if (this%iupdatematprop /= 0) then + if (this%ieslag == 0) then + ! + ! -- calculate compaction + call this%csub_cg_calc_comp(node, hnew(node), hold(node), comp) + this%cg_comp(node) = comp + ! + ! -- update coarse-grained thickness and void ratio + call this%csub_cg_update(node) + end if + end if + ! + ! -- calculate coarse-grained storage terms + call this%csub_cg_fc(node, tled, area, hnew(node), hold(node), & + hcof, rhsterm) + ! + ! -- add coarse-grained storage terms to amat and rhs for coarse-grained storage + amat(idxglo(idiag)) = amat(idxglo(idiag)) + hcof + rhs(node) = rhs(node) + rhsterm + ! + ! -- calculate coarse-grained water compressibility + ! storage terms + if (this%brg /= DZERO) then + call this%csub_cg_wcomp_fc(node, tled, area, hnew(node), hold(node), & + hcof, rhsterm) + ! + ! -- add water compression storage terms to amat and rhs for + ! coarse-grained storage + amat(idxglo(idiag)) = amat(idxglo(idiag)) + hcof + rhs(node) = rhs(node) + rhsterm + end if + end do + ! + ! -- interbed storage + if (this%ninterbeds /= 0) then + ! + ! -- check that aquifer head is greater than or equal to the + ! top of each delay interbed + do ib = 1, this%ninterbeds + idelay = this%idelay(ib) + if (idelay == 0) then + cycle + end if + node = this%nodelist(ib) + hcell = hnew(node) + call this%csub_delay_chk(ib, hcell) + end do + ! + ! -- terminate if the aquifer head is below the top of delay interbeds + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- calculate the contribution of interbeds to the + ! groundwater flow equation + do ib = 1, this%ninterbeds + node = this%nodelist(ib) + idiag = this%dis%con%ia(node) + area = this%dis%get_area(node) + call this%csub_interbed_fc(ib, node, area, hnew(node), hold(node), & + hcof, rhsterm) + amat(idxglo(idiag)) = amat(idxglo(idiag)) + hcof + rhs(node) = rhs(node) + rhsterm + ! + ! -- calculate interbed water compressibility terms + if (this%brg /= DZERO) then + call this%csub_interbed_wcomp_fc(ib, node, tled, area, & + hnew(node), hold(node), & + hcof, rhsterm) + ! + ! -- add water compression storage terms to amat and rhs for interbed + amat(idxglo(idiag)) = amat(idxglo(idiag)) + hcof + rhs(node) = rhs(node) + rhsterm + end if + end do + end if + end if + ! + ! -- terminate if the head in the cell is below the top of the cell for + ! non-convertible cells or top of the interbed for delay beds or if + ! errors encountered when updating material properties + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- return + return + end subroutine csub_fc + + subroutine csub_fn(this, kiter, hold, hnew, njasln, amat, idxglo, rhs) +! ****************************************************************************** +! csub_fn -- Fill the solution amat and rhs with csub contribution newton +! term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use TdisModule, only: delt + ! -- dummy + class(GwfCsubType) :: this + integer(I4B),intent(in) :: kiter + real(DP), intent(in), dimension(:) :: hold + real(DP), intent(in), dimension(:) :: hnew + integer(I4B),intent(in) :: njasln + real(DP), dimension(njasln),intent(inout) :: amat + integer(I4B), intent(in),dimension(:) :: idxglo + real(DP),intent(inout),dimension(:) :: rhs + ! -- local + integer(I4B) :: node + integer(I4B) :: idiag + integer(I4B) :: ib + real(DP) :: tled + real(DP) :: area + real(DP) :: hcof + real(DP) :: rhsterm +! ------------------------------------------------------------------------------ + ! + ! -- formulate csub terms + if (this%gwfiss == 0) then + tled = DONE / delt + ! + ! -- coarse-grained storage + do node = 1, this%dis%nodes + idiag = this%dis%con%ia(node) + area = this%dis%get_area(node) + ! + ! -- skip inactive cells + if (this%ibound(node) < 1) cycle + ! + ! -- calculate coarse-grained storage newton terms + call this%csub_cg_fn(node, tled, area, & + hnew(node), hcof, rhsterm) + ! + ! -- add coarse-grained storage newton terms to amat and rhs for + ! coarse-grained storage + amat(idxglo(idiag)) = amat(idxglo(idiag)) + hcof + rhs(node) = rhs(node) + rhsterm + ! + ! -- calculate coarse-grained water compressibility storage + ! newton terms + if (this%brg /= DZERO) then + call this%csub_cg_wcomp_fn(node, tled, area, hnew(node), hold(node), & + hcof, rhsterm) + ! + ! -- add water compression storage newton terms to amat and rhs for + ! coarse-grained storage + amat(idxglo(idiag)) = amat(idxglo(idiag)) + hcof + rhs(node) = rhs(node) + rhsterm + end if + end do + ! + ! -- interbed storage + if (this%ninterbeds /= 0) then + ! + ! -- calculate the interbed newton terms for the + ! groundwater flow equation + do ib = 1, this%ninterbeds + node = this%nodelist(ib) + ! + ! -- skip inactive cells + if (this%ibound(node) < 1) cycle + ! + ! -- calculate interbed newton terms + idiag = this%dis%con%ia(node) + area = this%dis%get_area(node) + call this%csub_interbed_fn(ib, node, area, hnew(node), hold(node), & + hcof, rhsterm) + ! + ! -- add interbed newton terms to amat and rhs + amat(idxglo(idiag)) = amat(idxglo(idiag)) + hcof + rhs(node) = rhs(node) + rhsterm + ! + ! -- calculate interbed water compressibility terms + if (this%brg /= DZERO) then + call this%csub_interbed_wcomp_fn(ib, node, tled, area, & + hnew(node), hold(node), & + hcof, rhsterm) + ! + ! -- add interbed water compression newton terms to amat and rhs + amat(idxglo(idiag)) = amat(idxglo(idiag)) + hcof + rhs(node) = rhs(node) + rhsterm + end if + end do + end if + end if + ! + ! -- return + return + end subroutine csub_fn + + subroutine csub_cg_fc(this, node, tled, area, hcell, hcellold, hcof, rhs) +! ****************************************************************************** +! csub_cg_fc -- Formulate the HCOF and RHS coarse-grained storage terms +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + class(GwfCsubType) :: this + integer(I4B),intent(in) :: node + real(DP), intent(in) :: tled + real(DP), intent(in) :: area + real(DP), intent(in) :: hcell + real(DP), intent(in) :: hcellold + real(DP), intent(inout) :: hcof + real(DP), intent(inout) :: rhs + ! locals + real(DP) :: top + real(DP) :: bot + real(DP) :: tthk + real(DP) :: snold + real(DP) :: snnew + real(DP) :: sske + real(DP) :: rho1 +! ------------------------------------------------------------------------------ +! +! -- initialize variables + rhs = DZERO + hcof = DZERO + ! + ! -- aquifer elevations and thickness + top = this%dis%top(node) + bot = this%dis%bot(node) + tthk = this%cg_thickini(node) + ! + ! -- calculate hcof and rhs terms if coarse-grained materials present + if (tthk > DZERO) then + ! + ! -- calculate aquifer saturation + call this%csub_calc_sat(node, hcell, hcellold, snnew, snold) + ! + ! -- storage coefficients + call this%csub_cg_calc_sske(node, sske, hcell) + rho1 = sske * area * tthk * tled + ! + ! -- update sk and ske + this%cg_ske(node) = sske * tthk * snold + this%cg_sk(node) = sske * tthk * snnew + ! + ! -- calculate hcof and rhs term + hcof = -rho1 * snnew + rhs = rho1 * snold * this%cg_es0(node) - & + rho1 * snnew * (this%cg_gs(node) + bot) + end if + ! + ! -- return + return + end subroutine csub_cg_fc + + subroutine csub_cg_fn(this, node, tled, area, hcell, hcof, rhs) +! ****************************************************************************** +! csub_cg_fn -- Formulate coarse-grained storage newton terms +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + class(GwfCsubType) :: this + integer(I4B),intent(in) :: node + real(DP), intent(in) :: tled + real(DP), intent(in) :: area + real(DP), intent(in) :: hcell + real(DP), intent(inout) :: hcof + real(DP), intent(inout) :: rhs + ! locals + real(DP) :: top + real(DP) :: bot + real(DP) :: tthk + real(DP) :: satderv + real(DP) :: sske + real(DP) :: rho1 +! ------------------------------------------------------------------------------ +! +! -- initialize variables + rhs = DZERO + hcof = DZERO + ! + ! -- aquifer elevations and thickness + top = this%dis%top(node) + bot = this%dis%bot(node) + tthk = this%cg_thickini(node) + ! + ! -- calculate newton terms if coarse-grained materials present + if (tthk > DZERO) then + ! + ! -- calculate saturation derivative + satderv = this%csub_calc_sat_derivative(node, hcell) + ! + ! -- storage coefficients + call this%csub_cg_calc_sske(node, sske, hcell) + rho1 = sske * area * tthk * tled + ! + ! -- calculate hcof term + hcof = rho1 * (this%cg_gs(node) - hcell + bot) * satderv + ! + ! -- Add additional term if using lagged effective stress + if (this%ieslag /= 0) then + hcof = hcof - rho1 * this%cg_es0(node) * satderv + end if + ! + ! -- calculate rhs term + rhs = hcof * hcell + end if + ! + ! -- return + return + end subroutine csub_cg_fn + + subroutine csub_interbed_fc(this, ib, node, area, hcell, hcellold, hcof, rhs) +! ****************************************************************************** +! csub_cf -- Formulate the HCOF and RHS terms +! Subroutine: (1) skip if no ibcs +! (2) calculate hcof and rhs +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + class(GwfCsubType) :: this + integer(I4B),intent(in) :: ib + integer(I4B),intent(in) :: node + real(DP), intent(in) :: area + real(DP), intent(in) :: hcell + real(DP), intent(in) :: hcellold + real(DP), intent(inout) :: hcof + real(DP), intent(inout) :: rhs + ! locals + character(len=20) :: cellid + character (len=LINELENGTH) :: errmsg + integer(I4B) :: idelaycalc + real(DP) :: snnew + real(DP) :: snold + real(DP) :: comp + real(DP) :: compi + real(DP) :: compe + real(DP) :: rho1 + real(DP) :: rho2 + real(DP) :: f + real(DP) :: top +! ------------------------------------------------------------------------------ +! +! -- initialize variables + rhs = DZERO + hcof = DZERO + comp = DZERO + compi = DZERO + compe = DZERO + ! + ! -- skip inactive and constant head cells + if (this%ibound(node) > 0) then + if (this%idelay(ib) == 0) then + ! + ! -- update material properties + if (this%iupdatematprop /= 0) then + if (this%ieslag == 0) then + ! + ! -- calculate compaction + call this%csub_nodelay_calc_comp(ib, hcell, hcellold, comp, & + rho1, rho2) + this%comp(ib) = comp + ! + ! -- update thickness and void ratio + call this%csub_nodelay_update(ib) + end if + end if + ! + ! -- calculate no-delay interbed rho1 and rho2 + call this%csub_nodelay_fc(ib, hcell, hcellold, rho1, hcof, rhs) + f = area + else + ! + ! -- calculate cell saturation + call this%csub_calc_sat(node, hcell, hcellold, snnew, snold) + ! + ! -- check that the delay bed should be evaluated + idelaycalc = this%csub_delay_eval(ib, node, hcell) + ! + ! -- calculate delay interbed hcof and rhs + if (idelaycalc > 0) then + ! + ! -- update material properties + if (this%iupdatematprop /= 0) then + if (this%ieslag == 0) then + ! + ! -- calculate compaction + call this%csub_delay_calc_comp(ib, hcell, hcellold, & + comp, compi, compe) + this%comp(ib) = comp + ! + ! -- update thickness and void ratio + call this%csub_delay_update(ib) + end if + end if + ! + ! -- calculate delay interbed hcof and rhs + call this%csub_delay_sln(ib, hcell) + call this%csub_delay_fc(ib, hcof, rhs) + ! -- create error message + else + if (idelaycalc < 0) then + call this%dis%noder_to_string(node, cellid) + write(errmsg,'(4x,a,1x,g0,1x,a,1x,a,1x,a,1x,g0,1x,a,1x,i0)') & + '****ERROR. HEAD (', hcell, ') IN NON-CONVERTIBLE CELL (', & + trim(adjustl(cellid)), ') DROPPED BELOW THE TOP OF THE CELL (', & + top, ') FOR DELAY INTERBED ', ib + call store_error(errmsg) + end if + end if + f = area * this%rnb(ib) * snnew + end if + rhs = rhs * f + hcof = -hcof * f + end if + ! + ! -- return + return + end subroutine csub_interbed_fc + + subroutine csub_interbed_fn(this, ib, node, area, hcell, hcellold, hcof, rhs) +! ****************************************************************************** +! csub_interbed_fn -- Formulate interbed newton terms +! Subroutine: (1) skip if no interbeds +! (2) calculate hcof and rhs +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use TdisModule, only: delt + implicit none + class(GwfCsubType) :: this + integer(I4B),intent(in) :: ib + integer(I4B),intent(in) :: node + real(DP), intent(in) :: area + real(DP), intent(in) :: hcell + real(DP), intent(in) :: hcellold + real(DP), intent(inout) :: hcof + real(DP), intent(inout) :: rhs + ! -- locals + integer(I4B) :: idelay + integer(I4B) :: idelaycalc + real(DP) :: hcofn + real(DP) :: rhsn + real(DP) :: snnew + real(DP) :: snold + real(DP) :: satderv + real(DP) :: tled + real(DP) :: tthk + real(DP) :: f + real(DP) :: top + real(DP) :: bot + real(DP) :: rho1 + real(DP) :: rho2 + real(DP) :: dz + real(DP) :: c + real(DP) :: h1 + real(DP) :: hn +! ------------------------------------------------------------------------------ +! +! -- initialize variables + rhs = DZERO + hcof = DZERO + rhsn = DZERO + hcofn = DZERO + satderv = DZERO + idelay = this%idelay(ib) + top = this%dis%top(node) + bot = this%dis%bot(node) + ! + ! -- skip inactive and constant head cells + if (this%ibound(node) > 0) then + tled = DONE / delt + tthk = this%thickini(ib) + ! + ! -- calculate cell saturation + call this%csub_calc_sat(node, hcell, hcellold, snnew, snold) + ! + ! -- no-delay interbeds + if (idelay == 0) then + ! + ! -- initialize factor + f = DONE + ! + ! -- calculate the saturation derivative + satderv = this%csub_calc_sat_derivative(node, hcell) + ! + ! -- calculate storage coefficient + call this%csub_nodelay_fc(ib, hcell, hcellold, rho1, rho2, rhsn) + ! + ! -- calculate hcofn term + if (this%ielastic(ib) /= 0) then + hcofn = rho2 * (this%cg_gs(node) - hcell + bot) * satderv + else + hcofn = rho2 * (this%cg_gs(node) - hcell + bot - this%pcs(ib)) * & + satderv + end if + ! + ! -- Add additional term if using lagged effective stress + if (this%ieslag /= 0) then + if (this%ielastic(ib) /= 0) then + hcofn = hcofn - rho1 * this%cg_es0(node) * satderv + else + hcofn = hcofn - rho1 * (this%pcs(ib) - this%cg_es0(node)) * satderv + end if + end if + ! + ! -- delay interbeds + else + ! + ! -- calculate factor + f = this%rnb(ib) + ! + ! -- check that the delay bed should be evaluated + idelaycalc = this%csub_delay_eval(ib, node, hcell) + ! + ! -- calculate newton terms if delay bed is not stranded + ! newton terms are calculated the same if using the + ! head-based and effective-stress formulations + if (idelaycalc > 0) then + ! + ! calculate delay interbed terms + dz = this%dbdzini(1, idelay) + c = DTWO * this%kv(ib) / dz + h1 = this%dbh(1, idelay) + hn = this%dbh(this%ndelaycells, idelay) + ! + ! -- calculate the saturation derivative + satderv = this%csub_calc_sat_derivative(node, hcell) + ! + ! -- calculate the saturation derivative term + hcofn = satderv * c * area * (hn + h1 - DTWO * hcell) + end if + ! + ! -- update hcof and rhs + hcof = f * hcofn + rhs = f * hcofn * hcell + end if + end if + ! + ! -- return + return + end subroutine csub_interbed_fn + + subroutine define_listlabel(this) +! ****************************************************************************** +! define_listlabel -- Define the list heading that is written to iout when +! PRINT_INPUT option is used. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this +! ------------------------------------------------------------------------------ + ! + ! -- create the header list label + this%listlabel = trim(this%filtyp) // ' NO.' + if(this%dis%ndim == 3) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif(this%dis%ndim == 2) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + else + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + endif + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'SIG0' + if(this%inamedbound == 1) then + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + endif + ! + ! -- return + return + end subroutine define_listlabel + + subroutine csub_cg_calc_sske(this, n, sske, hcell) +! ****************************************************************************** +! csub_cg_calc_sske -- Calculate sske for a gwf cell. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + integer(I4B), intent(in) :: n + real(DP), intent(inout) :: sske + real(DP), intent(in) :: hcell + ! -- local variables + real(DP) :: top + real(DP) :: bot + real(DP) :: znode + real(DP) :: es + real(DP) :: es0 + real(DP) :: theta + real(DP) :: f + real(DP) :: f0 +! ------------------------------------------------------------------------------ + ! + ! -- initialize variables + sske = DZERO + ! + ! -- calculate factor for the head-based case + if (this%lhead_based .EQV. .TRUE.) then + f = DONE + f0 = DONE + ! + ! -- calculate factor for the effective stress case + else + top = this%dis%top(n) + bot = this%dis%bot(n) + znode = this%csub_calc_znode(top, bot, hcell) + es = this%cg_es(n) + es0 = this%cg_es0(n) + theta = this%cg_thetaini(n) + ! + ! -- calculate the compression index factors for the delay + ! node relative to the center of the cell based on the + ! current and previous head + call this%csub_calc_sfacts(n, bot, znode, theta, es, es0, f) + end if + sske = f * this%cg_ske_cr(n) + ! + ! -- return + return + end subroutine csub_cg_calc_sske + + subroutine csub_cg_calc_comp(this, node, hcell, hcellold, comp) +! ****************************************************************************** +! csub_cg_calc_comp -- Calculate coarse-grained compaction +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + class(GwfCsubType) :: this + integer(I4B),intent(in) :: node + real(DP), intent(in) :: hcell + real(DP), intent(in) :: hcellold + real(DP), intent(inout) :: comp + ! locals + real(DP) :: area + real(DP) :: tled + real(DP) :: hcof + real(DP) :: rhs +! ------------------------------------------------------------------------------ +! +! -- initialize variables + area = DONE + tled = DONE + ! + ! -- calculate terms + call this%csub_cg_fc(node, tled, area, hcell, hcellold, hcof, rhs) + ! + ! - calculate compaction + comp = hcof * hcell - rhs + ! + ! -- return + return + end subroutine csub_cg_calc_comp + + + subroutine csub_cg_update(this, node) +! ****************************************************************************** +! csub_cg_update -- Update material properties for coarse grained sediments. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + integer(I4B),intent(in) :: node + ! locals + character(len=LINELENGTH) :: errmsg + character(len=20) :: cellid + real(DP) :: comp + real(DP) :: thick + real(DP) :: theta +! ------------------------------------------------------------------------------ +! +! -- update thickness and theta + comp = this%cg_tcomp(node) + this%cg_comp(node) + call this%dis%noder_to_string(node, cellid) + if (ABS(comp) > DZERO) then + thick = this%cg_thickini(node) + theta = this%cg_thetaini(node) + call this%csub_adj_matprop(comp, thick, theta) + if (thick <= DZERO) then + write(errmsg,'(4x,a,1x,a,1x,a,1x,g0,1x,a)') & + '****ERROR. ADJUSTED THICKNESS FOR CELL', trim(adjustl(cellid)), & + 'IS <= 0 (', thick, ')' + call store_error(errmsg) + end if + if (theta <= DZERO) then + write(errmsg,'(4x,a,1x,a,1x,a,1x,g0,1x,a)') & + '****ERROR. ADJUSTED THETA FOR CELL', trim(adjustl(cellid)), & + 'IS <= 0 (', theta, ')' + call store_error(errmsg) + end if + this%cg_thick(node) = thick + this%cg_theta(node) = theta + end if + ! + ! -- return + return + end subroutine csub_cg_update + + + subroutine csub_cg_wcomp_fc(this, node, tled, area, hcell, hcellold, & + hcof, rhs) +! ****************************************************************************** +! csub_cg_wcomp_fc -- Calculate water compressibility term for a gwf cell. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + integer(I4B),intent(in) :: node + real(DP), intent(in) :: tled + real(DP), intent(in) :: area + real(DP), intent(in) :: hcell + real(DP), intent(in) :: hcellold + real(DP), intent(inout) :: hcof + real(DP), intent(inout) :: rhs + ! locals + real(DP) :: top + real(DP) :: bot + real(DP) :: tthk + real(DP) :: tthk0 + real(DP) :: snold + real(DP) :: snnew + real(DP) :: wc1 + real(DP) :: wc2 +! ------------------------------------------------------------------------------ +! +! -- initialize variables + rhs = DZERO + hcof = DZERO + ! + ! -- aquifer elevations and thickness + top = this%dis%top(node) + bot = this%dis%bot(node) + tthk = this%cg_thick(node) + tthk0 = this%cg_thick0(node) + ! + ! -- aquifer saturation + call this%csub_calc_sat(node, hcell, hcellold, snnew, snold) + ! + ! -- storage coefficients + wc1 = this%brg * area * tthk0 * this%cg_theta0(node) * tled + wc2 = this%brg * area * tthk * this%cg_theta(node) * tled + ! + ! -- calculate hcof term + hcof = -wc2 * snnew + ! + ! -- calculate rhs term + rhs = -wc1 * snold * hcellold + ! + ! -- return + return + end subroutine csub_cg_wcomp_fc + + + subroutine csub_cg_wcomp_fn(this, node, tled, area, hcell, hcellold, hcof, rhs) +! ****************************************************************************** +! csub_cg_wcomp_fn -- Calculate water compressibility newton-rephson terms for +! a gwf cell. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + integer(I4B),intent(in) :: node + real(DP), intent(in) :: tled + real(DP), intent(in) :: area + real(DP), intent(in) :: hcell + real(DP), intent(in) :: hcellold + real(DP), intent(inout) :: hcof + real(DP), intent(inout) :: rhs + ! locals + real(DP) :: top + real(DP) :: bot + real(DP) :: tthk + real(DP) :: tthk0 + real(DP) :: satderv + real(DP) :: f + real(DP) :: wc1 + real(DP) :: wc2 +! ------------------------------------------------------------------------------ +! +! -- initialize variables + rhs = DZERO + hcof = DZERO + ! + ! -- aquifer elevations and thickness + top = this%dis%top(node) + bot = this%dis%bot(node) + tthk = this%cg_thick(node) + ! + ! -- calculate saturation derivitive + satderv = this%csub_calc_sat_derivative(node, hcell) + ! + ! -- calculate water compressibility factor + f = this%brg * area * tled + ! + ! -- water compressibility coefficient + !wc2 = this%brg * area * tthk * this%cg_theta(node) * tled + wc2 = f * tthk * this%cg_theta(node) + ! + ! -- calculate hcof term + hcof = -wc2 * hcell * satderv + ! + ! -- Add additional term if using lagged effective stress + if (this%ieslag /= 0) then + tthk0 = this%cg_thick0(node) + !wc1 = this%brg * area * tthk0 * this%cg_theta0(node) * tled + wc1 = f * tthk0 * this%cg_theta0(node) + hcof = hcof + wc1 * hcellold * satderv + end if + ! + ! -- calculate rhs term + rhs = hcof * hcell + ! + ! -- return + return + end subroutine csub_cg_wcomp_fn + + + subroutine csub_interbed_wcomp_fc(this, ib, node, tled, area, & + hcell, hcellold, hcof, rhs) +! ****************************************************************************** +! csub_interbed_wcomp_fc -- Calculate water compressibility term for an +! interbed. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + integer(I4B),intent(in) :: ib + integer(I4B),intent(in) :: node + real(DP), intent(in) :: tled + real(DP), intent(in) :: area + real(DP), intent(in) :: hcell + real(DP), intent(in) :: hcellold + real(DP), intent(inout) :: hcof + real(DP), intent(inout) :: rhs + ! locals + integer(I4B) :: n + integer(I4B) :: idelay + real(DP) :: top + real(DP) :: bot + real(DP) :: snold + real(DP) :: snnew + real(DP) :: f + real(DP) :: fmult + real(DP) :: dz + real(DP) :: dz0 + real(DP) :: wc1 + real(DP) :: wc2 +! ------------------------------------------------------------------------------ +! +! -- initialize variables + rhs = DZERO + hcof = DZERO + ! + ! -- aquifer elevations and thickness + top = this%dis%top(node) + bot = this%dis%bot(node) + ! + ! -- calculate cell saturation + call this%csub_calc_sat(node, hcell, hcellold, snnew, snold) + ! + ! + idelay = this%idelay(ib) + f = this%brg * area * tled + ! + ! -- no-delay interbeds + if (idelay == 0) then + wc1 = f * this%theta0(ib) * this%thick0(ib) + wc2 = f * this%theta(ib) * this%thick(ib) + hcof = -wc2 * snnew + rhs = -wc1 * snold * hcellold + ! + ! -- delay interbeds + else + ! + ! -- calculate cell saturation + call this%csub_calc_sat(node, hcell, hcellold, snnew, snold) + ! + ! -- calculate contribution for each delay interbed cell + if (this%thick(ib) > DZERO) then + do n = 1, this%ndelaycells + fmult = DONE + dz = this%dbdz(n, idelay) + dz0 = this%dbdz0(n, idelay) + wc2 = fmult * f * dz * this%dbtheta(n, idelay) + wc1 = fmult * f * dz0 * this%dbtheta0(n, idelay) + rhs = rhs - (wc1 * snold * this%dbh0(n, idelay) - & + wc2 * snnew * this%dbh(n, idelay)) + end do + rhs = rhs * this%rnb(ib) * snnew + end if + end if + ! + ! -- return + return + end subroutine csub_interbed_wcomp_fc + + + subroutine csub_interbed_wcomp_fn(this, ib, node, tled, area, & + hcell, hcellold, hcof, rhs) +! ****************************************************************************** +! csub_interbed_wcomp_fn -- Calculate water compressibility newton-raphson +! terms for an interbed. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + integer(I4B),intent(in) :: ib + integer(I4B),intent(in) :: node + real(DP), intent(in) :: tled + real(DP), intent(in) :: area + real(DP), intent(in) :: hcell + real(DP), intent(in) :: hcellold + real(DP), intent(inout) :: hcof + real(DP), intent(inout) :: rhs + ! locals + integer(I4B) :: idelay + real(DP) :: top + real(DP) :: bot + real(DP) :: f + real(DP) :: wc1 + real(DP) :: wc2 + real(DP) :: satderv +! ------------------------------------------------------------------------------ +! +! -- initialize variables + rhs = DZERO + hcof = DZERO + ! + ! -- aquifer elevations and thickness + top = this%dis%top(node) + bot = this%dis%bot(node) + ! + ! + idelay = this%idelay(ib) + f = this%brg * area * tled + ! + ! -- no-delay interbeds + if (idelay == 0) then + ! + ! -- calculate saturation derivitive + satderv = this%csub_calc_sat_derivative(node, hcell) + ! + ! -- calculate the current water compressibility factor + wc2 = f * this%theta(ib) * this%thick(ib) + ! + ! -- calculate derivative term + hcof = -wc2 * hcell * satderv + ! + ! -- Add additional term if using lagged effective stress + if (this%ieslag /= 0) then + wc1 = f * this%theta0(ib) * this%thick0(ib) + hcof = hcof + wc1 * hcellold * satderv + end if + ! + ! -- set rhs + rhs = hcof * hcell + ! + ! -- delay interbeds + else + ! -- delay beds are not head dependent + end if + ! + ! -- return + return + end subroutine csub_interbed_wcomp_fn + + function csub_calc_void(this, theta) result(void) +! ****************************************************************************** +! csub_calc_void -- Calculate void ratio from the porosity +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + ! -- dummy + real(DP), intent(in) :: theta + ! -- local variables + real(DP) :: void +! ------------------------------------------------------------------------------ + void = theta / (DONE - theta) + ! + ! -- return + return + end function csub_calc_void + + + function csub_calc_theta(this, void) result(theta) +! ****************************************************************************** +! csub_calc_theta -- Calculate porosity from the void ratio +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + ! -- dummy + real(DP), intent(in) :: void + ! -- local variables + real(DP) :: theta +! ------------------------------------------------------------------------------ + theta = void / (DONE + void) + ! + ! -- return + return + end function csub_calc_theta + + + function csub_calc_interbed_thickness(this, ib) result(thick) +! ****************************************************************************** +! csub_calc_interbed_thickness -- Calculate interbed thickness +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + ! -- dummy + integer(I4B), intent(in) :: ib + ! -- local variables + integer(I4B) :: idelay + real(DP) :: thick +! ------------------------------------------------------------------------------ + idelay = this%idelay(ib) + thick = this%thick(ib) + if (idelay /= 0) then + thick = thick * this%rnb(ib) + end if + ! + ! -- return + return + end function csub_calc_interbed_thickness + + + function csub_calc_znode(this, z1, z0, z) result(znode) +! ****************************************************************************** +! csub_calc_znode -- Calculate elevation of the node between the specified +! elevation z and the bottom elevation z0. If z is greater +! the top elevation z1, the node elevation is halfway between +! the top (z1) and bottom (z0) elevations. if z is less than +! the bottom elevation (z0) the node elevation is set to z0. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + ! -- dummy + real(DP), intent(in) :: z1 + real(DP), intent(in) :: z0 + real(DP), intent(in) :: z + ! -- local variables + real(DP) :: znode + real(DP) :: v +! ------------------------------------------------------------------------------ + if (z > z1) then + v = z1 + else if (z < z0) then + v = z0 + else + v = z + end if + znode = (v + z0) * DHALF + ! + ! -- return + return + end function csub_calc_znode + + function csub_calc_adjes(this, node, es0, z0, z) result(es) +! ****************************************************************************** +! csub_calc_adjes -- Calculate the effective stress at specified elevation z +! using the provided effective stress (es0) calculated at +! elevation z0 (which is <= z) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + ! -- dummy + integer(I4B), intent(in) :: node + real(DP), intent(in) :: es0 + real(DP), intent(in) :: z0 + real(DP), intent(in) :: z + ! -- local variables + real(DP) :: es +! ------------------------------------------------------------------------------ + ! + ! -- adjust effective stress to vertical node position + es = es0 - (z - z0) * (this%sgs(node) - DONE) + ! + ! -- return + return + end function csub_calc_adjes + + function csub_delay_eval(this, ib, node, hcell) result(idelaycalc) +! ****************************************************************************** +! csub_delay_eval -- Determine if the delay interbed should be solved, +! is stranded, or is a run-time error +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + ! -- dummy + integer(I4B), intent(in) :: ib + integer(I4B), intent(in) :: node + real(DP), intent(in) :: hcell + ! -- local variables + integer(I4B) :: idelaycalc + real(DP) :: top +! ------------------------------------------------------------------------------ + idelaycalc = 1 + ! + ! -- non-convertible cell + if (this%stoiconv(node) == 0) then + top = this%dis%top(node) + ! -- run-time error + if (hcell < top) then + idelaycalc = -999 + end if + ! + ! -- convertible cell + else + top = this%dis%bot(node) + this%thickini(ib) + ! + ! -- stranded cell + if (hcell < top) then + idelaycalc = 0 + end if + end if + ! + ! -- return + return + end function csub_delay_eval + + + subroutine csub_calc_sat(this, node, hcell, hcellold, snnew, snold) +! ****************************************************************************** +! csub_calc_sat -- Calculate current and previous cell saturation for a cell. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + integer(I4B), intent(in) :: node + real(DP), intent(in) :: hcell + real(DP), intent(in) :: hcellold + real(DP), intent(inout) :: snnew + real(DP), intent(inout) :: snold + ! -- local variables + real(DP) :: top + real(DP) :: bot +! ------------------------------------------------------------------------------ + if (this%stoiconv(node) /= 0) then + top = this%dis%top(node) + bot = this%dis%bot(node) + snnew = sQuadraticSaturation(top, bot, hcell, this%satomega) + snold = sQuadraticSaturation(top, bot, hcellold, this%satomega) + else + snnew = DONE + snold = DONE + end if + if (this%ieslag /= 0) then + snold = snnew + end if + ! + ! -- return + return + end subroutine csub_calc_sat + + function csub_calc_sat_derivative(this, node, hcell) result(satderv) +! ****************************************************************************** +! csub_calc_sat_derivative -- Calculate current saturation derivative for a cell. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + integer(I4B), intent(in) :: node + real(DP), intent(in) :: hcell + ! -- local variables + real(DP) :: satderv + real(DP) :: top + real(DP) :: bot +! ------------------------------------------------------------------------------ + if (this%stoiconv(node) /= 0) then + top = this%dis%top(node) + bot = this%dis%bot(node) + satderv = sQuadraticSaturationDerivative(top, bot, hcell, this%satomega) + else + satderv = DZERO + end if + ! + ! -- return + return + end function csub_calc_sat_derivative + + subroutine csub_calc_sfacts(this, node, bot, znode, theta, es, es0, fact) +! ****************************************************************************** +! csub_calc_sfacts -- Calculate sske and factor for a gwf cell or +! interbed. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + integer(I4B), intent(in) :: node + real(DP), intent(in) :: bot + real(DP), intent(in) :: znode + real(DP), intent(in) :: theta + real(DP), intent(in) :: es + real(DP), intent(in) :: es0 + real(DP), intent(inout) :: fact + ! -- local variables + real(DP) :: esv + real(DP) :: void + real(DP) :: denom +! ------------------------------------------------------------------------------ + ! + ! -- initialize variables + fact = DZERO + if (this%ieslag /= 0) then + esv = es0 + else + esv = es + end if + ! + ! -- calculate storage factors for the effective stress case + void = this%csub_calc_void(theta) + denom = this%csub_calc_adjes(node, esv, bot, znode) + denom = denom * (DONE + void) + if (denom /= DZERO) then + fact = DONE / denom + end if + ! + ! -- return + return + end subroutine csub_calc_sfacts + + subroutine csub_adj_matprop(this, comp, thick, theta) +! ****************************************************************************** +! csub_adj_matprop -- Adjust theta and thickness based on compaction. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + real(DP), intent(in) :: comp + real(DP), intent(inout) :: thick + real(DP), intent(inout) :: theta + ! -- local variables + real(DP) :: strain + real(DP) :: void +! ------------------------------------------------------------------------------ + ! + ! -- initialize variables + strain = DZERO + void = this%csub_calc_void(theta) + ! + ! -- calculate strain + if (thick > DZERO) strain = -comp / thick + ! + ! -- update void ratio, theta, and thickness + void = void + strain * (DONE + void) + theta = this%csub_calc_theta(void) + thick = thick - comp + ! + ! -- return + return + end subroutine csub_adj_matprop + + subroutine csub_delay_sln(this, ib, hcell, update) +! ****************************************************************************** +! csub_delay_sln -- Calculate flow in delay interbeds. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + integer(I4B), intent(in) :: ib + real(DP), intent(in) :: hcell + logical, intent(in), optional :: update + ! -- local variables + logical :: lupdate + integer(I4B) :: n + integer(I4B) :: icnvg + integer(I4B) :: iter + integer(I4B) :: idelay + real(DP) :: dh + real(DP) :: dhmax + real(DP) :: dhmax0 + real(DP), parameter :: dclose = DHUNDRED * DPREC +! ------------------------------------------------------------------------------ + ! + ! -- initialize variables + if (present(update)) then + lupdate = update + else + lupdate = .true. + end if + ! + ! -- calculate geostatic and effective stress for each delay bed cell + call this%csub_delay_calc_stress(ib, hcell) + ! + ! -- terminate if the aquifer head is below the top of delay interbeds + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- solve for delay bed heads + if (this%thickini(ib) > DZERO) then + icnvg = 0 + iter = 0 + idelay = this%idelay(ib) + do + iter = iter + 1 + ! + ! -- assemble coefficients + call this%csub_delay_assemble(ib, hcell) + ! + ! -- solve for head change in delay interbed cells + call csub_delay_solve(this%ndelaycells, & + this%dbal, this%dbad, this%dbau, & + this%dbrhs, this%dbdh, this%dbaw) + ! + ! -- calculate maximum head change and update delay bed heads + dhmax = DZERO + do n = 1, this%ndelaycells + dh = this%dbdh(n) - this%dbh(n, idelay) + if (abs(dh) > abs(dhmax)) then + dhmax = dh + if (lupdate) then + this%dbdhmax(idelay) = dhmax + end if + end if + ! -- update delay bed heads + this%dbh(n, idelay) = this%dbdh(n) + end do + ! + ! -- update delay bed stresses + call this%csub_delay_calc_stress(ib, hcell) + ! + ! -- check delay bed convergence + if (abs(dhmax) < dclose) then + icnvg = 1 + else if (iter /= 1) then + if (abs(dhmax)-abs(dhmax0) < DPREC) then + icnvg = 1 + end if + end if + if (icnvg == 1) then + exit + end if + dhmax0 = dhmax + end do + end if + ! + ! -- return + return + end subroutine csub_delay_sln + + + subroutine csub_delay_calc_zcell(this, ib) +! ****************************************************************************** +! csub_delay_calc_zcell -- Calculate z for delay interbeds cells. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + integer(I4B), intent(in) :: ib + ! -- local variables + integer(I4B) :: n + integer(I4B) :: node + integer(I4B) :: idelay + real(DP) :: bot + real(DP) :: top + real(DP) :: znode + real(DP) :: dzz + real(DP) :: z + real(DP) :: zr + real(DP) :: b + real(DP) :: dz +! ------------------------------------------------------------------------------ + ! + ! -- initialize variables + idelay = this%idelay(ib) + node = this%nodelist(ib) + b = this%thickini(ib) + bot = this%dis%bot(node) + top = bot + b + ! + ! -- calculate znode based on assumption that the delay bed bottom + ! is equal to the cell bottom + znode = this%csub_calc_znode(top, bot, top) + dz = DHALF * this%dbdzini(1, idelay) + dzz = DHALF * b + z = znode + dzz + zr = dzz + ! + ! -- calculate z and z relative to znode for each delay + ! interbed node + do n = 1, this%ndelaycells + ! z of node relative to bottom of cell + z = z - dz + this%dbz(n, idelay) = z + z = z - dz + ! z relative to znode + zr = zr - dz + if (ABS(zr) < dz) then + zr = DZERO + end if + this%dbrelz(n, idelay) = zr + zr = zr - dz + end do + ! + ! -- return + return + + end subroutine csub_delay_calc_zcell + + subroutine csub_delay_chk(this, ib, hcell) +! ****************************************************************************** +! csub_delay_chk -- Check the head relative to the top of a delay interbed. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + integer(I4B), intent(in) :: ib + real(DP), intent(in) :: hcell + ! -- local variables + character(len=LINELENGTH) :: errmsg + character(len=20) :: cellid + integer(I4B) :: idelay + integer(I4B) :: node + real(DP) :: dzhalf + real(DP) :: top +! ------------------------------------------------------------------------------ + ! + ! -- initialize variables + idelay = this%idelay(ib) + node = this%nodelist(ib) + dzhalf = DHALF * this%dbdzini(1, idelay) + top = this%dbz(1, idelay) + dzhalf + ! + ! -- check that aquifer head is above the top of the interbed + if (hcell < top) then + call this%dis%noder_to_string(node, cellid) + write(errmsg, '(a,g0,a,1x,a,1x,a,1x,i0,1x,a,g0,a)') & + 'ERROR: HEAD (', hcell, ') IN CONVERTIBLE CELL', trim(adjustl(cellid)), & + 'IS LESS THAN THE TOP OF DELAY INTERBED', ib, & + '(', top,')' + call store_error(errmsg) + end if + ! + ! -- return + return + + end subroutine csub_delay_chk + + + subroutine csub_delay_calc_stress(this, ib, hcell) +! ****************************************************************************** +! csub_delay_calc_stress -- Calculate geostatic and effective stress in delay +! interbeds. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + integer(I4B), intent(in) :: ib + real(DP), intent(in) :: hcell + ! -- local variables + integer(I4B) :: n + integer(I4B) :: idelay + integer(I4B) :: node + real(DP) :: sigma + real(DP) :: topaq + real(DP) :: botaq + real(DP) :: dzhalf + real(DP) :: sadd + real(DP) :: sgm + real(DP) :: sgs + real(DP) :: h + real(DP) :: z + real(DP) :: top + real(DP) :: bot + real(DP) :: u +! ------------------------------------------------------------------------------ + ! + ! -- initialize variables + idelay = this%idelay(ib) + node = this%nodelist(ib) + sigma = this%cg_gs(node) + topaq = this%dis%top(node) + botaq = this%dis%bot(node) + dzhalf = DHALF * this%dbdzini(1, idelay) + top = this%dbz(1, idelay) + dzhalf + ! + ! -- calculate the geostatic load in the cell at the top of the interbed. + sgm = this%sgm(node) + sgs = this%sgs(node) + if (hcell > top) then + sadd = (top - botaq) * sgs + else if (hcell < botaq) then + sadd = (top - botaq) * sgm + else + sadd = ((top - hcell) * sgm) + ((hcell - botaq) * sgs) + end if + sigma = sigma - sadd + ! + ! -- calculate geostatic and effective stress for each interbed node. + do n = 1, this%ndelaycells + h = this%dbh(n, idelay) + ! + ! -- geostatic calculated at the bottom of the delay cell + z = this%dbz(n, idelay) + top = z + dzhalf + bot = z - dzhalf + if (h > top) then + sadd = (top - bot) * sgs + else if (h < bot) then + sadd = (top - bot) * sgm + else + sadd = ((top - h) * sgm) + ((h - bot) * sgs) + end if + sigma = sigma + sadd + u = h - bot + this%dbgeo(n, idelay) = sigma + this%dbes(n, idelay) = sigma - u + end do + ! + ! -- return + return + end subroutine csub_delay_calc_stress + + subroutine csub_delay_calc_ssksske(this, ib, n, hcell, ssk, sske) +! ****************************************************************************** +! csub_delay_calc_ssksske -- Calculate ssk and sske for a node in a delay +! interbed cell. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + integer(I4B), intent(in) :: ib + integer(I4B), intent(in) :: n + real(DP), intent(in) :: hcell + real(DP), intent(inout) :: ssk + real(DP), intent(inout) :: sske + ! -- local variables + integer(I4B) :: idelay + integer(I4B) :: ielastic + integer(I4B) :: node + real(DP) :: z1 + real(DP) :: z0 + real(DP) :: zcell + real(DP) :: znode + real(DP) :: zbot + real(DP) :: es + real(DP) :: es0 + real(DP) :: theta + real(DP) :: f + real(DP) :: f0 +! ------------------------------------------------------------------------------ + ! + ! -- initialize variables + sske = DZERO + ssk = DZERO + idelay = this%idelay(ib) + ielastic = this%ielastic(ib) + ! + ! -- calculate factor for the head-based case + if (this%lhead_based .EQV. .TRUE.) then + f = DONE + f0 = f + ! + ! -- calculate factor for the effective stress case + else + node = this%nodelist(ib) + theta = this%dbthetaini(n, idelay) + ! + ! -- set top and bottom of layer and elevation of + ! node relative to the bottom of the cell + z1 = this%dis%top(node) + z0 = this%dis%bot(node) + zbot = this%dbz(n, idelay) - DHALF * this%dbdzini(1, idelay) + ! + ! -- set location of delay node relative to the center + ! of the cell based on current head + zcell = this%csub_calc_znode(z1, z0, hcell) + znode = zcell + this%dbrelz(n, idelay) + ! + ! -- set the effective stress + es = this%dbes(n, idelay) + es0 = this%dbes0(n, idelay) + ! + ! -- calculate the compression index factors for the delay + ! node relative to the center of the cell based on the + ! current and previous head + call this%csub_calc_sfacts(node, zbot, znode, theta, es, es0, f) + end if + this%idbconvert(n, idelay) = 0 + sske = f * this%rci(ib) + ssk = f * this%rci(ib) + if (ielastic == 0) then + if (this%dbes(n, idelay) > this%dbpcs(n, idelay)) then + this%idbconvert(n, idelay) = 1 + ssk = f * this%ci(ib) + end if + end if + ! + ! -- return + return + end subroutine csub_delay_calc_ssksske + + subroutine csub_delay_assemble(this, ib, hcell) +! ****************************************************************************** +! csub_delay_assemble -- Assemble coefficients for delay interbeds cells. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use TdisModule, only: delt + ! -- dummy variables + class(GwfCsubType), intent(inout) :: this + integer(I4B), intent(in) :: ib + real(DP), intent(in) :: hcell + ! -- local variables + integer(I4B) :: n + integer(I4B) :: node + integer(I4B) :: idelay + integer(I4B) :: ielastic + real(DP) :: dz + real(DP) :: dzhalf + real(DP) :: c + real(DP) :: c2 + real(DP) :: c3 + real(DP) :: fmult + real(DP) :: sske + real(DP) :: ssk + real(DP) :: z + real(DP) :: ztop + real(DP) :: zbot + real(DP) :: h + real(DP) :: aii + real(DP) :: r +! ------------------------------------------------------------------------------ + ! + ! -- initialize variables + idelay = this%idelay(ib) + ielastic = this%ielastic(ib) + node = this%nodelist(ib) + dz = this%dbdzini(1, idelay) + dzhalf = DHALF * dz + fmult = dz / delt + c = this%kv(ib) / dz + c2 = DTWO * c + c3 = DTHREE * c + ! + ! + do n = 1, this%ndelaycells + ! + ! -- current and previous delay cell states + z = this%dbz(n, idelay) + ztop = z + dzhalf + zbot = z - dzhalf + h = this%dbh(n, idelay) + ! + ! -- calculate ssk and sske + call this%csub_delay_calc_ssksske(ib, n, hcell, ssk, sske) + ! + ! -- calculate diagonal + aii = -ssk * fmult + ! + ! -- calculate right hand side + if (ielastic /= 0) then + r = -fmult * & + (ssk * (this%dbgeo(n, idelay) + zbot) - & + sske * this%dbes0(n, idelay)) + else + r = -fmult * & + (ssk * (this%dbgeo(n, idelay) + zbot - this%dbpcs(n, idelay)) + & + sske * (this%dbpcs(n, idelay) - this%dbes0(n, idelay))) + end if + ! + ! -- add connection to the gwf cell + if (n == 1 .or. n == this%ndelaycells) then + aii = aii - c3 + r = r - c2 * hcell + else + aii = aii - c2 + end if + ! + ! -- off diagonals + ! -- lower + if (n > 1) then + this%dbal(n) = c + end if + ! + ! -- upper + if (n < this%ndelaycells) then + this%dbau(n) = c + end if + ! + ! -- diagonal + this%dbad(n) = aii + ! + ! -- right hand side + this%dbrhs(n) = r + end do + ! + ! -- return + return + + end subroutine csub_delay_assemble + + subroutine csub_delay_solve(n, tl, td, tu, b, x, w) +! ****************************************************************************** +! csub_delay_solve -- Solve for head change in delay interbeds cells. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + integer(I4B), intent(in) :: n + real(DP), dimension(n), intent(in) :: tl + real(DP), dimension(n), intent(in) :: td + real(DP), dimension(n), intent(in) :: tu + real(DP), dimension(n), intent(in) :: b + real(DP), dimension(n), intent(inout) :: x + real(DP), dimension(n), intent(inout) :: w + ! -- local variables + integer(I4B) :: j + real(DP) :: bet + real(DP) :: beti +! ------------------------------------------------------------------------------ + ! + ! -- initialize variables + w(1) = DZERO + bet = td(1) + beti = DONE / bet + x(1) = b(1) * beti + ! + ! -- decomposition and forward substitution + do j = 2, n + w(j) = tu(j-1) * beti + bet = td(j) - tl(j) * w(j) + beti = DONE / bet + x(j) = (b(j) - tl(j) * x(j-1)) * beti + end do + ! + ! -- backsubstitution + do j = n-1, 1, -1 + x(j) = x(j) - w(j+1) * x(j+1) + end do + ! -- return + return + end subroutine csub_delay_solve + + subroutine csub_delay_calc_dstor(this, ib, hcell, stoe, stoi) +! ****************************************************************************** +! csub_delay_calc_dstor -- Calculate change in storage in a delay interbed. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy variables + class(GwfCsubType), intent(inout) :: this + integer(I4B), intent(in) :: ib + real(DP), intent(inout) :: hcell + real(DP), intent(inout) :: stoe + real(DP), intent(inout) :: stoi + ! -- local variables + integer(I4B) :: idelay + integer(I4B) :: ielastic + integer(I4B) :: n + real(DP) :: sske + real(DP) :: ssk + real(DP) :: fmult + real(DP) :: v1 + real(DP) :: v2 + real(DP) :: ske + real(DP) :: sk + real(DP) :: z + real(DP) :: zbot + real(DP) :: dzhalf +! ------------------------------------------------------------------------------ + ! + ! -- initialize variables + idelay = this%idelay(ib) + ielastic = this%ielastic(ib) + stoe = DZERO + stoi = DZERO + ske = DZERO + sk = DZERO + ! + ! + if (this%thickini(ib) > DZERO) then + fmult = this%dbdzini(1, idelay) + dzhalf = DHALF * this%dbdzini(1, idelay) + do n = 1, this%ndelaycells + call this%csub_delay_calc_ssksske(ib, n, hcell, ssk, sske) + z = this%dbz(n, idelay) + zbot = z - dzhalf + if (ielastic /= 0) then + v1 = ssk * (this%dbgeo(n, idelay) - this%dbh(n, idelay) + zbot) - & + sske * this%dbes0(n, idelay) + v2 = DZERO + else + v1 = ssk * (this%dbgeo(n, idelay) - this%dbh(n, idelay) + zbot - & + this%dbpcs(n, idelay)) + v2 = sske * (this%dbpcs(n, idelay) - this%dbes0(n, idelay)) + end if + ! + ! -- calculate inelastic and elastic storage components + if (this%idbconvert(n, idelay) /= 0) then + stoi = stoi + v1 * fmult + stoe = stoe + v2 * fmult + else + stoe = stoe + (v1 + v2) * fmult + end if + ! + ! calculate inelastic and elastic storativity + ske = ske + sske * fmult + sk = sk + ssk * fmult + end do + end if + ! + ! -- save ske and sk + this%ske(ib) = ske + this%sk(ib) = sk + ! + ! -- return + return + end subroutine csub_delay_calc_dstor + + subroutine csub_delay_calc_comp(this, ib, hcell, hcellold, comp, compi, compe) +! ****************************************************************************** +! csub_delay_calc_comp -- Calculate compaction in a delay interbed. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + integer(I4B), intent(in) :: ib + real(DP), intent(in) :: hcell + real(DP), intent(in) :: hcellold + real(DP), intent(inout) :: comp + real(DP), intent(inout) :: compi + real(DP), intent(inout) :: compe + ! -- local variables + integer(I4B) :: idelay + integer(I4B) :: ielastic + integer(I4B) :: node + integer(I4B) :: n + real(DP) :: snnew + real(DP) :: snold + real(DP) :: sske + real(DP) :: ssk + real(DP) :: fmult + real(DP) :: v + real(DP) :: v1 + real(DP) :: v2 +! ------------------------------------------------------------------------------ + ! + ! -- initialize variables + idelay = this%idelay(ib) + ielastic = this%ielastic(ib) + node = this%nodelist(ib) + comp = DZERO + compi = DZERO + compe = DZERO + ! + ! -- calculate cell saturation + call this%csub_calc_sat(node, hcell, hcellold, snnew, snold) + ! + ! -- calculate compaction + if (this%thickini(ib) > DZERO) then + fmult = this%dbdzini(1, idelay) + do n = 1, this%ndelaycells + call this%csub_delay_calc_ssksske(ib, n, hcell, ssk, sske) + if (ielastic /= 0) then + v1 = ssk * this%dbes(n, idelay) - sske * this%dbes0(n, idelay) + v2 = DZERO + else + v1 = ssk * (this%dbes(n, idelay) - this%dbpcs(n, idelay)) + v2 = sske * (this%dbpcs(n, idelay) - this%dbes0(n, idelay)) + end if + v = (v1 + v2) * fmult + comp = comp + v + ! + ! -- save compaction data + this%dbcomp(n, idelay) = v * snnew + ! + ! -- calculate inelastic and elastic storage components + if (this%idbconvert(n, idelay) /= 0) then + compi = compi + v1 * fmult + compe = compe + v2 * fmult + else + compe = compe + (v1 + v2) * fmult + end if + end do + end if + ! + ! -- fill compaction + comp = comp * this%rnb(ib) * snnew + compi = compi * this%rnb(ib) * snnew + compe = compe * this%rnb(ib) * snnew + ! + ! -- return + return + end subroutine csub_delay_calc_comp + + subroutine csub_delay_update(this, ib) +! ****************************************************************************** +! csub_delay_update -- Update delay interbed thickness and porosity. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + integer(I4B), intent(in) :: ib + ! -- local variables + character(len=LINELENGTH) :: errmsg + integer(I4B) :: idelay + integer(I4B) :: n + real(DP) :: comp + real(DP) :: thick + real(DP) :: theta + real(DP) :: tthick + real(DP) :: wtheta +! ------------------------------------------------------------------------------ + ! + ! -- initialize variables + idelay = this%idelay(ib) + comp = DZERO + tthick = DZERO + wtheta = DZERO + ! + ! + do n = 1, this%ndelaycells + ! + ! -- initialize compaction for delay cell + comp = this%dbtcomp(n, idelay) + this%dbcomp(n, idelay) + ! + ! -- scale compaction by rnb to get the compaction for + ! the interbed system (as opposed to the full system) + comp = comp / this%rnb(ib) + ! + ! -- update thickness and theta + if (ABS(comp) > DZERO) then + thick = this%dbdzini(n, idelay) + theta = this%dbthetaini(n, idelay) + call this%csub_adj_matprop(comp, thick, theta) + if (thick <= DZERO) then + write(errmsg,'(4x,2(a,1x,i0,1x),a,1x,g0,1x,a)') & + '****ERROR. ADJUSTED THICKNESS FOR DELAY INTERBED (', & + ib, ') CELL (', n, ') IS <= 0 (', thick, ')' + call store_error(errmsg) + end if + if (theta <= DZERO) then + write(errmsg,'(4x,2(a,1x,i0,1x),a,1x,g0,1x,a)') & + '****ERROR. ADJUSTED THETA FOR DELAY INTERBED (', & + ib, ') CELL (', n, 'IS <= 0 (', theta, ')' + call store_error(errmsg) + end if + this%dbdz(n, idelay) = thick + this%dbtheta(n, idelay) = theta + tthick = tthick + thick + wtheta = wtheta + thick * theta + else + thick = this%dbdz(n, idelay) + theta = this%dbtheta(n, idelay) + tthick = tthick + thick + wtheta = wtheta + thick * theta + end if + end do + ! + ! -- calculate thickness weighted theta and save thickness and weighted + ! theta values for delay interbed + if (tthick > DZERO) then + wtheta = wtheta / tthick + else + tthick = DZERO + wtheta = DZERO + end if + this%thick(ib) = tthick + this%theta(ib) = wtheta + ! + ! -- return + return + end subroutine csub_delay_update + + subroutine csub_delay_fc(this, ib, hcof, rhs) +! ****************************************************************************** +! csub_delay_fc -- Calculate hcof and rhs for delay interbed contribution to +! GWF cell. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + integer(I4B), intent(in) :: ib + real(DP), intent(inout) :: hcof + real(DP), intent(inout) :: rhs + ! -- local variables + integer(I4B) :: idelay + real(DP) :: c1 + real(DP) :: c2 +! ------------------------------------------------------------------------------ + ! + ! -- initialize variables + idelay = this%idelay(ib) + hcof = DZERO + rhs = DZERO + if (this%thickini(ib) > DZERO) then + ! -- calculate terms for gwf matrix + c1 = DTWO * this%kv(ib) / this%dbdzini(1, idelay) + rhs = -c1 * this%dbh(1, idelay) + c2 = DTWO * & + this%kv(ib) / this%dbdzini(this%ndelaycells, idelay) + rhs = rhs - c2 * this%dbh(this%ndelaycells, idelay) + hcof = c1 + c2 + end if + ! + ! -- return + return + end subroutine csub_delay_fc + + function csub_calc_delay_flow(this, ib, n, hcell) result(q) +! ****************************************************************************** +! csub_calc_delay_flow -- Calculate flow across top or bottom of delay interbed +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfCsubType), intent(inout) :: this + ! -- dummy + integer(I4B), intent(in) :: ib + integer(I4B), intent(in) :: n + real(DP), intent(in) :: hcell + ! -- local variables + integer(I4B) :: idelay + real(DP) :: q + real(DP) :: c +! ------------------------------------------------------------------------------ + idelay = this%idelay(ib) + c = DTWO * this%kv(ib) / this%dbdzini(n, idelay) + q = c * (hcell - this%dbh(n, idelay)) + ! + ! -- return + return + end function csub_calc_delay_flow + + + ! + ! -- Procedures related to observations (type-bound) + logical function csub_obs_supported(this) + ! ****************************************************************************** + ! csub_obs_supported + ! -- Return true because csub package supports observations. + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + class(GwfCsubType) :: this + ! ------------------------------------------------------------------------------ + csub_obs_supported = .true. + return + end function csub_obs_supported + + + subroutine csub_df_obs(this) + ! ****************************************************************************** + ! csub_df_obs (implements bnd_df_obs) + ! -- Store observation type supported by csub package. + ! -- Overrides BndType%bnd_df_obs + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfCsubType) :: this + ! -- local + integer(I4B) :: indx + ! ------------------------------------------------------------------------------ + ! + ! -- Store obs type and assign procedure pointer + ! for csub observation type. + call this%obs%StoreObsType('csub', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for inelastic-csub observation type. + call this%obs%StoreObsType('inelastic-csub', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for elastic-csub observation type. + call this%obs%StoreObsType('elastic-csub', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for coarse-csub observation type. + call this%obs%StoreObsType('coarse-csub', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for csub-cell observation type. + call this%obs%StoreObsType('csub-cell', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for watercomp-csub observation type. + call this%obs%StoreObsType('wcomp-csub-cell', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for interbed ske observation type. + call this%obs%StoreObsType('ske', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for interbed sk observation type. + call this%obs%StoreObsType('sk', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for ske-cell observation type. + call this%obs%StoreObsType('ske-cell', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for sk-cell observation type. + call this%obs%StoreObsType('sk-cell', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for geostatic-stress-cell observation type. + call this%obs%StoreObsType('gstress-cell', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for effective-stress-cell observation type. + call this%obs%StoreObsType('estress-cell', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for total-compaction observation type. + call this%obs%StoreObsType('interbed-compaction', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for inelastic-compaction observation type. + call this%obs%StoreObsType('inelastic-compaction', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for inelastic-compaction observation type. + call this%obs%StoreObsType('elastic-compaction', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for coarse-compaction observation type. + call this%obs%StoreObsType('coarse-compaction', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for inelastic-compaction-cell observation type. + call this%obs%StoreObsType('inelastic-compaction-cell', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for elastic-compaction-cell observation type. + call this%obs%StoreObsType('elastic-compaction-cell', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for compaction-cell observation type. + call this%obs%StoreObsType('compaction-cell', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for interbed thickness observation type. + call this%obs%StoreObsType('thickness', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for coarse-thickness observation type. + call this%obs%StoreObsType('coarse-thickness', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for thickness-cell observation type. + call this%obs%StoreObsType('thickness-cell', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for interbed theta observation type. + call this%obs%StoreObsType('theta', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for coarse-theta observation type. + call this%obs%StoreObsType('coarse-theta', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for theta-cell observation type. + call this%obs%StoreObsType('theta-cell', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for preconstress-cell observation type. + call this%obs%StoreObsType('preconstress-cell', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for delay-preconstress observation type. + call this%obs%StoreObsType('delay-preconstress', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for delay-head observation type. + call this%obs%StoreObsType('delay-head', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for delay-gstress observation type. + call this%obs%StoreObsType('delay-gstress', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for delay-estress observation type. + call this%obs%StoreObsType('delay-estress', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for delay-compaction observation type. + call this%obs%StoreObsType('delay-compaction', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for delay-thickness observation type. + call this%obs%StoreObsType('delay-thickness', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for delay-theta observation type. + call this%obs%StoreObsType('delay-theta', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for delay-flowtop observation type. + call this%obs%StoreObsType('delay-flowtop', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for delay-flowbot observation type. + call this%obs%StoreObsType('delay-flowbot', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => csub_process_obsID + ! + return + end subroutine csub_df_obs + + + subroutine csub_bd_obs(this) + ! ************************************************************************** + ! csub_bd_obs + ! -- Calculate observations this time step and call + ! ObsType%SaveOneSimval for each GwfCsubType observation. + ! ************************************************************************** + ! + ! SPECIFICATIONS: + ! -------------------------------------------------------------------------- + ! -- dummy + class(GwfCsubType), intent(inout) :: this + ! -- local + integer(I4B) :: i + integer(I4B) :: j + integer(I4B) :: n + integer(I4B) :: nn + integer(I4B) :: idelay + integer(I4B) :: ncol + integer(I4B) :: node + real(DP) :: v + real(DP) :: r + real(DP) :: f + character(len=100) :: msg + type(ObserveType), pointer :: obsrv => null() + !--------------------------------------------------------------------------- + ! + ! -- Fill simulated values for all csub observations + if (this%obs%npakobs > 0) then + call this%obs%obs_bd_clear() + do i = 1, this%obs%npakobs + obsrv => this%obs%pakobs(i)%obsrv + if (obsrv%BndFound) then + nn = size(obsrv%indxbnds) + if (obsrv%ObsTypeId == 'SKE' .or. & + obsrv%ObsTypeId == 'SK' .or. & + obsrv%ObsTypeId == 'SKE-CELL' .or. & + obsrv%ObsTypeId == 'SK-CELL' .or. & + obsrv%ObsTypeId == 'DELAY-HEAD' .or. & + obsrv%ObsTypeId == 'DELAY-PRECONSTRESS' .or. & + obsrv%ObsTypeId == 'DELAY-GSTRESS' .or. & + obsrv%ObsTypeId == 'DELAY-ESTRESS' .or. & + obsrv%ObsTypeId == 'PRECONSTRESS-CELL') then + if (this%gwfiss /= 0) then + call this%obs%SaveOneSimval(obsrv, DNODATA) + else + v = DZERO + do j = 1, nn + n = obsrv%indxbnds(j) + select case (obsrv%ObsTypeId) + case ('SKE') + v = this%ske(n) + case ('SK') + v = this%sk(n) + case ('SKE-CELL') + ! + ! -- add the coarse component + if (j == 1) then + v = this%cg_ske(n) + else + v = this%ske(n) + end if + case ('SK-CELL') + ! + ! -- add the coarse component + if (j == 1) then + v = this%cg_sk(n) + else + v = this%sk(n) + end if + case ('DELAY-HEAD', 'DELAY-PRECONSTRESS', & + 'DELAY-GSTRESS', 'DELAY-ESTRESS') + if (n > this%ndelaycells) then + r = real(n, DP) / real(this%ndelaycells, DP) + idelay = int(floor(r)) + 1 + ncol = mod(n, this%ndelaycells) + else + idelay = 1 + ncol = n + end if + select case(obsrv%ObsTypeId) + case ('DELAY-HEAD') + v = this%dbh(ncol, idelay) + case ('DELAY-PRECONSTRESS') + v = this%dbpcs(ncol, idelay) + case ('DELAY-GSTRESS') + v = this%dbgeo(ncol, idelay) + case ('DELAY-ESTRESS') + v = this%dbes(ncol, idelay) + end select + case ('PRECONSTRESS-CELL') + v = this%pcs(n) + case default + msg = 'Error: Unrecognized observation type: ' // & + trim(obsrv%ObsTypeId) + call store_error(msg) + end select + call this%obs%SaveOneSimval(obsrv, v) + end do + end if + else + v = DZERO + do j = 1, nn + n = obsrv%indxbnds(j) + select case (obsrv%ObsTypeId) + case ('CSUB') + v = this%storagee(n) + this%storagei(n) + case ('INELASTIC-CSUB') + v = this%storagei(n) + case ('ELASTIC-CSUB') + v = this%storagee(n) + case ('COARSE-CSUB') + v = this%cg_stor(n) + case ('WCOMP-CSUB-CELL') + v = this%cell_wcstor(n) + case ('CSUB-CELL') + ! + ! -- add the coarse component + if (j == 1) then + v = this%cg_stor(n) + else + v = this%storagee(n) + this%storagei(n) + end if + case ('THETA') + v = this%theta(n) + case ('COARSE-THETA') + v = this%cg_theta(n) + case ('THETA-CELL') + ! + ! -- add the coarse component + if (j == 1) then + f = this%cg_thick(n) / this%cell_thick(n) + v = f * this%cg_theta(n) + else + node = this%nodelist(n) + f = this%csub_calc_interbed_thickness(n) / this%cell_thick(node) + v = f * this%theta(n) + end if + case ('GSTRESS-CELL') + v = this%cg_gs(n) + case ('ESTRESS-CELL') + v = this%cg_es(n) + case ('INTERBED-COMPACTION') + v = this%tcomp(n) + case ('INELASTIC-COMPACTION') + v = this%tcompi(n) + case ('ELASTIC-COMPACTION') + v = this%tcompe(n) + case ('COARSE-COMPACTION') + v = this%cg_tcomp(n) + case ('INELASTIC-COMPACTION-CELL') + ! + ! -- no coarse inelastic component + if (j > 1) then + v = this%tcompi(n) + end if + case ('ELASTIC-COMPACTION-CELL') + ! + ! -- add the coarse component + if (j == 1) then + v = this%cg_tcomp(n) + else + v = this%tcompe(n) + end if + case ('COMPACTION-CELL') + ! + ! -- add the coarse component + if (j == 1) then + v = this%cg_tcomp(n) + else + v = this%tcomp(n) + end if + case ('THICKNESS') + idelay = this%idelay(n) + v = this%thick(n) + if (idelay /= 0) then + v = v * this%rnb(n) + end if + case ('COARSE-THICKNESS') + v = this%cg_thick(n) + case ('THICKNESS-CELL') + v = this%cell_thick(n) + case ('DELAY-COMPACTION', 'DELAY-THICKNESS', & + 'DELAY-THETA') + if (n > this%ndelaycells) then + r = real(n, DP) / real(this%ndelaycells, DP) + idelay = int(floor(r)) + 1 + ncol = mod(n, this%ndelaycells) + else + idelay = 1 + ncol = n + end if + select case(obsrv%ObsTypeId) + case ('DELAY-COMPACTION') + v = this%dbtcomp(ncol, idelay) + case ('DELAY-THICKNESS') + v = this%dbdz(ncol, idelay) + case ('DELAY-THETA') + v = this%dbtheta(ncol, idelay) + end select + case ('DELAY-FLOWTOP') + idelay = this%idelay(n) + v = this%dbflowtop(idelay) + case ('DELAY-FLOWBOT') + idelay = this%idelay(n) + v = this%dbflowbot(idelay) + case default + msg = 'Error: Unrecognized observation type: ' // & + trim(obsrv%ObsTypeId) + call store_error(msg) + end select + call this%obs%SaveOneSimval(obsrv, v) + end do + end if + else + call this%obs%SaveOneSimval(obsrv, DNODATA) + end if + end do + end if + ! + ! -- write summary of package block error messages + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + return + end subroutine csub_bd_obs + + + subroutine csub_rp_obs(this) + ! -- dummy + class(GwfCsubType), intent(inout) :: this + ! -- local + integer(I4B) :: i, j, n + integer(I4B) :: n2 + integer(I4B) :: idelay + class(ObserveType), pointer :: obsrv => null() + character(len=LENBOUNDNAME) :: bname + character(len=200) :: ermsg + ! + ! -- return if observations are not supported + if (.not. this%csub_obs_supported()) then + return + end if + ! + ! -- process each package observation + do i = 1, this%obs%npakobs + obsrv => this%obs%pakobs(i)%obsrv + ! + ! -- indxbnds needs to be deallocated and reallocated (using + ! ExpandArray) each stress period because list of boundaries + ! can change each stress period. + if (allocated(obsrv%indxbnds)) then + deallocate(obsrv%indxbnds) + end if + ! + ! -- initialize BndFound to .false. + obsrv%BndFound = .false. + ! + bname = obsrv%FeatureName + if (bname /= '') then + ! + ! -- Observation location(s) is(are) based on a boundary name. + ! Iterate through all boundaries to identify and store + ! corresponding index(indices) in bound array. + do j = 1, this%ninterbeds + if (this%boundname(j) == bname) then + obsrv%BndFound = .true. + obsrv%CurrentTimeStepEndValue = DZERO + call ExpandArray(obsrv%indxbnds) + n = size(obsrv%indxbnds) + obsrv%indxbnds(n) = j + end if + end do + ! + ! -- one value per cell + else if (obsrv%ObsTypeId == 'GSTRESS-CELL' .or. & + obsrv%ObsTypeId == 'ESTRESS-CELL' .or. & + obsrv%ObsTypeId == 'THICKNESS-CELL' .or. & + obsrv%ObsTypeId == 'COARSE-CSUB' .or. & + obsrv%ObsTypeId == 'WCOMP-CSUB-CELL' .or. & + obsrv%ObsTypeId == 'COARSE-COMPACTION' .or. & + obsrv%ObsTypeId == 'COARSE-THETA' .or. & + obsrv%ObsTypeId == 'COARSE-THICKNESS') then + obsrv%BndFound = .true. + obsrv%CurrentTimeStepEndValue = DZERO + call ExpandArray(obsrv%indxbnds) + n = size(obsrv%indxbnds) + obsrv%indxbnds(n) = obsrv%NodeNumber + else if (obsrv%ObsTypeId == 'DELAY-PRECONSTRESS' .or. & + obsrv%ObsTypeId == 'DELAY-HEAD' .or. & + obsrv%ObsTypeId == 'DELAY-GSTRESS' .or. & + obsrv%ObsTypeId == 'DELAY-ESTRESS' .or. & + obsrv%ObsTypeId == 'DELAY-COMPACTION' .or. & + obsrv%ObsTypeId == 'DELAY-THICKNESS' .or. & + obsrv%ObsTypeId == 'DELAY-THETA') then + if (this%ninterbeds > 0) then + n = obsrv%NodeNumber + idelay = this%idelay(n) + if (idelay /= 0) then + j = (idelay - 1) * this%ndelaycells + 1 + n2 = obsrv%NodeNumber2 + if (n2 < 1 .or. n2 > this%ndelaycells) then + write (ermsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & + 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & + ' interbed cell must be > 0 and <=', this%ndelaycells, & + '(specified value is ', n2, ')' + call store_error(ermsg) + else + j = (idelay - 1) * this%ndelaycells + n2 + end if + obsrv%BndFound = .true. + call ExpandArray(obsrv%indxbnds) + obsrv%indxbnds(1) = j + end if + end if + ! + ! -- interbed value + else if (obsrv%ObsTypeId == 'CSUB' .or. & + obsrv%ObsTypeId == 'INELASTIC-CSUB' .or. & + obsrv%ObsTypeId == 'ELASTIC-CSUB' .or. & + obsrv%ObsTypeId == 'SK' .or. & + obsrv%ObsTypeId == 'SKE' .or. & + obsrv%ObsTypeId == 'THICKNESS' .or. & + obsrv%ObsTypeId == 'THETA' .or. & + obsrv%ObsTypeId == 'INTERBED-COMPACTION' .or. & + obsrv%ObsTypeId == 'INELASTIC-COMPACTION' .or. & + obsrv%ObsTypeId == 'ELASTIC-COMPACTION') then + if (this%ninterbeds > 0) then + j = obsrv%NodeNumber + if (j < 1 .or. j > this%ninterbeds) then + write (ermsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & + 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & + ' interbed cell must be > 0 and <=', this%ninterbeds, & + '(specified value is ', j, ')' + call store_error(ermsg) + else + obsrv%BndFound = .true. + obsrv%CurrentTimeStepEndValue = DZERO + call ExpandArray(obsrv%indxbnds) + n = size(obsrv%indxbnds) + obsrv%indxbnds(n) = j + end if + end if + else if (obsrv%ObsTypeId == 'DELAY-FLOWTOP' .or. & + obsrv%ObsTypeId == 'DELAY-FLOWBOT') then + if (this%ninterbeds > 0) then + j = obsrv%NodeNumber + if (j < 1 .or. j > this%ninterbeds) then + write (ermsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & + 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & + ' interbed cell must be > 0 and <=', this%ninterbeds, & + '(specified value is ', j, ')' + call store_error(ermsg) + end if + idelay = this%idelay(j) + if (idelay /= 0) then + obsrv%BndFound = .true. + obsrv%CurrentTimeStepEndValue = DZERO + call ExpandArray(obsrv%indxbnds) + n = size(obsrv%indxbnds) + obsrv%indxbnds(n) = j + end if + end if + else + ! + ! -- Accumulate values in a single cell + ! -- Observation location is a single node number + ! -- save node number in first position + if (obsrv%ObsTypeId == 'CSUB-CELL' .or. & + obsrv%ObsTypeId == 'SKE-CELL' .or. & + obsrv%ObsTypeId == 'SK-CELL' .or. & + obsrv%ObsTypeId == 'THETA-CELL' .or. & + obsrv%ObsTypeId == 'INELASTIC-COMPACTION-CELL' .or. & + obsrv%ObsTypeId == 'ELASTIC-COMPACTION-CELL' .or. & + obsrv%ObsTypeId == 'COMPACTION-CELL') then + if (.NOT. obsrv%BndFound) then + obsrv%BndFound = .true. + obsrv%CurrentTimeStepEndValue = DZERO + call ExpandArray(obsrv%indxbnds) + n = size(obsrv%indxbnds) + obsrv%indxbnds(n) = obsrv%NodeNumber + end if + end if + jloop: do j = 1, this%ninterbeds + if (this%nodelist(j) == obsrv%NodeNumber) then + obsrv%BndFound = .true. + obsrv%CurrentTimeStepEndValue = DZERO + call ExpandArray(obsrv%indxbnds) + n = size(obsrv%indxbnds) + obsrv%indxbnds(n) = j + endif + end do jloop + endif + enddo + ! + if (count_errors() > 0) then + call store_error_unit(this%inunit) + call ustop() + endif + ! + return + end subroutine csub_rp_obs + ! + ! -- Procedures related to observations (NOT type-bound) + subroutine csub_process_obsID(obsrv, dis, inunitobs, iout) + ! -- This procedure is pointed to by ObsDataType%ProcesssIdPtr. It processes + ! the ID string of an observation definition for csub-package observations. + ! -- dummy + type(ObserveType), intent(inout) :: obsrv + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: inunitobs + integer(I4B), intent(in) :: iout + ! -- local + integer(I4B) :: nn1 + integer(I4B) :: nn2 + integer(I4B) :: icol, istart, istop + character(len=LINELENGTH) :: strng + character(len=LENBOUNDNAME) :: bndname + logical :: flag_string + !-------------------------------------------------------------------------- + ! + strng = obsrv%IDstring + ! + ! -- Extract reach number from strng and store it. + ! If 1st item is not an integer(I4B), it should be a + ! boundary name--deal with it. + icol = 1 + ! + ! -- get icsubno number or boundary name + if (obsrv%ObsTypeId=='CSUB' .or. & + obsrv%ObsTypeId == 'INELASTIC-CSUB' .or. & + obsrv%ObsTypeId == 'ELASTIC-CSUB' .or. & + obsrv%ObsTypeId=='SK' .or. & + obsrv%ObsTypeId=='SKE' .or. & + obsrv%ObsTypeId=='THETA' .or. & + obsrv%ObsTypeId=='THICKNESS' .or. & + obsrv%ObsTypeId == 'INTERBED-COMPACTION' .or. & + obsrv%ObsTypeId == 'INELASTIC-COMPACTION' .or. & + obsrv%ObsTypeId == 'ELASTIC-COMPACTION' .or. & + obsrv%ObsTypeId=='DELAY-HEAD' .or. & + obsrv%ObsTypeId=='DELAY-GSTRESS' .or. & + obsrv%ObsTypeId=='DELAY-ESTRESS' .or. & + obsrv%ObsTypeId=='DELAY-PRECONSTRESS' .or. & + obsrv%ObsTypeId=='DELAY-COMPACTION' .or. & + obsrv%ObsTypeId=='DELAY-THICKNESS' .or. & + obsrv%ObsTypeId=='DELAY-THETA' .or. & + obsrv%ObsTypeId=='DELAY-FLOWTOP' .or. & + obsrv%ObsTypeId=='DELAY-FLOWBOT') then + call extract_idnum_or_bndname(strng, icol, istart, istop, nn1, bndname) + else + nn1 = dis%noder_from_string(icol, istart, istop, inunitobs, & + iout, strng, flag_string) + end if + if (nn1 == NAMEDBOUNDFLAG) then + obsrv%FeatureName = bndname + else + if (obsrv%ObsTypeId=='DELAY-HEAD' .or. & + obsrv%ObsTypeId=='DELAY-GSTRESS' .or. & + obsrv%ObsTypeId=='DELAY-ESTRESS' .or. & + obsrv%ObsTypeId=='DELAY-PRECONSTRESS' .or. & + obsrv%ObsTypeId=='DELAY-COMPACTION' .or. & + obsrv%ObsTypeId=='DELAY-THICKNESS' .or. & + obsrv%ObsTypeId=='DELAY-THETA') then + call extract_idnum_or_bndname(strng, icol, istart, istop, nn2, bndname) + if (nn2 == NAMEDBOUNDFLAG) then + obsrv%FeatureName = bndname + ! -- reset nn1 + nn1 = nn2 + else + obsrv%NodeNumber2 = nn2 + end if + end if + endif + ! + ! -- store reach number (NodeNumber) + obsrv%NodeNumber = nn1 + ! + ! -- return + return + end subroutine csub_process_obsID + + ! + ! -- Procedure related to time series + subroutine csub_rp_ts(this) + ! + ! -- Assign tsLink%Text appropriately for + ! all time series in use by package. + ! In the CSUB package only the SIG0 variable + ! can be controlled by time series. + ! -- dummy + class(GwfCsubType), intent(inout) :: this + ! -- local + integer(I4B) :: i, nlinks + type(TimeSeriesLinkType), pointer :: tslink => null() + ! + ! -- process all timeseries links + nlinks = this%TsManager%boundtslinks%Count() + do i = 1, nlinks + tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) + if (associated(tslink)) then + if (tslink%JCol==1) then + tslink%Text = 'SIG0' + endif + endif + enddo + ! + return + end subroutine csub_rp_ts + +end module GwfCsubModule diff --git a/src/Model/GroundWaterFlow/gwf3dis8.f90 b/src/Model/GroundWaterFlow/gwf3dis8.f90 index 61087f59719..37b4369ee65 100644 --- a/src/Model/GroundWaterFlow/gwf3dis8.f90 +++ b/src/Model/GroundWaterFlow/gwf3dis8.f90 @@ -1,1917 +1,1917 @@ -module GwfDisModule - - use ArrayReadersModule, only: ReadArray - use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH, DHALF - use BaseDisModule, only: DisBaseType - use InputOutputModule, only: get_node, URWORD, ulasav, ulaprufw, ubdsv1, & - ubdsv06 - use SimModule, only: count_errors, store_error, store_error_unit, ustop - use BlockParserModule, only: BlockParserType - use MemoryManagerModule, only: mem_allocate - use TdisModule, only: kstp, kper, pertim, totim, delt - - implicit none - private - public dis_cr, dis_init_mem, GwfDisType - - type, extends(DisBaseType) :: GwfDisType - integer(I4B), pointer :: nlay => null() ! number of layers - integer(I4B), pointer :: nrow => null() ! number of rows - integer(I4B), pointer :: ncol => null() ! number of columns - real(DP), dimension(:), pointer, contiguous :: delr => null() ! spacing along a row - real(DP), dimension(:), pointer, contiguous :: delc => null() ! spacing along a column - real(DP), dimension(:, :), pointer, contiguous :: top2d => null() ! top elevations for each cell at top of model (ncol, nrow) - real(DP), dimension(:, :, :), pointer, contiguous :: bot3d => null() ! bottom elevations for each cell (ncol, nrow, nlay) - integer(I4B), dimension(:, :, :), pointer, contiguous :: idomain => null() ! idomain (ncol, nrow, nlay) - real(DP), dimension(:, :, :), pointer :: botm => null() ! top and bottom elevations for each cell (ncol, nrow, nlay) - real(DP), dimension(:), pointer, contiguous :: cellx => null() ! cell center x coordinate for column j - real(DP), dimension(:), pointer, contiguous :: celly => null() ! cell center y coordinate for row i - contains - procedure :: dis_df => dis3d_df - procedure :: dis_da => dis3d_da - procedure :: get_cellxy => get_cellxy_dis3d - procedure :: get_dis_type => get_dis_type - procedure, public :: record_array - procedure, public :: read_layer_array - procedure, public :: record_srcdst_list_header - procedure, public :: nlarray_to_nodelist - ! -- helper functions - procedure :: get_nodenumber_idx1 - procedure :: get_nodenumber_idx3 - procedure :: nodeu_to_string - procedure :: nodeu_to_array - procedure :: nodeu_from_string - procedure :: nodeu_from_cellid - procedure :: supports_layers - procedure :: get_ncpl - procedure :: connection_vector - procedure :: connection_normal - ! -- private - procedure :: read_options - procedure :: read_dimensions - procedure :: read_mf6_griddata - procedure :: grid_finalize - procedure :: write_grb - procedure :: allocate_scalars - procedure :: allocate_arrays - ! - ! -- Read a node-sized model array (reduced or not) - procedure :: read_int_array - procedure :: read_dbl_array - end type GwfDisType - - contains - - subroutine dis_cr(dis, name_model, inunit, iout) -! ****************************************************************************** -! dis_cr -- Create a new discretization 3d object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(DisBaseType), pointer :: dis - character(len=*), intent(in) :: name_model - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - type(GwfDisType), pointer :: disnew -! ------------------------------------------------------------------------------ - allocate(disnew) - dis => disnew - call disnew%allocate_scalars(name_model) - dis%inunit = inunit - dis%iout = iout - ! - ! -- Initialize block parser - call dis%parser%Initialize(dis%inunit, dis%iout) - ! - ! -- Return - return - end subroutine dis_cr - - subroutine dis_init_mem(dis, name_model, iout, nlay, nrow, ncol, & - delr, delc, top2d, bot3d, idomain) -! ****************************************************************************** -! dis_init_mem -- Create a new discretization 3d object from memory -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(DisBaseType), pointer :: dis - character(len=*), intent(in) :: name_model - integer(I4B), intent(in) :: iout - integer(I4B), intent(in) :: nlay - integer(I4B), intent(in) :: nrow - integer(I4B), intent(in) :: ncol - real(DP), dimension(:), pointer, contiguous, intent(in) :: delr - real(DP), dimension(:), pointer, contiguous, intent(in) :: delc - real(DP), dimension(:, :), pointer, contiguous, intent(in) :: top2d - real(DP), dimension(:, :, :), pointer, contiguous, intent(in) :: bot3d - integer(I4B), dimension(:, :, :), pointer, contiguous, intent(in), & - optional :: idomain - ! -- local - type(GwfDisType), pointer :: disext - integer(I4B) :: i - integer(I4B) :: j - integer(I4B) :: k - integer(I4B) :: ival - ! -- local -! ------------------------------------------------------------------------------ - allocate(disext) - dis => disext - call disext%allocate_scalars(name_model) - dis%inunit = 0 - dis%iout = iout - ! - ! -- set dimensions - disext%nrow = nrow - disext%ncol = ncol - disext%nlay = nlay - ! - ! -- calculate nodesuser - disext%nodesuser = disext%nlay * disext%nrow * disext%ncol - ! - ! -- Allocate delr, delc, and non-reduced vectors for dis - call mem_allocate(disext%delr, disext%ncol, 'DELR', disext%origin) - call mem_allocate(disext%delc, disext%nrow, 'DELC', disext%origin) - call mem_allocate(disext%idomain, disext%ncol, disext%nrow, disext%nlay, & - 'IDOMAIN',disext%origin) - call mem_allocate(disext%top2d, disext%ncol, disext%nrow, 'TOP2D', & - disext%origin) - call mem_allocate(disext%bot3d, disext%ncol, disext%nrow, disext%nlay, & - 'BOT3D', disext%origin) - ! -- fill data - do i = 1, disext%nrow - disext%delc(i) = delc(i) - end do - do j = 1, disext%ncol - disext%delr(j) = delr(j) - end do - do k = 1, disext%nlay - do i = 1, disext%nrow - do j = 1, disext%ncol - if (k == 1) then - disext%top2d(j, i) = top2d(j, i) - end if - disext%bot3d(j, i, k) = bot3d(j, i, k) - if (present(idomain)) then - ival = idomain(j, i, k) - else - ival = 1 - end if - disext%idomain(j, i, k) = ival - end do - end do - end do - ! - ! -- Return - return - end subroutine dis_init_mem - - subroutine dis3d_df(this) -! ****************************************************************************** -! read_from_file -- Allocate and read discretization information -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DNODATA - ! -- dummy - class(GwfDisType) :: this - ! -- locals -! ------------------------------------------------------------------------------ - ! - ! -- read data from file - 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() - ! - ! -- Read dimensions block - call this%read_dimensions() - ! - ! -- Read GRIDDATA block - call this%read_mf6_griddata() - end if - ! - ! -- Final grid initialization - call this%grid_finalize() - ! - ! -- Return - return - end subroutine dis3d_df - - subroutine dis3d_da(this) -! ****************************************************************************** -! dis3d_da -- Deallocate discretization data -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(GwfDisType) :: this - ! -- locals -! ------------------------------------------------------------------------------ - ! - ! -- DisBaseType deallocate - call this%DisBaseType%dis_da() - ! - ! -- Deallocate scalars - call mem_deallocate(this%nlay) - call mem_deallocate(this%nrow) - call mem_deallocate(this%ncol) - call mem_deallocate(this%delr) - call mem_deallocate(this%delc) - call mem_deallocate(this%cellx) - call mem_deallocate(this%celly) - ! - ! -- Deallocate Arrays - call mem_deallocate(this%nodereduced) - call mem_deallocate(this%nodeuser) - call mem_deallocate(this%top2d) - call mem_deallocate(this%bot3d) - call mem_deallocate(this%idomain) - ! - ! -- Return - return - end subroutine dis3d_da - - subroutine read_options(this) -! ****************************************************************************** -! read_options -- Read options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - ! -- 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' - endif - 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() - call ustop() - 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) write(this%iout,'(1x,a)') 'MODEL LENGTH UNIT IS UNDEFINED' - ! - ! -- Return - return - end subroutine read_options - - subroutine read_dimensions(this) -! ****************************************************************************** -! read_dimensions -- Read dimensions -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - ! -- dummy - class(GwfDisType) :: this - ! -- locals - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ierr - integer(I4B) :: i, j, k - logical :: isfound, endOfBlock -! ------------------------------------------------------------------------------ - ! - ! -- 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() - call ustop() - 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() - call ustop() - end if - ! - ! -- verify dimensions were set - if(this%nlay < 1) then - call store_error( & - 'ERROR. NLAY WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') - call this%parser%StoreErrorUnit() - call ustop() - endif - if(this%nrow < 1) then - call store_error( & - 'ERROR. NROW WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') - call this%parser%StoreErrorUnit() - call ustop() - endif - if(this%ncol < 1) then - call store_error( & - 'ERROR. NCOL WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- calculate nodesuser - this%nodesuser = this%nlay * this%nrow * this%ncol - ! - ! -- Allocate delr, delc, and non-reduced vectors for dis - call mem_allocate(this%delr, this%ncol, 'DELR', this%origin) - call mem_allocate(this%delc, this%nrow, 'DELC', this%origin) - call mem_allocate(this%idomain, this%ncol, this%nrow, this%nlay, 'IDOMAIN', & - this%origin) - call mem_allocate(this%top2d, this%ncol, this%nrow, 'TOP2D', this%origin) - call mem_allocate(this%bot3d, this%ncol, this%nrow, this%nlay, 'BOT3D', & - this%origin) - call mem_allocate(this%cellx, this%ncol, 'CELLX', this%origin) - call mem_allocate(this%celly, this%nrow, 'CELLY', this%origin) - ! - ! -- initialize all cells to be active (idomain = 1) - do k = 1, this%nlay - do i = 1, this%nrow - do j = 1, this%ncol - this%idomain(j, i, k) = 1 - end do - end do - end do - ! - ! -- Return - return - end subroutine read_dimensions - - subroutine read_mf6_griddata(this) -! ****************************************************************************** -! read_mf6_griddata -- Read griddata from a MODFLOW 6 ascii file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: ustop, count_errors, store_error - use ConstantsModule, only: LINELENGTH, DZERO - use MemoryManagerModule, only: mem_allocate - ! -- 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 - ! -- 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() - call ustop() - 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() - call ustop() - end if - ! - ! -- 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) - endif - enddo - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Return - return - end subroutine read_mf6_griddata - - subroutine grid_finalize(this) -! ****************************************************************************** -! grid_finalize -- Finalize grid -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: ustop, count_errors, store_error - use ConstantsModule, only: LINELENGTH, DZERO - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(GwfDisType) :: this - ! -- locals - character(len=300) :: ermsg - integer(I4B) :: n, i, j, k - integer(I4B) :: node - integer(I4B) :: noder - integer(I4B) :: nrsize - real(DP) :: top - real(DP) :: dz - ! -- formats - character(len=*), parameter :: fmtdz = & - "('ERROR. CELL (',i0,',',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, //)" -! ------------------------------------------------------------------------------ - ! - ! -- count active cells - this%nodes = 0 - do k = 1, this%nlay - do i = 1, this%nrow - do j = 1, this%ncol - if(this%idomain(j, i, k) > 0) this%nodes = this%nodes + 1 - enddo - enddo - enddo - ! - ! -- Check to make sure nodes is a valid number - if (this%nodes == 0) then - call store_error('ERROR. MODEL DOES NOT HAVE ANY ACTIVE NODES.') - call store_error('MAKE SURE IDOMAIN ARRAY HAS SOME VALUES GREATER & - &THAN ZERO.') - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- Check cell thicknesses - n = 0 - do k = 1, this%nlay - do i = 1, this%nrow - do j = 1, this%ncol - if (this%idomain(j, i, k) < 1) cycle - if (k > 1) then - top = this%bot3d(j, i, k - 1) - else - top = this%top2d(j, i) - end if - dz = top - this%bot3d(j, i, k) - if (dz <= DZERO) then - n = n + 1 - write(ermsg, fmt=fmtdz) k, i, j, top, this%bot3d(j, i, k) - call store_error(ermsg) - endif - enddo - enddo - enddo - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Write message if reduced grid - if(this%nodes < this%nodesuser) then - write(this%iout, fmtnr) this%nodesuser, this%nodes - endif - ! - ! -- Array size is now known, so allocate - call this%allocate_arrays() - ! - ! -- Fill the nodereduced array with the reduced nodenumber, or - ! a negative number to indicate it is a pass-through cell, or - ! a zero to indicate that the cell is excluded from the - ! solution. - if(this%nodes < this%nodesuser) then - node = 1 - noder = 1 - do k = 1, this%nlay - do i = 1, this%nrow - do j = 1, this%ncol - if(this%idomain(j, i, k) > 0) then - this%nodereduced(node) = noder - noder = noder + 1 - elseif(this%idomain(j, i, k) < 0) then - this%nodereduced(node) = -1 - else - this%nodereduced(node) = 0 - endif - node = node + 1 - enddo - enddo - enddo - endif - ! - ! -- allocate and fill nodeuser if a reduced grid - if(this%nodes < this%nodesuser) then - node = 1 - noder = 1 - do k = 1, this%nlay - do i = 1, this%nrow - do j = 1, this%ncol - if(this%idomain(j, i, k) > 0) then - this%nodeuser(noder) = node - noder = noder + 1 - endif - node = node + 1 - enddo - enddo - enddo - endif - ! - ! -- Move top2d and botm3d into top and bot, and calculate area - node = 0 - do k=1,this%nlay - do i=1,this%nrow - do j=1,this%ncol - node = node + 1 - noder = node - if(this%nodes < this%nodesuser) noder = this%nodereduced(node) - if(noder <= 0) cycle - if (k > 1) then - top = this%bot3d(j, i, k - 1) - else - top = this%top2d(j, i) - end if - this%top(noder) = top - this%bot(noder) = this%bot3d(j, i, k) - this%area(noder) = this%delr(j) * this%delc(i) - enddo - enddo - enddo - ! - ! -- fill x,y coordinate arrays - this%cellx(1) = DHALF*this%delr(1) - this%celly(this%nrow) = DHALF*this%delc(this%nrow) - do j = 2, this%ncol - this%cellx(j) = this%cellx(j-1) + DHALF*this%delr(j-1) + DHALF*this%delr(j) - enddo - ! -- row number increases in negative y direction: - do i = this%nrow-1, 1, -1 - this%celly(i) = this%celly(i+1) + DHALF*this%delc(i+1) + DHALF*this%delc(i) - enddo - ! - ! -- create and fill the connections object - nrsize = 0 - if(this%nodes < this%nodesuser) nrsize = this%nodes - allocate(this%con) - call this%con%disconnections(this%name_model, this%nodes, & - this%ncol, this%nrow, this%nlay, & - nrsize, this%delr, this%delc, & - this%top, this%bot, this%nodereduced, & - this%nodeuser) - this%nja = this%con%nja - this%njas = this%con%njas - ! - ! -- Return - return - end subroutine grid_finalize - - subroutine write_grb(this, icelltype) -! ****************************************************************************** -! write_grb -- Write the binary grid file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: getunit, openfile - use OpenSpecModule, only: access, form - use ConstantsModule, only: DZERO - ! -- dummy - class(GwfDisType) :: this - integer(I4B), dimension(:), intent(in) :: icelltype - ! -- local - integer(I4B) :: iunit, ntxt, ncpl - integer(I4B), parameter :: lentxt = 100 - character(len=50) :: txthdr - character(len=lentxt) :: txt - character(len=LINELENGTH) :: fname - character(len=*),parameter :: fmtgrdsave = & - "(4X,'BINARY GRID INFORMATION WILL BE WRITTEN TO:', & - &/,6X,'UNIT NUMBER: ', I0,/,6X, 'FILE NAME: ', A)" -! ------------------------------------------------------------------------------ - ! - ! -- Initialize - ntxt = 16 - ncpl = this%nrow * this%ncol - ! - ! -- Open the file - inquire(unit=this%inunit, name=fname) - fname = trim(fname) // '.grb' - iunit = getunit() - write(this%iout, fmtgrdsave) iunit, trim(adjustl(fname)) - call openfile(iunit, this%iout, trim(adjustl(fname)), 'DATA(BINARY)', & - form, access, 'REPLACE') - ! - ! -- write header information - write(txthdr, '(a)') 'GRID DIS' - txthdr(50:50) = new_line('a') - write(iunit) txthdr - write(txthdr, '(a)') 'VERSION 1' - txthdr(50:50) = new_line('a') - write(iunit) txthdr - write(txthdr, '(a, i0)') 'NTXT ', ntxt - txthdr(50:50) = new_line('a') - write(iunit) txthdr - write(txthdr, '(a, i0)') 'LENTXT ', lentxt - txthdr(50:50) = new_line('a') - write(iunit) txthdr - ! - ! -- write variable definitions - write(txt, '(3a, i0)') 'NCELLS ', 'INTEGER ', 'NDIM 0 # ', this%nodesuser - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'NLAY ', 'INTEGER ', 'NDIM 0 # ', this%nlay - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'NROW ', 'INTEGER ', 'NDIM 0 # ', this%nrow - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'NCOL ', 'INTEGER ', 'NDIM 0 # ', this%ncol - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'NJA ', 'INTEGER ', 'NDIM 0 # ', this%nja - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, 1pg24.15)') 'XORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%xorigin - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, 1pg24.15)') 'YORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%yorigin - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, 1pg24.15)') 'ANGROT ', 'DOUBLE ', 'NDIM 0 # ', this%angrot - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'DELR ', 'DOUBLE ', 'NDIM 1 ', this%ncol - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'DELC ', 'DOUBLE ', 'NDIM 1 ', this%nrow - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'TOP ', 'DOUBLE ', 'NDIM 1 ', ncpl - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'BOTM ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'IA ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + 1 - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'JA ', 'INTEGER ', 'NDIM 1 ', size(this%con%jausr) - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'IDOMAIN ', 'INTEGER ', 'NDIM 1 ', this%nodesuser - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'ICELLTYPE ', 'INTEGER ', 'NDIM 1 ', this%nodesuser - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - ! - ! -- write data - write(iunit) this%nodesuser ! ncells - write(iunit) this%nlay ! nlay - write(iunit) this%nrow ! nrow - write(iunit) this%ncol ! ncol - write(iunit) this%nja ! nja - write(iunit) this%xorigin ! xorigin - write(iunit) this%yorigin ! yorigin - write(iunit) this%angrot ! angrot - write(iunit) this%delr ! delr - write(iunit) this%delc ! delc - write(iunit) this%top2d ! top2d - write(iunit) this%bot3d ! bot3d - write(iunit) this%con%iausr ! iausr - write(iunit) this%con%jausr ! jausr - write(iunit) this%idomain ! idomain - write(iunit) icelltype ! icelltype - ! - ! -- Close the file - close(iunit) - ! - ! -- return - return - end subroutine write_grb - - subroutine nodeu_to_string(this, nodeu, str) -! ****************************************************************************** -! nodeu_to_string -- Convert user node number to a string in the form of -! (nodenumber) or (k,i,j) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use InputOutputModule, only: get_ijk - implicit none - class(GwfDisType) :: this - integer(I4B), intent(in) :: nodeu - character(len=*), intent(inout) :: str - ! -- local - integer(I4B) :: i, j, k - character(len=10) :: kstr, istr, jstr -! ------------------------------------------------------------------------------ - ! - call get_ijk(nodeu, this%nrow, this%ncol, this%nlay, i, j, k) - write(kstr, '(i10)') k - write(istr, '(i10)') i - write(jstr, '(i10)') j - str = '(' // trim(adjustl(kstr)) // ',' // & - trim(adjustl(istr)) // ',' // & - trim(adjustl(jstr)) // ')' - ! - ! -- return - return - end subroutine nodeu_to_string - - subroutine nodeu_to_array(this, nodeu, arr) -! ****************************************************************************** -! nodeu_to_array -- Convert user node number to cellid and fill array with -! (nodenumber) or (k,j) or (k,i,j) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use InputOutputModule, only: get_ijk - implicit none - class(GwfDisType) :: this - integer(I4B), intent(in) :: nodeu - integer(I4B), dimension(:), intent(inout) :: arr - ! -- local - character(len=LINELENGTH) :: errmsg - integer(I4B) :: isize - integer(I4B) :: i, j, k -! ------------------------------------------------------------------------------ - ! - ! -- check the size of arr - isize = size(arr) - if (isize /= this%ndim) then - write(errmsg,'(a,i0,a,i0,a)') & - 'Program error: nodeu_to_array size of array (', isize, & - ') is not equal to the discretization dimension (', this%ndim, ')' - call store_error(errmsg) - call ustop() - end if - ! - ! -- get k, i, j - call get_ijk(nodeu, this%nrow, this%ncol, this%nlay, i, j, k) - ! - ! -- fill array - arr(1) = k - arr(2) = i - arr(3) = j - ! - ! -- return - return - end subroutine nodeu_to_array - - function get_nodenumber_idx1(this, nodeu, icheck) result(nodenumber) -! ****************************************************************************** -! get_nodenumber -- Return a nodenumber from the user specified node number -! with an option to perform a check. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - ! -- return - integer(I4B) :: nodenumber - ! -- dummy - class(GwfDisType), intent(in) :: this - integer(I4B), intent(in) :: nodeu - integer(I4B), intent(in) :: icheck - ! -- local - character(len=LINELENGTH) :: errmsg -! ------------------------------------------------------------------------------ - ! - ! -- check the node number if requested - if(icheck /= 0) then - ! - ! -- If within valid range, convert to reduced nodenumber - if(nodeu < 1 .or. nodeu > this%nodesuser) then - write(errmsg, '(a,i10)') & - 'Nodenumber less than 1 or greater than nodes:', nodeu - call store_error(errmsg) - nodenumber = 0 - else - nodenumber = nodeu - if(this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) - endif - else - nodenumber = nodeu - if(this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) - endif - ! - ! -- return - return - end function get_nodenumber_idx1 - - function get_nodenumber_idx3(this, k, i, j, icheck) & - result(nodenumber) -! ****************************************************************************** -! get_nodenumber_idx3 -- Return a nodenumber from the user specified layer, row, -! and column with an option to perform a check. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use InputOutputModule, only: get_node - implicit none - ! -- return - integer(I4B) :: nodenumber - ! -- dummy - class(GwfDisType), intent(in) :: this - integer(I4B), intent(in) :: k, i, j - integer(I4B), intent(in) :: icheck - ! -- local - character(len=LINELENGTH) :: errmsg - integer(I4B) :: nodeu - ! formats - character(len=*), parameter :: fmterr = & - "('Error in structured-grid cell indices: layer = ',i0,', row = ',i0,', column = ',i0)" -! ------------------------------------------------------------------------------ - ! - nodeu = get_node(k, i, j, this%nlay, this%nrow, this%ncol) - if (nodeu < 1) then - write(errmsg, fmterr) k, i, j - call store_error(errmsg) - call ustop() - endif - nodenumber = nodeu - if(this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) - ! - ! -- check the node number if requested - if(icheck /= 0) then - ! - if(k < 1 .or. k > this%nlay) & - call store_error('Layer less than one or greater than nlay') - if(i < 1 .or. i > this%nrow) & - call store_error('Row less than one or greater than nrow') - if(j < 1 .or. j > this%ncol) & - call store_error('Column less than one or greater than ncol') - ! - ! -- Error if outside of range - if(nodeu < 1 .or. nodeu > this%nodesuser) then - write(errmsg, '(a,i10)') & - 'Nodenumber less than 1 or greater than nodes:', nodeu - call store_error(errmsg) - endif - endif - ! - ! -- return - return - end function get_nodenumber_idx3 - - subroutine allocate_scalars(this, name_model) -! ****************************************************************************** -! allocate_scalars -- Allocate and initialize scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(GwfDisType) :: this - character(len=*), intent(in) :: name_model -! ------------------------------------------------------------------------------ - ! - ! -- Allocate parent scalars - call this%DisBaseType%allocate_scalars(name_model) - ! - ! -- Allocate - call mem_allocate(this%nlay, 'NLAY', this%origin) - call mem_allocate(this%nrow, 'NROW', this%origin) - call mem_allocate(this%ncol, 'NCOL', this%origin) - ! - ! -- Initialize - this%nlay = 0 - this%nrow = 0 - this%ncol = 0 - this%ndim = 3 - ! - ! -- Return - return - end subroutine allocate_scalars - - subroutine allocate_arrays(this) -! ****************************************************************************** -! allocate_arrays -- Allocate arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(GwfDisType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Allocate arrays in DisBaseType (mshape, top, bot, area) - call this%DisBaseType%allocate_arrays() - ! - ! -- Allocate arrays for GwfDisType - if(this%nodes < this%nodesuser) then - call mem_allocate(this%nodeuser, this%nodes, 'NODEUSER', this%origin) - call mem_allocate(this%nodereduced, this%nodesuser, 'NODEREDUCED', & - this%origin) - else - call mem_allocate(this%nodeuser, 1, 'NODEUSER', this%origin) - call mem_allocate(this%nodereduced, 1, 'NODEREDUCED', this%origin) - endif - ! - ! -- Initialize - this%mshape(1) = this%nlay - this%mshape(2) = this%nrow - this%mshape(3) = this%ncol - ! - ! -- Return - return - end subroutine allocate_arrays - - function nodeu_from_string(this, lloc, istart, istop, in, iout, line, & - flag_string, allow_zero) result(nodeu) -! ****************************************************************************** -! nodeu_from_string -- Receive a string and convert the string to a user -! nodenumber. The model discretization is DIS; read layer, row, and column. -! If flag_string argument is present and true, the first token in string -! is allowed to be a string (e.g. boundary name). In this case, if a string -! is encountered, return value as -2. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfDisType) :: this - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout - character(len=*), intent(inout) :: line - logical, optional, intent(in) :: flag_string - logical, optional, intent(in) :: allow_zero - integer(I4B) :: nodeu - ! -- local - integer(I4B) :: k, i, j, nlay, nrow, ncol - integer(I4B) :: lloclocal, ndum, istat, n - real(DP) :: r - character(len=LINELENGTH) :: ermsg, fname -! ------------------------------------------------------------------------------ - ! - if (present(flag_string)) then - if (flag_string) then - ! Check to see if first token in line can be read as an integer. - lloclocal = lloc - call urword(line, lloclocal, istart, istop, 1, ndum, r, iout, in) - read(line(istart:istop),*,iostat=istat)n - if (istat /= 0) then - ! First token in line is not an integer; return flag to this effect. - nodeu = -2 - return - endif - endif - endif - ! - nlay = this%mshape(1) - nrow = this%mshape(2) - ncol = this%mshape(3) - ! - call urword(line, lloc, istart, istop, 2, k, r, iout, in) - call urword(line, lloc, istart, istop, 2, i, r, iout, in) - call urword(line, lloc, istart, istop, 2, j, r, iout, in) - ! - if (k == 0 .and. i == 0 .and. j == 0) then - if (present(allow_zero)) then - if (allow_zero) then - nodeu = 0 - return - endif - endif - endif - ! - if(k < 1 .or. k > nlay) then - write(ermsg, *) ' Layer number in list is outside of the grid', k - call store_error(ermsg) - end if - if(i < 1 .or. i > nrow) then - write(ermsg, *) ' Row number in list is outside of the grid', i - call store_error(ermsg) - end if - if(j < 1 .or. j > ncol) then - write(ermsg, *) ' Column number in list is outside of the grid', j - call store_error(ermsg) - end if - nodeu = get_node(k, i, j, nlay, nrow, ncol) - ! - if(nodeu < 1 .or. nodeu > this%nodesuser) then - write(ermsg, *) ' Node number in list is outside of the grid', nodeu - call store_error(ermsg) - inquire(unit=in, name=fname) - call store_error('Error converting in file: ') - call store_error(trim(adjustl(fname))) - call store_error('Cell number cannot be determined in line: ') - call store_error(trim(adjustl(line))) - call store_error_unit(in) - call ustop() - end if - ! - ! -- return - return - - end function nodeu_from_string - - function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & - allow_zero) result(nodeu) -! ****************************************************************************** -! nodeu_from_cellid -- Receive cellid as a string and convert the string to a -! user nodenumber. -! If flag_string argument is present and true, the first token in string -! is allowed to be a string (e.g. boundary name). In this case, if a string -! is encountered, return value as -2. -! If allow_zero argument is present and true, if all indices equal zero, the -! result can be zero. If allow_zero is false, a zero in any index causes an -! error. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - integer(I4B) :: nodeu - ! -- dummy - class(GwfDisType) :: this - character(len=*), intent(inout) :: cellid - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - logical, optional, intent(in) :: flag_string - logical, optional, intent(in) :: allow_zero - ! -- local - integer(I4B) :: lloclocal, istart, istop, ndum, n - integer(I4B) :: k, i, j, nlay, nrow, ncol - integer(I4B) :: istat - real(DP) :: r - character(len=LINELENGTH) :: ermsg, fname -! ------------------------------------------------------------------------------ - ! - if (present(flag_string)) then - if (flag_string) then - ! Check to see if first token in cellid can be read as an integer. - lloclocal = 1 - call urword(cellid, lloclocal, istart, istop, 1, ndum, r, iout, inunit) - read(cellid(istart:istop), *, iostat=istat) n - if (istat /= 0) then - ! First token in cellid is not an integer; return flag to this effect. - nodeu = -2 - return - endif - endif - endif - ! - nlay = this%mshape(1) - nrow = this%mshape(2) - ncol = this%mshape(3) - ! - lloclocal = 1 - call urword(cellid, lloclocal, istart, istop, 2, k, r, iout, inunit) - call urword(cellid, lloclocal, istart, istop, 2, i, r, iout, inunit) - call urword(cellid, lloclocal, istart, istop, 2, j, r, iout, inunit) - ! - if (k == 0 .and. i == 0 .and. j == 0) then - if (present(allow_zero)) then - if (allow_zero) then - nodeu = 0 - return - endif - endif - endif - ! - if(k < 1 .or. k > nlay) then - write(ermsg, *) ' Layer number in list is outside of the grid', k - call store_error(ermsg) - end if - if(i < 1 .or. i > nrow) then - write(ermsg, *) ' Row number in list is outside of the grid', i - call store_error(ermsg) - end if - if(j < 1 .or. j > ncol) then - write(ermsg, *) ' Column number in list is outside of the grid', j - call store_error(ermsg) - end if - nodeu = get_node(k, i, j, nlay, nrow, ncol) - ! - if(nodeu < 1 .or. nodeu > this%nodesuser) then - write(ermsg, *) ' Node number in list is outside of the grid', nodeu - call store_error(ermsg) - inquire(unit=inunit, name=fname) - call store_error('Error converting in file: ') - call store_error(trim(adjustl(fname))) - call store_error('Cell number cannot be determined in cellid: ') - call store_error(trim(adjustl(cellid))) - call store_error_unit(inunit) - call ustop() - end if - ! - ! -- return - return - end function nodeu_from_cellid - - - logical function supports_layers(this) - implicit none - ! -- dummy - class(GwfDisType) :: this - ! - supports_layers = .true. - return - end function supports_layers - - function get_ncpl(this) -! ****************************************************************************** -! get_ncpl -- Return number of cells per layer. This is nrow * ncol -! for a DIS3D grid. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - integer(I4B) :: get_ncpl - ! -- dummy - class(GwfDisType) :: this -! ------------------------------------------------------------------------------ - ! - get_ncpl = this%nrow * this%ncol - ! - ! -- Return - return - end function get_ncpl - - subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & - ipos) -! ****************************************************************************** -! connection_normal -- calculate the normal vector components for reduced -! nodenumber cell (noden) and its shared face with cell nodem. ihc is the -! horizontal connection flag. Connection normal is a normal vector pointing -! outward from the shared face between noden and nodem. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DZERO, DONE - use InputOutputModule, only: get_ijk - ! -- dummy - class(GwfDisType) :: this - integer(I4B), intent(in) :: noden - integer(I4B), intent(in) :: nodem - integer(I4B), intent(in) :: ihc - real(DP), intent(inout) :: xcomp - real(DP), intent(inout) :: ycomp - real(DP), intent(inout) :: zcomp - integer(I4B), intent(in) :: ipos - ! -- local - integer(I4B) :: nodeu1, i1, j1, k1 - integer(I4B) :: nodeu2, i2, j2, k2 -! ------------------------------------------------------------------------------ - ! - ! -- Set vector components based on ihc - if(ihc == 0) then - xcomp = DZERO - ycomp = DZERO - if(nodem < noden) then - ! - ! -- nodem must be above noden, so upward connection - zcomp = DONE - else - ! - ! -- nodem must be below noden, so downward connection - zcomp = -DONE - endif - else - xcomp = DZERO - ycomp = DZERO - zcomp = DZERO - nodeu1 = this%get_nodeuser(noden) - nodeu2 = this%get_nodeuser(nodem) - call get_ijk(nodeu1, this%nrow, this%ncol, this%nlay, i1, j1, k1) - call get_ijk(nodeu2, this%nrow, this%ncol, this%nlay, i2, j2, k2) - if (i2 < i1) then ! back - ycomp = DONE - elseif (j2 < j1) then ! left - xcomp = -DONE - elseif (j2 > j1) then ! right - xcomp = DONE - else ! front - ycomp = -DONE - endif - ! - endif - ! - ! -- return - return - end subroutine connection_normal - - subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & - xcomp, ycomp, zcomp, conlen) -! ****************************************************************************** -! connection_vector -- calculate the unit vector components from reduced -! nodenumber cell (noden) to its neighbor cell (nodem). The saturation for -! for these cells are also required so that the vertical position of the cell -! cell centers can be calculated. ihc is the horizontal flag. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DZERO, DONE, DHALF - use DisvGeom, only: line_unit_vector - use InputOutputModule, only: get_ijk - ! -- dummy - class(GwfDisType) :: this - integer(I4B), intent(in) :: noden - integer(I4B), intent(in) :: nodem - logical, intent(in) :: nozee - real(DP), intent(in) :: satn - real(DP), intent(in) :: satm - integer(I4B), intent(in) :: ihc - real(DP), intent(inout) :: xcomp - real(DP), intent(inout) :: ycomp - real(DP), intent(inout) :: zcomp - real(DP), intent(inout) :: conlen - ! -- local - real(DP) :: z1, z2 - real(DP) :: x1, y1, x2, y2 - real(DP) :: ds - integer(I4B) :: i1, i2, j1, j2, k1, k2 - integer(I4B) :: nodeu1, nodeu2, ipos -! ------------------------------------------------------------------------------ - ! - ! -- Set vector components based on ihc - if(ihc == 0) then - ! - ! -- vertical connection; set zcomp positive upward - xcomp = DZERO - ycomp = DZERO - if(nodem < noden) then - zcomp = DONE - else - zcomp = -DONE - endif - z1 = this%bot(noden) + DHALF * (this%top(noden) - this%bot(noden)) - z2 = this%bot(nodem) + DHALF * (this%top(nodem) - this%bot(nodem)) - conlen = abs(z2 - z1) - else - ! - if(nozee) then - z1 = DZERO - z2 = DZERO - else - z1 = this%bot(noden) + DHALF * satn * (this%top(noden) - this%bot(noden)) - z2 = this%bot(nodem) + DHALF * satm * (this%top(nodem) - this%bot(nodem)) - endif - ipos = this%con%getjaindex(noden, nodem) - ds = this%con%cl1(this%con%jas(ipos)) + this%con%cl2(this%con%jas(ipos)) - nodeu1 = this%get_nodeuser(noden) - nodeu2 = this%get_nodeuser(nodem) - call get_ijk(nodeu1, this%nrow, this%ncol, this%nlay, i1, j1, k1) - call get_ijk(nodeu2, this%nrow, this%ncol, this%nlay, i2, j2, k2) - x1 = DZERO - x2 = DZERO - y1 = DZERO - y2 = DZERO - if (i2 < i1) then ! back - y2 = ds - elseif (j2 < j1) then ! left - x2 = -ds - elseif (j2 > j1) then ! right - x2 = ds - else ! front - y2 = -ds - endif - call line_unit_vector(x1, y1, z1, x2, y2, z2, xcomp, ycomp, zcomp, conlen) - endif - ! - ! -- return - return - end subroutine - - ! return x,y coordinate for a node - subroutine get_cellxy_dis3d(this, node, xcell, ycell) - use InputOutputModule, only: get_ijk - class(GwfDisType), intent(in) :: this - integer(I4B), intent(in) :: node ! the reduced node number - real(DP), intent(out) :: xcell, ycell ! the x,y for the cell - ! local - integer(I4B) :: nodeuser, i, j, k - - nodeuser = this%get_nodeuser(node) - call get_ijk(nodeuser, this%nrow, this%ncol, this%nlay, i, j, k) - - xcell = this%cellx(j) - ycell = this%celly(i) - - end subroutine get_cellxy_dis3d - - ! return discretization type - subroutine get_dis_type(this, dis_type) - class(GwfDisType), intent(in) :: this - character(len=*), intent(out) :: dis_type - - dis_type = "DIS" - - end subroutine get_dis_type - - subroutine read_int_array(this, line, lloc, istart, istop, iout, in, & - iarray, aname) -! ****************************************************************************** -! read_int_array -- Read a GWF integer array -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: urword - use SimModule, only: store_error, ustop - use ConstantsModule, only: LINELENGTH - ! -- dummy - class(GwfDisType), intent(inout) :: this - character(len=*), intent(inout) :: line - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: iarray - character(len=*), intent(in) :: aname - ! -- local - integer(I4B) :: ival - real(DP) :: rval - integer(I4B) :: nlay - integer(I4B) :: nrow - integer(I4B) :: ncol - integer(I4B) :: nval - integer(I4B), dimension(:), pointer, contiguous :: itemp -! ------------------------------------------------------------------------------ - ! - ! -- Point the temporary pointer array, which is passed to the reading - ! subroutine. The temporary array will point to ibuff if it is a - ! reduced structured system, or to iarray if it is an unstructured - ! model. - nlay = this%mshape(1) - nrow = this%mshape(2) - ncol = this%mshape(3) - ! - if (this%nodes < this%nodesuser) then - nval = this%nodesuser - itemp => this%ibuff - else - nval = this%nodes - itemp => iarray - endif - ! - ! -- Read the array - call urword(line, lloc, istart, istop, 1, ival, rval, iout, in) - if (line(istart:istop).EQ.'LAYERED') then - ! - ! -- Read layered input - call ReadArray(in, itemp, aname, this%ndim, ncol, nrow, nlay, nval, & - iout, 1, nlay) - else - ! - ! -- Read unstructured input - call ReadArray(in, itemp, aname, this%ndim, nval, iout, 0) - end if - ! - ! -- If reduced model, then need to copy from itemp(=>ibuff) to iarray - if (this%nodes < this%nodesuser) then - call this%fill_grid_array(itemp, iarray) - endif - ! - ! -- return - return - end subroutine read_int_array - - subroutine read_dbl_array(this, line, lloc, istart, istop, iout, in, & - darray, aname) -! ****************************************************************************** -! read_dbl_array -- Read a GWF double precision array -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: urword - use SimModule, only: ustop, store_error - use ConstantsModule, only: LINELENGTH - ! -- dummy - class(GwfDisType), intent(inout) :: this - character(len=*), intent(inout) :: line - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout - real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray - character(len=*), intent(in) :: aname - ! -- local - integer(I4B) :: ival - real(DP) :: rval - integer(I4B) :: nlay - integer(I4B) :: nrow - integer(I4B) :: ncol - integer(I4B) :: nval - real(DP), dimension(:), pointer, contiguous :: dtemp -! ------------------------------------------------------------------------------ - ! - ! -- Point the temporary pointer array, which is passed to the reading - ! subroutine. The temporary array will point to dbuff if it is a - ! reduced structured system, or to darray if it is an unstructured - ! model. - nlay = this%mshape(1) - nrow = this%mshape(2) - ncol = this%mshape(3) - ! - if(this%nodes < this%nodesuser) then - nval = this%nodesuser - dtemp => this%dbuff - else - nval = this%nodes - dtemp => darray - endif - ! - ! -- Read the array - call urword(line, lloc, istart, istop, 1, ival, rval, iout, in) - if (line(istart:istop).EQ.'LAYERED') then - ! - ! -- Read structured input - call ReadArray(in, dtemp, aname, this%ndim, ncol, nrow, nlay, nval, & - iout, 1, nlay) - else - ! - ! -- Read unstructured input - call ReadArray(in, dtemp, aname, this%ndim, nval, iout, 0) - end if - ! - ! -- If reduced model, then need to copy from dtemp(=>dbuff) to darray - if(this%nodes < this%nodesuser) then - call this%fill_grid_array(dtemp, darray) - endif - ! - ! -- return - return - end subroutine read_dbl_array - - subroutine read_layer_array(this, nodelist, darray, ncolbnd, maxbnd, & - icolbnd, aname, inunit, iout) -! ****************************************************************************** -! read_layer_array -- Read a 2d double array into col icolbnd of darray. -! For cells that are outside of the active domain, -! do not copy the array value into darray. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: get_node - ! -- dummy - class(GwfDisType) :: this - integer(I4B), intent(in) :: maxbnd - integer(I4B), dimension(maxbnd) :: nodelist - integer(I4B), intent(in) :: ncolbnd - real(DP), dimension(ncolbnd, maxbnd), intent(inout) :: darray - integer(I4B), intent(in) :: icolbnd - character(len=*), intent(in) :: aname - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - ! -- local - integer(I4B) :: il, ir, ic, ncol, nrow, nlay, nval, ipos, noder, nodeu - logical :: found -! ------------------------------------------------------------------------------ - ! - ! -- set variables - nlay = this%mshape(1) - nrow = this%mshape(2) - ncol = this%mshape(3) - ! - ! -- Read the array - nval = ncol * nrow - call ReadArray(inunit, this%dbuff, aname, this%ndim, ncol, nrow, nlay, & - nval, iout, 0, 0) - ! - ! -- Copy array into bound - ipos = 1 - do ir = 1, nrow - columnloop: do ic = 1, ncol - ! - ! -- look down through all layers and see if nodeu == nodelist(ipos) - ! cycle if not, because node must be inactive or pass through - found = .false. - layerloop: do il = 1, nlay - nodeu = get_node(il, ir, ic, nlay, nrow, ncol) - noder = this%get_nodenumber(nodeu, 0) - if(noder == 0) cycle layerloop - if(noder == nodelist(ipos)) then - found = .true. - exit layerloop - endif - enddo layerloop - if(.not. found) cycle columnloop - ! - ! -- Assign the array value to darray - nodeu = get_node(1, ir, ic, nlay, nrow, ncol) - darray(icolbnd, ipos) = this%dbuff(nodeu) - ipos = ipos + 1 - ! - enddo columnloop - enddo - ! - ! -- return - end subroutine read_layer_array - - subroutine record_array(this, darray, iout, iprint, idataun, aname, & - cdatafmp, nvaluesp, nwidthp, editdesc, dinact) -! ****************************************************************************** -! record_array -- Record a double precision array. The array will be -! printed to an external file and/or written to an unformatted external file -! depending on the argument specifications. -! ****************************************************************************** -! -! SPECIFICATIONS: -! darray is the double precision array to record -! iout is the unit number for ascii output -! iprint is a flag indicating whether or not to print the array -! idataun is the unit number to which the array will be written in binary -! form; if negative then do not write by layers, write entire array -! aname is the text descriptor of the array -! cdatafmp is the fortran format for writing the array -! nvaluesp is the number of values per line for printing -! nwidthp is the width of the number for printing -! editdesc is the format type (I, G, F, S, E) -! dinact is the double precision value to use for cells that are excluded -! from the model domain -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(GwfDisType), intent(inout) :: this - real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray - integer(I4B), intent(in) :: iout - integer(I4B), intent(in) :: iprint - integer(I4B), intent(in) :: idataun - character(len=*), intent(in) :: aname - character(len=*), intent(in) :: cdatafmp - integer(I4B), intent(in) :: nvaluesp - integer(I4B), intent(in) :: nwidthp - character(len=*), intent(in) :: editdesc - real(DP), intent(in) :: dinact - ! -- local - integer(I4B) :: k, ifirst - integer(I4B) :: nlay - integer(I4B) :: nrow - integer(I4B) :: ncol - integer(I4B) :: nval - integer(I4B) :: nodeu, noder - integer(I4B) :: istart, istop - real(DP), dimension(:), pointer, contiguous :: dtemp - ! -- formats - character(len=*),parameter :: fmthsv = & - "(1X,/1X,a,' WILL BE SAVED ON UNIT ',I4, & - &' AT END OF TIME STEP',I5,', STRESS PERIOD ',I4)" -! ------------------------------------------------------------------------------ - ! - ! -- set variables - nlay = this%mshape(1) - nrow = this%mshape(2) - ncol = this%mshape(3) - ! - ! -- If this is a reduced model, then copy the values from darray into - ! dtemp. - if(this%nodes < this%nodesuser) then - nval = this%nodes - dtemp => this%dbuff - do nodeu = 1, this%nodesuser - noder = this%get_nodenumber(nodeu, 0) - if(noder <= 0) then - dtemp(nodeu) = dinact - cycle - endif - dtemp(nodeu) = darray(noder) - enddo - else - nval = this%nodes - dtemp => darray - endif - ! - ! -- Print to iout if iprint /= 0 - if(iprint /= 0) then - istart = 1 - do k = 1, nlay - istop = istart + nrow * ncol - 1 - call ulaprufw(ncol, nrow, kstp, kper, k, iout, dtemp(istart:istop), & - aname, cdatafmp, nvaluesp, nwidthp, editdesc) - istart = istop + 1 - enddo - endif - ! - ! -- Save array to an external file. - if(idataun > 0) then - ! -- write to binary file by layer - ifirst = 1 - istart = 1 - do k=1, nlay - istop = istart + nrow * ncol - 1 - if(ifirst == 1) write(iout, fmthsv) & - trim(adjustl(aname)), idataun, & - kstp, kper - ifirst = 0 - call ulasav(dtemp(istart:istop), aname, kstp, kper, & - pertim, totim, ncol, nrow, k, idataun) - istart = istop + 1 - enddo - elseif(idataun < 0) then - ! - ! -- write entire array as one record - call ubdsv1(kstp, kper, aname, -idataun, dtemp, ncol, nrow, nlay, & - iout, delt, pertim, totim) - endif - ! - ! -- return - return - end subroutine record_array - - subroutine record_srcdst_list_header(this, text, textmodel, textpackage, & - dstmodel, dstpackage, naux, auxtxt, & - ibdchn, nlist, iout) -! ****************************************************************************** -! record_srcdst_list_header -- Record list header for imeth=6 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfDisType) :: this - character(len=16), intent(in) :: text - character(len=16), intent(in) :: textmodel - character(len=16), intent(in) :: textpackage - character(len=16), intent(in) :: dstmodel - character(len=16), intent(in) :: dstpackage - integer(I4B), intent(in) :: naux - character(len=16), dimension(:), intent(in) :: auxtxt - integer(I4B), intent(in) :: ibdchn - integer(I4B), intent(in) :: nlist - integer(I4B), intent(in) :: iout - ! -- local - integer(I4B) :: nlay, nrow, ncol -! ------------------------------------------------------------------------------ - ! - nlay = this%mshape(1) - nrow = this%mshape(2) - ncol = this%mshape(3) - ! - ! -- Use ubdsv06 to write list header - call ubdsv06(kstp, kper, text, textmodel, textpackage, dstmodel, dstpackage,& - ibdchn, naux, auxtxt, ncol, nrow, nlay, & - nlist, iout, delt, pertim, totim) - ! - ! -- return - return - end subroutine record_srcdst_list_header - - subroutine nlarray_to_nodelist(this, nodelist, maxbnd, nbound, aname, & - inunit, iout) -! ****************************************************************************** -! nlarray_to_nodelist -- Read an integer array into nodelist. For structured -! model, integer array is layer number; for unstructured -! model, integer array is node number. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: get_node - use SimModule, only: ustop, store_error - use ConstantsModule, only: LINELENGTH - ! -- dummy - class(GwfDisType) :: this - integer(I4B), intent(in) :: maxbnd - integer(I4B), dimension(maxbnd), intent(inout) :: nodelist - integer(I4B), intent(inout) :: nbound - character(len=*), intent(in) :: aname - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - ! -- local - integer(I4B) :: il, ir, ic, ncol, nrow, nlay, nval, nodeu, noder, ipos, ierr - character(len=LINELENGTH) :: errmsg -! ------------------------------------------------------------------------------ - ! - ! -- set variables - nlay = this%mshape(1) - nrow = this%mshape(2) - ncol = this%mshape(3) - ! - if(this%ndim > 1) then - ! - nval = ncol * nrow - call ReadArray(inunit, this%ibuff, aname, this%ndim, ncol, nrow, nlay, nval, iout, 0, 0) - ! - ! -- Copy array into nodelist - ipos = 1 - ierr = 0 - do ir = 1, nrow - do ic = 1, ncol - nodeu = get_node(1, ir, ic, nlay, nrow, ncol) - il = this%ibuff(nodeu) - if(il < 1 .or. il > nlay) then - write(errmsg, *) 'ERROR. INVALID LAYER NUMBER: ', il - call store_error(errmsg) - call ustop() - endif - nodeu = get_node(il, ir, ic, nlay, nrow, ncol) - noder = this%get_nodenumber(nodeu, 0) - if(noder > 0) then - if(ipos > maxbnd) then - ierr = ipos - else - nodelist(ipos) = noder - endif - ipos = ipos + 1 - endif - enddo - enddo - ! - ! -- Check for errors - nbound = ipos - 1 - if(ierr > 0) then - write(errmsg, *) 'ERROR. MAXBOUND DIMENSION IS TOO SMALL.' - call store_error(errmsg) - write(errmsg, *) 'INCREASE MAXBOUND TO: ', ierr - call store_error(errmsg) - call ustop() - endif - ! - ! -- If nbound < maxbnd, then initialize nodelist to zero in this range - if(nbound < maxbnd) then - do ipos = nbound+1, maxbnd - nodelist(ipos) = 0 - enddo - endif - ! - else - ! - ! -- For unstructured, read nodelist directly, then check node numbers - call ReadArray(inunit, nodelist, aname, this%ndim, maxbnd, iout, 0) - do noder = 1, maxbnd - if(noder < 1 .or. noder > this%nodes) then - write(errmsg, *) 'ERROR. INVALID NODE NUMBER: ', noder - call store_error(errmsg) - call ustop() - endif - enddo - nbound = maxbnd - ! - endif - ! - ! -- return - end subroutine nlarray_to_nodelist - -end module GwfDisModule +module GwfDisModule + + use ArrayReadersModule, only: ReadArray + use KindModule, only: DP, I4B + use ConstantsModule, only: LINELENGTH, DHALF + use BaseDisModule, only: DisBaseType + use InputOutputModule, only: get_node, URWORD, ulasav, ulaprufw, ubdsv1, & + ubdsv06 + use SimModule, only: count_errors, store_error, store_error_unit, ustop + use BlockParserModule, only: BlockParserType + use MemoryManagerModule, only: mem_allocate + use TdisModule, only: kstp, kper, pertim, totim, delt + + implicit none + private + public dis_cr, dis_init_mem, GwfDisType + + type, extends(DisBaseType) :: GwfDisType + integer(I4B), pointer :: nlay => null() ! number of layers + integer(I4B), pointer :: nrow => null() ! number of rows + integer(I4B), pointer :: ncol => null() ! number of columns + real(DP), dimension(:), pointer, contiguous :: delr => null() ! spacing along a row + real(DP), dimension(:), pointer, contiguous :: delc => null() ! spacing along a column + real(DP), dimension(:, :), pointer, contiguous :: top2d => null() ! top elevations for each cell at top of model (ncol, nrow) + real(DP), dimension(:, :, :), pointer, contiguous :: bot3d => null() ! bottom elevations for each cell (ncol, nrow, nlay) + integer(I4B), dimension(:, :, :), pointer, contiguous :: idomain => null() ! idomain (ncol, nrow, nlay) + real(DP), dimension(:, :, :), pointer :: botm => null() ! top and bottom elevations for each cell (ncol, nrow, nlay) + real(DP), dimension(:), pointer, contiguous :: cellx => null() ! cell center x coordinate for column j + real(DP), dimension(:), pointer, contiguous :: celly => null() ! cell center y coordinate for row i + contains + procedure :: dis_df => dis3d_df + procedure :: dis_da => dis3d_da + procedure :: get_cellxy => get_cellxy_dis3d + procedure :: get_dis_type => get_dis_type + procedure, public :: record_array + procedure, public :: read_layer_array + procedure, public :: record_srcdst_list_header + procedure, public :: nlarray_to_nodelist + ! -- helper functions + procedure :: get_nodenumber_idx1 + procedure :: get_nodenumber_idx3 + procedure :: nodeu_to_string + procedure :: nodeu_to_array + procedure :: nodeu_from_string + procedure :: nodeu_from_cellid + procedure :: supports_layers + procedure :: get_ncpl + procedure :: connection_vector + procedure :: connection_normal + ! -- private + procedure :: read_options + procedure :: read_dimensions + procedure :: read_mf6_griddata + procedure :: grid_finalize + procedure :: write_grb + procedure :: allocate_scalars + procedure :: allocate_arrays + ! + ! -- Read a node-sized model array (reduced or not) + procedure :: read_int_array + procedure :: read_dbl_array + end type GwfDisType + + contains + + subroutine dis_cr(dis, name_model, inunit, iout) +! ****************************************************************************** +! dis_cr -- Create a new discretization 3d object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(DisBaseType), pointer :: dis + character(len=*), intent(in) :: name_model + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + type(GwfDisType), pointer :: disnew +! ------------------------------------------------------------------------------ + allocate(disnew) + dis => disnew + call disnew%allocate_scalars(name_model) + dis%inunit = inunit + dis%iout = iout + ! + ! -- Initialize block parser + call dis%parser%Initialize(dis%inunit, dis%iout) + ! + ! -- Return + return + end subroutine dis_cr + + subroutine dis_init_mem(dis, name_model, iout, nlay, nrow, ncol, & + delr, delc, top2d, bot3d, idomain) +! ****************************************************************************** +! dis_init_mem -- Create a new discretization 3d object from memory +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(DisBaseType), pointer :: dis + character(len=*), intent(in) :: name_model + integer(I4B), intent(in) :: iout + integer(I4B), intent(in) :: nlay + integer(I4B), intent(in) :: nrow + integer(I4B), intent(in) :: ncol + real(DP), dimension(:), pointer, contiguous, intent(in) :: delr + real(DP), dimension(:), pointer, contiguous, intent(in) :: delc + real(DP), dimension(:, :), pointer, contiguous, intent(in) :: top2d + real(DP), dimension(:, :, :), pointer, contiguous, intent(in) :: bot3d + integer(I4B), dimension(:, :, :), pointer, contiguous, intent(in), & + optional :: idomain + ! -- local + type(GwfDisType), pointer :: disext + integer(I4B) :: i + integer(I4B) :: j + integer(I4B) :: k + integer(I4B) :: ival + ! -- local +! ------------------------------------------------------------------------------ + allocate(disext) + dis => disext + call disext%allocate_scalars(name_model) + dis%inunit = 0 + dis%iout = iout + ! + ! -- set dimensions + disext%nrow = nrow + disext%ncol = ncol + disext%nlay = nlay + ! + ! -- calculate nodesuser + disext%nodesuser = disext%nlay * disext%nrow * disext%ncol + ! + ! -- Allocate delr, delc, and non-reduced vectors for dis + call mem_allocate(disext%delr, disext%ncol, 'DELR', disext%origin) + call mem_allocate(disext%delc, disext%nrow, 'DELC', disext%origin) + call mem_allocate(disext%idomain, disext%ncol, disext%nrow, disext%nlay, & + 'IDOMAIN',disext%origin) + call mem_allocate(disext%top2d, disext%ncol, disext%nrow, 'TOP2D', & + disext%origin) + call mem_allocate(disext%bot3d, disext%ncol, disext%nrow, disext%nlay, & + 'BOT3D', disext%origin) + ! -- fill data + do i = 1, disext%nrow + disext%delc(i) = delc(i) + end do + do j = 1, disext%ncol + disext%delr(j) = delr(j) + end do + do k = 1, disext%nlay + do i = 1, disext%nrow + do j = 1, disext%ncol + if (k == 1) then + disext%top2d(j, i) = top2d(j, i) + end if + disext%bot3d(j, i, k) = bot3d(j, i, k) + if (present(idomain)) then + ival = idomain(j, i, k) + else + ival = 1 + end if + disext%idomain(j, i, k) = ival + end do + end do + end do + ! + ! -- Return + return + end subroutine dis_init_mem + + subroutine dis3d_df(this) +! ****************************************************************************** +! read_from_file -- Allocate and read discretization information +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DNODATA + ! -- dummy + class(GwfDisType) :: this + ! -- locals +! ------------------------------------------------------------------------------ + ! + ! -- read data from file + 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() + ! + ! -- Read dimensions block + call this%read_dimensions() + ! + ! -- Read GRIDDATA block + call this%read_mf6_griddata() + end if + ! + ! -- Final grid initialization + call this%grid_finalize() + ! + ! -- Return + return + end subroutine dis3d_df + + subroutine dis3d_da(this) +! ****************************************************************************** +! dis3d_da -- Deallocate discretization data +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(GwfDisType) :: this + ! -- locals +! ------------------------------------------------------------------------------ + ! + ! -- DisBaseType deallocate + call this%DisBaseType%dis_da() + ! + ! -- Deallocate scalars + call mem_deallocate(this%nlay) + call mem_deallocate(this%nrow) + call mem_deallocate(this%ncol) + call mem_deallocate(this%delr) + call mem_deallocate(this%delc) + call mem_deallocate(this%cellx) + call mem_deallocate(this%celly) + ! + ! -- Deallocate Arrays + call mem_deallocate(this%nodereduced) + call mem_deallocate(this%nodeuser) + call mem_deallocate(this%top2d) + call mem_deallocate(this%bot3d) + call mem_deallocate(this%idomain) + ! + ! -- Return + return + end subroutine dis3d_da + + subroutine read_options(this) +! ****************************************************************************** +! read_options -- Read options +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + ! -- 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' + endif + 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() + call ustop() + 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) write(this%iout,'(1x,a)') 'MODEL LENGTH UNIT IS UNDEFINED' + ! + ! -- Return + return + end subroutine read_options + + subroutine read_dimensions(this) +! ****************************************************************************** +! read_dimensions -- Read dimensions +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + ! -- dummy + class(GwfDisType) :: this + ! -- locals + character(len=LINELENGTH) :: errmsg, keyword + integer(I4B) :: ierr + integer(I4B) :: i, j, k + logical :: isfound, endOfBlock +! ------------------------------------------------------------------------------ + ! + ! -- 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() + call ustop() + 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() + call ustop() + end if + ! + ! -- verify dimensions were set + if(this%nlay < 1) then + call store_error( & + 'ERROR. NLAY WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') + call this%parser%StoreErrorUnit() + call ustop() + endif + if(this%nrow < 1) then + call store_error( & + 'ERROR. NROW WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') + call this%parser%StoreErrorUnit() + call ustop() + endif + if(this%ncol < 1) then + call store_error( & + 'ERROR. NCOL WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- calculate nodesuser + this%nodesuser = this%nlay * this%nrow * this%ncol + ! + ! -- Allocate delr, delc, and non-reduced vectors for dis + call mem_allocate(this%delr, this%ncol, 'DELR', this%origin) + call mem_allocate(this%delc, this%nrow, 'DELC', this%origin) + call mem_allocate(this%idomain, this%ncol, this%nrow, this%nlay, 'IDOMAIN', & + this%origin) + call mem_allocate(this%top2d, this%ncol, this%nrow, 'TOP2D', this%origin) + call mem_allocate(this%bot3d, this%ncol, this%nrow, this%nlay, 'BOT3D', & + this%origin) + call mem_allocate(this%cellx, this%ncol, 'CELLX', this%origin) + call mem_allocate(this%celly, this%nrow, 'CELLY', this%origin) + ! + ! -- initialize all cells to be active (idomain = 1) + do k = 1, this%nlay + do i = 1, this%nrow + do j = 1, this%ncol + this%idomain(j, i, k) = 1 + end do + end do + end do + ! + ! -- Return + return + end subroutine read_dimensions + + subroutine read_mf6_griddata(this) +! ****************************************************************************** +! read_mf6_griddata -- Read griddata from a MODFLOW 6 ascii file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: ustop, count_errors, store_error + use ConstantsModule, only: LINELENGTH, DZERO + use MemoryManagerModule, only: mem_allocate + ! -- 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 + ! -- 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() + call ustop() + 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() + call ustop() + end if + ! + ! -- 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) + endif + enddo + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Return + return + end subroutine read_mf6_griddata + + subroutine grid_finalize(this) +! ****************************************************************************** +! grid_finalize -- Finalize grid +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: ustop, count_errors, store_error + use ConstantsModule, only: LINELENGTH, DZERO + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GwfDisType) :: this + ! -- locals + character(len=300) :: ermsg + integer(I4B) :: n, i, j, k + integer(I4B) :: node + integer(I4B) :: noder + integer(I4B) :: nrsize + real(DP) :: top + real(DP) :: dz + ! -- formats + character(len=*), parameter :: fmtdz = & + "('ERROR. CELL (',i0,',',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, //)" +! ------------------------------------------------------------------------------ + ! + ! -- count active cells + this%nodes = 0 + do k = 1, this%nlay + do i = 1, this%nrow + do j = 1, this%ncol + if(this%idomain(j, i, k) > 0) this%nodes = this%nodes + 1 + enddo + enddo + enddo + ! + ! -- Check to make sure nodes is a valid number + if (this%nodes == 0) then + call store_error('ERROR. MODEL DOES NOT HAVE ANY ACTIVE NODES.') + call store_error('MAKE SURE IDOMAIN ARRAY HAS SOME VALUES GREATER & + &THAN ZERO.') + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- Check cell thicknesses + n = 0 + do k = 1, this%nlay + do i = 1, this%nrow + do j = 1, this%ncol + if (this%idomain(j, i, k) < 1) cycle + if (k > 1) then + top = this%bot3d(j, i, k - 1) + else + top = this%top2d(j, i) + end if + dz = top - this%bot3d(j, i, k) + if (dz <= DZERO) then + n = n + 1 + write(ermsg, fmt=fmtdz) k, i, j, top, this%bot3d(j, i, k) + call store_error(ermsg) + endif + enddo + enddo + enddo + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Write message if reduced grid + if(this%nodes < this%nodesuser) then + write(this%iout, fmtnr) this%nodesuser, this%nodes + endif + ! + ! -- Array size is now known, so allocate + call this%allocate_arrays() + ! + ! -- Fill the nodereduced array with the reduced nodenumber, or + ! a negative number to indicate it is a pass-through cell, or + ! a zero to indicate that the cell is excluded from the + ! solution. + if(this%nodes < this%nodesuser) then + node = 1 + noder = 1 + do k = 1, this%nlay + do i = 1, this%nrow + do j = 1, this%ncol + if(this%idomain(j, i, k) > 0) then + this%nodereduced(node) = noder + noder = noder + 1 + elseif(this%idomain(j, i, k) < 0) then + this%nodereduced(node) = -1 + else + this%nodereduced(node) = 0 + endif + node = node + 1 + enddo + enddo + enddo + endif + ! + ! -- allocate and fill nodeuser if a reduced grid + if(this%nodes < this%nodesuser) then + node = 1 + noder = 1 + do k = 1, this%nlay + do i = 1, this%nrow + do j = 1, this%ncol + if(this%idomain(j, i, k) > 0) then + this%nodeuser(noder) = node + noder = noder + 1 + endif + node = node + 1 + enddo + enddo + enddo + endif + ! + ! -- Move top2d and botm3d into top and bot, and calculate area + node = 0 + do k=1,this%nlay + do i=1,this%nrow + do j=1,this%ncol + node = node + 1 + noder = node + if(this%nodes < this%nodesuser) noder = this%nodereduced(node) + if(noder <= 0) cycle + if (k > 1) then + top = this%bot3d(j, i, k - 1) + else + top = this%top2d(j, i) + end if + this%top(noder) = top + this%bot(noder) = this%bot3d(j, i, k) + this%area(noder) = this%delr(j) * this%delc(i) + enddo + enddo + enddo + ! + ! -- fill x,y coordinate arrays + this%cellx(1) = DHALF*this%delr(1) + this%celly(this%nrow) = DHALF*this%delc(this%nrow) + do j = 2, this%ncol + this%cellx(j) = this%cellx(j-1) + DHALF*this%delr(j-1) + DHALF*this%delr(j) + enddo + ! -- row number increases in negative y direction: + do i = this%nrow-1, 1, -1 + this%celly(i) = this%celly(i+1) + DHALF*this%delc(i+1) + DHALF*this%delc(i) + enddo + ! + ! -- create and fill the connections object + nrsize = 0 + if(this%nodes < this%nodesuser) nrsize = this%nodes + allocate(this%con) + call this%con%disconnections(this%name_model, this%nodes, & + this%ncol, this%nrow, this%nlay, & + nrsize, this%delr, this%delc, & + this%top, this%bot, this%nodereduced, & + this%nodeuser) + this%nja = this%con%nja + this%njas = this%con%njas + ! + ! -- Return + return + end subroutine grid_finalize + + subroutine write_grb(this, icelltype) +! ****************************************************************************** +! write_grb -- Write the binary grid file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: getunit, openfile + use OpenSpecModule, only: access, form + use ConstantsModule, only: DZERO + ! -- dummy + class(GwfDisType) :: this + integer(I4B), dimension(:), intent(in) :: icelltype + ! -- local + integer(I4B) :: iunit, ntxt, ncpl + integer(I4B), parameter :: lentxt = 100 + character(len=50) :: txthdr + character(len=lentxt) :: txt + character(len=LINELENGTH) :: fname + character(len=*),parameter :: fmtgrdsave = & + "(4X,'BINARY GRID INFORMATION WILL BE WRITTEN TO:', & + &/,6X,'UNIT NUMBER: ', I0,/,6X, 'FILE NAME: ', A)" +! ------------------------------------------------------------------------------ + ! + ! -- Initialize + ntxt = 16 + ncpl = this%nrow * this%ncol + ! + ! -- Open the file + inquire(unit=this%inunit, name=fname) + fname = trim(fname) // '.grb' + iunit = getunit() + write(this%iout, fmtgrdsave) iunit, trim(adjustl(fname)) + call openfile(iunit, this%iout, trim(adjustl(fname)), 'DATA(BINARY)', & + form, access, 'REPLACE') + ! + ! -- write header information + write(txthdr, '(a)') 'GRID DIS' + txthdr(50:50) = new_line('a') + write(iunit) txthdr + write(txthdr, '(a)') 'VERSION 1' + txthdr(50:50) = new_line('a') + write(iunit) txthdr + write(txthdr, '(a, i0)') 'NTXT ', ntxt + txthdr(50:50) = new_line('a') + write(iunit) txthdr + write(txthdr, '(a, i0)') 'LENTXT ', lentxt + txthdr(50:50) = new_line('a') + write(iunit) txthdr + ! + ! -- write variable definitions + write(txt, '(3a, i0)') 'NCELLS ', 'INTEGER ', 'NDIM 0 # ', this%nodesuser + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'NLAY ', 'INTEGER ', 'NDIM 0 # ', this%nlay + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'NROW ', 'INTEGER ', 'NDIM 0 # ', this%nrow + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'NCOL ', 'INTEGER ', 'NDIM 0 # ', this%ncol + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'NJA ', 'INTEGER ', 'NDIM 0 # ', this%nja + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, 1pg24.15)') 'XORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%xorigin + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, 1pg24.15)') 'YORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%yorigin + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, 1pg24.15)') 'ANGROT ', 'DOUBLE ', 'NDIM 0 # ', this%angrot + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'DELR ', 'DOUBLE ', 'NDIM 1 ', this%ncol + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'DELC ', 'DOUBLE ', 'NDIM 1 ', this%nrow + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'TOP ', 'DOUBLE ', 'NDIM 1 ', ncpl + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'BOTM ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'IA ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + 1 + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'JA ', 'INTEGER ', 'NDIM 1 ', size(this%con%jausr) + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'IDOMAIN ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'ICELLTYPE ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + ! + ! -- write data + write(iunit) this%nodesuser ! ncells + write(iunit) this%nlay ! nlay + write(iunit) this%nrow ! nrow + write(iunit) this%ncol ! ncol + write(iunit) this%nja ! nja + write(iunit) this%xorigin ! xorigin + write(iunit) this%yorigin ! yorigin + write(iunit) this%angrot ! angrot + write(iunit) this%delr ! delr + write(iunit) this%delc ! delc + write(iunit) this%top2d ! top2d + write(iunit) this%bot3d ! bot3d + write(iunit) this%con%iausr ! iausr + write(iunit) this%con%jausr ! jausr + write(iunit) this%idomain ! idomain + write(iunit) icelltype ! icelltype + ! + ! -- Close the file + close(iunit) + ! + ! -- return + return + end subroutine write_grb + + subroutine nodeu_to_string(this, nodeu, str) +! ****************************************************************************** +! nodeu_to_string -- Convert user node number to a string in the form of +! (nodenumber) or (k,i,j) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use InputOutputModule, only: get_ijk + implicit none + class(GwfDisType) :: this + integer(I4B), intent(in) :: nodeu + character(len=*), intent(inout) :: str + ! -- local + integer(I4B) :: i, j, k + character(len=10) :: kstr, istr, jstr +! ------------------------------------------------------------------------------ + ! + call get_ijk(nodeu, this%nrow, this%ncol, this%nlay, i, j, k) + write(kstr, '(i10)') k + write(istr, '(i10)') i + write(jstr, '(i10)') j + str = '(' // trim(adjustl(kstr)) // ',' // & + trim(adjustl(istr)) // ',' // & + trim(adjustl(jstr)) // ')' + ! + ! -- return + return + end subroutine nodeu_to_string + + subroutine nodeu_to_array(this, nodeu, arr) +! ****************************************************************************** +! nodeu_to_array -- Convert user node number to cellid and fill array with +! (nodenumber) or (k,j) or (k,i,j) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use InputOutputModule, only: get_ijk + implicit none + class(GwfDisType) :: this + integer(I4B), intent(in) :: nodeu + integer(I4B), dimension(:), intent(inout) :: arr + ! -- local + character(len=LINELENGTH) :: errmsg + integer(I4B) :: isize + integer(I4B) :: i, j, k +! ------------------------------------------------------------------------------ + ! + ! -- check the size of arr + isize = size(arr) + if (isize /= this%ndim) then + write(errmsg,'(a,i0,a,i0,a)') & + 'Program error: nodeu_to_array size of array (', isize, & + ') is not equal to the discretization dimension (', this%ndim, ')' + call store_error(errmsg) + call ustop() + end if + ! + ! -- get k, i, j + call get_ijk(nodeu, this%nrow, this%ncol, this%nlay, i, j, k) + ! + ! -- fill array + arr(1) = k + arr(2) = i + arr(3) = j + ! + ! -- return + return + end subroutine nodeu_to_array + + function get_nodenumber_idx1(this, nodeu, icheck) result(nodenumber) +! ****************************************************************************** +! get_nodenumber -- Return a nodenumber from the user specified node number +! with an option to perform a check. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + ! -- return + integer(I4B) :: nodenumber + ! -- dummy + class(GwfDisType), intent(in) :: this + integer(I4B), intent(in) :: nodeu + integer(I4B), intent(in) :: icheck + ! -- local + character(len=LINELENGTH) :: errmsg +! ------------------------------------------------------------------------------ + ! + ! -- check the node number if requested + if(icheck /= 0) then + ! + ! -- If within valid range, convert to reduced nodenumber + if(nodeu < 1 .or. nodeu > this%nodesuser) then + write(errmsg, '(a,i10)') & + 'Nodenumber less than 1 or greater than nodes:', nodeu + call store_error(errmsg) + nodenumber = 0 + else + nodenumber = nodeu + if(this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) + endif + else + nodenumber = nodeu + if(this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) + endif + ! + ! -- return + return + end function get_nodenumber_idx1 + + function get_nodenumber_idx3(this, k, i, j, icheck) & + result(nodenumber) +! ****************************************************************************** +! get_nodenumber_idx3 -- Return a nodenumber from the user specified layer, row, +! and column with an option to perform a check. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use InputOutputModule, only: get_node + implicit none + ! -- return + integer(I4B) :: nodenumber + ! -- dummy + class(GwfDisType), intent(in) :: this + integer(I4B), intent(in) :: k, i, j + integer(I4B), intent(in) :: icheck + ! -- local + character(len=LINELENGTH) :: errmsg + integer(I4B) :: nodeu + ! formats + character(len=*), parameter :: fmterr = & + "('Error in structured-grid cell indices: layer = ',i0,', row = ',i0,', column = ',i0)" +! ------------------------------------------------------------------------------ + ! + nodeu = get_node(k, i, j, this%nlay, this%nrow, this%ncol) + if (nodeu < 1) then + write(errmsg, fmterr) k, i, j + call store_error(errmsg) + call ustop() + endif + nodenumber = nodeu + if(this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) + ! + ! -- check the node number if requested + if(icheck /= 0) then + ! + if(k < 1 .or. k > this%nlay) & + call store_error('Layer less than one or greater than nlay') + if(i < 1 .or. i > this%nrow) & + call store_error('Row less than one or greater than nrow') + if(j < 1 .or. j > this%ncol) & + call store_error('Column less than one or greater than ncol') + ! + ! -- Error if outside of range + if(nodeu < 1 .or. nodeu > this%nodesuser) then + write(errmsg, '(a,i10)') & + 'Nodenumber less than 1 or greater than nodes:', nodeu + call store_error(errmsg) + endif + endif + ! + ! -- return + return + end function get_nodenumber_idx3 + + subroutine allocate_scalars(this, name_model) +! ****************************************************************************** +! allocate_scalars -- Allocate and initialize scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfDisType) :: this + character(len=*), intent(in) :: name_model +! ------------------------------------------------------------------------------ + ! + ! -- Allocate parent scalars + call this%DisBaseType%allocate_scalars(name_model) + ! + ! -- Allocate + call mem_allocate(this%nlay, 'NLAY', this%origin) + call mem_allocate(this%nrow, 'NROW', this%origin) + call mem_allocate(this%ncol, 'NCOL', this%origin) + ! + ! -- Initialize + this%nlay = 0 + this%nrow = 0 + this%ncol = 0 + this%ndim = 3 + ! + ! -- Return + return + end subroutine allocate_scalars + + subroutine allocate_arrays(this) +! ****************************************************************************** +! allocate_arrays -- Allocate arrays +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GwfDisType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Allocate arrays in DisBaseType (mshape, top, bot, area) + call this%DisBaseType%allocate_arrays() + ! + ! -- Allocate arrays for GwfDisType + if(this%nodes < this%nodesuser) then + call mem_allocate(this%nodeuser, this%nodes, 'NODEUSER', this%origin) + call mem_allocate(this%nodereduced, this%nodesuser, 'NODEREDUCED', & + this%origin) + else + call mem_allocate(this%nodeuser, 1, 'NODEUSER', this%origin) + call mem_allocate(this%nodereduced, 1, 'NODEREDUCED', this%origin) + endif + ! + ! -- Initialize + this%mshape(1) = this%nlay + this%mshape(2) = this%nrow + this%mshape(3) = this%ncol + ! + ! -- Return + return + end subroutine allocate_arrays + + function nodeu_from_string(this, lloc, istart, istop, in, iout, line, & + flag_string, allow_zero) result(nodeu) +! ****************************************************************************** +! nodeu_from_string -- Receive a string and convert the string to a user +! nodenumber. The model discretization is DIS; read layer, row, and column. +! If flag_string argument is present and true, the first token in string +! is allowed to be a string (e.g. boundary name). In this case, if a string +! is encountered, return value as -2. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfDisType) :: this + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout + character(len=*), intent(inout) :: line + logical, optional, intent(in) :: flag_string + logical, optional, intent(in) :: allow_zero + integer(I4B) :: nodeu + ! -- local + integer(I4B) :: k, i, j, nlay, nrow, ncol + integer(I4B) :: lloclocal, ndum, istat, n + real(DP) :: r + character(len=LINELENGTH) :: ermsg, fname +! ------------------------------------------------------------------------------ + ! + if (present(flag_string)) then + if (flag_string) then + ! Check to see if first token in line can be read as an integer. + lloclocal = lloc + call urword(line, lloclocal, istart, istop, 1, ndum, r, iout, in) + read(line(istart:istop),*,iostat=istat)n + if (istat /= 0) then + ! First token in line is not an integer; return flag to this effect. + nodeu = -2 + return + endif + endif + endif + ! + nlay = this%mshape(1) + nrow = this%mshape(2) + ncol = this%mshape(3) + ! + call urword(line, lloc, istart, istop, 2, k, r, iout, in) + call urword(line, lloc, istart, istop, 2, i, r, iout, in) + call urword(line, lloc, istart, istop, 2, j, r, iout, in) + ! + if (k == 0 .and. i == 0 .and. j == 0) then + if (present(allow_zero)) then + if (allow_zero) then + nodeu = 0 + return + endif + endif + endif + ! + if(k < 1 .or. k > nlay) then + write(ermsg, *) ' Layer number in list is outside of the grid', k + call store_error(ermsg) + end if + if(i < 1 .or. i > nrow) then + write(ermsg, *) ' Row number in list is outside of the grid', i + call store_error(ermsg) + end if + if(j < 1 .or. j > ncol) then + write(ermsg, *) ' Column number in list is outside of the grid', j + call store_error(ermsg) + end if + nodeu = get_node(k, i, j, nlay, nrow, ncol) + ! + if(nodeu < 1 .or. nodeu > this%nodesuser) then + write(ermsg, *) ' Node number in list is outside of the grid', nodeu + call store_error(ermsg) + inquire(unit=in, name=fname) + call store_error('Error converting in file: ') + call store_error(trim(adjustl(fname))) + call store_error('Cell number cannot be determined in line: ') + call store_error(trim(adjustl(line))) + call store_error_unit(in) + call ustop() + end if + ! + ! -- return + return + + end function nodeu_from_string + + function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & + allow_zero) result(nodeu) +! ****************************************************************************** +! nodeu_from_cellid -- Receive cellid as a string and convert the string to a +! user nodenumber. +! If flag_string argument is present and true, the first token in string +! is allowed to be a string (e.g. boundary name). In this case, if a string +! is encountered, return value as -2. +! If allow_zero argument is present and true, if all indices equal zero, the +! result can be zero. If allow_zero is false, a zero in any index causes an +! error. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + integer(I4B) :: nodeu + ! -- dummy + class(GwfDisType) :: this + character(len=*), intent(inout) :: cellid + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + logical, optional, intent(in) :: flag_string + logical, optional, intent(in) :: allow_zero + ! -- local + integer(I4B) :: lloclocal, istart, istop, ndum, n + integer(I4B) :: k, i, j, nlay, nrow, ncol + integer(I4B) :: istat + real(DP) :: r + character(len=LINELENGTH) :: ermsg, fname +! ------------------------------------------------------------------------------ + ! + if (present(flag_string)) then + if (flag_string) then + ! Check to see if first token in cellid can be read as an integer. + lloclocal = 1 + call urword(cellid, lloclocal, istart, istop, 1, ndum, r, iout, inunit) + read(cellid(istart:istop), *, iostat=istat) n + if (istat /= 0) then + ! First token in cellid is not an integer; return flag to this effect. + nodeu = -2 + return + endif + endif + endif + ! + nlay = this%mshape(1) + nrow = this%mshape(2) + ncol = this%mshape(3) + ! + lloclocal = 1 + call urword(cellid, lloclocal, istart, istop, 2, k, r, iout, inunit) + call urword(cellid, lloclocal, istart, istop, 2, i, r, iout, inunit) + call urword(cellid, lloclocal, istart, istop, 2, j, r, iout, inunit) + ! + if (k == 0 .and. i == 0 .and. j == 0) then + if (present(allow_zero)) then + if (allow_zero) then + nodeu = 0 + return + endif + endif + endif + ! + if(k < 1 .or. k > nlay) then + write(ermsg, *) ' Layer number in list is outside of the grid', k + call store_error(ermsg) + end if + if(i < 1 .or. i > nrow) then + write(ermsg, *) ' Row number in list is outside of the grid', i + call store_error(ermsg) + end if + if(j < 1 .or. j > ncol) then + write(ermsg, *) ' Column number in list is outside of the grid', j + call store_error(ermsg) + end if + nodeu = get_node(k, i, j, nlay, nrow, ncol) + ! + if(nodeu < 1 .or. nodeu > this%nodesuser) then + write(ermsg, *) ' Node number in list is outside of the grid', nodeu + call store_error(ermsg) + inquire(unit=inunit, name=fname) + call store_error('Error converting in file: ') + call store_error(trim(adjustl(fname))) + call store_error('Cell number cannot be determined in cellid: ') + call store_error(trim(adjustl(cellid))) + call store_error_unit(inunit) + call ustop() + end if + ! + ! -- return + return + end function nodeu_from_cellid + + + logical function supports_layers(this) + implicit none + ! -- dummy + class(GwfDisType) :: this + ! + supports_layers = .true. + return + end function supports_layers + + function get_ncpl(this) +! ****************************************************************************** +! get_ncpl -- Return number of cells per layer. This is nrow * ncol +! for a DIS3D grid. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + integer(I4B) :: get_ncpl + ! -- dummy + class(GwfDisType) :: this +! ------------------------------------------------------------------------------ + ! + get_ncpl = this%nrow * this%ncol + ! + ! -- Return + return + end function get_ncpl + + subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & + ipos) +! ****************************************************************************** +! connection_normal -- calculate the normal vector components for reduced +! nodenumber cell (noden) and its shared face with cell nodem. ihc is the +! horizontal connection flag. Connection normal is a normal vector pointing +! outward from the shared face between noden and nodem. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DZERO, DONE + use InputOutputModule, only: get_ijk + ! -- dummy + class(GwfDisType) :: this + integer(I4B), intent(in) :: noden + integer(I4B), intent(in) :: nodem + integer(I4B), intent(in) :: ihc + real(DP), intent(inout) :: xcomp + real(DP), intent(inout) :: ycomp + real(DP), intent(inout) :: zcomp + integer(I4B), intent(in) :: ipos + ! -- local + integer(I4B) :: nodeu1, i1, j1, k1 + integer(I4B) :: nodeu2, i2, j2, k2 +! ------------------------------------------------------------------------------ + ! + ! -- Set vector components based on ihc + if(ihc == 0) then + xcomp = DZERO + ycomp = DZERO + if(nodem < noden) then + ! + ! -- nodem must be above noden, so upward connection + zcomp = DONE + else + ! + ! -- nodem must be below noden, so downward connection + zcomp = -DONE + endif + else + xcomp = DZERO + ycomp = DZERO + zcomp = DZERO + nodeu1 = this%get_nodeuser(noden) + nodeu2 = this%get_nodeuser(nodem) + call get_ijk(nodeu1, this%nrow, this%ncol, this%nlay, i1, j1, k1) + call get_ijk(nodeu2, this%nrow, this%ncol, this%nlay, i2, j2, k2) + if (i2 < i1) then ! back + ycomp = DONE + elseif (j2 < j1) then ! left + xcomp = -DONE + elseif (j2 > j1) then ! right + xcomp = DONE + else ! front + ycomp = -DONE + endif + ! + endif + ! + ! -- return + return + end subroutine connection_normal + + subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & + xcomp, ycomp, zcomp, conlen) +! ****************************************************************************** +! connection_vector -- calculate the unit vector components from reduced +! nodenumber cell (noden) to its neighbor cell (nodem). The saturation for +! for these cells are also required so that the vertical position of the cell +! cell centers can be calculated. ihc is the horizontal flag. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DZERO, DONE, DHALF + use DisvGeom, only: line_unit_vector + use InputOutputModule, only: get_ijk + ! -- dummy + class(GwfDisType) :: this + integer(I4B), intent(in) :: noden + integer(I4B), intent(in) :: nodem + logical, intent(in) :: nozee + real(DP), intent(in) :: satn + real(DP), intent(in) :: satm + integer(I4B), intent(in) :: ihc + real(DP), intent(inout) :: xcomp + real(DP), intent(inout) :: ycomp + real(DP), intent(inout) :: zcomp + real(DP), intent(inout) :: conlen + ! -- local + real(DP) :: z1, z2 + real(DP) :: x1, y1, x2, y2 + real(DP) :: ds + integer(I4B) :: i1, i2, j1, j2, k1, k2 + integer(I4B) :: nodeu1, nodeu2, ipos +! ------------------------------------------------------------------------------ + ! + ! -- Set vector components based on ihc + if(ihc == 0) then + ! + ! -- vertical connection; set zcomp positive upward + xcomp = DZERO + ycomp = DZERO + if(nodem < noden) then + zcomp = DONE + else + zcomp = -DONE + endif + z1 = this%bot(noden) + DHALF * (this%top(noden) - this%bot(noden)) + z2 = this%bot(nodem) + DHALF * (this%top(nodem) - this%bot(nodem)) + conlen = abs(z2 - z1) + else + ! + if(nozee) then + z1 = DZERO + z2 = DZERO + else + z1 = this%bot(noden) + DHALF * satn * (this%top(noden) - this%bot(noden)) + z2 = this%bot(nodem) + DHALF * satm * (this%top(nodem) - this%bot(nodem)) + endif + ipos = this%con%getjaindex(noden, nodem) + ds = this%con%cl1(this%con%jas(ipos)) + this%con%cl2(this%con%jas(ipos)) + nodeu1 = this%get_nodeuser(noden) + nodeu2 = this%get_nodeuser(nodem) + call get_ijk(nodeu1, this%nrow, this%ncol, this%nlay, i1, j1, k1) + call get_ijk(nodeu2, this%nrow, this%ncol, this%nlay, i2, j2, k2) + x1 = DZERO + x2 = DZERO + y1 = DZERO + y2 = DZERO + if (i2 < i1) then ! back + y2 = ds + elseif (j2 < j1) then ! left + x2 = -ds + elseif (j2 > j1) then ! right + x2 = ds + else ! front + y2 = -ds + endif + call line_unit_vector(x1, y1, z1, x2, y2, z2, xcomp, ycomp, zcomp, conlen) + endif + ! + ! -- return + return + end subroutine + + ! return x,y coordinate for a node + subroutine get_cellxy_dis3d(this, node, xcell, ycell) + use InputOutputModule, only: get_ijk + class(GwfDisType), intent(in) :: this + integer(I4B), intent(in) :: node ! the reduced node number + real(DP), intent(out) :: xcell, ycell ! the x,y for the cell + ! local + integer(I4B) :: nodeuser, i, j, k + + nodeuser = this%get_nodeuser(node) + call get_ijk(nodeuser, this%nrow, this%ncol, this%nlay, i, j, k) + + xcell = this%cellx(j) + ycell = this%celly(i) + + end subroutine get_cellxy_dis3d + + ! return discretization type + subroutine get_dis_type(this, dis_type) + class(GwfDisType), intent(in) :: this + character(len=*), intent(out) :: dis_type + + dis_type = "DIS" + + end subroutine get_dis_type + + subroutine read_int_array(this, line, lloc, istart, istop, iout, in, & + iarray, aname) +! ****************************************************************************** +! read_int_array -- Read a GWF integer array +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: urword + use SimModule, only: store_error, ustop + use ConstantsModule, only: LINELENGTH + ! -- dummy + class(GwfDisType), intent(inout) :: this + character(len=*), intent(inout) :: line + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: iarray + character(len=*), intent(in) :: aname + ! -- local + integer(I4B) :: ival + real(DP) :: rval + integer(I4B) :: nlay + integer(I4B) :: nrow + integer(I4B) :: ncol + integer(I4B) :: nval + integer(I4B), dimension(:), pointer, contiguous :: itemp +! ------------------------------------------------------------------------------ + ! + ! -- Point the temporary pointer array, which is passed to the reading + ! subroutine. The temporary array will point to ibuff if it is a + ! reduced structured system, or to iarray if it is an unstructured + ! model. + nlay = this%mshape(1) + nrow = this%mshape(2) + ncol = this%mshape(3) + ! + if (this%nodes < this%nodesuser) then + nval = this%nodesuser + itemp => this%ibuff + else + nval = this%nodes + itemp => iarray + endif + ! + ! -- Read the array + call urword(line, lloc, istart, istop, 1, ival, rval, iout, in) + if (line(istart:istop).EQ.'LAYERED') then + ! + ! -- Read layered input + call ReadArray(in, itemp, aname, this%ndim, ncol, nrow, nlay, nval, & + iout, 1, nlay) + else + ! + ! -- Read unstructured input + call ReadArray(in, itemp, aname, this%ndim, nval, iout, 0) + end if + ! + ! -- If reduced model, then need to copy from itemp(=>ibuff) to iarray + if (this%nodes < this%nodesuser) then + call this%fill_grid_array(itemp, iarray) + endif + ! + ! -- return + return + end subroutine read_int_array + + subroutine read_dbl_array(this, line, lloc, istart, istop, iout, in, & + darray, aname) +! ****************************************************************************** +! read_dbl_array -- Read a GWF double precision array +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: urword + use SimModule, only: ustop, store_error + use ConstantsModule, only: LINELENGTH + ! -- dummy + class(GwfDisType), intent(inout) :: this + character(len=*), intent(inout) :: line + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout + real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray + character(len=*), intent(in) :: aname + ! -- local + integer(I4B) :: ival + real(DP) :: rval + integer(I4B) :: nlay + integer(I4B) :: nrow + integer(I4B) :: ncol + integer(I4B) :: nval + real(DP), dimension(:), pointer, contiguous :: dtemp +! ------------------------------------------------------------------------------ + ! + ! -- Point the temporary pointer array, which is passed to the reading + ! subroutine. The temporary array will point to dbuff if it is a + ! reduced structured system, or to darray if it is an unstructured + ! model. + nlay = this%mshape(1) + nrow = this%mshape(2) + ncol = this%mshape(3) + ! + if(this%nodes < this%nodesuser) then + nval = this%nodesuser + dtemp => this%dbuff + else + nval = this%nodes + dtemp => darray + endif + ! + ! -- Read the array + call urword(line, lloc, istart, istop, 1, ival, rval, iout, in) + if (line(istart:istop).EQ.'LAYERED') then + ! + ! -- Read structured input + call ReadArray(in, dtemp, aname, this%ndim, ncol, nrow, nlay, nval, & + iout, 1, nlay) + else + ! + ! -- Read unstructured input + call ReadArray(in, dtemp, aname, this%ndim, nval, iout, 0) + end if + ! + ! -- If reduced model, then need to copy from dtemp(=>dbuff) to darray + if(this%nodes < this%nodesuser) then + call this%fill_grid_array(dtemp, darray) + endif + ! + ! -- return + return + end subroutine read_dbl_array + + subroutine read_layer_array(this, nodelist, darray, ncolbnd, maxbnd, & + icolbnd, aname, inunit, iout) +! ****************************************************************************** +! read_layer_array -- Read a 2d double array into col icolbnd of darray. +! For cells that are outside of the active domain, +! do not copy the array value into darray. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: get_node + ! -- dummy + class(GwfDisType) :: this + integer(I4B), intent(in) :: maxbnd + integer(I4B), dimension(maxbnd) :: nodelist + integer(I4B), intent(in) :: ncolbnd + real(DP), dimension(ncolbnd, maxbnd), intent(inout) :: darray + integer(I4B), intent(in) :: icolbnd + character(len=*), intent(in) :: aname + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + ! -- local + integer(I4B) :: il, ir, ic, ncol, nrow, nlay, nval, ipos, noder, nodeu + logical :: found +! ------------------------------------------------------------------------------ + ! + ! -- set variables + nlay = this%mshape(1) + nrow = this%mshape(2) + ncol = this%mshape(3) + ! + ! -- Read the array + nval = ncol * nrow + call ReadArray(inunit, this%dbuff, aname, this%ndim, ncol, nrow, nlay, & + nval, iout, 0, 0) + ! + ! -- Copy array into bound + ipos = 1 + do ir = 1, nrow + columnloop: do ic = 1, ncol + ! + ! -- look down through all layers and see if nodeu == nodelist(ipos) + ! cycle if not, because node must be inactive or pass through + found = .false. + layerloop: do il = 1, nlay + nodeu = get_node(il, ir, ic, nlay, nrow, ncol) + noder = this%get_nodenumber(nodeu, 0) + if(noder == 0) cycle layerloop + if(noder == nodelist(ipos)) then + found = .true. + exit layerloop + endif + enddo layerloop + if(.not. found) cycle columnloop + ! + ! -- Assign the array value to darray + nodeu = get_node(1, ir, ic, nlay, nrow, ncol) + darray(icolbnd, ipos) = this%dbuff(nodeu) + ipos = ipos + 1 + ! + enddo columnloop + enddo + ! + ! -- return + end subroutine read_layer_array + + subroutine record_array(this, darray, iout, iprint, idataun, aname, & + cdatafmp, nvaluesp, nwidthp, editdesc, dinact) +! ****************************************************************************** +! record_array -- Record a double precision array. The array will be +! printed to an external file and/or written to an unformatted external file +! depending on the argument specifications. +! ****************************************************************************** +! +! SPECIFICATIONS: +! darray is the double precision array to record +! iout is the unit number for ascii output +! iprint is a flag indicating whether or not to print the array +! idataun is the unit number to which the array will be written in binary +! form; if negative then do not write by layers, write entire array +! aname is the text descriptor of the array +! cdatafmp is the fortran format for writing the array +! nvaluesp is the number of values per line for printing +! nwidthp is the width of the number for printing +! editdesc is the format type (I, G, F, S, E) +! dinact is the double precision value to use for cells that are excluded +! from the model domain +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfDisType), intent(inout) :: this + real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray + integer(I4B), intent(in) :: iout + integer(I4B), intent(in) :: iprint + integer(I4B), intent(in) :: idataun + character(len=*), intent(in) :: aname + character(len=*), intent(in) :: cdatafmp + integer(I4B), intent(in) :: nvaluesp + integer(I4B), intent(in) :: nwidthp + character(len=*), intent(in) :: editdesc + real(DP), intent(in) :: dinact + ! -- local + integer(I4B) :: k, ifirst + integer(I4B) :: nlay + integer(I4B) :: nrow + integer(I4B) :: ncol + integer(I4B) :: nval + integer(I4B) :: nodeu, noder + integer(I4B) :: istart, istop + real(DP), dimension(:), pointer, contiguous :: dtemp + ! -- formats + character(len=*),parameter :: fmthsv = & + "(1X,/1X,a,' WILL BE SAVED ON UNIT ',I4, & + &' AT END OF TIME STEP',I5,', STRESS PERIOD ',I4)" +! ------------------------------------------------------------------------------ + ! + ! -- set variables + nlay = this%mshape(1) + nrow = this%mshape(2) + ncol = this%mshape(3) + ! + ! -- If this is a reduced model, then copy the values from darray into + ! dtemp. + if(this%nodes < this%nodesuser) then + nval = this%nodes + dtemp => this%dbuff + do nodeu = 1, this%nodesuser + noder = this%get_nodenumber(nodeu, 0) + if(noder <= 0) then + dtemp(nodeu) = dinact + cycle + endif + dtemp(nodeu) = darray(noder) + enddo + else + nval = this%nodes + dtemp => darray + endif + ! + ! -- Print to iout if iprint /= 0 + if(iprint /= 0) then + istart = 1 + do k = 1, nlay + istop = istart + nrow * ncol - 1 + call ulaprufw(ncol, nrow, kstp, kper, k, iout, dtemp(istart:istop), & + aname, cdatafmp, nvaluesp, nwidthp, editdesc) + istart = istop + 1 + enddo + endif + ! + ! -- Save array to an external file. + if(idataun > 0) then + ! -- write to binary file by layer + ifirst = 1 + istart = 1 + do k=1, nlay + istop = istart + nrow * ncol - 1 + if(ifirst == 1) write(iout, fmthsv) & + trim(adjustl(aname)), idataun, & + kstp, kper + ifirst = 0 + call ulasav(dtemp(istart:istop), aname, kstp, kper, & + pertim, totim, ncol, nrow, k, idataun) + istart = istop + 1 + enddo + elseif(idataun < 0) then + ! + ! -- write entire array as one record + call ubdsv1(kstp, kper, aname, -idataun, dtemp, ncol, nrow, nlay, & + iout, delt, pertim, totim) + endif + ! + ! -- return + return + end subroutine record_array + + subroutine record_srcdst_list_header(this, text, textmodel, textpackage, & + dstmodel, dstpackage, naux, auxtxt, & + ibdchn, nlist, iout) +! ****************************************************************************** +! record_srcdst_list_header -- Record list header for imeth=6 +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfDisType) :: this + character(len=16), intent(in) :: text + character(len=16), intent(in) :: textmodel + character(len=16), intent(in) :: textpackage + character(len=16), intent(in) :: dstmodel + character(len=16), intent(in) :: dstpackage + integer(I4B), intent(in) :: naux + character(len=16), dimension(:), intent(in) :: auxtxt + integer(I4B), intent(in) :: ibdchn + integer(I4B), intent(in) :: nlist + integer(I4B), intent(in) :: iout + ! -- local + integer(I4B) :: nlay, nrow, ncol +! ------------------------------------------------------------------------------ + ! + nlay = this%mshape(1) + nrow = this%mshape(2) + ncol = this%mshape(3) + ! + ! -- Use ubdsv06 to write list header + call ubdsv06(kstp, kper, text, textmodel, textpackage, dstmodel, dstpackage,& + ibdchn, naux, auxtxt, ncol, nrow, nlay, & + nlist, iout, delt, pertim, totim) + ! + ! -- return + return + end subroutine record_srcdst_list_header + + subroutine nlarray_to_nodelist(this, nodelist, maxbnd, nbound, aname, & + inunit, iout) +! ****************************************************************************** +! nlarray_to_nodelist -- Read an integer array into nodelist. For structured +! model, integer array is layer number; for unstructured +! model, integer array is node number. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: get_node + use SimModule, only: ustop, store_error + use ConstantsModule, only: LINELENGTH + ! -- dummy + class(GwfDisType) :: this + integer(I4B), intent(in) :: maxbnd + integer(I4B), dimension(maxbnd), intent(inout) :: nodelist + integer(I4B), intent(inout) :: nbound + character(len=*), intent(in) :: aname + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + ! -- local + integer(I4B) :: il, ir, ic, ncol, nrow, nlay, nval, nodeu, noder, ipos, ierr + character(len=LINELENGTH) :: errmsg +! ------------------------------------------------------------------------------ + ! + ! -- set variables + nlay = this%mshape(1) + nrow = this%mshape(2) + ncol = this%mshape(3) + ! + if(this%ndim > 1) then + ! + nval = ncol * nrow + call ReadArray(inunit, this%ibuff, aname, this%ndim, ncol, nrow, nlay, nval, iout, 0, 0) + ! + ! -- Copy array into nodelist + ipos = 1 + ierr = 0 + do ir = 1, nrow + do ic = 1, ncol + nodeu = get_node(1, ir, ic, nlay, nrow, ncol) + il = this%ibuff(nodeu) + if(il < 1 .or. il > nlay) then + write(errmsg, *) 'ERROR. INVALID LAYER NUMBER: ', il + call store_error(errmsg) + call ustop() + endif + nodeu = get_node(il, ir, ic, nlay, nrow, ncol) + noder = this%get_nodenumber(nodeu, 0) + if(noder > 0) then + if(ipos > maxbnd) then + ierr = ipos + else + nodelist(ipos) = noder + endif + ipos = ipos + 1 + endif + enddo + enddo + ! + ! -- Check for errors + nbound = ipos - 1 + if(ierr > 0) then + write(errmsg, *) 'ERROR. MAXBOUND DIMENSION IS TOO SMALL.' + call store_error(errmsg) + write(errmsg, *) 'INCREASE MAXBOUND TO: ', ierr + call store_error(errmsg) + call ustop() + endif + ! + ! -- If nbound < maxbnd, then initialize nodelist to zero in this range + if(nbound < maxbnd) then + do ipos = nbound+1, maxbnd + nodelist(ipos) = 0 + enddo + endif + ! + else + ! + ! -- For unstructured, read nodelist directly, then check node numbers + call ReadArray(inunit, nodelist, aname, this%ndim, maxbnd, iout, 0) + do noder = 1, maxbnd + if(noder < 1 .or. noder > this%nodes) then + write(errmsg, *) 'ERROR. INVALID NODE NUMBER: ', noder + call store_error(errmsg) + call ustop() + endif + enddo + nbound = maxbnd + ! + endif + ! + ! -- return + end subroutine nlarray_to_nodelist + +end module GwfDisModule diff --git a/src/Model/GroundWaterFlow/gwf3disu8.f90 b/src/Model/GroundWaterFlow/gwf3disu8.f90 index 6b614e8ac26..1ff48a22c2a 100644 --- a/src/Model/GroundWaterFlow/gwf3disu8.f90 +++ b/src/Model/GroundWaterFlow/gwf3disu8.f90 @@ -1,1969 +1,1969 @@ -module GwfDisuModule - - use ArrayReadersModule, only: ReadArray - use KindModule, only: DP, I4B - use ConstantsModule, only: LENMODELNAME, LENORIGIN, LINELENGTH - use ConnectionsModule, only: ConnectionsType, iac_to_ia - use InputOutputModule, only: URWORD, ulasav, ulaprufw, ubdsv1, ubdsv06 - use SimModule, only: count_errors, store_error, store_error_unit, ustop - use BaseDisModule, only: DisBaseType - use BlockParserModule, only: BlockParserType - use MemoryManagerModule, only: mem_allocate - use TdisModule, only: kstp, kper, pertim, totim, delt - - implicit none - - private - public :: GwfDisuType - public :: disu_cr - public :: disu_init_mem - - type, extends(DisBaseType) :: GwfDisuType - integer(I4B), pointer :: njausr => null() ! user-specified nja size - integer(I4B), pointer :: nvert => null() ! number of x,y vertices - real(DP), dimension(:,:), pointer, contiguous :: vertices => null() ! cell vertices stored as 2d array of x and y - real(DP), dimension(:,:), pointer, contiguous :: cellxy => null() ! cell center stored as 2d array of x and y - real(DP), dimension(:), pointer, contiguous :: top1d => null() ! (size:nodesuser) cell top elevation - real(DP), dimension(:), pointer, contiguous :: bot1d => null() ! (size:nodesuser) cell bottom elevation - real(DP), dimension(:), pointer, contiguous :: area1d => null() ! (size:nodesuser) cell area, in plan view - integer(I4B), dimension(:), pointer, contiguous :: iainp => null() ! (size:nodesuser+1) user iac converted ia - integer(I4B), dimension(:), pointer, contiguous :: jainp => null() ! (size:njausr) user-input ja array - integer(I4B), dimension(:), pointer, contiguous :: ihcinp => null() ! (size:njausr) user-input ihc array - real(DP), dimension(:), pointer, contiguous :: cl12inp => null() ! (size:njausr) user-input cl12 array - real(DP), dimension(:), pointer, contiguous :: hwvainp => null() ! (size:njausr) user-input hwva array - real(DP), dimension(:), pointer, contiguous :: angldegxinp => null() ! (size:njausr) user-input angldegx array - integer(I4B), dimension(:), pointer, contiguous :: iavert => null() ! cell vertex pointer ia array - integer(I4B), dimension(:), pointer, contiguous:: javert => null() ! cell vertex pointer ja array - integer(I4B), dimension(:), pointer, contiguous :: idomain => null() ! idomain (nodes) - contains - procedure :: dis_df => disu_df - procedure :: dis_da => disu_da - procedure :: get_cellxy => get_cellxy_disu - procedure :: get_dis_type => get_dis_type - procedure :: disu_ck - procedure :: grid_finalize - procedure :: get_nodenumber_idx1 - procedure :: nodeu_to_string - procedure :: nodeu_to_array - procedure :: nodeu_from_string - procedure :: nodeu_from_cellid - procedure :: connection_normal - procedure :: connection_vector - procedure :: supports_layers - procedure :: get_ncpl - procedure, public :: record_array - procedure, public :: record_srcdst_list_header - ! -- private - procedure :: allocate_scalars - procedure :: allocate_arrays - procedure :: read_options - procedure :: read_dimensions - procedure :: read_mf6_griddata - procedure :: read_connectivity - procedure :: read_vertices - procedure :: read_cell2d - procedure :: write_grb - ! - ! -- Read a node-sized model array (reduced or not) - procedure :: read_int_array - procedure :: read_dbl_array - end type GwfDisuType - - contains - - subroutine disu_cr(dis, name_model, inunit, iout) -! ****************************************************************************** -! disu_cr -- Create discretization object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(DisBaseType), pointer :: dis - character(len=*), intent(in) :: name_model - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - ! -- local - type(GwfDisuType), pointer :: disnew -! ------------------------------------------------------------------------------ - ! - ! -- Create a new discretization object - allocate(disnew) - dis => disnew - ! - ! -- Allocate scalars and assign data - call dis%allocate_scalars(name_model) - dis%inunit = inunit - dis%iout = iout - ! - ! -- Initialize block parser - call dis%parser%Initialize(dis%inunit, dis%iout) - ! - ! -- Return - return - end subroutine disu_cr - - subroutine disu_init_mem(dis, name_model, iout, nodes, nja, & - top, bot, area, iac, ja, ihc, cl12, hwva, angldegx, & - nvert, vertices, cellxy, idomain) -! ****************************************************************************** -! dis_init_mem -- Create a new unstructured discretization object from memory -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(DisBaseType), pointer :: dis - character(len=*), intent(in) :: name_model - integer(I4B), intent(in) :: iout - integer(I4B), intent(in) :: nodes - integer(I4B), intent(in) :: nja - real(DP), dimension(:), pointer, contiguous, intent(in) :: top - real(DP), dimension(:), pointer, contiguous, intent(in) :: bot - real(DP), dimension(:), pointer, contiguous, intent(in) :: area - integer(I4B), dimension(:), pointer, contiguous, intent(in) :: iac - integer(I4B), dimension(:), pointer, contiguous, intent(in) :: ja - integer(I4B), dimension(:), pointer, contiguous, intent(in) :: ihc - real(DP), dimension(:), pointer, contiguous, intent(in) :: cl12 - real(DP), dimension(:), pointer, contiguous, intent(in) :: hwva - real(DP), dimension(:), pointer, contiguous, intent(in), optional :: angldegx - integer(I4B), intent(in), optional :: nvert - integer(I4B), dimension(:, :), pointer, contiguous, intent(in), & - optional :: vertices - integer(I4B), dimension(:, :), pointer, contiguous, intent(in), & - optional :: cellxy - integer(I4B), dimension(:), pointer, contiguous, intent(in), & - optional :: idomain - ! -- local - type(GwfDisuType), pointer :: disext - integer(I4B) :: n - integer(I4B) :: j - integer(I4B) :: ival - real(DP), dimension(:), pointer, contiguous :: atemp -! ------------------------------------------------------------------------------ - allocate(disext) - dis => disext - call disext%allocate_scalars(name_model) - dis%inunit = 0 - dis%iout = iout - ! - ! -- set dimensions - disext%nodes = nodes - disext%nja = nja - if (present(nvert)) then - disext%nvert = nvert - end if - ! - ! -- Calculate nodesuser - disext%nodesuser = disext%nodes - ! - ! -- Allocate vectors for disu - call disext%allocate_arrays() - ! - ! -- fill data - do n = 1, disext%nodes - disext%top(n) = top(n) - disext%bot(n) = bot(n) - disext%area(n) = area(n) - disext%con%ia(n) = iac(n) - if (present(idomain)) then - ival = idomain(n) - else - ival = 1 - end if - disext%idomain(n) = ival - end do - call iac_to_ia(disext%con%ia) - do n = 1, nja - disext%con%ja(n) = ja(n) - end do - if (present(nvert)) then - if (present(vertices)) then - do n = 1, disext%nvert - do j = 1, 2 - disext%vertices(j, n) = vertices(j, n) - end do - end do - ! -- error - else - end if - if (present(cellxy)) then - do n = 1, disext%nodes - do j = 1, 2 - disext%cellxy(j, n) = cellxy(j, n) - end do - end do - ! -- error - else - end if - else - ! -- connection direction information cannot be calculated - disext%icondir = 0 - end if - ! - ! -- allocate space for atemp and fill - allocate(atemp(nja)) - if (present(angldegx)) then - disext%con%ianglex = 1 - do n = 1, nja - atemp(n) = angldegx(n) - end do - end if - ! - ! -- finalize connection data - call disext%con%con_finalize(ihc, cl12, hwva, atemp) - disext%njas = disext%con%njas - ! - ! -- deallocate temp arrays - deallocate(atemp) - ! - ! -- Make some final disu checks - call disext%disu_ck() - ! - ! -- Return - return - end subroutine disu_init_mem - - subroutine disu_df(this) -! ****************************************************************************** -! disu_df -- Read discretization information from DISU input file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- 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 - endif - end if - ! - ! -- Make some final disu checks on the non-reduced user-provided - ! input - call this%disu_ck() - ! - ! -- Finalize the grid by creating the connection object and reducing the - ! grid using IDOMAIN, if necessary - call this%grid_finalize() - ! - ! -- Return - return - end subroutine disu_df - - subroutine grid_finalize(this) -! ****************************************************************************** -! grid_finalize -- Finalize grid -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: ustop, count_errors, store_error - use ConstantsModule, only: LINELENGTH, DZERO - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(GwfDisuType) :: this - ! -- locals - integer(I4B) :: n - integer(I4B) :: node - integer(I4B) :: noder - integer(I4B) :: nrsize - ! -- formats - character(len=*), parameter :: fmtdz = & - "('ERROR. CELL (',i0,',',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, //)" -! ------------------------------------------------------------------------------ - ! - ! -- count active cells - this%nodes = 0 - do n = 1, this%nodesuser - if(this%idomain(n) > 0) this%nodes = this%nodes + 1 - enddo - ! - ! -- Check to make sure nodes is a valid number - if (this%nodes == 0) then - call store_error('ERROR. MODEL DOES NOT HAVE ANY ACTIVE NODES.') - call store_error('MAKE SURE IDOMAIN ARRAY HAS SOME VALUES GREATER & - &THAN ZERO.') - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- Write message if reduced grid - if(this%nodes < this%nodesuser) then - write(this%iout, fmtnr) this%nodesuser, this%nodes - endif - ! - ! -- Array size is now known, so allocate - call this%allocate_arrays() - ! - ! -- Fill the nodereduced array with the reduced nodenumber, or - ! a negative number to indicate it is a pass-through cell, or - ! a zero to indicate that the cell is excluded from the - ! solution. (negative idomain not supported for disu) - if(this%nodes < this%nodesuser) then - noder = 1 - do node = 1, this%nodesuser - if(this%idomain(node) > 0) then - this%nodereduced(node) = noder - noder = noder + 1 - elseif(this%idomain(node) < 0) then - this%nodereduced(node) = -1 - else - this%nodereduced(node) = 0 - endif - enddo - endif - ! - ! -- Fill nodeuser if a reduced grid - if(this%nodes < this%nodesuser) then - noder = 1 - do node = 1, this%nodesuser - if(this%idomain(node) > 0) then - this%nodeuser(noder) = node - noder = noder + 1 - endif - enddo - endif - ! - ! -- Move top1d, bot1d, and area1d into top, bot, and area - do node = 1, this%nodesuser - noder = node - if(this%nodes < this%nodesuser) noder = this%nodereduced(node) - if(noder <= 0) cycle - this%top(noder) = this%top1d(node) - this%bot(noder) = this%bot1d(node) - this%area(noder) = this%area1d(node) - enddo - ! - ! -- create and fill the connections object - nrsize = 0 - if(this%nodes < this%nodesuser) nrsize = this%nodes - allocate(this%con) - call this%con%disuconnections(this%name_model, this%nodes, & - this%nodesuser, nrsize, & - this%nodereduced, this%nodeuser, & - this%iainp, this%jainp, & - this%ihcinp, this%cl12inp, & - this%hwvainp, this%angldegxinp) - this%nja = this%con%nja - this%njas = this%con%njas - ! - ! -- Return - return - end subroutine grid_finalize - - subroutine disu_ck(this) -! ****************************************************************************** -! disu_ck -- Check the discretization information -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DZERO - ! -- dummy - class(GwfDisuType) :: this - ! -- local - character(len=LINELENGTH) :: errmsg - integer(I4B) :: n, m - integer(I4B) :: ipos - integer(I4B) :: ihc - real(DP) :: dz - ! -- formats - character(len=*), parameter :: fmtidm = & - "('ERROR. INVALID IDOMAIN VALUE ', i0, ' SPECIFIED FOR NODE ', i0)" - character(len=*), parameter :: fmtdz = & - "('ERROR. CELL ', i0, ' WITH THICKNESS <= 0. TOP, BOT: ', 2(1pg24.15))" - character(len=*), parameter :: fmtarea = & - "('ERROR. CELL ', i0, ' WITH AREA <= 0. AREA: ', 1(1pg24.15))" - character(len=*),parameter :: fmterrmsg = & - "(' Top elevation (', 1pg15.6, ') for cell ', i0, ' is above bottom & - &elevation (', 1pg15.6, ') for cell ', i0, '. Based on node numbering & - &rules cell ', i0, ' must be below cell ', i0, '.')" -! ------------------------------------------------------------------------------ - ! - ! -- Ensure idomain values are valid - do n = 1, this%nodesuser - if(this%idomain(n) > 1 .or. this%idomain(n) < 0) then - write(errmsg, fmtidm) this%idomain(n), n - call store_error(errmsg) - end if - enddo - ! - ! -- Check for zero and negative thickness and zero or negative areas - do n = 1, this%nodesuser - dz = this%top1d(n) - this%bot1d(n) - if (dz <= DZERO) then - write(errmsg, fmt=fmtdz) n, this%top1d(n), this%bot1d(n) - call store_error(errmsg) - endif - if (this%area1d(n) <= DZERO) then - write(errmsg, fmt=fmtarea) n, this%area1d(n) - call store_error(errmsg) - endif - enddo - ! - ! -- For cell n, ensure that underlying cells have tops less than - ! or equal to the bottom of cell n - do n = 1, this%nodesuser - do ipos = this%iainp(n) + 1, this%iainp(n + 1) - 1 - m = this%jainp(ipos) - ihc = this%ihcinp(ipos) - if (ihc == 0 .and. m > n) then - if (this%top1d(m) > this%bot1d(n)) then - write(errmsg, fmterrmsg) this%top1d(m), m, this%bot1d(n), n, m, n - call store_error(errmsg) - end if - end if - end do - end do - ! - ! -- terminate if errors found - if(count_errors() > 0) then - if (this%inunit > 0) call store_error_unit(this%inunit) - call ustop() - endif - ! - ! -- Return - return - end subroutine disu_ck - - subroutine disu_da(this) -! ****************************************************************************** -! disu_da -- Deallocate discretization object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(GwfDisuType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- scalars - call mem_deallocate(this%njausr) - call mem_deallocate(this%nvert) - ! - ! -- arrays - call mem_deallocate(this%top1d) - call mem_deallocate(this%bot1d) - call mem_deallocate(this%area1d) - call mem_deallocate(this%idomain) - if (associated(this%iavert)) then - call mem_deallocate(this%iavert) - call mem_deallocate(this%javert) - end if - call mem_deallocate(this%vertices) - call mem_deallocate(this%iainp) - call mem_deallocate(this%jainp) - call mem_deallocate(this%ihcinp) - call mem_deallocate(this%cl12inp) - call mem_deallocate(this%hwvainp) - call mem_deallocate(this%angldegxinp) - call mem_deallocate(this%cellxy) - call mem_deallocate(this%nodeuser) - call mem_deallocate(this%nodereduced) - ! - ! -- DisBaseType deallocate - call this%DisBaseType%dis_da() - ! - ! -- Return - return - end subroutine disu_da - - subroutine nodeu_to_string(this, nodeu, str) -! ****************************************************************************** -! nodeu_to_string -- Convert user node number to a string in the form of -! (nodenumber) or (k,i,j) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfDisuType) :: this - integer(I4B), intent(in) :: nodeu - character(len=*), intent(inout) :: str - ! -- local - character(len=10) :: nstr -! ------------------------------------------------------------------------------ - ! - write(nstr, '(i0)') nodeu - str = '(' // trim(adjustl(nstr)) // ')' - ! - ! -- return - return - end subroutine nodeu_to_string - - subroutine nodeu_to_array(this, nodeu, arr) -! ****************************************************************************** -! nodeu_to_array -- Convert user node number to cellid and fill array with -! (nodenumber) or (k,j) or (k,i,j) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use InputOutputModule, only: get_ijk - implicit none - class(GwfDisuType) :: this - integer(I4B), intent(in) :: nodeu - integer(I4B), dimension(:), intent(inout) :: arr - ! -- local - character(len=LINELENGTH) :: errmsg - integer(I4B) :: isize -! ------------------------------------------------------------------------------ - ! - ! -- check the size of arr - isize = size(arr) - if (isize /= this%ndim) then - write(errmsg,'(a,i0,a,i0,a)') & - 'Program error: nodeu_to_array size of array (', isize, & - ') is not equal to the discretization dimension (', this%ndim, ')' - call store_error(errmsg) - call ustop() - end if - ! - ! -- fill array - arr(1) = nodeu - ! - ! -- return - return - end subroutine nodeu_to_array - - subroutine read_options(this) -! ****************************************************************************** -! read_options -- Read discretization options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use MemoryManagerModule, only: mem_allocate - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, count_errors, store_error - implicit none - class(GwfDisuType) :: this - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ierr, nerr - 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' - endif - 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) - 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) write(this%iout,'(1x,a)') 'MODEL LENGTH UNIT IS UNDEFINED' - ! - nerr = count_errors() - if(nerr > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Return - return - end subroutine read_options - - subroutine read_dimensions(this) -! ****************************************************************************** -! read_dimensions -- Read discretization information from file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use MemoryManagerModule, only: mem_allocate - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, count_errors, store_error - implicit none - class(GwfDisuType) :: this - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: n, ierr - logical :: isfound, endOfBlock -! ------------------------------------------------------------------------------ - ! - ! -- 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,'(4x,a,a)')'****ERROR. UNKNOWN DISU DIMENSION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - end do - write(this%iout,'(1x,a)')'END OF DISCRETIZATION OPTIONS' - else - call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- verify dimensions were set - if(this%nodesuser < 1) then - call store_error( & - 'ERROR. NODES WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') - call ustop() - endif - if(this%njausr < 1) then - call store_error( & - 'ERROR. NJA WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') - call ustop() - endif - ! - ! -- allocate vectors that are the size of nodesuser - call mem_allocate(this%top1d, this%nodesuser, 'TOP1D', this%origin) - call mem_allocate(this%bot1d, this%nodesuser, 'BOT1D', this%origin) - call mem_allocate(this%area1d, this%nodesuser, 'AREA1D', this%origin) - call mem_allocate(this%idomain, this%nodesuser, 'IDOMAIN', this%origin) - call mem_allocate(this%vertices, 2, this%nvert, 'VERTICES', this%origin) - call mem_allocate(this%iainp, this%nodesuser + 1, 'IAINP', this%origin) - call mem_allocate(this%jainp, this%njausr, 'JAINP', this%origin) - call mem_allocate(this%ihcinp, this%njausr, 'IHCINP', this%origin) - call mem_allocate(this%cl12inp, this%njausr, 'CL12INP', this%origin) - call mem_allocate(this%hwvainp, this%njausr, 'HWVAINP', this%origin) - call mem_allocate(this%angldegxinp, this%njausr, 'ANGLDEGXINP', this%origin) - if(this%nvert > 0) then - call mem_allocate(this%cellxy, 2, this%nodesuser, 'CELLXY', this%origin) - else - call mem_allocate(this%cellxy, 2, 0, 'CELLXY', this%origin) - endif - ! - ! -- initialize all cells to be active (idomain = 1) - do n = 1, this%nodesuser - this%idomain(n) = 1 - end do - ! - ! -- Return - return - end subroutine read_dimensions - - subroutine read_mf6_griddata(this) -! ****************************************************************************** -! read_mf6_griddata -- Read discretization data -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, count_errors, store_error, store_error_unit - ! -- dummy - class(GwfDisuType) :: this - ! -- local - character(len=LINELENGTH) :: errmsg, 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) - ! -- 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,'(4x,a,a)')'ERROR. UNKNOWN GRIDDATA TAG: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - 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() - call ustop() - end if - ! - ! -- verify all items were read - do n = 1, nname - if (n == 4) cycle - if(.not. lname(n)) then - write(errmsg,'(1x,a,a)') & - 'ERROR. REQUIRED INPUT WAS NOT SPECIFIED: ', aname(n) - call store_error(errmsg) - endif - enddo - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Return - return - end subroutine read_mf6_griddata - - subroutine read_connectivity(this) -! ****************************************************************************** -! read_connectivity -- Read user-specified connectivity information -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH, DONE, DHALF, DPIO180, DNODATA - use SimModule, only: ustop, store_error, count_errors, store_error_unit - ! -- 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) - character(len=300) :: ermsg - ! -- 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(ermsg,'(4x,a,a)')'ERROR. UNKNOWN CONNECTIONDATA TAG: ', & - trim(keyword) - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - end do - write(this%iout,'(1x,a)')'END PROCESSING CONNECTIONDATA' - else - call store_error('ERROR. REQUIRED CONNECTIONDATA BLOCK NOT FOUND.') - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- 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(ermsg,'(1x,a,a)') & - 'ERROR. REQUIRED CONNECTIONDATA INPUT WAS NOT SPECIFIED: ', & - adjustl(trim(aname(n))) - call store_error(ermsg) - endif - enddo - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - if (.not. lname(6)) then - write(this%iout, '(1x,a)') 'ANGLDEGX NOT FOUND IN CONNECTIONDATA ' // & - 'BLOCK. SOME CAPABILITIES MAY BE LIMITED.' - end if - ! - ! -- Return - return - end subroutine read_connectivity - - subroutine read_vertices(this) -! ****************************************************************************** -! read_vertices -- Read data -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: ustop, count_errors, store_error - use ConstantsModule, only: LINELENGTH, DZERO - ! -- dummy - class(GwfDisuType) :: this - integer(I4B) :: i - integer(I4B) :: ierr, ival - logical :: isfound, endOfBlock - real(DP) :: xmin, xmax, ymin, ymax - character(len=300) :: ermsg - ! -- 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' - 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() - call ustop() - endif - ! - ! -- 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)) - endif - enddo - ! - ! -- Terminate the block - call this%parser%terminateblock() - else - call store_error('ERROR. REQUIRED VERTICES BLOCK NOT FOUND.') - call this%parser%StoreErrorUnit() - call ustop() - 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' - ! - ! -- Return - return - end subroutine read_vertices - - subroutine read_cell2d(this) -! ****************************************************************************** -! read_cell2d -- Read information describing the two dimensional (x, y) -! configuration of each cell. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: ustop, count_errors, store_error - use ConstantsModule, only: LINELENGTH, DZERO - use InputOutputModule, only: urword - use SparseModule, only: sparsematrix - ! -- 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 - character(len=300) :: ermsg - integer(I4B), dimension(:), allocatable :: maxnnz - type(sparsematrix) :: vertspm - ! -- 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 - ! - ! -- 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 - enddo - call vertspm%init(this%nodesuser, this%nvert, maxnnz) - ! - ! --Read CELL2D block - call this%parser%GetBlock('CELL2D', isfound, ierr, supportOpenClose=.true.) - if(isfound) then - write(this%iout,'(/,1x,a)') 'PROCESSING CELL2D' - do i = 1, this%nodesuser - 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) - call ustop() - endif - ! - ! -- 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 - endif - ! - ! -- 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) - endif - endif - enddo - ! - ! -- 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)) - endif - enddo - ! - ! -- Terminate the block - call this%parser%terminateblock() - else - call store_error('ERROR. REQUIRED CELL2D BLOCK NOT FOUND.') - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- Convert vertspm into ia/ja form - call mem_allocate(this%iavert, this%nodesuser + 1, 'IAVERT', this%origin) - call mem_allocate(this%javert, vertspm%nnz, 'JAVERT', this%origin) - - 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' - ! - ! -- Return - return - end subroutine read_cell2d - - subroutine write_grb(this, icelltype) -! ****************************************************************************** -! write_grb -- Write the binary grid file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: getunit, openfile - use OpenSpecModule, only: access, form - use ConstantsModule, only: DZERO - ! -- dummy - class(GwfDisuType) :: this - integer(I4B), dimension(:), intent(in) :: icelltype - ! -- local - integer(I4B) :: i, iunit, ntxt - integer(I4B), parameter :: lentxt = 100 - character(len=50) :: txthdr - character(len=lentxt) :: txt - character(len=LINELENGTH) :: fname - character(len=*),parameter :: fmtgrdsave = & - "(4X,'BINARY GRID INFORMATION WILL BE WRITTEN TO:', & - &/,6X,'UNIT NUMBER: ', I0,/,6X, 'FILE NAME: ', A)" -! ------------------------------------------------------------------------------ - ! - ! -- Initialize - ntxt = 10 - if (this%nvert > 0) ntxt = ntxt + 5 - ! - ! -- Open the file - inquire(unit=this%inunit, name=fname) - fname = trim(fname) // '.grb' - iunit = getunit() - write(this%iout, fmtgrdsave) iunit, trim(adjustl(fname)) - call openfile(iunit, this%iout, trim(adjustl(fname)), 'DATA(BINARY)', & - form, access, 'REPLACE') - ! - ! -- write header information - write(txthdr, '(a)') 'GRID DISU' - txthdr(50:50) = new_line('a') - write(iunit) txthdr - write(txthdr, '(a)') 'VERSION 1' - txthdr(50:50) = new_line('a') - write(iunit) txthdr - write(txthdr, '(a, i0)') 'NTXT ', ntxt - txthdr(50:50) = new_line('a') - write(iunit) txthdr - write(txthdr, '(a, i0)') 'LENTXT ', lentxt - txthdr(50:50) = new_line('a') - write(iunit) txthdr - ! - ! -- write variable definitions - write(txt, '(3a, i0)') 'NODES ', 'INTEGER ', 'NDIM 0 # ', this%nodesuser - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'NJA ', 'INTEGER ', 'NDIM 0 # ', this%con%nja - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, 1pg24.15)') 'XORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%xorigin - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, 1pg24.15)') 'YORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%yorigin - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, 1pg24.15)') 'ANGROT ', 'DOUBLE ', 'NDIM 0 # ', this%angrot - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'TOP ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'BOT ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'IA ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + 1 - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'JA ', 'INTEGER ', 'NDIM 1 ', this%con%nja - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'ICELLTYPE ', 'INTEGER ', 'NDIM 1 ', this%nodesuser - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - ! - ! -- if vertices have been read then write additional header information - if (this%nvert > 0) then - write(txt, '(3a, i0)') 'VERTICES ', 'DOUBLE ', 'NDIM 2 2 ', this%nvert - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'CELLX ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'CELLY ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'IAVERT ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + 1 - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'JAVERT ', 'INTEGER ', 'NDIM 1 ', size(this%javert) - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - endif - ! - ! -- write data - write(iunit) this%nodesuser ! nodes - write(iunit) this%nja ! nja - write(iunit) this%xorigin ! xorigin - write(iunit) this%yorigin ! yorigin - write(iunit) this%angrot ! angrot - write(iunit) this%top1d ! top - write(iunit) this%bot1d ! bot - write(iunit) this%con%iausr ! ia - write(iunit) this%con%jausr ! ja - write(iunit) icelltype ! icelltype - ! - ! -- if vertices have been read then write additional data - if (this%nvert > 0) then - write(iunit) this%vertices ! vertices - write(iunit) (this%cellxy(1, i), i = 1, this%nodesuser) ! cellx - write(iunit) (this%cellxy(2, i), i = 1, this%nodesuser) ! celly - write(iunit) this%iavert ! iavert - write(iunit) this%javert ! javert - endif - ! - ! -- Close the file - close(iunit) - ! - ! -- return - return - end subroutine write_grb - - function get_nodenumber_idx1(this, nodeu, icheck) result(nodenumber) -! ****************************************************************************** -! get_nodenumber -- Return a nodenumber from the user specified node number -! with an option to perform a check. This subroutine -! can be overridden by child classes to perform mapping -! to a model node number -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error - implicit none - class(GwfDisuType), intent(in) :: this - integer(I4B), intent(in) :: nodeu - integer(I4B), intent(in) :: icheck - character(len=LINELENGTH) :: errmsg - integer(I4B) :: nodenumber -! ------------------------------------------------------------------------------ - ! - if(icheck /= 0) then - if(nodeu < 1 .or. nodeu > this%nodes) then - write(errmsg, '(a,i10)') & - 'Nodenumber less than 1 or greater than nodes:', nodeu - call store_error(errmsg) - endif - endif - ! - ! -- set node number to passed in nodenumber since there is a one to one - ! mapping for an unstructured grid - if (this%nodes == this%nodesuser) then - nodenumber = nodeu - else - nodenumber = this%nodereduced(nodeu) - end if - ! - ! -- return - return - end function get_nodenumber_idx1 - - subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & - ipos) -! ****************************************************************************** -! connection_normal -- calculate the normal vector components for reduced -! nodenumber cell (noden) and its shared face with cell nodem. ihc is the -! horizontal connection flag. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DONE, DZERO - use SimModule, only: ustop, store_error - ! -- dummy - class(GwfDisuType) :: this - integer(I4B), intent(in) :: noden - integer(I4B), intent(in) :: nodem - integer(I4B), intent(in) :: ihc - real(DP), intent(inout) :: xcomp - real(DP), intent(inout) :: ycomp - real(DP), intent(inout) :: zcomp - integer(I4B), intent(in) :: ipos - ! -- local - !integer(I4B) :: ipos - real(DP) :: angle, dmult -! ------------------------------------------------------------------------------ - ! - ! -- Set vector components based on ihc - if(ihc == 0) then - ! - ! -- connection is vertical - xcomp = DZERO - ycomp = DZERO - if(nodem < noden) then - ! - ! -- nodem must be above noden, so upward connection - zcomp = DONE - else - ! - ! -- nodem must be below noden, so downward connection - zcomp = -DONE - endif - else - ! -- find from anglex, since anglex is symmetric, need to flip vector - ! for lower triangle (nodem < noden) - angle = this%con%anglex(this%con%jas(ipos)) - dmult = DONE - if (nodem < noden) dmult = -DONE - xcomp = cos(angle) * dmult - ycomp = sin(angle) * dmult - zcomp = DZERO - endif - ! - ! -- return - return - end subroutine connection_normal - - subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & - xcomp, ycomp, zcomp, conlen) -! ****************************************************************************** -! connection_vector -- calculate the unit vector components from reduced -! nodenumber cell (noden) to its neighbor cell (nodem). The saturation for -! for these cells are also required so that the vertical position of the cell -! cell centers can be calculated. ihc is the horizontal flag. Also return -! the straight-line connection length. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DZERO, DONE, DHALF - use SimModule, only: ustop, store_error - use DisvGeom, only: line_unit_vector - ! -- dummy - class(GwfDisuType) :: this - integer(I4B), intent(in) :: noden - integer(I4B), intent(in) :: nodem - logical, intent(in) :: nozee - real(DP), intent(in) :: satn - real(DP), intent(in) :: satm - integer(I4B), intent(in) :: ihc - real(DP), intent(inout) :: xcomp - real(DP), intent(inout) :: ycomp - real(DP), intent(inout) :: zcomp - real(DP), intent(inout) :: conlen - ! -- local - real(DP) :: xn, xm, yn, ym, zn, zm -! ------------------------------------------------------------------------------ - ! - ! -- Find xy coords - call this%get_cellxy(noden, xn, yn) - call this%get_cellxy(nodem, xm, ym) - ! - ! -- Set vector components based on ihc - if(ihc == 0) then - ! - ! -- vertical connection, calculate z as cell center elevation - zn = this%bot(noden) + DHALF * (this%top(noden) - this%bot(noden)) - zm = this%bot(nodem) + DHALF * (this%top(nodem) - this%bot(nodem)) - else - ! - ! -- horizontal connection, with possible z component due to cell offsets - ! and/or water table conditions - if (nozee) then - zn = DZERO - zm = DZERO - else - zn = this%bot(noden) + DHALF * satn * (this%top(noden) - this%bot(noden)) - zm = this%bot(nodem) + DHALF * satm * (this%top(nodem) - this%bot(nodem)) - endif - endif - ! - ! -- Use coords to find vector components and connection length - call line_unit_vector(xn, yn, zn, xm, ym, zm, xcomp, ycomp, zcomp, & - conlen) - ! - ! -- return - return - end subroutine connection_vector - - subroutine get_cellxy_disu(this, node, xcell, ycell) -! ****************************************************************************** -! get_cellxy_disu -- assign xcell and ycell -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfDisuType), intent(in) :: this - integer(I4B), intent(in) :: node ! the reduced node number - real(DP), intent(out) :: xcell, ycell ! the x,y for the cell - ! -- local - integer(I4B) :: nu -! ------------------------------------------------------------------------------ - ! - ! -- Convert to user node number (because that's how cell centers are - ! stored) and then set xcell and ycell - nu = this%get_nodeuser(node) - xcell = this%cellxy(1, nu) - ycell = this%cellxy(2, nu) - ! - ! -- return - return - end subroutine get_cellxy_disu - - ! return discretization type - subroutine get_dis_type(this, dis_type) - class(GwfDisuType), intent(in) :: this - character(len=*), intent(out) :: dis_type - - dis_type = "DISU" - - end subroutine get_dis_type - - subroutine allocate_scalars(this, name_model) -! ****************************************************************************** -! allocate_scalars -- Allocate and initialize scalar variables in this class -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(GwfDisuType) :: this - character(len=*), intent(in) :: name_model - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- Allocate parent scalars - call this%DisBaseType%allocate_scalars(name_model) - ! - ! -- Allocate variables for DISU - call mem_allocate(this%njausr, 'NJAUSR', this%origin) - call mem_allocate(this%nvert, 'NVERT', this%origin) - ! - ! -- Set values - this%ndim = 1 - this%njausr = 0 - this%nvert = 0 - ! - ! -- Return - return - end subroutine allocate_scalars - - subroutine allocate_arrays(this) -! ****************************************************************************** -! allocate_arrays -- Read discretization information from file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(GwfDisuType) :: this - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- Allocate arrays in DisBaseType (mshape, top, bot, area) - call this%DisBaseType%allocate_arrays() - ! - ! -- Allocate arrays in DISU - if(this%nodes < this%nodesuser) then - call mem_allocate(this%nodeuser, this%nodes, 'NODEUSER', this%origin) - call mem_allocate(this%nodereduced, this%nodesuser, 'NODEREDUCED', & - this%origin) - else - call mem_allocate(this%nodeuser, 1, 'NODEUSER', this%origin) - call mem_allocate(this%nodereduced, 1, 'NODEREDUCED', this%origin) - endif - ! - ! -- Initialize - this%mshape(1) = this%nodesuser - ! - ! -- Return - return - end subroutine allocate_arrays - - function nodeu_from_string(this, lloc, istart, istop, in, iout, line, & - flag_string, allow_zero) result(nodeu) -! ****************************************************************************** -! nodeu_from_string -- Receive a string and convert the string to a user -! nodenumber. The model is unstructured; just read user nodenumber. -! If flag_string argument is present and true, the first token in string -! is allowed to be a string (e.g. boundary name). In this case, if a string -! is encountered, return value as -2. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfDisuType) :: this - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout - character(len=*), intent(inout) :: line - logical, optional, intent(in) :: flag_string - logical, optional, intent(in) :: allow_zero - integer(I4B) :: nodeu - ! -- local - integer(I4B) :: lloclocal, ndum, istat, n - real(DP) :: r - character(len=LINELENGTH) :: ermsg, fname -! ------------------------------------------------------------------------------ - ! - if (present(flag_string)) then - if (flag_string) then - ! Check to see if first token in line can be read as an integer. - lloclocal = lloc - call urword(line, lloclocal, istart, istop, 1, ndum, r, iout, in) - read(line(istart:istop),*,iostat=istat)n - if (istat /= 0) then - ! First token in line is not an integer; return flag to this effect. - nodeu = -2 - return - endif - endif - endif - ! - call urword(line, lloc, istart, istop, 2, nodeu, r, iout, in) - ! - if (nodeu == 0) then - if (present(allow_zero)) then - if (allow_zero) then - return - endif - endif - endif - ! - if(nodeu < 1 .or. nodeu > this%nodesuser) then - write(ermsg, *) ' Node number in list is outside of the grid', nodeu - call store_error(ermsg) - inquire(unit=in, name=fname) - call store_error('Error converting in file: ') - call store_error(trim(adjustl(fname))) - call store_error('Cell number cannot be determined in line: ') - call store_error(trim(adjustl(line))) - call store_error_unit(in) - call ustop() - end if - ! - ! -- return - return - - end function nodeu_from_string - - function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & - allow_zero) result(nodeu) -! ****************************************************************************** -! nodeu_from_cellid -- Receive cellid as a string and convert the string to a -! user nodenumber. -! If flag_string argument is present and true, the first token in string -! is allowed to be a string (e.g. boundary name). In this case, if a string -! is encountered, return value as -2. -! If allow_zero argument is present and true, if all indices equal zero, the -! result can be zero. If allow_zero is false, a zero in any index causes an -! error. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - integer(I4B) :: nodeu - ! -- dummy - class(GwfDisuType) :: this - character(len=*), intent(inout) :: cellid - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - logical, optional, intent(in) :: flag_string - logical, optional, intent(in) :: allow_zero - ! -- local - integer(I4B) :: lloclocal, istart, istop, ndum, n - integer(I4B) :: istat - real(DP) :: r - character(len=LINELENGTH) :: ermsg, fname -! ------------------------------------------------------------------------------ - ! - if (present(flag_string)) then - if (flag_string) then - ! Check to see if first token in cellid can be read as an integer. - lloclocal = 1 - call urword(cellid, lloclocal, istart, istop, 1, ndum, r, iout, inunit) - read(cellid(istart:istop), *, iostat=istat) n - if (istat /= 0) then - ! First token in cellid is not an integer; return flag to this effect. - nodeu = -2 - return - endif - endif - endif - ! - lloclocal = 1 - call urword(cellid, lloclocal, istart, istop, 2, nodeu, r, iout, inunit) - ! - if (nodeu == 0) then - if (present(allow_zero)) then - if (allow_zero) then - return - endif - endif - endif - ! - if(nodeu < 1 .or. nodeu > this%nodesuser) then - write(ermsg, *) ' Node number in list is outside of the grid', nodeu - call store_error(ermsg) - inquire(unit=inunit, name=fname) - call store_error('Error converting in file: ') - call store_error(trim(adjustl(fname))) - call store_error('Cell number cannot be determined in cellid: ') - call store_error(trim(adjustl(cellid))) - call store_error_unit(inunit) - call ustop() - end if - ! - ! -- return - return - end function nodeu_from_cellid - - logical function supports_layers(this) - implicit none - ! -- dummy - class(GwfDisuType) :: this - ! - supports_layers = .false. - return - end function supports_layers - - function get_ncpl(this) -! ****************************************************************************** -! get_ncpl -- Return number of cells per layer. This is nodes -! for a DISU grid, as there are no layers. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - integer(I4B) :: get_ncpl - ! -- dummy - class(GwfDisuType) :: this -! ------------------------------------------------------------------------------ - ! - get_ncpl = this%nodesuser - ! - ! -- Return - return - end function get_ncpl - - subroutine read_int_array(this, line, lloc, istart, istop, iout, in, & - iarray, aname) -! ****************************************************************************** -! read_int_array -- Read a GWF integer array -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: urword - use SimModule, only: store_error, ustop - use ConstantsModule, only: LINELENGTH - ! -- dummy - class(GwfDisuType), intent(inout) :: this - character(len=*), intent(inout) :: line - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: iarray - character(len=*), intent(in) :: aname - ! -- local - integer(I4B) :: nval - integer(I4B), dimension(:), pointer, contiguous :: itemp -! ------------------------------------------------------------------------------ - ! - ! -- Point the temporary pointer array, which is passed to the reading - ! subroutine. The temporary array will point to ibuff if it is a - ! reduced structured system, or to iarray if it is an unstructured - ! model. - if(this%nodes < this%nodesuser) then - nval = this%nodesuser - itemp => this%ibuff - else - nval = this%nodes - itemp => iarray - endif - ! - ! -- Read the array - ! -- Read unstructured input - call ReadArray(in, itemp, aname, this%ndim, nval, iout, 0) - ! - ! -- If reduced model, then need to copy from itemp(=>ibuff) to iarray - if(this%nodes < this%nodesuser) then - call this%fill_grid_array(itemp, iarray) - endif - ! - ! -- return - return - end subroutine read_int_array - - subroutine read_dbl_array(this, line, lloc, istart, istop, iout, in, & - darray, aname) -! ****************************************************************************** -! read_dbl_array -- Read a GWF double precision array -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: urword - use SimModule, only: ustop, store_error - use ConstantsModule, only: LINELENGTH - ! -- dummy - class(GwfDisuType), intent(inout) :: this - character(len=*), intent(inout) :: line - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout - real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray - character(len=*), intent(in) :: aname - ! -- local - integer(I4B) :: nval - real(DP), dimension(:), pointer, contiguous :: dtemp -! ------------------------------------------------------------------------------ - ! - ! -- Point the temporary pointer array, which is passed to the reading - ! subroutine. The temporary array will point to dbuff if it is a - ! reduced structured system, or to darray if it is an unstructured - ! model. - if(this%nodes < this%nodesuser) then - nval = this%nodesuser - dtemp => this%dbuff - else - nval = this%nodes - dtemp => darray - endif - ! - ! -- Read the array - call ReadArray(in, dtemp, aname, this%ndim, nval, iout, 0) - ! - ! -- If reduced model, then need to copy from dtemp(=>dbuff) to darray - if(this%nodes < this%nodesuser) then - call this%fill_grid_array(dtemp, darray) - endif - ! - ! -- return - return - end subroutine read_dbl_array - - subroutine record_array(this, darray, iout, iprint, idataun, aname, & - cdatafmp, nvaluesp, nwidthp, editdesc, dinact) -! ****************************************************************************** -! record_array -- Record a double precision array. The array will be -! printed to an external file and/or written to an unformatted external file -! depending on the argument specifications. -! ****************************************************************************** -! -! SPECIFICATIONS: -! darray is the double precision array to record -! iout is the unit number for ascii output -! iprint is a flag indicating whether or not to print the array -! idataun is the unit number to which the array will be written in binary -! form; if negative then do not write by layers, write entire array -! aname is the text descriptor of the array -! cdatafmp is the fortran format for writing the array -! nvaluesp is the number of values per line for printing -! nwidthp is the width of the number for printing -! editdesc is the format type (I, G, F, S, E) -! dinact is the double precision value to use for cells that are excluded -! from the model domain -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(GwfDisuType), intent(inout) :: this - real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray - integer(I4B), intent(in) :: iout - integer(I4B), intent(in) :: iprint - integer(I4B), intent(in) :: idataun - character(len=*), intent(in) :: aname - character(len=*), intent(in) :: cdatafmp - integer(I4B), intent(in) :: nvaluesp - integer(I4B), intent(in) :: nwidthp - character(len=*), intent(in) :: editdesc - real(DP), intent(in) :: dinact - ! -- local - integer(I4B) :: k, ifirst - integer(I4B) :: nlay - integer(I4B) :: nrow - integer(I4B) :: ncol - integer(I4B) :: nval - integer(I4B) :: nodeu, noder - integer(I4B) :: istart, istop - real(DP), dimension(:), pointer, contiguous :: dtemp - ! -- formats - character(len=*),parameter :: fmthsv = & - "(1X,/1X,a,' WILL BE SAVED ON UNIT ',I4, & - &' AT END OF TIME STEP',I5,', STRESS PERIOD ',I4)" -! ------------------------------------------------------------------------------ - ! - ! -- set variables - nlay = 1 - nrow = 1 - ncol = this%mshape(1) - ! - ! -- If this is a reduced model, then copy the values from darray into - ! dtemp. - if(this%nodes < this%nodesuser) then - nval = this%nodes - dtemp => this%dbuff - do nodeu = 1, this%nodesuser - noder = this%get_nodenumber(nodeu, 0) - if(noder <= 0) then - dtemp(nodeu) = dinact - cycle - endif - dtemp(nodeu) = darray(noder) - enddo - else - nval = this%nodes - dtemp => darray - endif - ! - ! -- Print to iout if iprint /= 0 - if(iprint /= 0) then - istart = 1 - do k = 1, nlay - istop = istart + nrow * ncol - 1 - call ulaprufw(ncol, nrow, kstp, kper, k, iout, dtemp(istart:istop), & - aname, cdatafmp, nvaluesp, nwidthp, editdesc) - istart = istop + 1 - enddo - endif - ! - ! -- Save array to an external file. - if(idataun > 0) then - ! -- write to binary file by layer - ifirst = 1 - istart = 1 - do k=1, nlay - istop = istart + nrow * ncol - 1 - if(ifirst == 1) write(iout, fmthsv) & - trim(adjustl(aname)), idataun, & - kstp, kper - ifirst = 0 - call ulasav(dtemp(istart:istop), aname, kstp, kper, & - pertim, totim, ncol, nrow, k, idataun) - istart = istop + 1 - enddo - elseif(idataun < 0) then - ! - ! -- write entire array as one record - call ubdsv1(kstp, kper, aname, -idataun, dtemp, ncol, nrow, nlay, & - iout, delt, pertim, totim) - endif - ! - ! -- return - return - end subroutine record_array - - subroutine record_srcdst_list_header(this, text, textmodel, textpackage, & - dstmodel, dstpackage, naux, auxtxt, & - ibdchn, nlist, iout) -! ****************************************************************************** -! record_srcdst_list_header -- Record list header for imeth=6 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfDisuType) :: this - character(len=16), intent(in) :: text - character(len=16), intent(in) :: textmodel - character(len=16), intent(in) :: textpackage - character(len=16), intent(in) :: dstmodel - character(len=16), intent(in) :: dstpackage - integer(I4B), intent(in) :: naux - character(len=16), dimension(:), intent(in) :: auxtxt - integer(I4B), intent(in) :: ibdchn - integer(I4B), intent(in) :: nlist - integer(I4B), intent(in) :: iout - ! -- local - integer(I4B) :: nlay, nrow, ncol -! ------------------------------------------------------------------------------ - ! - nlay = 1 - nrow = 1 - ncol = this%mshape(1) - ! - ! -- Use ubdsv06 to write list header - call ubdsv06(kstp, kper, text, textmodel, textpackage, dstmodel, dstpackage,& - ibdchn, naux, auxtxt, ncol, nrow, nlay, & - nlist, iout, delt, pertim, totim) - ! - ! -- return - return - end subroutine record_srcdst_list_header - -end module GwfDisuModule +module GwfDisuModule + + use ArrayReadersModule, only: ReadArray + use KindModule, only: DP, I4B + use ConstantsModule, only: LENMODELNAME, LENORIGIN, LINELENGTH + use ConnectionsModule, only: ConnectionsType, iac_to_ia + use InputOutputModule, only: URWORD, ulasav, ulaprufw, ubdsv1, ubdsv06 + use SimModule, only: count_errors, store_error, store_error_unit, ustop + use BaseDisModule, only: DisBaseType + use BlockParserModule, only: BlockParserType + use MemoryManagerModule, only: mem_allocate + use TdisModule, only: kstp, kper, pertim, totim, delt + + implicit none + + private + public :: GwfDisuType + public :: disu_cr + public :: disu_init_mem + + type, extends(DisBaseType) :: GwfDisuType + integer(I4B), pointer :: njausr => null() ! user-specified nja size + integer(I4B), pointer :: nvert => null() ! number of x,y vertices + real(DP), dimension(:,:), pointer, contiguous :: vertices => null() ! cell vertices stored as 2d array of x and y + real(DP), dimension(:,:), pointer, contiguous :: cellxy => null() ! cell center stored as 2d array of x and y + real(DP), dimension(:), pointer, contiguous :: top1d => null() ! (size:nodesuser) cell top elevation + real(DP), dimension(:), pointer, contiguous :: bot1d => null() ! (size:nodesuser) cell bottom elevation + real(DP), dimension(:), pointer, contiguous :: area1d => null() ! (size:nodesuser) cell area, in plan view + integer(I4B), dimension(:), pointer, contiguous :: iainp => null() ! (size:nodesuser+1) user iac converted ia + integer(I4B), dimension(:), pointer, contiguous :: jainp => null() ! (size:njausr) user-input ja array + integer(I4B), dimension(:), pointer, contiguous :: ihcinp => null() ! (size:njausr) user-input ihc array + real(DP), dimension(:), pointer, contiguous :: cl12inp => null() ! (size:njausr) user-input cl12 array + real(DP), dimension(:), pointer, contiguous :: hwvainp => null() ! (size:njausr) user-input hwva array + real(DP), dimension(:), pointer, contiguous :: angldegxinp => null() ! (size:njausr) user-input angldegx array + integer(I4B), dimension(:), pointer, contiguous :: iavert => null() ! cell vertex pointer ia array + integer(I4B), dimension(:), pointer, contiguous:: javert => null() ! cell vertex pointer ja array + integer(I4B), dimension(:), pointer, contiguous :: idomain => null() ! idomain (nodes) + contains + procedure :: dis_df => disu_df + procedure :: dis_da => disu_da + procedure :: get_cellxy => get_cellxy_disu + procedure :: get_dis_type => get_dis_type + procedure :: disu_ck + procedure :: grid_finalize + procedure :: get_nodenumber_idx1 + procedure :: nodeu_to_string + procedure :: nodeu_to_array + procedure :: nodeu_from_string + procedure :: nodeu_from_cellid + procedure :: connection_normal + procedure :: connection_vector + procedure :: supports_layers + procedure :: get_ncpl + procedure, public :: record_array + procedure, public :: record_srcdst_list_header + ! -- private + procedure :: allocate_scalars + procedure :: allocate_arrays + procedure :: read_options + procedure :: read_dimensions + procedure :: read_mf6_griddata + procedure :: read_connectivity + procedure :: read_vertices + procedure :: read_cell2d + procedure :: write_grb + ! + ! -- Read a node-sized model array (reduced or not) + procedure :: read_int_array + procedure :: read_dbl_array + end type GwfDisuType + + contains + + subroutine disu_cr(dis, name_model, inunit, iout) +! ****************************************************************************** +! disu_cr -- Create discretization object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(DisBaseType), pointer :: dis + character(len=*), intent(in) :: name_model + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + ! -- local + type(GwfDisuType), pointer :: disnew +! ------------------------------------------------------------------------------ + ! + ! -- Create a new discretization object + allocate(disnew) + dis => disnew + ! + ! -- Allocate scalars and assign data + call dis%allocate_scalars(name_model) + dis%inunit = inunit + dis%iout = iout + ! + ! -- Initialize block parser + call dis%parser%Initialize(dis%inunit, dis%iout) + ! + ! -- Return + return + end subroutine disu_cr + + subroutine disu_init_mem(dis, name_model, iout, nodes, nja, & + top, bot, area, iac, ja, ihc, cl12, hwva, angldegx, & + nvert, vertices, cellxy, idomain) +! ****************************************************************************** +! dis_init_mem -- Create a new unstructured discretization object from memory +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(DisBaseType), pointer :: dis + character(len=*), intent(in) :: name_model + integer(I4B), intent(in) :: iout + integer(I4B), intent(in) :: nodes + integer(I4B), intent(in) :: nja + real(DP), dimension(:), pointer, contiguous, intent(in) :: top + real(DP), dimension(:), pointer, contiguous, intent(in) :: bot + real(DP), dimension(:), pointer, contiguous, intent(in) :: area + integer(I4B), dimension(:), pointer, contiguous, intent(in) :: iac + integer(I4B), dimension(:), pointer, contiguous, intent(in) :: ja + integer(I4B), dimension(:), pointer, contiguous, intent(in) :: ihc + real(DP), dimension(:), pointer, contiguous, intent(in) :: cl12 + real(DP), dimension(:), pointer, contiguous, intent(in) :: hwva + real(DP), dimension(:), pointer, contiguous, intent(in), optional :: angldegx + integer(I4B), intent(in), optional :: nvert + integer(I4B), dimension(:, :), pointer, contiguous, intent(in), & + optional :: vertices + integer(I4B), dimension(:, :), pointer, contiguous, intent(in), & + optional :: cellxy + integer(I4B), dimension(:), pointer, contiguous, intent(in), & + optional :: idomain + ! -- local + type(GwfDisuType), pointer :: disext + integer(I4B) :: n + integer(I4B) :: j + integer(I4B) :: ival + real(DP), dimension(:), pointer, contiguous :: atemp +! ------------------------------------------------------------------------------ + allocate(disext) + dis => disext + call disext%allocate_scalars(name_model) + dis%inunit = 0 + dis%iout = iout + ! + ! -- set dimensions + disext%nodes = nodes + disext%nja = nja + if (present(nvert)) then + disext%nvert = nvert + end if + ! + ! -- Calculate nodesuser + disext%nodesuser = disext%nodes + ! + ! -- Allocate vectors for disu + call disext%allocate_arrays() + ! + ! -- fill data + do n = 1, disext%nodes + disext%top(n) = top(n) + disext%bot(n) = bot(n) + disext%area(n) = area(n) + disext%con%ia(n) = iac(n) + if (present(idomain)) then + ival = idomain(n) + else + ival = 1 + end if + disext%idomain(n) = ival + end do + call iac_to_ia(disext%con%ia) + do n = 1, nja + disext%con%ja(n) = ja(n) + end do + if (present(nvert)) then + if (present(vertices)) then + do n = 1, disext%nvert + do j = 1, 2 + disext%vertices(j, n) = vertices(j, n) + end do + end do + ! -- error + else + end if + if (present(cellxy)) then + do n = 1, disext%nodes + do j = 1, 2 + disext%cellxy(j, n) = cellxy(j, n) + end do + end do + ! -- error + else + end if + else + ! -- connection direction information cannot be calculated + disext%icondir = 0 + end if + ! + ! -- allocate space for atemp and fill + allocate(atemp(nja)) + if (present(angldegx)) then + disext%con%ianglex = 1 + do n = 1, nja + atemp(n) = angldegx(n) + end do + end if + ! + ! -- finalize connection data + call disext%con%con_finalize(ihc, cl12, hwva, atemp) + disext%njas = disext%con%njas + ! + ! -- deallocate temp arrays + deallocate(atemp) + ! + ! -- Make some final disu checks + call disext%disu_ck() + ! + ! -- Return + return + end subroutine disu_init_mem + + subroutine disu_df(this) +! ****************************************************************************** +! disu_df -- Read discretization information from DISU input file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- 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 + endif + end if + ! + ! -- Make some final disu checks on the non-reduced user-provided + ! input + call this%disu_ck() + ! + ! -- Finalize the grid by creating the connection object and reducing the + ! grid using IDOMAIN, if necessary + call this%grid_finalize() + ! + ! -- Return + return + end subroutine disu_df + + subroutine grid_finalize(this) +! ****************************************************************************** +! grid_finalize -- Finalize grid +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: ustop, count_errors, store_error + use ConstantsModule, only: LINELENGTH, DZERO + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GwfDisuType) :: this + ! -- locals + integer(I4B) :: n + integer(I4B) :: node + integer(I4B) :: noder + integer(I4B) :: nrsize + ! -- formats + character(len=*), parameter :: fmtdz = & + "('ERROR. CELL (',i0,',',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, //)" +! ------------------------------------------------------------------------------ + ! + ! -- count active cells + this%nodes = 0 + do n = 1, this%nodesuser + if(this%idomain(n) > 0) this%nodes = this%nodes + 1 + enddo + ! + ! -- Check to make sure nodes is a valid number + if (this%nodes == 0) then + call store_error('ERROR. MODEL DOES NOT HAVE ANY ACTIVE NODES.') + call store_error('MAKE SURE IDOMAIN ARRAY HAS SOME VALUES GREATER & + &THAN ZERO.') + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- Write message if reduced grid + if(this%nodes < this%nodesuser) then + write(this%iout, fmtnr) this%nodesuser, this%nodes + endif + ! + ! -- Array size is now known, so allocate + call this%allocate_arrays() + ! + ! -- Fill the nodereduced array with the reduced nodenumber, or + ! a negative number to indicate it is a pass-through cell, or + ! a zero to indicate that the cell is excluded from the + ! solution. (negative idomain not supported for disu) + if(this%nodes < this%nodesuser) then + noder = 1 + do node = 1, this%nodesuser + if(this%idomain(node) > 0) then + this%nodereduced(node) = noder + noder = noder + 1 + elseif(this%idomain(node) < 0) then + this%nodereduced(node) = -1 + else + this%nodereduced(node) = 0 + endif + enddo + endif + ! + ! -- Fill nodeuser if a reduced grid + if(this%nodes < this%nodesuser) then + noder = 1 + do node = 1, this%nodesuser + if(this%idomain(node) > 0) then + this%nodeuser(noder) = node + noder = noder + 1 + endif + enddo + endif + ! + ! -- Move top1d, bot1d, and area1d into top, bot, and area + do node = 1, this%nodesuser + noder = node + if(this%nodes < this%nodesuser) noder = this%nodereduced(node) + if(noder <= 0) cycle + this%top(noder) = this%top1d(node) + this%bot(noder) = this%bot1d(node) + this%area(noder) = this%area1d(node) + enddo + ! + ! -- create and fill the connections object + nrsize = 0 + if(this%nodes < this%nodesuser) nrsize = this%nodes + allocate(this%con) + call this%con%disuconnections(this%name_model, this%nodes, & + this%nodesuser, nrsize, & + this%nodereduced, this%nodeuser, & + this%iainp, this%jainp, & + this%ihcinp, this%cl12inp, & + this%hwvainp, this%angldegxinp) + this%nja = this%con%nja + this%njas = this%con%njas + ! + ! -- Return + return + end subroutine grid_finalize + + subroutine disu_ck(this) +! ****************************************************************************** +! disu_ck -- Check the discretization information +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DZERO + ! -- dummy + class(GwfDisuType) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + integer(I4B) :: n, m + integer(I4B) :: ipos + integer(I4B) :: ihc + real(DP) :: dz + ! -- formats + character(len=*), parameter :: fmtidm = & + "('ERROR. INVALID IDOMAIN VALUE ', i0, ' SPECIFIED FOR NODE ', i0)" + character(len=*), parameter :: fmtdz = & + "('ERROR. CELL ', i0, ' WITH THICKNESS <= 0. TOP, BOT: ', 2(1pg24.15))" + character(len=*), parameter :: fmtarea = & + "('ERROR. CELL ', i0, ' WITH AREA <= 0. AREA: ', 1(1pg24.15))" + character(len=*),parameter :: fmterrmsg = & + "(' Top elevation (', 1pg15.6, ') for cell ', i0, ' is above bottom & + &elevation (', 1pg15.6, ') for cell ', i0, '. Based on node numbering & + &rules cell ', i0, ' must be below cell ', i0, '.')" +! ------------------------------------------------------------------------------ + ! + ! -- Ensure idomain values are valid + do n = 1, this%nodesuser + if(this%idomain(n) > 1 .or. this%idomain(n) < 0) then + write(errmsg, fmtidm) this%idomain(n), n + call store_error(errmsg) + end if + enddo + ! + ! -- Check for zero and negative thickness and zero or negative areas + do n = 1, this%nodesuser + dz = this%top1d(n) - this%bot1d(n) + if (dz <= DZERO) then + write(errmsg, fmt=fmtdz) n, this%top1d(n), this%bot1d(n) + call store_error(errmsg) + endif + if (this%area1d(n) <= DZERO) then + write(errmsg, fmt=fmtarea) n, this%area1d(n) + call store_error(errmsg) + endif + enddo + ! + ! -- For cell n, ensure that underlying cells have tops less than + ! or equal to the bottom of cell n + do n = 1, this%nodesuser + do ipos = this%iainp(n) + 1, this%iainp(n + 1) - 1 + m = this%jainp(ipos) + ihc = this%ihcinp(ipos) + if (ihc == 0 .and. m > n) then + if (this%top1d(m) > this%bot1d(n)) then + write(errmsg, fmterrmsg) this%top1d(m), m, this%bot1d(n), n, m, n + call store_error(errmsg) + end if + end if + end do + end do + ! + ! -- terminate if errors found + if(count_errors() > 0) then + if (this%inunit > 0) call store_error_unit(this%inunit) + call ustop() + endif + ! + ! -- Return + return + end subroutine disu_ck + + subroutine disu_da(this) +! ****************************************************************************** +! disu_da -- Deallocate discretization object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(GwfDisuType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- scalars + call mem_deallocate(this%njausr) + call mem_deallocate(this%nvert) + ! + ! -- arrays + call mem_deallocate(this%top1d) + call mem_deallocate(this%bot1d) + call mem_deallocate(this%area1d) + call mem_deallocate(this%idomain) + if (associated(this%iavert)) then + call mem_deallocate(this%iavert) + call mem_deallocate(this%javert) + end if + call mem_deallocate(this%vertices) + call mem_deallocate(this%iainp) + call mem_deallocate(this%jainp) + call mem_deallocate(this%ihcinp) + call mem_deallocate(this%cl12inp) + call mem_deallocate(this%hwvainp) + call mem_deallocate(this%angldegxinp) + call mem_deallocate(this%cellxy) + call mem_deallocate(this%nodeuser) + call mem_deallocate(this%nodereduced) + ! + ! -- DisBaseType deallocate + call this%DisBaseType%dis_da() + ! + ! -- Return + return + end subroutine disu_da + + subroutine nodeu_to_string(this, nodeu, str) +! ****************************************************************************** +! nodeu_to_string -- Convert user node number to a string in the form of +! (nodenumber) or (k,i,j) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfDisuType) :: this + integer(I4B), intent(in) :: nodeu + character(len=*), intent(inout) :: str + ! -- local + character(len=10) :: nstr +! ------------------------------------------------------------------------------ + ! + write(nstr, '(i0)') nodeu + str = '(' // trim(adjustl(nstr)) // ')' + ! + ! -- return + return + end subroutine nodeu_to_string + + subroutine nodeu_to_array(this, nodeu, arr) +! ****************************************************************************** +! nodeu_to_array -- Convert user node number to cellid and fill array with +! (nodenumber) or (k,j) or (k,i,j) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use InputOutputModule, only: get_ijk + implicit none + class(GwfDisuType) :: this + integer(I4B), intent(in) :: nodeu + integer(I4B), dimension(:), intent(inout) :: arr + ! -- local + character(len=LINELENGTH) :: errmsg + integer(I4B) :: isize +! ------------------------------------------------------------------------------ + ! + ! -- check the size of arr + isize = size(arr) + if (isize /= this%ndim) then + write(errmsg,'(a,i0,a,i0,a)') & + 'Program error: nodeu_to_array size of array (', isize, & + ') is not equal to the discretization dimension (', this%ndim, ')' + call store_error(errmsg) + call ustop() + end if + ! + ! -- fill array + arr(1) = nodeu + ! + ! -- return + return + end subroutine nodeu_to_array + + subroutine read_options(this) +! ****************************************************************************** +! read_options -- Read discretization options +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use MemoryManagerModule, only: mem_allocate + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, count_errors, store_error + implicit none + class(GwfDisuType) :: this + character(len=LINELENGTH) :: errmsg, keyword + integer(I4B) :: ierr, nerr + 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' + endif + 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) + 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) write(this%iout,'(1x,a)') 'MODEL LENGTH UNIT IS UNDEFINED' + ! + nerr = count_errors() + if(nerr > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Return + return + end subroutine read_options + + subroutine read_dimensions(this) +! ****************************************************************************** +! read_dimensions -- Read discretization information from file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use MemoryManagerModule, only: mem_allocate + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, count_errors, store_error + implicit none + class(GwfDisuType) :: this + character(len=LINELENGTH) :: errmsg, keyword + integer(I4B) :: n, ierr + logical :: isfound, endOfBlock +! ------------------------------------------------------------------------------ + ! + ! -- 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,'(4x,a,a)')'****ERROR. UNKNOWN DISU DIMENSION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + end do + write(this%iout,'(1x,a)')'END OF DISCRETIZATION OPTIONS' + else + call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- verify dimensions were set + if(this%nodesuser < 1) then + call store_error( & + 'ERROR. NODES WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') + call ustop() + endif + if(this%njausr < 1) then + call store_error( & + 'ERROR. NJA WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') + call ustop() + endif + ! + ! -- allocate vectors that are the size of nodesuser + call mem_allocate(this%top1d, this%nodesuser, 'TOP1D', this%origin) + call mem_allocate(this%bot1d, this%nodesuser, 'BOT1D', this%origin) + call mem_allocate(this%area1d, this%nodesuser, 'AREA1D', this%origin) + call mem_allocate(this%idomain, this%nodesuser, 'IDOMAIN', this%origin) + call mem_allocate(this%vertices, 2, this%nvert, 'VERTICES', this%origin) + call mem_allocate(this%iainp, this%nodesuser + 1, 'IAINP', this%origin) + call mem_allocate(this%jainp, this%njausr, 'JAINP', this%origin) + call mem_allocate(this%ihcinp, this%njausr, 'IHCINP', this%origin) + call mem_allocate(this%cl12inp, this%njausr, 'CL12INP', this%origin) + call mem_allocate(this%hwvainp, this%njausr, 'HWVAINP', this%origin) + call mem_allocate(this%angldegxinp, this%njausr, 'ANGLDEGXINP', this%origin) + if(this%nvert > 0) then + call mem_allocate(this%cellxy, 2, this%nodesuser, 'CELLXY', this%origin) + else + call mem_allocate(this%cellxy, 2, 0, 'CELLXY', this%origin) + endif + ! + ! -- initialize all cells to be active (idomain = 1) + do n = 1, this%nodesuser + this%idomain(n) = 1 + end do + ! + ! -- Return + return + end subroutine read_dimensions + + subroutine read_mf6_griddata(this) +! ****************************************************************************** +! read_mf6_griddata -- Read discretization data +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, count_errors, store_error, store_error_unit + ! -- dummy + class(GwfDisuType) :: this + ! -- local + character(len=LINELENGTH) :: errmsg, 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) + ! -- 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,'(4x,a,a)')'ERROR. UNKNOWN GRIDDATA TAG: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + 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() + call ustop() + end if + ! + ! -- verify all items were read + do n = 1, nname + if (n == 4) cycle + if(.not. lname(n)) then + write(errmsg,'(1x,a,a)') & + 'ERROR. REQUIRED INPUT WAS NOT SPECIFIED: ', aname(n) + call store_error(errmsg) + endif + enddo + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Return + return + end subroutine read_mf6_griddata + + subroutine read_connectivity(this) +! ****************************************************************************** +! read_connectivity -- Read user-specified connectivity information +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH, DONE, DHALF, DPIO180, DNODATA + use SimModule, only: ustop, store_error, count_errors, store_error_unit + ! -- 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) + character(len=300) :: ermsg + ! -- 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(ermsg,'(4x,a,a)')'ERROR. UNKNOWN CONNECTIONDATA TAG: ', & + trim(keyword) + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + end do + write(this%iout,'(1x,a)')'END PROCESSING CONNECTIONDATA' + else + call store_error('ERROR. REQUIRED CONNECTIONDATA BLOCK NOT FOUND.') + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- 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(ermsg,'(1x,a,a)') & + 'ERROR. REQUIRED CONNECTIONDATA INPUT WAS NOT SPECIFIED: ', & + adjustl(trim(aname(n))) + call store_error(ermsg) + endif + enddo + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + if (.not. lname(6)) then + write(this%iout, '(1x,a)') 'ANGLDEGX NOT FOUND IN CONNECTIONDATA ' // & + 'BLOCK. SOME CAPABILITIES MAY BE LIMITED.' + end if + ! + ! -- Return + return + end subroutine read_connectivity + + subroutine read_vertices(this) +! ****************************************************************************** +! read_vertices -- Read data +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: ustop, count_errors, store_error + use ConstantsModule, only: LINELENGTH, DZERO + ! -- dummy + class(GwfDisuType) :: this + integer(I4B) :: i + integer(I4B) :: ierr, ival + logical :: isfound, endOfBlock + real(DP) :: xmin, xmax, ymin, ymax + character(len=300) :: ermsg + ! -- 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' + 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() + call ustop() + endif + ! + ! -- 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)) + endif + enddo + ! + ! -- Terminate the block + call this%parser%terminateblock() + else + call store_error('ERROR. REQUIRED VERTICES BLOCK NOT FOUND.') + call this%parser%StoreErrorUnit() + call ustop() + 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' + ! + ! -- Return + return + end subroutine read_vertices + + subroutine read_cell2d(this) +! ****************************************************************************** +! read_cell2d -- Read information describing the two dimensional (x, y) +! configuration of each cell. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: ustop, count_errors, store_error + use ConstantsModule, only: LINELENGTH, DZERO + use InputOutputModule, only: urword + use SparseModule, only: sparsematrix + ! -- 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 + character(len=300) :: ermsg + integer(I4B), dimension(:), allocatable :: maxnnz + type(sparsematrix) :: vertspm + ! -- 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 + ! + ! -- 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 + enddo + call vertspm%init(this%nodesuser, this%nvert, maxnnz) + ! + ! --Read CELL2D block + call this%parser%GetBlock('CELL2D', isfound, ierr, supportOpenClose=.true.) + if(isfound) then + write(this%iout,'(/,1x,a)') 'PROCESSING CELL2D' + do i = 1, this%nodesuser + 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) + call ustop() + endif + ! + ! -- 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 + endif + ! + ! -- 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) + endif + endif + enddo + ! + ! -- 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)) + endif + enddo + ! + ! -- Terminate the block + call this%parser%terminateblock() + else + call store_error('ERROR. REQUIRED CELL2D BLOCK NOT FOUND.') + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- Convert vertspm into ia/ja form + call mem_allocate(this%iavert, this%nodesuser + 1, 'IAVERT', this%origin) + call mem_allocate(this%javert, vertspm%nnz, 'JAVERT', this%origin) + + 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' + ! + ! -- Return + return + end subroutine read_cell2d + + subroutine write_grb(this, icelltype) +! ****************************************************************************** +! write_grb -- Write the binary grid file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: getunit, openfile + use OpenSpecModule, only: access, form + use ConstantsModule, only: DZERO + ! -- dummy + class(GwfDisuType) :: this + integer(I4B), dimension(:), intent(in) :: icelltype + ! -- local + integer(I4B) :: i, iunit, ntxt + integer(I4B), parameter :: lentxt = 100 + character(len=50) :: txthdr + character(len=lentxt) :: txt + character(len=LINELENGTH) :: fname + character(len=*),parameter :: fmtgrdsave = & + "(4X,'BINARY GRID INFORMATION WILL BE WRITTEN TO:', & + &/,6X,'UNIT NUMBER: ', I0,/,6X, 'FILE NAME: ', A)" +! ------------------------------------------------------------------------------ + ! + ! -- Initialize + ntxt = 10 + if (this%nvert > 0) ntxt = ntxt + 5 + ! + ! -- Open the file + inquire(unit=this%inunit, name=fname) + fname = trim(fname) // '.grb' + iunit = getunit() + write(this%iout, fmtgrdsave) iunit, trim(adjustl(fname)) + call openfile(iunit, this%iout, trim(adjustl(fname)), 'DATA(BINARY)', & + form, access, 'REPLACE') + ! + ! -- write header information + write(txthdr, '(a)') 'GRID DISU' + txthdr(50:50) = new_line('a') + write(iunit) txthdr + write(txthdr, '(a)') 'VERSION 1' + txthdr(50:50) = new_line('a') + write(iunit) txthdr + write(txthdr, '(a, i0)') 'NTXT ', ntxt + txthdr(50:50) = new_line('a') + write(iunit) txthdr + write(txthdr, '(a, i0)') 'LENTXT ', lentxt + txthdr(50:50) = new_line('a') + write(iunit) txthdr + ! + ! -- write variable definitions + write(txt, '(3a, i0)') 'NODES ', 'INTEGER ', 'NDIM 0 # ', this%nodesuser + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'NJA ', 'INTEGER ', 'NDIM 0 # ', this%con%nja + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, 1pg24.15)') 'XORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%xorigin + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, 1pg24.15)') 'YORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%yorigin + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, 1pg24.15)') 'ANGROT ', 'DOUBLE ', 'NDIM 0 # ', this%angrot + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'TOP ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'BOT ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'IA ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + 1 + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'JA ', 'INTEGER ', 'NDIM 1 ', this%con%nja + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'ICELLTYPE ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + ! + ! -- if vertices have been read then write additional header information + if (this%nvert > 0) then + write(txt, '(3a, i0)') 'VERTICES ', 'DOUBLE ', 'NDIM 2 2 ', this%nvert + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'CELLX ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'CELLY ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'IAVERT ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + 1 + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'JAVERT ', 'INTEGER ', 'NDIM 1 ', size(this%javert) + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + endif + ! + ! -- write data + write(iunit) this%nodesuser ! nodes + write(iunit) this%nja ! nja + write(iunit) this%xorigin ! xorigin + write(iunit) this%yorigin ! yorigin + write(iunit) this%angrot ! angrot + write(iunit) this%top1d ! top + write(iunit) this%bot1d ! bot + write(iunit) this%con%iausr ! ia + write(iunit) this%con%jausr ! ja + write(iunit) icelltype ! icelltype + ! + ! -- if vertices have been read then write additional data + if (this%nvert > 0) then + write(iunit) this%vertices ! vertices + write(iunit) (this%cellxy(1, i), i = 1, this%nodesuser) ! cellx + write(iunit) (this%cellxy(2, i), i = 1, this%nodesuser) ! celly + write(iunit) this%iavert ! iavert + write(iunit) this%javert ! javert + endif + ! + ! -- Close the file + close(iunit) + ! + ! -- return + return + end subroutine write_grb + + function get_nodenumber_idx1(this, nodeu, icheck) result(nodenumber) +! ****************************************************************************** +! get_nodenumber -- Return a nodenumber from the user specified node number +! with an option to perform a check. This subroutine +! can be overridden by child classes to perform mapping +! to a model node number +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error + implicit none + class(GwfDisuType), intent(in) :: this + integer(I4B), intent(in) :: nodeu + integer(I4B), intent(in) :: icheck + character(len=LINELENGTH) :: errmsg + integer(I4B) :: nodenumber +! ------------------------------------------------------------------------------ + ! + if(icheck /= 0) then + if(nodeu < 1 .or. nodeu > this%nodes) then + write(errmsg, '(a,i10)') & + 'Nodenumber less than 1 or greater than nodes:', nodeu + call store_error(errmsg) + endif + endif + ! + ! -- set node number to passed in nodenumber since there is a one to one + ! mapping for an unstructured grid + if (this%nodes == this%nodesuser) then + nodenumber = nodeu + else + nodenumber = this%nodereduced(nodeu) + end if + ! + ! -- return + return + end function get_nodenumber_idx1 + + subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & + ipos) +! ****************************************************************************** +! connection_normal -- calculate the normal vector components for reduced +! nodenumber cell (noden) and its shared face with cell nodem. ihc is the +! horizontal connection flag. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DONE, DZERO + use SimModule, only: ustop, store_error + ! -- dummy + class(GwfDisuType) :: this + integer(I4B), intent(in) :: noden + integer(I4B), intent(in) :: nodem + integer(I4B), intent(in) :: ihc + real(DP), intent(inout) :: xcomp + real(DP), intent(inout) :: ycomp + real(DP), intent(inout) :: zcomp + integer(I4B), intent(in) :: ipos + ! -- local + !integer(I4B) :: ipos + real(DP) :: angle, dmult +! ------------------------------------------------------------------------------ + ! + ! -- Set vector components based on ihc + if(ihc == 0) then + ! + ! -- connection is vertical + xcomp = DZERO + ycomp = DZERO + if(nodem < noden) then + ! + ! -- nodem must be above noden, so upward connection + zcomp = DONE + else + ! + ! -- nodem must be below noden, so downward connection + zcomp = -DONE + endif + else + ! -- find from anglex, since anglex is symmetric, need to flip vector + ! for lower triangle (nodem < noden) + angle = this%con%anglex(this%con%jas(ipos)) + dmult = DONE + if (nodem < noden) dmult = -DONE + xcomp = cos(angle) * dmult + ycomp = sin(angle) * dmult + zcomp = DZERO + endif + ! + ! -- return + return + end subroutine connection_normal + + subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & + xcomp, ycomp, zcomp, conlen) +! ****************************************************************************** +! connection_vector -- calculate the unit vector components from reduced +! nodenumber cell (noden) to its neighbor cell (nodem). The saturation for +! for these cells are also required so that the vertical position of the cell +! cell centers can be calculated. ihc is the horizontal flag. Also return +! the straight-line connection length. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DZERO, DONE, DHALF + use SimModule, only: ustop, store_error + use DisvGeom, only: line_unit_vector + ! -- dummy + class(GwfDisuType) :: this + integer(I4B), intent(in) :: noden + integer(I4B), intent(in) :: nodem + logical, intent(in) :: nozee + real(DP), intent(in) :: satn + real(DP), intent(in) :: satm + integer(I4B), intent(in) :: ihc + real(DP), intent(inout) :: xcomp + real(DP), intent(inout) :: ycomp + real(DP), intent(inout) :: zcomp + real(DP), intent(inout) :: conlen + ! -- local + real(DP) :: xn, xm, yn, ym, zn, zm +! ------------------------------------------------------------------------------ + ! + ! -- Find xy coords + call this%get_cellxy(noden, xn, yn) + call this%get_cellxy(nodem, xm, ym) + ! + ! -- Set vector components based on ihc + if(ihc == 0) then + ! + ! -- vertical connection, calculate z as cell center elevation + zn = this%bot(noden) + DHALF * (this%top(noden) - this%bot(noden)) + zm = this%bot(nodem) + DHALF * (this%top(nodem) - this%bot(nodem)) + else + ! + ! -- horizontal connection, with possible z component due to cell offsets + ! and/or water table conditions + if (nozee) then + zn = DZERO + zm = DZERO + else + zn = this%bot(noden) + DHALF * satn * (this%top(noden) - this%bot(noden)) + zm = this%bot(nodem) + DHALF * satm * (this%top(nodem) - this%bot(nodem)) + endif + endif + ! + ! -- Use coords to find vector components and connection length + call line_unit_vector(xn, yn, zn, xm, ym, zm, xcomp, ycomp, zcomp, & + conlen) + ! + ! -- return + return + end subroutine connection_vector + + subroutine get_cellxy_disu(this, node, xcell, ycell) +! ****************************************************************************** +! get_cellxy_disu -- assign xcell and ycell +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfDisuType), intent(in) :: this + integer(I4B), intent(in) :: node ! the reduced node number + real(DP), intent(out) :: xcell, ycell ! the x,y for the cell + ! -- local + integer(I4B) :: nu +! ------------------------------------------------------------------------------ + ! + ! -- Convert to user node number (because that's how cell centers are + ! stored) and then set xcell and ycell + nu = this%get_nodeuser(node) + xcell = this%cellxy(1, nu) + ycell = this%cellxy(2, nu) + ! + ! -- return + return + end subroutine get_cellxy_disu + + ! return discretization type + subroutine get_dis_type(this, dis_type) + class(GwfDisuType), intent(in) :: this + character(len=*), intent(out) :: dis_type + + dis_type = "DISU" + + end subroutine get_dis_type + + subroutine allocate_scalars(this, name_model) +! ****************************************************************************** +! allocate_scalars -- Allocate and initialize scalar variables in this class +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GwfDisuType) :: this + character(len=*), intent(in) :: name_model + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Allocate parent scalars + call this%DisBaseType%allocate_scalars(name_model) + ! + ! -- Allocate variables for DISU + call mem_allocate(this%njausr, 'NJAUSR', this%origin) + call mem_allocate(this%nvert, 'NVERT', this%origin) + ! + ! -- Set values + this%ndim = 1 + this%njausr = 0 + this%nvert = 0 + ! + ! -- Return + return + end subroutine allocate_scalars + + subroutine allocate_arrays(this) +! ****************************************************************************** +! allocate_arrays -- Read discretization information from file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GwfDisuType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Allocate arrays in DisBaseType (mshape, top, bot, area) + call this%DisBaseType%allocate_arrays() + ! + ! -- Allocate arrays in DISU + if(this%nodes < this%nodesuser) then + call mem_allocate(this%nodeuser, this%nodes, 'NODEUSER', this%origin) + call mem_allocate(this%nodereduced, this%nodesuser, 'NODEREDUCED', & + this%origin) + else + call mem_allocate(this%nodeuser, 1, 'NODEUSER', this%origin) + call mem_allocate(this%nodereduced, 1, 'NODEREDUCED', this%origin) + endif + ! + ! -- Initialize + this%mshape(1) = this%nodesuser + ! + ! -- Return + return + end subroutine allocate_arrays + + function nodeu_from_string(this, lloc, istart, istop, in, iout, line, & + flag_string, allow_zero) result(nodeu) +! ****************************************************************************** +! nodeu_from_string -- Receive a string and convert the string to a user +! nodenumber. The model is unstructured; just read user nodenumber. +! If flag_string argument is present and true, the first token in string +! is allowed to be a string (e.g. boundary name). In this case, if a string +! is encountered, return value as -2. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfDisuType) :: this + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout + character(len=*), intent(inout) :: line + logical, optional, intent(in) :: flag_string + logical, optional, intent(in) :: allow_zero + integer(I4B) :: nodeu + ! -- local + integer(I4B) :: lloclocal, ndum, istat, n + real(DP) :: r + character(len=LINELENGTH) :: ermsg, fname +! ------------------------------------------------------------------------------ + ! + if (present(flag_string)) then + if (flag_string) then + ! Check to see if first token in line can be read as an integer. + lloclocal = lloc + call urword(line, lloclocal, istart, istop, 1, ndum, r, iout, in) + read(line(istart:istop),*,iostat=istat)n + if (istat /= 0) then + ! First token in line is not an integer; return flag to this effect. + nodeu = -2 + return + endif + endif + endif + ! + call urword(line, lloc, istart, istop, 2, nodeu, r, iout, in) + ! + if (nodeu == 0) then + if (present(allow_zero)) then + if (allow_zero) then + return + endif + endif + endif + ! + if(nodeu < 1 .or. nodeu > this%nodesuser) then + write(ermsg, *) ' Node number in list is outside of the grid', nodeu + call store_error(ermsg) + inquire(unit=in, name=fname) + call store_error('Error converting in file: ') + call store_error(trim(adjustl(fname))) + call store_error('Cell number cannot be determined in line: ') + call store_error(trim(adjustl(line))) + call store_error_unit(in) + call ustop() + end if + ! + ! -- return + return + + end function nodeu_from_string + + function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & + allow_zero) result(nodeu) +! ****************************************************************************** +! nodeu_from_cellid -- Receive cellid as a string and convert the string to a +! user nodenumber. +! If flag_string argument is present and true, the first token in string +! is allowed to be a string (e.g. boundary name). In this case, if a string +! is encountered, return value as -2. +! If allow_zero argument is present and true, if all indices equal zero, the +! result can be zero. If allow_zero is false, a zero in any index causes an +! error. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + integer(I4B) :: nodeu + ! -- dummy + class(GwfDisuType) :: this + character(len=*), intent(inout) :: cellid + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + logical, optional, intent(in) :: flag_string + logical, optional, intent(in) :: allow_zero + ! -- local + integer(I4B) :: lloclocal, istart, istop, ndum, n + integer(I4B) :: istat + real(DP) :: r + character(len=LINELENGTH) :: ermsg, fname +! ------------------------------------------------------------------------------ + ! + if (present(flag_string)) then + if (flag_string) then + ! Check to see if first token in cellid can be read as an integer. + lloclocal = 1 + call urword(cellid, lloclocal, istart, istop, 1, ndum, r, iout, inunit) + read(cellid(istart:istop), *, iostat=istat) n + if (istat /= 0) then + ! First token in cellid is not an integer; return flag to this effect. + nodeu = -2 + return + endif + endif + endif + ! + lloclocal = 1 + call urword(cellid, lloclocal, istart, istop, 2, nodeu, r, iout, inunit) + ! + if (nodeu == 0) then + if (present(allow_zero)) then + if (allow_zero) then + return + endif + endif + endif + ! + if(nodeu < 1 .or. nodeu > this%nodesuser) then + write(ermsg, *) ' Node number in list is outside of the grid', nodeu + call store_error(ermsg) + inquire(unit=inunit, name=fname) + call store_error('Error converting in file: ') + call store_error(trim(adjustl(fname))) + call store_error('Cell number cannot be determined in cellid: ') + call store_error(trim(adjustl(cellid))) + call store_error_unit(inunit) + call ustop() + end if + ! + ! -- return + return + end function nodeu_from_cellid + + logical function supports_layers(this) + implicit none + ! -- dummy + class(GwfDisuType) :: this + ! + supports_layers = .false. + return + end function supports_layers + + function get_ncpl(this) +! ****************************************************************************** +! get_ncpl -- Return number of cells per layer. This is nodes +! for a DISU grid, as there are no layers. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + integer(I4B) :: get_ncpl + ! -- dummy + class(GwfDisuType) :: this +! ------------------------------------------------------------------------------ + ! + get_ncpl = this%nodesuser + ! + ! -- Return + return + end function get_ncpl + + subroutine read_int_array(this, line, lloc, istart, istop, iout, in, & + iarray, aname) +! ****************************************************************************** +! read_int_array -- Read a GWF integer array +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: urword + use SimModule, only: store_error, ustop + use ConstantsModule, only: LINELENGTH + ! -- dummy + class(GwfDisuType), intent(inout) :: this + character(len=*), intent(inout) :: line + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: iarray + character(len=*), intent(in) :: aname + ! -- local + integer(I4B) :: nval + integer(I4B), dimension(:), pointer, contiguous :: itemp +! ------------------------------------------------------------------------------ + ! + ! -- Point the temporary pointer array, which is passed to the reading + ! subroutine. The temporary array will point to ibuff if it is a + ! reduced structured system, or to iarray if it is an unstructured + ! model. + if(this%nodes < this%nodesuser) then + nval = this%nodesuser + itemp => this%ibuff + else + nval = this%nodes + itemp => iarray + endif + ! + ! -- Read the array + ! -- Read unstructured input + call ReadArray(in, itemp, aname, this%ndim, nval, iout, 0) + ! + ! -- If reduced model, then need to copy from itemp(=>ibuff) to iarray + if(this%nodes < this%nodesuser) then + call this%fill_grid_array(itemp, iarray) + endif + ! + ! -- return + return + end subroutine read_int_array + + subroutine read_dbl_array(this, line, lloc, istart, istop, iout, in, & + darray, aname) +! ****************************************************************************** +! read_dbl_array -- Read a GWF double precision array +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: urword + use SimModule, only: ustop, store_error + use ConstantsModule, only: LINELENGTH + ! -- dummy + class(GwfDisuType), intent(inout) :: this + character(len=*), intent(inout) :: line + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout + real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray + character(len=*), intent(in) :: aname + ! -- local + integer(I4B) :: nval + real(DP), dimension(:), pointer, contiguous :: dtemp +! ------------------------------------------------------------------------------ + ! + ! -- Point the temporary pointer array, which is passed to the reading + ! subroutine. The temporary array will point to dbuff if it is a + ! reduced structured system, or to darray if it is an unstructured + ! model. + if(this%nodes < this%nodesuser) then + nval = this%nodesuser + dtemp => this%dbuff + else + nval = this%nodes + dtemp => darray + endif + ! + ! -- Read the array + call ReadArray(in, dtemp, aname, this%ndim, nval, iout, 0) + ! + ! -- If reduced model, then need to copy from dtemp(=>dbuff) to darray + if(this%nodes < this%nodesuser) then + call this%fill_grid_array(dtemp, darray) + endif + ! + ! -- return + return + end subroutine read_dbl_array + + subroutine record_array(this, darray, iout, iprint, idataun, aname, & + cdatafmp, nvaluesp, nwidthp, editdesc, dinact) +! ****************************************************************************** +! record_array -- Record a double precision array. The array will be +! printed to an external file and/or written to an unformatted external file +! depending on the argument specifications. +! ****************************************************************************** +! +! SPECIFICATIONS: +! darray is the double precision array to record +! iout is the unit number for ascii output +! iprint is a flag indicating whether or not to print the array +! idataun is the unit number to which the array will be written in binary +! form; if negative then do not write by layers, write entire array +! aname is the text descriptor of the array +! cdatafmp is the fortran format for writing the array +! nvaluesp is the number of values per line for printing +! nwidthp is the width of the number for printing +! editdesc is the format type (I, G, F, S, E) +! dinact is the double precision value to use for cells that are excluded +! from the model domain +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfDisuType), intent(inout) :: this + real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray + integer(I4B), intent(in) :: iout + integer(I4B), intent(in) :: iprint + integer(I4B), intent(in) :: idataun + character(len=*), intent(in) :: aname + character(len=*), intent(in) :: cdatafmp + integer(I4B), intent(in) :: nvaluesp + integer(I4B), intent(in) :: nwidthp + character(len=*), intent(in) :: editdesc + real(DP), intent(in) :: dinact + ! -- local + integer(I4B) :: k, ifirst + integer(I4B) :: nlay + integer(I4B) :: nrow + integer(I4B) :: ncol + integer(I4B) :: nval + integer(I4B) :: nodeu, noder + integer(I4B) :: istart, istop + real(DP), dimension(:), pointer, contiguous :: dtemp + ! -- formats + character(len=*),parameter :: fmthsv = & + "(1X,/1X,a,' WILL BE SAVED ON UNIT ',I4, & + &' AT END OF TIME STEP',I5,', STRESS PERIOD ',I4)" +! ------------------------------------------------------------------------------ + ! + ! -- set variables + nlay = 1 + nrow = 1 + ncol = this%mshape(1) + ! + ! -- If this is a reduced model, then copy the values from darray into + ! dtemp. + if(this%nodes < this%nodesuser) then + nval = this%nodes + dtemp => this%dbuff + do nodeu = 1, this%nodesuser + noder = this%get_nodenumber(nodeu, 0) + if(noder <= 0) then + dtemp(nodeu) = dinact + cycle + endif + dtemp(nodeu) = darray(noder) + enddo + else + nval = this%nodes + dtemp => darray + endif + ! + ! -- Print to iout if iprint /= 0 + if(iprint /= 0) then + istart = 1 + do k = 1, nlay + istop = istart + nrow * ncol - 1 + call ulaprufw(ncol, nrow, kstp, kper, k, iout, dtemp(istart:istop), & + aname, cdatafmp, nvaluesp, nwidthp, editdesc) + istart = istop + 1 + enddo + endif + ! + ! -- Save array to an external file. + if(idataun > 0) then + ! -- write to binary file by layer + ifirst = 1 + istart = 1 + do k=1, nlay + istop = istart + nrow * ncol - 1 + if(ifirst == 1) write(iout, fmthsv) & + trim(adjustl(aname)), idataun, & + kstp, kper + ifirst = 0 + call ulasav(dtemp(istart:istop), aname, kstp, kper, & + pertim, totim, ncol, nrow, k, idataun) + istart = istop + 1 + enddo + elseif(idataun < 0) then + ! + ! -- write entire array as one record + call ubdsv1(kstp, kper, aname, -idataun, dtemp, ncol, nrow, nlay, & + iout, delt, pertim, totim) + endif + ! + ! -- return + return + end subroutine record_array + + subroutine record_srcdst_list_header(this, text, textmodel, textpackage, & + dstmodel, dstpackage, naux, auxtxt, & + ibdchn, nlist, iout) +! ****************************************************************************** +! record_srcdst_list_header -- Record list header for imeth=6 +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfDisuType) :: this + character(len=16), intent(in) :: text + character(len=16), intent(in) :: textmodel + character(len=16), intent(in) :: textpackage + character(len=16), intent(in) :: dstmodel + character(len=16), intent(in) :: dstpackage + integer(I4B), intent(in) :: naux + character(len=16), dimension(:), intent(in) :: auxtxt + integer(I4B), intent(in) :: ibdchn + integer(I4B), intent(in) :: nlist + integer(I4B), intent(in) :: iout + ! -- local + integer(I4B) :: nlay, nrow, ncol +! ------------------------------------------------------------------------------ + ! + nlay = 1 + nrow = 1 + ncol = this%mshape(1) + ! + ! -- Use ubdsv06 to write list header + call ubdsv06(kstp, kper, text, textmodel, textpackage, dstmodel, dstpackage,& + ibdchn, naux, auxtxt, ncol, nrow, nlay, & + nlist, iout, delt, pertim, totim) + ! + ! -- return + return + end subroutine record_srcdst_list_header + +end module GwfDisuModule diff --git a/src/Model/GroundWaterFlow/gwf3disv8.f90 b/src/Model/GroundWaterFlow/gwf3disv8.f90 index 89643883908..bc46a41afea 100644 --- a/src/Model/GroundWaterFlow/gwf3disv8.f90 +++ b/src/Model/GroundWaterFlow/gwf3disv8.f90 @@ -1,2199 +1,2199 @@ -module GwfDisvModule - - use ArrayReadersModule, only: ReadArray - use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH - use BaseDisModule, only: DisBaseType - use InputOutputModule, only: get_node, URWORD, ulasav, ulaprufw, ubdsv1, & - ubdsv06 - use SimModule, only: count_errors, store_error, store_error_unit, ustop - use DisvGeom, only: DisvGeomType - use BlockParserModule, only: BlockParserType - use MemoryManagerModule, only: mem_allocate - use TdisModule, only: kstp, kper, pertim, totim, delt - - implicit none - private - public disv_cr, disv_init_mem, GwfDisvType - - type, extends(DisBaseType) :: GwfDisvType - integer(I4B), pointer :: nlay => null() ! number of layers - integer(I4B), pointer :: ncpl => null() ! number of cells per layer - integer(I4B), pointer :: nvert => null() ! number of x,y vertices - real(DP), dimension(:,:), pointer, contiguous :: vertices => null() ! cell vertices stored as 2d array of x and y - real(DP), dimension(:,:), pointer, contiguous :: cellxy => null() ! cell center stored as 2d array of x and y - integer(I4B), dimension(:), pointer, contiguous :: iavert => null() ! cell vertex pointer ia array - integer(I4B), dimension(:), pointer, contiguous :: javert => null() ! cell vertex pointer ja array - real(DP), dimension(:, :), pointer, contiguous :: top2d => null() ! top elevations for each cell at top of model (ncpl, 1) - real(DP), dimension(:, :, :), pointer, contiguous :: bot3d => null() ! bottom elevations for each cell (ncpl, 1, nlay) - integer(I4B), dimension(:, :, :), pointer, contiguous :: idomain => null() ! idomain (ncpl, 1, nlay) - type(DisvGeomType) :: cell1 ! cell object used to calculate geometric properties - type(DisvGeomType) :: cell2 ! cell object used to calculate geometric properties - contains - procedure :: dis_df => disv_df - procedure :: dis_da => disv_da - procedure :: get_cellxy => get_cellxy_disv - procedure :: get_dis_type => get_dis_type - procedure, public :: record_array - procedure, public :: read_layer_array - procedure, public :: record_srcdst_list_header - procedure, public :: nlarray_to_nodelist - ! -- helper functions - procedure :: get_nodenumber_idx1 - procedure :: get_nodenumber_idx2 - procedure :: nodeu_to_string - procedure :: nodeu_to_array - procedure :: nodeu_from_string - procedure :: nodeu_from_cellid - procedure :: connection_normal - procedure :: connection_vector - procedure :: supports_layers - procedure :: get_ncpl - ! -- private - procedure :: read_options - procedure :: read_dimensions - procedure :: read_vertices - procedure :: read_cell2d - procedure :: read_mf6_griddata - procedure :: grid_finalize - procedure :: connect - procedure :: write_grb - procedure :: allocate_scalars - procedure :: allocate_arrays - procedure :: get_cell2d_area - ! - procedure :: read_int_array - procedure :: read_dbl_array - ! - end type GwfDisvType - - contains - - subroutine disv_cr(dis, name_model, inunit, iout) -! ****************************************************************************** -! disv_cr -- Create a new discretization by vertices object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(DisBaseType), pointer :: dis - character(len=*), intent(in) :: name_model - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - type(GwfDisvType), pointer :: disnew -! ------------------------------------------------------------------------------ - allocate(disnew) - dis => disnew - call disnew%allocate_scalars(name_model) - dis%inunit = inunit - dis%iout = iout - ! - ! -- Initialize block parser - call dis%parser%Initialize(dis%inunit, dis%iout) - ! - ! -- Return - return - end subroutine disv_cr - - subroutine disv_init_mem(dis, name_model, iout, nlay, ncpl, & - top2d, bot3d, vertices, cellxy, idomain) -! ****************************************************************************** -! dis_init_mem -- Create a new discretization by vertices object from memory -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(DisBaseType), pointer :: dis - character(len=*), intent(in) :: name_model - integer(I4B), intent(in) :: iout - integer(I4B), intent(in) :: nlay - integer(I4B), intent(in) :: ncpl - real(DP), dimension(:, :), pointer, contiguous, intent(in) :: top2d - real(DP), dimension(:, :, :), pointer, contiguous, intent(in) :: bot3d - integer(I4B), dimension(:, :), pointer, contiguous, intent(in) :: vertices - integer(I4B), dimension(:, :), pointer, contiguous, intent(in) :: cellxy - integer(I4B), dimension(:, :, :), pointer, contiguous, intent(in), & - optional :: idomain - ! -- local - type(GwfDisvType), pointer :: disext - integer(I4B) :: n - integer(I4B) :: j - integer(I4B) :: k - integer(I4B) :: ival - ! -- local -! ------------------------------------------------------------------------------ - allocate(disext) - dis => disext - call disext%allocate_scalars(name_model) - dis%inunit = 0 - dis%iout = iout - ! - ! -- set dimensions - disext%ncpl = ncpl - disext%nlay = nlay - ! - ! -- Calculate nodesuser - disext%nodesuser = disext%nlay * disext%ncpl - ! - ! -- Allocate non-reduced vectors for disv - call mem_allocate(disext%idomain, disext%ncpl, 1, disext%nlay, 'IDOMAIN', & - disext%origin) - call mem_allocate(disext%top2d, disext%ncpl, 1, 'TOP2D', disext%origin) - call mem_allocate(disext%bot3d, disext%ncpl, 1, disext%nlay, 'BOT3D', & - disext%origin) - ! - ! -- Allocate vertices array - call mem_allocate(disext%vertices, 2, disext%nvert, 'VERTICES', disext%origin) - call mem_allocate(disext%cellxy, 2, disext%ncpl, 'CELLXY', disext%origin) - ! - ! -- fill data - do k = 1, disext%nlay - do j = 1, disext%ncpl - if (k == 1) then - disext%top2d(j, 1) = top2d(j, 1) - end if - disext%bot3d(j, 1, k) = bot3d(j, 1, k) - if (present(idomain)) then - ival = idomain(j, 1, k) - else - ival = 1 - end if - disext%idomain(j, 1, k) = ival - end do - end do - do n = 1, disext%nvert - do j = 1, 2 - disext%vertices(j, n) = vertices(j, n) - end do - end do - do n = 1, disext%ncpl - do j = 1, 2 - disext%cellxy(j, n) = cellxy(j, n) - end do - end do - ! - ! -- Return - return - end subroutine disv_init_mem - - subroutine disv_df(this) -! ****************************************************************************** -! read_from_file -- Allocate and read discretization information -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfDisvType) :: 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 - ! - ! -- Final grid initialization - call this%grid_finalize() - ! - ! -- Return - return - end subroutine disv_df - - subroutine disv_da(this) -! ****************************************************************************** -! disv_da -- Deallocate discretization data -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(GwfDisvType) :: this - ! -- locals -! ------------------------------------------------------------------------------ - ! - ! -- DisBaseType deallocate - call this%DisBaseType%dis_da() - ! - ! -- Deallocate scalars - call mem_deallocate(this%nlay) - call mem_deallocate(this%ncpl) - call mem_deallocate(this%nvert) - ! - ! -- Deallocate Arrays - call mem_deallocate(this%nodereduced) - call mem_deallocate(this%nodeuser) - call mem_deallocate(this%vertices) - call mem_deallocate(this%cellxy) - call mem_deallocate(this%iavert) - call mem_deallocate(this%javert) - call mem_deallocate(this%top2d) - call mem_deallocate(this%bot3d) - call mem_deallocate(this%idomain) - ! - ! -- Return - return - end subroutine disv_da - - subroutine read_options(this) -! ****************************************************************************** -! read_options -- Read options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - ! -- dummy - class(GwfDisvType) :: 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' - endif - 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() - call ustop() - end select - end do - else - write(this%iout,'(1x,a)')'NO DISV OPTION BLOCK DETECTED.' - end if - if(this%lenuni==0) write(this%iout,'(3x,a)') 'MODEL LENGTH UNIT IS UNDEFINED' - if(isfound) then - write(this%iout,'(1x,a)')'END OF DISCRETIZATION OPTIONS' - endif - ! - ! -- Return - return - end subroutine read_options - - subroutine read_dimensions(this) -! ****************************************************************************** -! read_dimensions -- Read dimensions -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - ! -- dummy - class(GwfDisvType) :: this - ! -- locals - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock - integer(I4B) :: j - integer(I4B) :: k -! ------------------------------------------------------------------------------ - ! - ! -- 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)')'****ERROR. UNKNOWN DIS DIMENSION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - end do - else - call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- verify dimensions were set - if(this%nlay < 1) then - call store_error( & - 'ERROR. NLAY WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') - call this%parser%StoreErrorUnit() - call ustop() - endif - if(this%ncpl < 1) then - call store_error( & - 'ERROR. NCPL WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') - call this%parser%StoreErrorUnit() - call ustop() - endif - if(this%nvert < 1) then - call store_error( & - 'ERROR. NVERT WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') - call this%parser%StoreErrorUnit() - call ustop() - endif - write(this%iout,'(1x,a)')'END OF DISCRETIZATION DIMENSIONS' - ! - ! -- Calculate nodesuser - this%nodesuser = this%nlay * this%ncpl - ! - ! -- Allocate non-reduced vectors for disv - call mem_allocate(this%idomain, this%ncpl, 1, this%nlay, 'IDOMAIN', & - this%origin) - call mem_allocate(this%top2d, this%ncpl, 1, 'TOP2D', this%origin) - call mem_allocate(this%bot3d, this%ncpl, 1, this%nlay, 'BOT3D', this%origin) - ! - ! -- Allocate vertices array - call mem_allocate(this%vertices, 2, this%nvert, 'VERTICES', this%origin) - call mem_allocate(this%cellxy, 2, this%ncpl, 'CELLXY', this%origin) - ! - ! -- initialize all cells to be active (idomain = 1) - do k = 1, this%nlay - do j = 1, this%ncpl - this%idomain(j, 1, k) = 1 - end do - end do - ! - ! -- Return - return - end subroutine read_dimensions - - subroutine read_mf6_griddata(this) -! ****************************************************************************** -! read_mf6_griddata -- Read grid data from a MODFLOW 6 ascii file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: ustop, count_errors, store_error - use ConstantsModule, only: LINELENGTH, DZERO - ! -- 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 - ! -- 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)')'ERROR. UNKNOWN GRIDDATA TAG: ', & - trim(keyword) - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - 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() - call ustop() - end if - ! - ! -- 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) - endif - enddo - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Return - return - end subroutine read_mf6_griddata - - subroutine grid_finalize(this) -! ****************************************************************************** -! grid_finalize -- Finalize grid -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: ustop, count_errors, store_error - use ConstantsModule, only: LINELENGTH, DZERO - ! -- dummy - class(GwfDisvType) :: this - ! -- locals - integer(I4B) :: node, noder, j, k - real(DP) :: top - real(DP) :: dz - character(len=300) :: ermsg - ! -- 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: ',I7," // & - "/1X, 'NUMBER OF NODES IN SOLUTION: ', I7, //)" - ! -- data -! ------------------------------------------------------------------------------ - ! - ! -- count active cells - this%nodes = 0 - do k = 1, this%nlay - do j = 1, this%ncpl - if(this%idomain(j, 1, k) > 0) this%nodes = this%nodes + 1 - enddo - enddo - ! - ! -- Check to make sure nodes is a valid number - if (this%nodes == 0) then - call store_error('ERROR. MODEL DOES NOT HAVE ANY ACTIVE NODES.') - call store_error('MAKE SURE IDOMAIN ARRAY HAS SOME VALUES GREATER & - &THAN ZERO.') - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- Check cell thicknesses - do k = 1, this%nlay - do j = 1, this%ncpl - if (this%idomain(j, 1, k) == 0) cycle - if (this%idomain(j, 1, k) > 0) then - if (k > 1) then - top = this%bot3d(j, 1, k - 1) - else - top = this%top2d(j, 1) - end if - dz = top - this%bot3d(j, 1, k) - if (dz <= DZERO) then - write(ermsg, fmt=fmtdz) k, j, top, this%bot3d(j, 1, k) - call store_error(ermsg) - endif - endif - enddo - enddo - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Write message if reduced grid - if(this%nodes < this%nodesuser) then - write(this%iout, fmtnr) this%nodesuser, this%nodes - endif - ! - ! -- Array size is now known, so allocate - call this%allocate_arrays() - ! - ! -- Fill the nodereduced array with the reduced nodenumber, or - ! a negative number to indicate it is a pass-through cell, or - ! a zero to indicate that the cell is excluded from the - ! solution. - if(this%nodes < this%nodesuser) then - node = 1 - noder = 1 - do k = 1, this%nlay - do j = 1, this%ncpl - if(this%idomain(j, 1, k) > 0) then - this%nodereduced(node) = noder - noder = noder + 1 - elseif(this%idomain(j, 1, k) < 0) then - this%nodereduced(node) = -1 - else - this%nodereduced(node) = 0 - endif - node = node + 1 - enddo - enddo - endif - ! - ! -- allocate and fill nodeuser if a reduced grid - if(this%nodes < this%nodesuser) then - node = 1 - noder = 1 - do k = 1, this%nlay - do j = 1, this%ncpl - if(this%idomain(j, 1, k) > 0) then - this%nodeuser(noder) = node - noder = noder + 1 - endif - node = node + 1 - enddo - enddo - endif - ! - ! -- Move top2d and bot3d into top and bot, and calculate area - node = 0 - do k = 1, this%nlay - do j = 1, this%ncpl - node = node + 1 - noder = node - if(this%nodes < this%nodesuser) noder = this%nodereduced(node) - if(noder <= 0) cycle - if (k > 1) then - top = this%bot3d(j, 1, k - 1) - else - top = this%top2d(j, 1) - end if - this%top(noder) = top - this%bot(noder) = this%bot3d(j, 1, k) - enddo - enddo - ! - ! -- Build connections - call this%connect() - ! - ! -- Create two cell objects that can be used for geometric processing - call this%cell1%init(this%nlay, this%ncpl, this%nodes, this%top, this%bot, & - this%iavert, this%javert, this%vertices, this%cellxy, & - this%nodereduced, this%nodeuser) - call this%cell2%init(this%nlay, this%ncpl, this%nodes, this%top, this%bot, & - this%iavert, this%javert, this%vertices, this%cellxy, & - this%nodereduced, this%nodeuser) - ! - ! -- Return - return - end subroutine grid_finalize - - subroutine read_vertices(this) -! ****************************************************************************** -! read_vertices -- Read data -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: ustop, count_errors, store_error - use ConstantsModule, only: LINELENGTH, DZERO - ! -- dummy - class(GwfDisvType) :: this - integer(I4B) :: i - integer(I4B) :: ierr, ival - logical :: isfound, endOfBlock - real(DP) :: xmin, xmax, ymin, ymax - character(len=300) :: ermsg - ! -- 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 - ! - ! --Read DISDATA block - call this%parser%GetBlock('VERTICES', isfound, ierr, & - supportOpenClose=.true.) - if(isfound) then - write(this%iout,'(/,1x,a)') 'PROCESSING VERTICES' - 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() - call ustop() - endif - ! - ! -- 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)) - endif - enddo - ! - ! -- Terminate the block - call this%parser%terminateblock() - else - call store_error('ERROR. REQUIRED VERTICES BLOCK NOT FOUND.') - call this%parser%StoreErrorUnit() - call ustop() - 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' - ! - ! -- Return - return - end subroutine read_vertices - - subroutine read_cell2d(this) -! ****************************************************************************** -! read_cell2d -- Read information describing the two dimensional (x, y) -! configuration of each cell. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: ustop, count_errors, store_error - use ConstantsModule, only: LINELENGTH, DZERO - use InputOutputModule, only: urword - use SparseModule, only: sparsematrix - use MemoryManagerModule, only: mem_allocate - ! -- 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 - ! -- 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 - ! - ! -- 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 - enddo - call vertspm%init(this%ncpl, this%nvert, maxnnz) - ! - ! --Read CELL2D block - call this%parser%GetBlock('CELL2D', isfound, ierr, supportOpenClose=.true.) - if(isfound) then - write(this%iout,'(/,1x,a)') 'PROCESSING CELL2D' - 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) - call ustop() - endif - ! - ! -- 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 - endif - ! - ! -- 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) - endif - endif - enddo - ! - ! -- 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)) - endif - enddo - ! - ! -- Terminate the block - call this%parser%terminateblock() - else - call store_error('ERROR. REQUIRED CELL2D BLOCK NOT FOUND.') - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- Convert vertspm into ia/ja form - call mem_allocate(this%iavert, this%ncpl+1, 'IAVERT', this%origin) - call mem_allocate(this%javert, vertspm%nnz, 'JAVERT', this%origin) - 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' - ! - ! -- Return - return - end subroutine read_cell2d - - subroutine connect(this) -! ****************************************************************************** -! connect -- Build grid connections -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(GwfDisvType) :: this - ! -- local - integer(I4B) :: j, k - integer(I4B) :: noder, nrsize - real(DP) :: area - character(len=LINELENGTH) :: errmsg -! ------------------------------------------------------------------------------ - ! - ! -- Assign the cell area - do j = 1, this%ncpl - area = this%get_cell2d_area(j) - do k = 1, this%nlay - noder = this%get_nodenumber(k, j, 0) - if(noder > 0) this%area(noder) = area - enddo - if (area < 0) then - write(errmsg, '(a,i0)') 'ERROR. CELL2D AREA LESS THAN ZERO FOR CELL ', j - call store_error(errmsg) - endif - enddo - ! - ! -- check for errors - if(count_errors() > 0) then - write(errmsg, '(a)') 'CELL VERTICES MUST BE LISTED IN CLOCKWISE ORDER. ' - call store_error(errmsg) - call store_error_unit(this%inunit) - call ustop() - endif - ! - ! -- create and fill the connections object - nrsize = 0 - if(this%nodes < this%nodesuser) nrsize = this%nodes - allocate(this%con) - call this%con%disvconnections(this%name_model, this%nodes, & - this%ncpl, this%nlay, nrsize, & - this%nvert, this%vertices, this%iavert, & - this%javert, this%cellxy, & - this%top, this%bot, & - this%nodereduced, this%nodeuser) - this%nja = this%con%nja - this%njas = this%con%njas - ! - ! - ! -- return - return - end subroutine connect - - subroutine write_grb(this, icelltype) -! ****************************************************************************** -! write_grb -- Write the binary grid file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: getunit, openfile - use OpenSpecModule, only: access, form - use ConstantsModule, only: DZERO - ! -- dummy - class(GwfDisvType) :: this - integer(I4B), dimension(:), intent(in) :: icelltype - ! -- local - integer(I4B) :: iunit, i, ntxt - integer(I4B), parameter :: lentxt = 100 - character(len=50) :: txthdr - character(len=lentxt) :: txt - character(len=LINELENGTH) :: fname - character(len=*),parameter :: fmtgrdsave = & - "(4X,'BINARY GRID INFORMATION WILL BE WRITTEN TO:', & - &/,6X,'UNIT NUMBER: ', I0,/,6X, 'FILE NAME: ', A)" -! ------------------------------------------------------------------------------ - ! - ! -- Initialize - ntxt = 20 - ! - ! -- Open the file - inquire(unit=this%inunit, name=fname) - fname = trim(fname) // '.grb' - iunit = getunit() - write(this%iout, fmtgrdsave) iunit, trim(adjustl(fname)) - call openfile(iunit, this%iout, trim(adjustl(fname)), 'DATA(BINARY)', & - form, access, 'REPLACE') - ! - ! -- write header information - write(txthdr, '(a)') 'GRID DISV' - txthdr(50:50) = new_line('a') - write(iunit) txthdr - write(txthdr, '(a)') 'VERSION 1' - txthdr(50:50) = new_line('a') - write(iunit) txthdr - write(txthdr, '(a, i0)') 'NTXT ', ntxt - txthdr(50:50) = new_line('a') - write(iunit) txthdr - write(txthdr, '(a, i0)') 'LENTXT ', lentxt - txthdr(50:50) = new_line('a') - write(iunit) txthdr - ! - ! -- write variable definitions - write(txt, '(3a, i0)') 'NCELLS ', 'INTEGER ', 'NDIM 0 # ', this%nodesuser - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'NLAY ', 'INTEGER ', 'NDIM 0 # ', this%nlay - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'NCPL ', 'INTEGER ', 'NDIM 0 # ', this%ncpl - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'NVERT ', 'INTEGER ', 'NDIM 0 # ', this%nvert - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'NJAVERT ', 'INTEGER ', 'NDIM 0 # ', size(this%javert) - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'NJA ', 'INTEGER ', 'NDIM 0 # ', this%con%nja - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, 1pg25.15e3)') 'XORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%xorigin - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, 1pg25.15e3)') 'YORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%yorigin - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, 1pg25.15e3)') 'ANGROT ', 'DOUBLE ', 'NDIM 0 # ', this%angrot - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'TOP ', 'DOUBLE ', 'NDIM 1 ', this%ncpl - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'BOTM ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'VERTICES ', 'DOUBLE ', 'NDIM 2 2 ', this%nvert - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'CELLX ', 'DOUBLE ', 'NDIM 1 ', this%ncpl - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'CELLY ', 'DOUBLE ', 'NDIM 1 ', this%ncpl - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'IAVERT ', 'INTEGER ', 'NDIM 1 ', this%ncpl + 1 - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'JAVERT ', 'INTEGER ', 'NDIM 1 ', size(this%javert) - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'IA ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + 1 - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'JA ', 'INTEGER ', 'NDIM 1 ', size(this%con%jausr) - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'IDOMAIN ', 'INTEGER ', 'NDIM 1 ', this%nodesuser - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'ICELLTYPE ', 'INTEGER ', 'NDIM 1 ', this%nodesuser - txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - ! - ! -- write data - write(iunit) this%nodesuser ! ncells - write(iunit) this%nlay ! nlay - write(iunit) this%ncpl ! ncpl - write(iunit) this%nvert ! nvert - write(iunit) size(this%javert) ! njavert - write(iunit) this%nja ! nja - write(iunit) this%xorigin ! xorigin - write(iunit) this%yorigin ! yorigin - write(iunit) this%angrot ! angrot - write(iunit) this%top2d ! top - write(iunit) this%bot3d ! botm - write(iunit) this%vertices ! vertices - write(iunit) (this%cellxy(1, i), i = 1, this%ncpl) ! cellx - write(iunit) (this%cellxy(2, i), i = 1, this%ncpl) ! celly - write(iunit) this%iavert ! iavert - write(iunit) this%javert ! javert - write(iunit) this%con%iausr ! iausr - write(iunit) this%con%jausr ! jausr - write(iunit) this%idomain ! idomain - write(iunit) icelltype ! icelltype - ! - ! -- Close the file - close(iunit) - ! - ! -- return - return - end subroutine write_grb - - subroutine nodeu_to_string(this, nodeu, str) -! ****************************************************************************** -! nodeu_to_string -- Convert user node number to a string in the form of -! (nodenumber) or (k,j) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: get_ijk - ! -- dummy - class(GwfDisvType) :: this - integer(I4B), intent(in) :: nodeu - character(len=*), intent(inout) :: str - ! -- local - integer(I4B) :: i, j, k - character(len=10) :: kstr, jstr -! ------------------------------------------------------------------------------ - ! - call get_ijk(nodeu, 1, this%ncpl, this%nlay, i, j, k) - write(kstr, '(i10)') k - write(jstr, '(i10)') j - str = '(' // trim(adjustl(kstr)) // ',' // & - trim(adjustl(jstr)) // ')' - ! - ! -- return - return - end subroutine nodeu_to_string - - subroutine nodeu_to_array(this, nodeu, arr) -! ****************************************************************************** -! nodeu_to_array -- Convert user node number to cellid and fill array with -! (nodenumber) or (k, j) or (k,i,j) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use InputOutputModule, only: get_ijk - implicit none - class(GwfDisvType) :: this - integer(I4B), intent(in) :: nodeu - integer(I4B), dimension(:), intent(inout) :: arr - ! -- local - character(len=LINELENGTH) :: errmsg - integer(I4B) :: isize - integer(I4B) :: i, j, k -! ------------------------------------------------------------------------------ - ! - ! -- check the size of arr - isize = size(arr) - if (isize /= this%ndim) then - write(errmsg,'(a,i0,a,i0,a)') & - 'Program error: nodeu_to_array size of array (', isize, & - ') is not equal to the discretization dimension (', this%ndim, ')' - call store_error(errmsg) - call ustop() - end if - ! - ! -- get k, i, j - call get_ijk(nodeu, 1, this%ncpl, this%nlay, i, j, k) - ! - ! -- fill array - arr(1) = k - arr(2) = j - ! - ! -- return - return - end subroutine nodeu_to_array - - function get_nodenumber_idx1(this, nodeu, icheck) result(nodenumber) -! ****************************************************************************** -! get_nodenumber -- Return a nodenumber from the user specified node number -! with an option to perform a check. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - ! -- return - integer(I4B) :: nodenumber - ! -- dummy - class(GwfDisvType), intent(in) :: this - integer(I4B), intent(in) :: nodeu - integer(I4B), intent(in) :: icheck - ! -- local - character(len=LINELENGTH) :: errmsg -! ------------------------------------------------------------------------------ - ! - ! -- check the node number if requested - if(icheck /= 0) then - ! - ! -- If within valid range, convert to reduced nodenumber - if(nodeu < 1 .or. nodeu > this%nodesuser) then - write(errmsg, '(a,i10)') & - 'Nodenumber less than 1 or greater than nodes:', nodeu - call store_error(errmsg) - nodenumber = 0 - else - nodenumber = nodeu - if(this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) - endif - else - nodenumber = nodeu - if(this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) - endif - ! - ! -- return - return - end function get_nodenumber_idx1 - - function get_nodenumber_idx2(this, k, j, icheck) & - result(nodenumber) -! ****************************************************************************** -! get_nodenumber_idx2 -- Return a nodenumber from the user specified layer and -! column with an option to perform a check. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use InputOutputModule, only: get_node - implicit none - ! -- return - integer(I4B) :: nodenumber - ! -- dummy - class(GwfDisvType), intent(in) :: this - integer(I4B), intent(in) :: k, j - integer(I4B), intent(in) :: icheck - ! -- local - character(len=LINELENGTH) :: errmsg - integer(I4B) :: nodeu - ! formats - character(len=*), parameter :: fmterr = & - "('Error in disv grid cell indices: layer = ',i0,', node = ',i0)" -! ------------------------------------------------------------------------------ - ! - nodeu = get_node(k, 1, j, this%nlay, 1, this%ncpl) - if (nodeu < 1) then - write(errmsg, fmterr) k, j - call store_error(errmsg) - call ustop() - endif - nodenumber = nodeu - if(this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) - ! - ! -- check the node number if requested - if(icheck /= 0) then - ! - if(k < 1 .or. k > this%nlay) & - call store_error('Layer less than one or greater than nlay') - if(j < 1 .or. j > this%ncpl) & - call store_error('Node number less than one or greater than ncpl') - ! - ! -- Error if outside of range - if(nodeu < 1 .or. nodeu > this%nodesuser) then - write(errmsg, '(a,i10)') & - 'Nodenumber less than 1 or greater than nodes:', nodeu - call store_error(errmsg) - endif - endif - ! - ! -- return - return - end function get_nodenumber_idx2 - - subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & - ipos) -! ****************************************************************************** -! connection_normal -- calculate the normal vector components for reduced -! nodenumber cell (noden) and its shared face with cell nodem. ihc is the -! horizontal connection flag. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DONE, DZERO - use SimModule, only: ustop, store_error - ! -- dummy - class(GwfDisvType) :: this - integer(I4B), intent(in) :: noden - integer(I4B), intent(in) :: nodem - integer(I4B), intent(in) :: ihc - real(DP), intent(inout) :: xcomp - real(DP), intent(inout) :: ycomp - real(DP), intent(inout) :: zcomp - integer(I4B), intent(in) :: ipos - ! -- local - !integer(I4B) :: ipos - !integer(I4B) :: ncell3d, mcell3d - real(DP) :: angle, dmult -! ------------------------------------------------------------------------------ - ! - ! -- Set vector components based on ihc - if(ihc == 0) then - xcomp = DZERO - ycomp = DZERO - if(nodem < noden) then - ! - ! -- nodem must be above noden, so upward connection - zcomp = DONE - else - ! - ! -- nodem must be below noden, so downward connection - zcomp = -DONE - endif - else - ! -- find from anglex, since anglex is symmetric, need to flip vector - ! for lower triangle (nodem < noden) - !ipos = this%con%getjaindex(noden, nodem) - angle = this%con%anglex(this%con%jas(ipos)) - dmult = DONE - if (nodem < noden) dmult = -DONE - xcomp = cos(angle) * dmult - ycomp = sin(angle) * dmult - zcomp = DZERO - endif - ! - ! -- return - return - end subroutine connection_normal - - subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & - xcomp, ycomp, zcomp, conlen) -! ****************************************************************************** -! connection_vector -- calculate the unit vector components from reduced -! nodenumber cell (noden) to its neighbor cell (nodem). The saturation for -! for these cells are also required so that the vertical position of the cell -! cell centers can be calculated. ihc is the horizontal flag. Also return -! the straight-line connection length. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DZERO, DONE, DHALF - use SimModule, only: ustop, store_error - use InputOutputModule, only: get_jk - use DisvGeom, only: line_unit_vector - ! -- dummy - class(GwfDisvType) :: this - integer(I4B), intent(in) :: noden - integer(I4B), intent(in) :: nodem - logical, intent(in) :: nozee - real(DP), intent(in) :: satn - real(DP), intent(in) :: satm - integer(I4B), intent(in) :: ihc - real(DP), intent(inout) :: xcomp - real(DP), intent(inout) :: ycomp - real(DP), intent(inout) :: zcomp - real(DP), intent(inout) :: conlen - ! -- local - integer(I4B) :: nodeu, ncell2d, mcell2d, k - real(DP) :: xn, xm, yn, ym, zn, zm -! ------------------------------------------------------------------------------ - ! - ! -- Set vector components based on ihc - if(ihc == 0) then - ! - ! -- vertical connection; set zcomp positive upward - xcomp = DZERO - ycomp = DZERO - if(nodem < noden) then - zcomp = DONE - else - zcomp = -DONE - endif - zn = this%bot(noden) + DHALF * (this%top(noden) - this%bot(noden)) - zm = this%bot(nodem) + DHALF * (this%top(nodem) - this%bot(nodem)) - conlen = abs(zm - zn) - else - ! - ! -- horizontal connection, with possible z component due to cell offsets - ! and/or water table conditions - if (nozee) then - zn = DZERO - zm = DZERO - else - zn = this%bot(noden) + DHALF * satn * (this%top(noden) - this%bot(noden)) - zm = this%bot(nodem) + DHALF * satm * (this%top(nodem) - this%bot(nodem)) - endif - nodeu = this%get_nodeuser(noden) - call get_jk(nodeu, this%ncpl, this%nlay, ncell2d, k) - nodeu = this%get_nodeuser(nodem) - call get_jk(nodeu, this%ncpl, this%nlay, mcell2d, k) - xn = this%cellxy(1, ncell2d) - yn = this%cellxy(2, ncell2d) - xm = this%cellxy(1, mcell2d) - ym = this%cellxy(2, mcell2d) - call line_unit_vector(xn, yn, zn, xm, ym, zm, xcomp, ycomp, zcomp, & - conlen) - endif - ! - ! -- return - return - end subroutine connection_vector - - ! return x,y coordinate for a node - subroutine get_cellxy_disv(this, node, xcell, ycell) - use InputOutputModule, only: get_jk - class(GwfDisvType), intent(in) :: this - integer(I4B), intent(in) :: node ! the reduced node number - real(DP), intent(out) :: xcell, ycell ! the x,y for the cell - ! local - integer(I4B) :: nodeuser, ncell2d, k - - nodeuser = this%get_nodeuser(node) - call get_jk(nodeuser, this%ncpl, this%nlay, ncell2d, k) - - xcell = this%cellxy(1, ncell2d) - ycell = this%cellxy(2, ncell2d) - - end subroutine get_cellxy_disv - - ! return discretization type - subroutine get_dis_type(this, dis_type) - class(GwfDisvType), intent(in) :: this - character(len=*), intent(out) :: dis_type - - dis_type = "DISV" - - end subroutine get_dis_type - - subroutine allocate_scalars(this, name_model) -! ****************************************************************************** -! allocate_scalars -- Allocate and initialize scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(GwfDisvType) :: this - character(len=*), intent(in) :: name_model -! ------------------------------------------------------------------------------ - ! - ! -- Allocate parent scalars - call this%DisBaseType%allocate_scalars(name_model) - ! - ! -- Allocate - call mem_allocate(this%nlay, 'NLAY', this%origin) - call mem_allocate(this%ncpl, 'NCPL', this%origin) - call mem_allocate(this%nvert, 'NVERT', this%origin) - ! - ! -- Initialize - this%nlay = 0 - this%ncpl = 0 - this%nvert = 0 - this%ndim = 2 - ! - ! -- Return - return - end subroutine allocate_scalars - - subroutine allocate_arrays(this) -! ****************************************************************************** -! allocate_arrays -- Allocate arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(GwfDisvType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Allocate arrays in DisBaseType (mshape, top, bot, area) - call this%DisBaseType%allocate_arrays() - ! - ! -- Allocate arrays for GwfDisvType - if(this%nodes < this%nodesuser) then - call mem_allocate(this%nodeuser, this%nodes, 'NODEUSER', this%origin) - call mem_allocate(this%nodereduced, this%nodesuser, 'NODEREDUCED', & - this%origin) - else - call mem_allocate(this%nodeuser, 1, 'NODEUSER', this%origin) - call mem_allocate(this%nodereduced, 1, 'NODEREDUCED', this%origin) - endif - !! - !! -- Allocate vertices array - !call mem_allocate(this%vertices, 2, this%nvert, 'VERTICES', this%origin) - !call mem_allocate(this%cellxy, 2, this%ncpl, 'CELLXY', this%origin) - ! - ! -- Initialize - this%mshape(1) = this%nlay - this%mshape(2) = this%ncpl - ! - ! -- Return - return - end subroutine allocate_arrays - - function get_cell2d_area(this, icell2d) result(area) -! ****************************************************************************** -! get_cell2d_area -- Calculate and return the signed area of the cell. A -! negative area means the points are in counter clockwise orientation. -! a = 1/2 *[(x1*y2 + x2*y3 + x3*y4 + ... + xn*y1) - -! (x2*y1 + x3*y2 + x4*y3 + ... + x1*yn)] -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- module - use ConstantsModule, only: DZERO, DHALF, DONE - ! -- dummy - class(GwfDisvType) :: this - integer(I4B), intent(in) :: icell2d - ! -- return - real(DP) :: area - ! -- local - integer(I4B) :: ivert - integer(I4B) :: nvert - integer(I4B) :: icount - real(DP) :: x - real(DP) :: y -! ------------------------------------------------------------------------------ - ! - area = DZERO - nvert = this%iavert(icell2d + 1) - this%iavert(icell2d) - icount = 1 - do ivert = this%iavert(icell2d), this%iavert(icell2d + 1) - 1 - x = this%vertices(1, this%javert(ivert)) - if(icount < nvert) then - y = this%vertices(2, this%javert(ivert + 1)) - else - y = this%vertices(2, this%javert(this%iavert(icell2d))) - endif - area = area + x * y - icount = icount + 1 - enddo - ! - icount = 1 - do ivert = this%iavert(icell2d), this%iavert(icell2d + 1) - 1 - y = this%vertices(2, this%javert(ivert)) - if(icount < nvert) then - x = this%vertices(1, this%javert(ivert + 1)) - else - x = this%vertices(1, this%javert(this%iavert(icell2d))) - endif - area = area - x * y - icount = icount + 1 - enddo - ! - area = -DONE * area * DHALF - ! - ! -- return - return - end function get_cell2d_area - - function nodeu_from_string(this, lloc, istart, istop, in, iout, line, & - flag_string, allow_zero) result(nodeu) -! ****************************************************************************** -! nodeu_from_string -- Receive a string and convert the string to a user -! nodenumber. The model discretization is DISV; read layer and cell number. -! If flag_string argument is present and true, the first token in string -! is allowed to be a string (e.g. boundary name). In this case, if a string -! is encountered, return value as -2. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfDisvType) :: this - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout - character(len=*), intent(inout) :: line - logical, optional, intent(in) :: flag_string - logical, optional, intent(in) :: allow_zero - integer(I4B) :: nodeu - ! -- local - integer(I4B) :: j, k, nlay, nrow, ncpl - integer(I4B) :: lloclocal, ndum, istat, n - real(DP) :: r - character(len=LINELENGTH) :: ermsg, fname -! ------------------------------------------------------------------------------ - ! - if (present(flag_string)) then - if (flag_string) then - ! Check to see if first token in line can be read as an integer. - lloclocal = lloc - call urword(line, lloclocal, istart, istop, 1, ndum, r, iout, in) - read(line(istart:istop),*,iostat=istat)n - if (istat /= 0) then - ! First token in line is not an integer; return flag to this effect. - nodeu = -2 - return - endif - endif - endif - ! - nlay = this%mshape(1) - nrow = 1 - ncpl = this%mshape(2) - ! - call urword(line, lloc, istart, istop, 2, k, r, iout, in) - call urword(line, lloc, istart, istop, 2, j, r, iout, in) - ! - if (k == 0 .and. j == 0) then - if (present(allow_zero)) then - if (allow_zero) then - nodeu = 0 - return - endif - endif - endif - ! - if(k < 1 .or. k > nlay) then - write(ermsg, *) ' Layer number in list is outside of the grid', k - call store_error(ermsg) - end if - if(j < 1 .or. j > ncpl) then - write(ermsg, *) ' Cell2d number in list is outside of the grid', j - call store_error(ermsg) - end if - nodeu = get_node(k, 1, j, nlay, nrow, ncpl) - ! - if(nodeu < 1 .or. nodeu > this%nodesuser) then - write(ermsg, *) ' Node number in list is outside of the grid', nodeu - call store_error(ermsg) - inquire(unit=in, name=fname) - call store_error('Error converting in file: ') - call store_error(trim(adjustl(fname))) - call store_error('Cell number cannot be determined in line: ') - call store_error(trim(adjustl(line))) - call store_error_unit(in) - call ustop() - end if - ! - ! -- return - return - end function nodeu_from_string - - function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & - allow_zero) result(nodeu) -! ****************************************************************************** -! nodeu_from_cellid -- Receive cellid as a string and convert the string to a -! user nodenumber. -! If flag_string argument is present and true, the first token in string -! is allowed to be a string (e.g. boundary name). In this case, if a string -! is encountered, return value as -2. -! If allow_zero argument is present and true, if all indices equal zero, the -! result can be zero. If allow_zero is false, a zero in any index causes an -! error. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - integer(I4B) :: nodeu - ! -- dummy - class(GwfDisvType) :: this - character(len=*), intent(inout) :: cellid - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - logical, optional, intent(in) :: flag_string - logical, optional, intent(in) :: allow_zero - ! -- local - integer(I4B) :: j, k, nlay, nrow, ncpl - integer(I4B) :: lloclocal, ndum, istat, n - integer(I4B) :: istart, istop - real(DP) :: r - character(len=LINELENGTH) :: ermsg, fname -! ------------------------------------------------------------------------------ - ! - if (present(flag_string)) then - if (flag_string) then - ! Check to see if first token in cellid can be read as an integer. - lloclocal = 1 - call urword(cellid, lloclocal, istart, istop, 1, ndum, r, iout, inunit) - read(cellid(istart:istop), *, iostat=istat) n - if (istat /= 0) then - ! First token in cellid is not an integer; return flag to this effect. - nodeu = -2 - return - endif - endif - endif - ! - nlay = this%mshape(1) - nrow = 1 - ncpl = this%mshape(2) - ! - lloclocal = 1 - call urword(cellid, lloclocal, istart, istop, 2, k, r, iout, inunit) - call urword(cellid, lloclocal, istart, istop, 2, j, r, iout, inunit) - ! - if (k == 0 .and. j == 0) then - if (present(allow_zero)) then - if (allow_zero) then - nodeu = 0 - return - endif - endif - endif - ! - if(k < 1 .or. k > nlay) then - write(ermsg, *) ' Layer number in list is outside of the grid', k - call store_error(ermsg) - end if - if(j < 1 .or. j > ncpl) then - write(ermsg, *) ' Cell2d number in list is outside of the grid', j - call store_error(ermsg) - end if - nodeu = get_node(k, 1, j, nlay, nrow, ncpl) - ! - if(nodeu < 1 .or. nodeu > this%nodesuser) then - write(ermsg, *) ' Node number in list is outside of the grid', nodeu - call store_error(ermsg) - inquire(unit=inunit, name=fname) - call store_error('Error converting in file: ') - call store_error(trim(adjustl(fname))) - call store_error('Cell number cannot be determined in cellid: ') - call store_error(trim(adjustl(cellid))) - call store_error_unit(inunit) - call ustop() - end if - ! - ! -- return - return - end function nodeu_from_cellid - - logical function supports_layers(this) - implicit none - ! -- dummy - class(GwfDisvType) :: this - ! - supports_layers = .true. - return - end function supports_layers - - function get_ncpl(this) -! ****************************************************************************** -! get_ncpl -- Return number of cells per layer. This is ncpl -! for a DISV grid. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - integer(I4B) :: get_ncpl - ! -- dummy - class(GwfDisvType) :: this -! ------------------------------------------------------------------------------ - ! - get_ncpl = this%ncpl - ! - ! -- Return - return - end function get_ncpl - - subroutine read_int_array(this, line, lloc, istart, istop, iout, in, & - iarray, aname) -! ****************************************************************************** -! read_int_array -- Read a GWF integer array -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: urword - use SimModule, only: store_error, ustop - use ConstantsModule, only: LINELENGTH - ! -- dummy - class(GwfDisvType), intent(inout) :: this - character(len=*), intent(inout) :: line - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: iarray - character(len=*), intent(in) :: aname - ! -- local - integer(I4B) :: ival - real(DP) :: rval - integer(I4B) :: nlay - integer(I4B) :: nrow - integer(I4B) :: ncol - integer(I4B) :: nval - integer(I4B), dimension(:), pointer, contiguous :: itemp -! ------------------------------------------------------------------------------ - ! - ! -- Point the temporary pointer array, which is passed to the reading - ! subroutine. The temporary array will point to ibuff if it is a - ! reduced structured system, or to iarray if it is an unstructured - ! model. - nlay = this%mshape(1) - nrow = 1 - ncol = this%mshape(2) - ! - if(this%nodes < this%nodesuser) then - nval = this%nodesuser - itemp => this%ibuff - else - nval = this%nodes - itemp => iarray - endif - ! - ! -- Read the array - call urword(line, lloc, istart, istop, 1, ival, rval, iout, in) - if (line(istart:istop).EQ.'LAYERED') then - ! - ! -- Read layered input - call ReadArray(in, itemp, aname, this%ndim, ncol, nrow, nlay, nval, & - iout, 1, nlay) - else - ! - ! -- Read unstructured input - call ReadArray(in, itemp, aname, this%ndim, nval, iout, 0) - end if - ! - ! -- If reduced model, then need to copy from itemp(=>ibuff) to iarray - if(this%nodes < this%nodesuser) then - call this%fill_grid_array(itemp, iarray) - endif - ! - ! -- return - return - end subroutine read_int_array - - subroutine read_dbl_array(this, line, lloc, istart, istop, iout, in, & - darray, aname) -! ****************************************************************************** -! read_dbl_array -- Read a GWF double precision array -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: urword - use SimModule, only: ustop, store_error - use ConstantsModule, only: LINELENGTH - ! -- dummy - class(GwfDisvType), intent(inout) :: this - character(len=*), intent(inout) :: line - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout - real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray - character(len=*), intent(in) :: aname - ! -- local - integer(I4B) :: ival - real(DP) :: rval - integer(I4B) :: nlay - integer(I4B) :: nrow - integer(I4B) :: ncol - integer(I4B) :: nval - real(DP), dimension(:), pointer, contiguous :: dtemp -! ------------------------------------------------------------------------------ - ! - ! -- Point the temporary pointer array, which is passed to the reading - ! subroutine. The temporary array will point to dbuff if it is a - ! reduced structured system, or to darray if it is an unstructured - ! model. - nlay = this%mshape(1) - nrow = 1 - ncol = this%mshape(2) - ! - if(this%nodes < this%nodesuser) then - nval = this%nodesuser - dtemp => this%dbuff - else - nval = this%nodes - dtemp => darray - endif - ! - ! -- Read the array - call urword(line, lloc, istart, istop, 1, ival, rval, iout, in) - if (line(istart:istop).EQ.'LAYERED') then - ! - ! -- Read structured input - call ReadArray(in, dtemp, aname, this%ndim, ncol, nrow, nlay, nval, & - iout, 1, nlay) - else - ! - ! -- Read unstructured input - call ReadArray(in, dtemp, aname, this%ndim, nval, iout, 0) - end if - ! - ! -- If reduced model, then need to copy from dtemp(=>dbuff) to darray - if(this%nodes < this%nodesuser) then - call this%fill_grid_array(dtemp, darray) - endif - ! - ! -- return - return - end subroutine read_dbl_array - - subroutine read_layer_array(this, nodelist, darray, ncolbnd, maxbnd, & - icolbnd, aname, inunit, iout) -! ****************************************************************************** -! read_layer_array -- Read a 2d double array into col icolbnd of darray. -! For cells that are outside of the active domain, -! do not copy the array value into darray. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: get_node - ! -- dummy - class(GwfDisvType) :: this - integer(I4B), intent(in) :: ncolbnd - integer(I4B), intent(in) :: maxbnd - integer(I4B), dimension(maxbnd) :: nodelist - real(DP), dimension(ncolbnd, maxbnd), intent(inout) :: darray - integer(I4B), intent(in) :: icolbnd - character(len=*), intent(in) :: aname - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - ! -- local - integer(I4B) :: il, ir, ic, ncol, nrow, nlay, nval, ipos, noder, nodeu - logical :: found -! ------------------------------------------------------------------------------ - ! - nlay = this%mshape(1) - nrow = 1 - ncol = this%mshape(2) - ! - ! -- Read the array - nval = ncol * nrow - call ReadArray(inunit, this%dbuff, aname, this%ndim, nval, iout, 0) - ! - ! -- Copy array into bound - ipos = 1 - do ir = 1, nrow - columnloop: do ic = 1, ncol - ! - ! -- look down through all layers and see if nodeu == nodelist(ipos) - ! cycle if not, because node must be inactive or pass through - found = .false. - layerloop: do il = 1, nlay - nodeu = get_node(il, ir, ic, nlay, nrow, ncol) - noder = this%get_nodenumber(nodeu, 0) - if(noder == 0) cycle layerloop - if(noder == nodelist(ipos)) then - found = .true. - exit layerloop - endif - enddo layerloop - if(.not. found) cycle columnloop - ! - ! -- Assign the array value to darray - nodeu = get_node(1, ir, ic, nlay, nrow, ncol) - darray(icolbnd, ipos) = this%dbuff(nodeu) - ipos = ipos + 1 - ! - enddo columnloop - enddo - ! - ! -- return - end subroutine read_layer_array - - subroutine record_array(this, darray, iout, iprint, idataun, aname, & - cdatafmp, nvaluesp, nwidthp, editdesc, dinact) -! ****************************************************************************** -! record_array -- Record a double precision array. The array will be -! printed to an external file and/or written to an unformatted external file -! depending on the argument specifications. -! ****************************************************************************** -! -! SPECIFICATIONS: -! darray is the double precision array to record -! iout is the unit number for ascii output -! iprint is a flag indicating whether or not to print the array -! idataun is the unit number to which the array will be written in binary -! form; if negative then do not write by layers, write entire array -! aname is the text descriptor of the array -! cdatafmp is the fortran format for writing the array -! nvaluesp is the number of values per line for printing -! nwidthp is the width of the number for printing -! editdesc is the format type (I, G, F, S, E) -! dinact is the double precision value to use for cells that are excluded -! from the model domain -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(GwfDisvType), intent(inout) :: this - real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray - integer(I4B), intent(in) :: iout - integer(I4B), intent(in) :: iprint - integer(I4B), intent(in) :: idataun - character(len=*), intent(in) :: aname - character(len=*), intent(in) :: cdatafmp - integer(I4B), intent(in) :: nvaluesp - integer(I4B), intent(in) :: nwidthp - character(len=*), intent(in) :: editdesc - real(DP), intent(in) :: dinact - ! -- local - integer(I4B) :: k, ifirst - integer(I4B) :: nlay - integer(I4B) :: nrow - integer(I4B) :: ncol - integer(I4B) :: nval - integer(I4B) :: nodeu, noder - integer(I4B) :: istart, istop - real(DP), dimension(:), pointer, contiguous :: dtemp - ! -- formats - character(len=*),parameter :: fmthsv = & - "(1X,/1X,a,' WILL BE SAVED ON UNIT ',I4, & - &' AT END OF TIME STEP',I5,', STRESS PERIOD ',I4)" -! ------------------------------------------------------------------------------ - ! - ! -- set variables - nlay = this%mshape(1) - nrow = 1 - ncol = this%mshape(2) - ! - ! -- If this is a reduced model, then copy the values from darray into - ! dtemp. - if(this%nodes < this%nodesuser) then - nval = this%nodes - dtemp => this%dbuff - do nodeu = 1, this%nodesuser - noder = this%get_nodenumber(nodeu, 0) - if(noder <= 0) then - dtemp(nodeu) = dinact - cycle - endif - dtemp(nodeu) = darray(noder) - enddo - else - nval = this%nodes - dtemp => darray - endif - ! - ! -- Print to iout if iprint /= 0 - if(iprint /= 0) then - istart = 1 - do k = 1, nlay - istop = istart + nrow * ncol - 1 - call ulaprufw(ncol, nrow, kstp, kper, k, iout, dtemp(istart:istop), & - aname, cdatafmp, nvaluesp, nwidthp, editdesc) - istart = istop + 1 - enddo - endif - ! - ! -- Save array to an external file. - if(idataun > 0) then - ! -- write to binary file by layer - ifirst = 1 - istart = 1 - do k=1, nlay - istop = istart + nrow * ncol - 1 - if(ifirst == 1) write(iout, fmthsv) & - trim(adjustl(aname)), idataun, & - kstp, kper - ifirst = 0 - call ulasav(dtemp(istart:istop), aname, kstp, kper, & - pertim, totim, ncol, nrow, k, idataun) - istart = istop + 1 - enddo - elseif(idataun < 0) then - ! - ! -- write entire array as one record - call ubdsv1(kstp, kper, aname, -idataun, dtemp, ncol, nrow, nlay, & - iout, delt, pertim, totim) - endif - ! - ! -- return - return - end subroutine record_array - - subroutine record_srcdst_list_header(this, text, textmodel, textpackage, & - dstmodel, dstpackage, naux, auxtxt, & - ibdchn, nlist, iout) -! ****************************************************************************** -! record_srcdst_list_header -- Record list header for imeth=6 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfDisvType) :: this - character(len=16), intent(in) :: text - character(len=16), intent(in) :: textmodel - character(len=16), intent(in) :: textpackage - character(len=16), intent(in) :: dstmodel - character(len=16), intent(in) :: dstpackage - integer(I4B), intent(in) :: naux - character(len=16), dimension(:), intent(in) :: auxtxt - integer(I4B), intent(in) :: ibdchn - integer(I4B), intent(in) :: nlist - integer(I4B), intent(in) :: iout - ! -- local - integer(I4B) :: nlay, nrow, ncol -! ------------------------------------------------------------------------------ - ! - nlay = this%mshape(1) - nrow = 1 - ncol = this%mshape(2) - ! - ! -- Use ubdsv06 to write list header - call ubdsv06(kstp, kper, text, textmodel, textpackage, dstmodel, dstpackage,& - ibdchn, naux, auxtxt, ncol, nrow, nlay, & - nlist, iout, delt, pertim, totim) - ! - ! -- return - return - end subroutine record_srcdst_list_header - - subroutine nlarray_to_nodelist(this, nodelist, maxbnd, nbound, aname, & - inunit, iout) -! ****************************************************************************** -! nlarray_to_nodelist -- Read an integer array into nodelist. For structured -! model, integer array is layer number; for unstructured -! model, integer array is node number. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: get_node - use SimModule, only: ustop, store_error - use ConstantsModule, only: LINELENGTH - ! -- dummy - class(GwfDisvType) :: this - integer(I4B), intent(in) :: maxbnd - integer(I4B), dimension(maxbnd), intent(inout) :: nodelist - integer(I4B), intent(inout) :: nbound - character(len=*), intent(in) :: aname - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - ! -- local - integer(I4B) :: il, ir, ic, ncol, nrow, nlay, nval, nodeu, noder, ipos, ierr - character(len=LINELENGTH) :: errmsg -! ------------------------------------------------------------------------------ - ! - ! -- set variables - nlay = this%mshape(1) - nrow = 1 - ncol = this%mshape(2) - ! - nval = ncol * nrow - call ReadArray(inunit, this%ibuff, aname, this%ndim, nval, iout, 0) - ! - ! -- Copy array into nodelist - ipos = 1 - ierr = 0 - do ir = 1, nrow - do ic = 1, ncol - nodeu = get_node(1, ir, ic, nlay, nrow, ncol) - il = this%ibuff(nodeu) - if(il < 1 .or. il > nlay) then - write(errmsg, *) 'ERROR. INVALID LAYER NUMBER: ', il - call store_error(errmsg) - call ustop() - endif - nodeu = get_node(il, ir, ic, nlay, nrow, ncol) - noder = this%get_nodenumber(nodeu, 0) - if(noder > 0) then - if(ipos > maxbnd) then - ierr = ipos - else - nodelist(ipos) = noder - endif - ipos = ipos + 1 - endif - enddo - enddo - ! - ! -- Check for errors - nbound = ipos - 1 - if(ierr > 0) then - write(errmsg, *) 'ERROR. MAXBOUND DIMENSION IS TOO SMALL.' - call store_error(errmsg) - write(errmsg, *) 'INCREASE MAXBOUND TO: ', ierr - call store_error(errmsg) - call ustop() - endif - ! - ! -- If nbound < maxbnd, then initialize nodelist to zero in this range - if(nbound < maxbnd) then - do ipos = nbound+1, maxbnd - nodelist(ipos) = 0 - enddo - endif - ! - ! -- return - end subroutine nlarray_to_nodelist - -end module GwfDisvModule +module GwfDisvModule + + use ArrayReadersModule, only: ReadArray + use KindModule, only: DP, I4B + use ConstantsModule, only: LINELENGTH + use BaseDisModule, only: DisBaseType + use InputOutputModule, only: get_node, URWORD, ulasav, ulaprufw, ubdsv1, & + ubdsv06 + use SimModule, only: count_errors, store_error, store_error_unit, ustop + use DisvGeom, only: DisvGeomType + use BlockParserModule, only: BlockParserType + use MemoryManagerModule, only: mem_allocate + use TdisModule, only: kstp, kper, pertim, totim, delt + + implicit none + private + public disv_cr, disv_init_mem, GwfDisvType + + type, extends(DisBaseType) :: GwfDisvType + integer(I4B), pointer :: nlay => null() ! number of layers + integer(I4B), pointer :: ncpl => null() ! number of cells per layer + integer(I4B), pointer :: nvert => null() ! number of x,y vertices + real(DP), dimension(:,:), pointer, contiguous :: vertices => null() ! cell vertices stored as 2d array of x and y + real(DP), dimension(:,:), pointer, contiguous :: cellxy => null() ! cell center stored as 2d array of x and y + integer(I4B), dimension(:), pointer, contiguous :: iavert => null() ! cell vertex pointer ia array + integer(I4B), dimension(:), pointer, contiguous :: javert => null() ! cell vertex pointer ja array + real(DP), dimension(:, :), pointer, contiguous :: top2d => null() ! top elevations for each cell at top of model (ncpl, 1) + real(DP), dimension(:, :, :), pointer, contiguous :: bot3d => null() ! bottom elevations for each cell (ncpl, 1, nlay) + integer(I4B), dimension(:, :, :), pointer, contiguous :: idomain => null() ! idomain (ncpl, 1, nlay) + type(DisvGeomType) :: cell1 ! cell object used to calculate geometric properties + type(DisvGeomType) :: cell2 ! cell object used to calculate geometric properties + contains + procedure :: dis_df => disv_df + procedure :: dis_da => disv_da + procedure :: get_cellxy => get_cellxy_disv + procedure :: get_dis_type => get_dis_type + procedure, public :: record_array + procedure, public :: read_layer_array + procedure, public :: record_srcdst_list_header + procedure, public :: nlarray_to_nodelist + ! -- helper functions + procedure :: get_nodenumber_idx1 + procedure :: get_nodenumber_idx2 + procedure :: nodeu_to_string + procedure :: nodeu_to_array + procedure :: nodeu_from_string + procedure :: nodeu_from_cellid + procedure :: connection_normal + procedure :: connection_vector + procedure :: supports_layers + procedure :: get_ncpl + ! -- private + procedure :: read_options + procedure :: read_dimensions + procedure :: read_vertices + procedure :: read_cell2d + procedure :: read_mf6_griddata + procedure :: grid_finalize + procedure :: connect + procedure :: write_grb + procedure :: allocate_scalars + procedure :: allocate_arrays + procedure :: get_cell2d_area + ! + procedure :: read_int_array + procedure :: read_dbl_array + ! + end type GwfDisvType + + contains + + subroutine disv_cr(dis, name_model, inunit, iout) +! ****************************************************************************** +! disv_cr -- Create a new discretization by vertices object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(DisBaseType), pointer :: dis + character(len=*), intent(in) :: name_model + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + type(GwfDisvType), pointer :: disnew +! ------------------------------------------------------------------------------ + allocate(disnew) + dis => disnew + call disnew%allocate_scalars(name_model) + dis%inunit = inunit + dis%iout = iout + ! + ! -- Initialize block parser + call dis%parser%Initialize(dis%inunit, dis%iout) + ! + ! -- Return + return + end subroutine disv_cr + + subroutine disv_init_mem(dis, name_model, iout, nlay, ncpl, & + top2d, bot3d, vertices, cellxy, idomain) +! ****************************************************************************** +! dis_init_mem -- Create a new discretization by vertices object from memory +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(DisBaseType), pointer :: dis + character(len=*), intent(in) :: name_model + integer(I4B), intent(in) :: iout + integer(I4B), intent(in) :: nlay + integer(I4B), intent(in) :: ncpl + real(DP), dimension(:, :), pointer, contiguous, intent(in) :: top2d + real(DP), dimension(:, :, :), pointer, contiguous, intent(in) :: bot3d + integer(I4B), dimension(:, :), pointer, contiguous, intent(in) :: vertices + integer(I4B), dimension(:, :), pointer, contiguous, intent(in) :: cellxy + integer(I4B), dimension(:, :, :), pointer, contiguous, intent(in), & + optional :: idomain + ! -- local + type(GwfDisvType), pointer :: disext + integer(I4B) :: n + integer(I4B) :: j + integer(I4B) :: k + integer(I4B) :: ival + ! -- local +! ------------------------------------------------------------------------------ + allocate(disext) + dis => disext + call disext%allocate_scalars(name_model) + dis%inunit = 0 + dis%iout = iout + ! + ! -- set dimensions + disext%ncpl = ncpl + disext%nlay = nlay + ! + ! -- Calculate nodesuser + disext%nodesuser = disext%nlay * disext%ncpl + ! + ! -- Allocate non-reduced vectors for disv + call mem_allocate(disext%idomain, disext%ncpl, 1, disext%nlay, 'IDOMAIN', & + disext%origin) + call mem_allocate(disext%top2d, disext%ncpl, 1, 'TOP2D', disext%origin) + call mem_allocate(disext%bot3d, disext%ncpl, 1, disext%nlay, 'BOT3D', & + disext%origin) + ! + ! -- Allocate vertices array + call mem_allocate(disext%vertices, 2, disext%nvert, 'VERTICES', disext%origin) + call mem_allocate(disext%cellxy, 2, disext%ncpl, 'CELLXY', disext%origin) + ! + ! -- fill data + do k = 1, disext%nlay + do j = 1, disext%ncpl + if (k == 1) then + disext%top2d(j, 1) = top2d(j, 1) + end if + disext%bot3d(j, 1, k) = bot3d(j, 1, k) + if (present(idomain)) then + ival = idomain(j, 1, k) + else + ival = 1 + end if + disext%idomain(j, 1, k) = ival + end do + end do + do n = 1, disext%nvert + do j = 1, 2 + disext%vertices(j, n) = vertices(j, n) + end do + end do + do n = 1, disext%ncpl + do j = 1, 2 + disext%cellxy(j, n) = cellxy(j, n) + end do + end do + ! + ! -- Return + return + end subroutine disv_init_mem + + subroutine disv_df(this) +! ****************************************************************************** +! read_from_file -- Allocate and read discretization information +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfDisvType) :: 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 + ! + ! -- Final grid initialization + call this%grid_finalize() + ! + ! -- Return + return + end subroutine disv_df + + subroutine disv_da(this) +! ****************************************************************************** +! disv_da -- Deallocate discretization data +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(GwfDisvType) :: this + ! -- locals +! ------------------------------------------------------------------------------ + ! + ! -- DisBaseType deallocate + call this%DisBaseType%dis_da() + ! + ! -- Deallocate scalars + call mem_deallocate(this%nlay) + call mem_deallocate(this%ncpl) + call mem_deallocate(this%nvert) + ! + ! -- Deallocate Arrays + call mem_deallocate(this%nodereduced) + call mem_deallocate(this%nodeuser) + call mem_deallocate(this%vertices) + call mem_deallocate(this%cellxy) + call mem_deallocate(this%iavert) + call mem_deallocate(this%javert) + call mem_deallocate(this%top2d) + call mem_deallocate(this%bot3d) + call mem_deallocate(this%idomain) + ! + ! -- Return + return + end subroutine disv_da + + subroutine read_options(this) +! ****************************************************************************** +! read_options -- Read options +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + ! -- dummy + class(GwfDisvType) :: 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' + endif + 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() + call ustop() + end select + end do + else + write(this%iout,'(1x,a)')'NO DISV OPTION BLOCK DETECTED.' + end if + if(this%lenuni==0) write(this%iout,'(3x,a)') 'MODEL LENGTH UNIT IS UNDEFINED' + if(isfound) then + write(this%iout,'(1x,a)')'END OF DISCRETIZATION OPTIONS' + endif + ! + ! -- Return + return + end subroutine read_options + + subroutine read_dimensions(this) +! ****************************************************************************** +! read_dimensions -- Read dimensions +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + ! -- dummy + class(GwfDisvType) :: this + ! -- locals + character(len=LINELENGTH) :: errmsg, keyword + integer(I4B) :: ierr + logical :: isfound, endOfBlock + integer(I4B) :: j + integer(I4B) :: k +! ------------------------------------------------------------------------------ + ! + ! -- 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)')'****ERROR. UNKNOWN DIS DIMENSION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + end do + else + call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- verify dimensions were set + if(this%nlay < 1) then + call store_error( & + 'ERROR. NLAY WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') + call this%parser%StoreErrorUnit() + call ustop() + endif + if(this%ncpl < 1) then + call store_error( & + 'ERROR. NCPL WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') + call this%parser%StoreErrorUnit() + call ustop() + endif + if(this%nvert < 1) then + call store_error( & + 'ERROR. NVERT WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') + call this%parser%StoreErrorUnit() + call ustop() + endif + write(this%iout,'(1x,a)')'END OF DISCRETIZATION DIMENSIONS' + ! + ! -- Calculate nodesuser + this%nodesuser = this%nlay * this%ncpl + ! + ! -- Allocate non-reduced vectors for disv + call mem_allocate(this%idomain, this%ncpl, 1, this%nlay, 'IDOMAIN', & + this%origin) + call mem_allocate(this%top2d, this%ncpl, 1, 'TOP2D', this%origin) + call mem_allocate(this%bot3d, this%ncpl, 1, this%nlay, 'BOT3D', this%origin) + ! + ! -- Allocate vertices array + call mem_allocate(this%vertices, 2, this%nvert, 'VERTICES', this%origin) + call mem_allocate(this%cellxy, 2, this%ncpl, 'CELLXY', this%origin) + ! + ! -- initialize all cells to be active (idomain = 1) + do k = 1, this%nlay + do j = 1, this%ncpl + this%idomain(j, 1, k) = 1 + end do + end do + ! + ! -- Return + return + end subroutine read_dimensions + + subroutine read_mf6_griddata(this) +! ****************************************************************************** +! read_mf6_griddata -- Read grid data from a MODFLOW 6 ascii file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: ustop, count_errors, store_error + use ConstantsModule, only: LINELENGTH, DZERO + ! -- 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 + ! -- 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)')'ERROR. UNKNOWN GRIDDATA TAG: ', & + trim(keyword) + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + 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() + call ustop() + end if + ! + ! -- 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) + endif + enddo + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Return + return + end subroutine read_mf6_griddata + + subroutine grid_finalize(this) +! ****************************************************************************** +! grid_finalize -- Finalize grid +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: ustop, count_errors, store_error + use ConstantsModule, only: LINELENGTH, DZERO + ! -- dummy + class(GwfDisvType) :: this + ! -- locals + integer(I4B) :: node, noder, j, k + real(DP) :: top + real(DP) :: dz + character(len=300) :: ermsg + ! -- 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: ',I7," // & + "/1X, 'NUMBER OF NODES IN SOLUTION: ', I7, //)" + ! -- data +! ------------------------------------------------------------------------------ + ! + ! -- count active cells + this%nodes = 0 + do k = 1, this%nlay + do j = 1, this%ncpl + if(this%idomain(j, 1, k) > 0) this%nodes = this%nodes + 1 + enddo + enddo + ! + ! -- Check to make sure nodes is a valid number + if (this%nodes == 0) then + call store_error('ERROR. MODEL DOES NOT HAVE ANY ACTIVE NODES.') + call store_error('MAKE SURE IDOMAIN ARRAY HAS SOME VALUES GREATER & + &THAN ZERO.') + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- Check cell thicknesses + do k = 1, this%nlay + do j = 1, this%ncpl + if (this%idomain(j, 1, k) == 0) cycle + if (this%idomain(j, 1, k) > 0) then + if (k > 1) then + top = this%bot3d(j, 1, k - 1) + else + top = this%top2d(j, 1) + end if + dz = top - this%bot3d(j, 1, k) + if (dz <= DZERO) then + write(ermsg, fmt=fmtdz) k, j, top, this%bot3d(j, 1, k) + call store_error(ermsg) + endif + endif + enddo + enddo + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Write message if reduced grid + if(this%nodes < this%nodesuser) then + write(this%iout, fmtnr) this%nodesuser, this%nodes + endif + ! + ! -- Array size is now known, so allocate + call this%allocate_arrays() + ! + ! -- Fill the nodereduced array with the reduced nodenumber, or + ! a negative number to indicate it is a pass-through cell, or + ! a zero to indicate that the cell is excluded from the + ! solution. + if(this%nodes < this%nodesuser) then + node = 1 + noder = 1 + do k = 1, this%nlay + do j = 1, this%ncpl + if(this%idomain(j, 1, k) > 0) then + this%nodereduced(node) = noder + noder = noder + 1 + elseif(this%idomain(j, 1, k) < 0) then + this%nodereduced(node) = -1 + else + this%nodereduced(node) = 0 + endif + node = node + 1 + enddo + enddo + endif + ! + ! -- allocate and fill nodeuser if a reduced grid + if(this%nodes < this%nodesuser) then + node = 1 + noder = 1 + do k = 1, this%nlay + do j = 1, this%ncpl + if(this%idomain(j, 1, k) > 0) then + this%nodeuser(noder) = node + noder = noder + 1 + endif + node = node + 1 + enddo + enddo + endif + ! + ! -- Move top2d and bot3d into top and bot, and calculate area + node = 0 + do k = 1, this%nlay + do j = 1, this%ncpl + node = node + 1 + noder = node + if(this%nodes < this%nodesuser) noder = this%nodereduced(node) + if(noder <= 0) cycle + if (k > 1) then + top = this%bot3d(j, 1, k - 1) + else + top = this%top2d(j, 1) + end if + this%top(noder) = top + this%bot(noder) = this%bot3d(j, 1, k) + enddo + enddo + ! + ! -- Build connections + call this%connect() + ! + ! -- Create two cell objects that can be used for geometric processing + call this%cell1%init(this%nlay, this%ncpl, this%nodes, this%top, this%bot, & + this%iavert, this%javert, this%vertices, this%cellxy, & + this%nodereduced, this%nodeuser) + call this%cell2%init(this%nlay, this%ncpl, this%nodes, this%top, this%bot, & + this%iavert, this%javert, this%vertices, this%cellxy, & + this%nodereduced, this%nodeuser) + ! + ! -- Return + return + end subroutine grid_finalize + + subroutine read_vertices(this) +! ****************************************************************************** +! read_vertices -- Read data +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: ustop, count_errors, store_error + use ConstantsModule, only: LINELENGTH, DZERO + ! -- dummy + class(GwfDisvType) :: this + integer(I4B) :: i + integer(I4B) :: ierr, ival + logical :: isfound, endOfBlock + real(DP) :: xmin, xmax, ymin, ymax + character(len=300) :: ermsg + ! -- 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 + ! + ! --Read DISDATA block + call this%parser%GetBlock('VERTICES', isfound, ierr, & + supportOpenClose=.true.) + if(isfound) then + write(this%iout,'(/,1x,a)') 'PROCESSING VERTICES' + 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() + call ustop() + endif + ! + ! -- 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)) + endif + enddo + ! + ! -- Terminate the block + call this%parser%terminateblock() + else + call store_error('ERROR. REQUIRED VERTICES BLOCK NOT FOUND.') + call this%parser%StoreErrorUnit() + call ustop() + 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' + ! + ! -- Return + return + end subroutine read_vertices + + subroutine read_cell2d(this) +! ****************************************************************************** +! read_cell2d -- Read information describing the two dimensional (x, y) +! configuration of each cell. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: ustop, count_errors, store_error + use ConstantsModule, only: LINELENGTH, DZERO + use InputOutputModule, only: urword + use SparseModule, only: sparsematrix + use MemoryManagerModule, only: mem_allocate + ! -- 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 + ! -- 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 + ! + ! -- 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 + enddo + call vertspm%init(this%ncpl, this%nvert, maxnnz) + ! + ! --Read CELL2D block + call this%parser%GetBlock('CELL2D', isfound, ierr, supportOpenClose=.true.) + if(isfound) then + write(this%iout,'(/,1x,a)') 'PROCESSING CELL2D' + 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) + call ustop() + endif + ! + ! -- 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 + endif + ! + ! -- 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) + endif + endif + enddo + ! + ! -- 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)) + endif + enddo + ! + ! -- Terminate the block + call this%parser%terminateblock() + else + call store_error('ERROR. REQUIRED CELL2D BLOCK NOT FOUND.') + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- Convert vertspm into ia/ja form + call mem_allocate(this%iavert, this%ncpl+1, 'IAVERT', this%origin) + call mem_allocate(this%javert, vertspm%nnz, 'JAVERT', this%origin) + 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' + ! + ! -- Return + return + end subroutine read_cell2d + + subroutine connect(this) +! ****************************************************************************** +! connect -- Build grid connections +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfDisvType) :: this + ! -- local + integer(I4B) :: j, k + integer(I4B) :: noder, nrsize + real(DP) :: area + character(len=LINELENGTH) :: errmsg +! ------------------------------------------------------------------------------ + ! + ! -- Assign the cell area + do j = 1, this%ncpl + area = this%get_cell2d_area(j) + do k = 1, this%nlay + noder = this%get_nodenumber(k, j, 0) + if(noder > 0) this%area(noder) = area + enddo + if (area < 0) then + write(errmsg, '(a,i0)') 'ERROR. CELL2D AREA LESS THAN ZERO FOR CELL ', j + call store_error(errmsg) + endif + enddo + ! + ! -- check for errors + if(count_errors() > 0) then + write(errmsg, '(a)') 'CELL VERTICES MUST BE LISTED IN CLOCKWISE ORDER. ' + call store_error(errmsg) + call store_error_unit(this%inunit) + call ustop() + endif + ! + ! -- create and fill the connections object + nrsize = 0 + if(this%nodes < this%nodesuser) nrsize = this%nodes + allocate(this%con) + call this%con%disvconnections(this%name_model, this%nodes, & + this%ncpl, this%nlay, nrsize, & + this%nvert, this%vertices, this%iavert, & + this%javert, this%cellxy, & + this%top, this%bot, & + this%nodereduced, this%nodeuser) + this%nja = this%con%nja + this%njas = this%con%njas + ! + ! + ! -- return + return + end subroutine connect + + subroutine write_grb(this, icelltype) +! ****************************************************************************** +! write_grb -- Write the binary grid file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: getunit, openfile + use OpenSpecModule, only: access, form + use ConstantsModule, only: DZERO + ! -- dummy + class(GwfDisvType) :: this + integer(I4B), dimension(:), intent(in) :: icelltype + ! -- local + integer(I4B) :: iunit, i, ntxt + integer(I4B), parameter :: lentxt = 100 + character(len=50) :: txthdr + character(len=lentxt) :: txt + character(len=LINELENGTH) :: fname + character(len=*),parameter :: fmtgrdsave = & + "(4X,'BINARY GRID INFORMATION WILL BE WRITTEN TO:', & + &/,6X,'UNIT NUMBER: ', I0,/,6X, 'FILE NAME: ', A)" +! ------------------------------------------------------------------------------ + ! + ! -- Initialize + ntxt = 20 + ! + ! -- Open the file + inquire(unit=this%inunit, name=fname) + fname = trim(fname) // '.grb' + iunit = getunit() + write(this%iout, fmtgrdsave) iunit, trim(adjustl(fname)) + call openfile(iunit, this%iout, trim(adjustl(fname)), 'DATA(BINARY)', & + form, access, 'REPLACE') + ! + ! -- write header information + write(txthdr, '(a)') 'GRID DISV' + txthdr(50:50) = new_line('a') + write(iunit) txthdr + write(txthdr, '(a)') 'VERSION 1' + txthdr(50:50) = new_line('a') + write(iunit) txthdr + write(txthdr, '(a, i0)') 'NTXT ', ntxt + txthdr(50:50) = new_line('a') + write(iunit) txthdr + write(txthdr, '(a, i0)') 'LENTXT ', lentxt + txthdr(50:50) = new_line('a') + write(iunit) txthdr + ! + ! -- write variable definitions + write(txt, '(3a, i0)') 'NCELLS ', 'INTEGER ', 'NDIM 0 # ', this%nodesuser + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'NLAY ', 'INTEGER ', 'NDIM 0 # ', this%nlay + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'NCPL ', 'INTEGER ', 'NDIM 0 # ', this%ncpl + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'NVERT ', 'INTEGER ', 'NDIM 0 # ', this%nvert + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'NJAVERT ', 'INTEGER ', 'NDIM 0 # ', size(this%javert) + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'NJA ', 'INTEGER ', 'NDIM 0 # ', this%con%nja + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, 1pg25.15e3)') 'XORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%xorigin + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, 1pg25.15e3)') 'YORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%yorigin + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, 1pg25.15e3)') 'ANGROT ', 'DOUBLE ', 'NDIM 0 # ', this%angrot + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'TOP ', 'DOUBLE ', 'NDIM 1 ', this%ncpl + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'BOTM ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'VERTICES ', 'DOUBLE ', 'NDIM 2 2 ', this%nvert + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'CELLX ', 'DOUBLE ', 'NDIM 1 ', this%ncpl + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'CELLY ', 'DOUBLE ', 'NDIM 1 ', this%ncpl + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'IAVERT ', 'INTEGER ', 'NDIM 1 ', this%ncpl + 1 + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'JAVERT ', 'INTEGER ', 'NDIM 1 ', size(this%javert) + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'IA ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + 1 + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'JA ', 'INTEGER ', 'NDIM 1 ', size(this%con%jausr) + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'IDOMAIN ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + write(txt, '(3a, i0)') 'ICELLTYPE ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + txt(lentxt:lentxt) = new_line('a') + write(iunit) txt + ! + ! -- write data + write(iunit) this%nodesuser ! ncells + write(iunit) this%nlay ! nlay + write(iunit) this%ncpl ! ncpl + write(iunit) this%nvert ! nvert + write(iunit) size(this%javert) ! njavert + write(iunit) this%nja ! nja + write(iunit) this%xorigin ! xorigin + write(iunit) this%yorigin ! yorigin + write(iunit) this%angrot ! angrot + write(iunit) this%top2d ! top + write(iunit) this%bot3d ! botm + write(iunit) this%vertices ! vertices + write(iunit) (this%cellxy(1, i), i = 1, this%ncpl) ! cellx + write(iunit) (this%cellxy(2, i), i = 1, this%ncpl) ! celly + write(iunit) this%iavert ! iavert + write(iunit) this%javert ! javert + write(iunit) this%con%iausr ! iausr + write(iunit) this%con%jausr ! jausr + write(iunit) this%idomain ! idomain + write(iunit) icelltype ! icelltype + ! + ! -- Close the file + close(iunit) + ! + ! -- return + return + end subroutine write_grb + + subroutine nodeu_to_string(this, nodeu, str) +! ****************************************************************************** +! nodeu_to_string -- Convert user node number to a string in the form of +! (nodenumber) or (k,j) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: get_ijk + ! -- dummy + class(GwfDisvType) :: this + integer(I4B), intent(in) :: nodeu + character(len=*), intent(inout) :: str + ! -- local + integer(I4B) :: i, j, k + character(len=10) :: kstr, jstr +! ------------------------------------------------------------------------------ + ! + call get_ijk(nodeu, 1, this%ncpl, this%nlay, i, j, k) + write(kstr, '(i10)') k + write(jstr, '(i10)') j + str = '(' // trim(adjustl(kstr)) // ',' // & + trim(adjustl(jstr)) // ')' + ! + ! -- return + return + end subroutine nodeu_to_string + + subroutine nodeu_to_array(this, nodeu, arr) +! ****************************************************************************** +! nodeu_to_array -- Convert user node number to cellid and fill array with +! (nodenumber) or (k, j) or (k,i,j) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use InputOutputModule, only: get_ijk + implicit none + class(GwfDisvType) :: this + integer(I4B), intent(in) :: nodeu + integer(I4B), dimension(:), intent(inout) :: arr + ! -- local + character(len=LINELENGTH) :: errmsg + integer(I4B) :: isize + integer(I4B) :: i, j, k +! ------------------------------------------------------------------------------ + ! + ! -- check the size of arr + isize = size(arr) + if (isize /= this%ndim) then + write(errmsg,'(a,i0,a,i0,a)') & + 'Program error: nodeu_to_array size of array (', isize, & + ') is not equal to the discretization dimension (', this%ndim, ')' + call store_error(errmsg) + call ustop() + end if + ! + ! -- get k, i, j + call get_ijk(nodeu, 1, this%ncpl, this%nlay, i, j, k) + ! + ! -- fill array + arr(1) = k + arr(2) = j + ! + ! -- return + return + end subroutine nodeu_to_array + + function get_nodenumber_idx1(this, nodeu, icheck) result(nodenumber) +! ****************************************************************************** +! get_nodenumber -- Return a nodenumber from the user specified node number +! with an option to perform a check. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + ! -- return + integer(I4B) :: nodenumber + ! -- dummy + class(GwfDisvType), intent(in) :: this + integer(I4B), intent(in) :: nodeu + integer(I4B), intent(in) :: icheck + ! -- local + character(len=LINELENGTH) :: errmsg +! ------------------------------------------------------------------------------ + ! + ! -- check the node number if requested + if(icheck /= 0) then + ! + ! -- If within valid range, convert to reduced nodenumber + if(nodeu < 1 .or. nodeu > this%nodesuser) then + write(errmsg, '(a,i10)') & + 'Nodenumber less than 1 or greater than nodes:', nodeu + call store_error(errmsg) + nodenumber = 0 + else + nodenumber = nodeu + if(this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) + endif + else + nodenumber = nodeu + if(this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) + endif + ! + ! -- return + return + end function get_nodenumber_idx1 + + function get_nodenumber_idx2(this, k, j, icheck) & + result(nodenumber) +! ****************************************************************************** +! get_nodenumber_idx2 -- Return a nodenumber from the user specified layer and +! column with an option to perform a check. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use InputOutputModule, only: get_node + implicit none + ! -- return + integer(I4B) :: nodenumber + ! -- dummy + class(GwfDisvType), intent(in) :: this + integer(I4B), intent(in) :: k, j + integer(I4B), intent(in) :: icheck + ! -- local + character(len=LINELENGTH) :: errmsg + integer(I4B) :: nodeu + ! formats + character(len=*), parameter :: fmterr = & + "('Error in disv grid cell indices: layer = ',i0,', node = ',i0)" +! ------------------------------------------------------------------------------ + ! + nodeu = get_node(k, 1, j, this%nlay, 1, this%ncpl) + if (nodeu < 1) then + write(errmsg, fmterr) k, j + call store_error(errmsg) + call ustop() + endif + nodenumber = nodeu + if(this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) + ! + ! -- check the node number if requested + if(icheck /= 0) then + ! + if(k < 1 .or. k > this%nlay) & + call store_error('Layer less than one or greater than nlay') + if(j < 1 .or. j > this%ncpl) & + call store_error('Node number less than one or greater than ncpl') + ! + ! -- Error if outside of range + if(nodeu < 1 .or. nodeu > this%nodesuser) then + write(errmsg, '(a,i10)') & + 'Nodenumber less than 1 or greater than nodes:', nodeu + call store_error(errmsg) + endif + endif + ! + ! -- return + return + end function get_nodenumber_idx2 + + subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & + ipos) +! ****************************************************************************** +! connection_normal -- calculate the normal vector components for reduced +! nodenumber cell (noden) and its shared face with cell nodem. ihc is the +! horizontal connection flag. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DONE, DZERO + use SimModule, only: ustop, store_error + ! -- dummy + class(GwfDisvType) :: this + integer(I4B), intent(in) :: noden + integer(I4B), intent(in) :: nodem + integer(I4B), intent(in) :: ihc + real(DP), intent(inout) :: xcomp + real(DP), intent(inout) :: ycomp + real(DP), intent(inout) :: zcomp + integer(I4B), intent(in) :: ipos + ! -- local + !integer(I4B) :: ipos + !integer(I4B) :: ncell3d, mcell3d + real(DP) :: angle, dmult +! ------------------------------------------------------------------------------ + ! + ! -- Set vector components based on ihc + if(ihc == 0) then + xcomp = DZERO + ycomp = DZERO + if(nodem < noden) then + ! + ! -- nodem must be above noden, so upward connection + zcomp = DONE + else + ! + ! -- nodem must be below noden, so downward connection + zcomp = -DONE + endif + else + ! -- find from anglex, since anglex is symmetric, need to flip vector + ! for lower triangle (nodem < noden) + !ipos = this%con%getjaindex(noden, nodem) + angle = this%con%anglex(this%con%jas(ipos)) + dmult = DONE + if (nodem < noden) dmult = -DONE + xcomp = cos(angle) * dmult + ycomp = sin(angle) * dmult + zcomp = DZERO + endif + ! + ! -- return + return + end subroutine connection_normal + + subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & + xcomp, ycomp, zcomp, conlen) +! ****************************************************************************** +! connection_vector -- calculate the unit vector components from reduced +! nodenumber cell (noden) to its neighbor cell (nodem). The saturation for +! for these cells are also required so that the vertical position of the cell +! cell centers can be calculated. ihc is the horizontal flag. Also return +! the straight-line connection length. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DZERO, DONE, DHALF + use SimModule, only: ustop, store_error + use InputOutputModule, only: get_jk + use DisvGeom, only: line_unit_vector + ! -- dummy + class(GwfDisvType) :: this + integer(I4B), intent(in) :: noden + integer(I4B), intent(in) :: nodem + logical, intent(in) :: nozee + real(DP), intent(in) :: satn + real(DP), intent(in) :: satm + integer(I4B), intent(in) :: ihc + real(DP), intent(inout) :: xcomp + real(DP), intent(inout) :: ycomp + real(DP), intent(inout) :: zcomp + real(DP), intent(inout) :: conlen + ! -- local + integer(I4B) :: nodeu, ncell2d, mcell2d, k + real(DP) :: xn, xm, yn, ym, zn, zm +! ------------------------------------------------------------------------------ + ! + ! -- Set vector components based on ihc + if(ihc == 0) then + ! + ! -- vertical connection; set zcomp positive upward + xcomp = DZERO + ycomp = DZERO + if(nodem < noden) then + zcomp = DONE + else + zcomp = -DONE + endif + zn = this%bot(noden) + DHALF * (this%top(noden) - this%bot(noden)) + zm = this%bot(nodem) + DHALF * (this%top(nodem) - this%bot(nodem)) + conlen = abs(zm - zn) + else + ! + ! -- horizontal connection, with possible z component due to cell offsets + ! and/or water table conditions + if (nozee) then + zn = DZERO + zm = DZERO + else + zn = this%bot(noden) + DHALF * satn * (this%top(noden) - this%bot(noden)) + zm = this%bot(nodem) + DHALF * satm * (this%top(nodem) - this%bot(nodem)) + endif + nodeu = this%get_nodeuser(noden) + call get_jk(nodeu, this%ncpl, this%nlay, ncell2d, k) + nodeu = this%get_nodeuser(nodem) + call get_jk(nodeu, this%ncpl, this%nlay, mcell2d, k) + xn = this%cellxy(1, ncell2d) + yn = this%cellxy(2, ncell2d) + xm = this%cellxy(1, mcell2d) + ym = this%cellxy(2, mcell2d) + call line_unit_vector(xn, yn, zn, xm, ym, zm, xcomp, ycomp, zcomp, & + conlen) + endif + ! + ! -- return + return + end subroutine connection_vector + + ! return x,y coordinate for a node + subroutine get_cellxy_disv(this, node, xcell, ycell) + use InputOutputModule, only: get_jk + class(GwfDisvType), intent(in) :: this + integer(I4B), intent(in) :: node ! the reduced node number + real(DP), intent(out) :: xcell, ycell ! the x,y for the cell + ! local + integer(I4B) :: nodeuser, ncell2d, k + + nodeuser = this%get_nodeuser(node) + call get_jk(nodeuser, this%ncpl, this%nlay, ncell2d, k) + + xcell = this%cellxy(1, ncell2d) + ycell = this%cellxy(2, ncell2d) + + end subroutine get_cellxy_disv + + ! return discretization type + subroutine get_dis_type(this, dis_type) + class(GwfDisvType), intent(in) :: this + character(len=*), intent(out) :: dis_type + + dis_type = "DISV" + + end subroutine get_dis_type + + subroutine allocate_scalars(this, name_model) +! ****************************************************************************** +! allocate_scalars -- Allocate and initialize scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GwfDisvType) :: this + character(len=*), intent(in) :: name_model +! ------------------------------------------------------------------------------ + ! + ! -- Allocate parent scalars + call this%DisBaseType%allocate_scalars(name_model) + ! + ! -- Allocate + call mem_allocate(this%nlay, 'NLAY', this%origin) + call mem_allocate(this%ncpl, 'NCPL', this%origin) + call mem_allocate(this%nvert, 'NVERT', this%origin) + ! + ! -- Initialize + this%nlay = 0 + this%ncpl = 0 + this%nvert = 0 + this%ndim = 2 + ! + ! -- Return + return + end subroutine allocate_scalars + + subroutine allocate_arrays(this) +! ****************************************************************************** +! allocate_arrays -- Allocate arrays +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GwfDisvType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Allocate arrays in DisBaseType (mshape, top, bot, area) + call this%DisBaseType%allocate_arrays() + ! + ! -- Allocate arrays for GwfDisvType + if(this%nodes < this%nodesuser) then + call mem_allocate(this%nodeuser, this%nodes, 'NODEUSER', this%origin) + call mem_allocate(this%nodereduced, this%nodesuser, 'NODEREDUCED', & + this%origin) + else + call mem_allocate(this%nodeuser, 1, 'NODEUSER', this%origin) + call mem_allocate(this%nodereduced, 1, 'NODEREDUCED', this%origin) + endif + !! + !! -- Allocate vertices array + !call mem_allocate(this%vertices, 2, this%nvert, 'VERTICES', this%origin) + !call mem_allocate(this%cellxy, 2, this%ncpl, 'CELLXY', this%origin) + ! + ! -- Initialize + this%mshape(1) = this%nlay + this%mshape(2) = this%ncpl + ! + ! -- Return + return + end subroutine allocate_arrays + + function get_cell2d_area(this, icell2d) result(area) +! ****************************************************************************** +! get_cell2d_area -- Calculate and return the signed area of the cell. A +! negative area means the points are in counter clockwise orientation. +! a = 1/2 *[(x1*y2 + x2*y3 + x3*y4 + ... + xn*y1) - +! (x2*y1 + x3*y2 + x4*y3 + ... + x1*yn)] +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- module + use ConstantsModule, only: DZERO, DHALF, DONE + ! -- dummy + class(GwfDisvType) :: this + integer(I4B), intent(in) :: icell2d + ! -- return + real(DP) :: area + ! -- local + integer(I4B) :: ivert + integer(I4B) :: nvert + integer(I4B) :: icount + real(DP) :: x + real(DP) :: y +! ------------------------------------------------------------------------------ + ! + area = DZERO + nvert = this%iavert(icell2d + 1) - this%iavert(icell2d) + icount = 1 + do ivert = this%iavert(icell2d), this%iavert(icell2d + 1) - 1 + x = this%vertices(1, this%javert(ivert)) + if(icount < nvert) then + y = this%vertices(2, this%javert(ivert + 1)) + else + y = this%vertices(2, this%javert(this%iavert(icell2d))) + endif + area = area + x * y + icount = icount + 1 + enddo + ! + icount = 1 + do ivert = this%iavert(icell2d), this%iavert(icell2d + 1) - 1 + y = this%vertices(2, this%javert(ivert)) + if(icount < nvert) then + x = this%vertices(1, this%javert(ivert + 1)) + else + x = this%vertices(1, this%javert(this%iavert(icell2d))) + endif + area = area - x * y + icount = icount + 1 + enddo + ! + area = -DONE * area * DHALF + ! + ! -- return + return + end function get_cell2d_area + + function nodeu_from_string(this, lloc, istart, istop, in, iout, line, & + flag_string, allow_zero) result(nodeu) +! ****************************************************************************** +! nodeu_from_string -- Receive a string and convert the string to a user +! nodenumber. The model discretization is DISV; read layer and cell number. +! If flag_string argument is present and true, the first token in string +! is allowed to be a string (e.g. boundary name). In this case, if a string +! is encountered, return value as -2. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfDisvType) :: this + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout + character(len=*), intent(inout) :: line + logical, optional, intent(in) :: flag_string + logical, optional, intent(in) :: allow_zero + integer(I4B) :: nodeu + ! -- local + integer(I4B) :: j, k, nlay, nrow, ncpl + integer(I4B) :: lloclocal, ndum, istat, n + real(DP) :: r + character(len=LINELENGTH) :: ermsg, fname +! ------------------------------------------------------------------------------ + ! + if (present(flag_string)) then + if (flag_string) then + ! Check to see if first token in line can be read as an integer. + lloclocal = lloc + call urword(line, lloclocal, istart, istop, 1, ndum, r, iout, in) + read(line(istart:istop),*,iostat=istat)n + if (istat /= 0) then + ! First token in line is not an integer; return flag to this effect. + nodeu = -2 + return + endif + endif + endif + ! + nlay = this%mshape(1) + nrow = 1 + ncpl = this%mshape(2) + ! + call urword(line, lloc, istart, istop, 2, k, r, iout, in) + call urword(line, lloc, istart, istop, 2, j, r, iout, in) + ! + if (k == 0 .and. j == 0) then + if (present(allow_zero)) then + if (allow_zero) then + nodeu = 0 + return + endif + endif + endif + ! + if(k < 1 .or. k > nlay) then + write(ermsg, *) ' Layer number in list is outside of the grid', k + call store_error(ermsg) + end if + if(j < 1 .or. j > ncpl) then + write(ermsg, *) ' Cell2d number in list is outside of the grid', j + call store_error(ermsg) + end if + nodeu = get_node(k, 1, j, nlay, nrow, ncpl) + ! + if(nodeu < 1 .or. nodeu > this%nodesuser) then + write(ermsg, *) ' Node number in list is outside of the grid', nodeu + call store_error(ermsg) + inquire(unit=in, name=fname) + call store_error('Error converting in file: ') + call store_error(trim(adjustl(fname))) + call store_error('Cell number cannot be determined in line: ') + call store_error(trim(adjustl(line))) + call store_error_unit(in) + call ustop() + end if + ! + ! -- return + return + end function nodeu_from_string + + function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & + allow_zero) result(nodeu) +! ****************************************************************************** +! nodeu_from_cellid -- Receive cellid as a string and convert the string to a +! user nodenumber. +! If flag_string argument is present and true, the first token in string +! is allowed to be a string (e.g. boundary name). In this case, if a string +! is encountered, return value as -2. +! If allow_zero argument is present and true, if all indices equal zero, the +! result can be zero. If allow_zero is false, a zero in any index causes an +! error. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + integer(I4B) :: nodeu + ! -- dummy + class(GwfDisvType) :: this + character(len=*), intent(inout) :: cellid + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + logical, optional, intent(in) :: flag_string + logical, optional, intent(in) :: allow_zero + ! -- local + integer(I4B) :: j, k, nlay, nrow, ncpl + integer(I4B) :: lloclocal, ndum, istat, n + integer(I4B) :: istart, istop + real(DP) :: r + character(len=LINELENGTH) :: ermsg, fname +! ------------------------------------------------------------------------------ + ! + if (present(flag_string)) then + if (flag_string) then + ! Check to see if first token in cellid can be read as an integer. + lloclocal = 1 + call urword(cellid, lloclocal, istart, istop, 1, ndum, r, iout, inunit) + read(cellid(istart:istop), *, iostat=istat) n + if (istat /= 0) then + ! First token in cellid is not an integer; return flag to this effect. + nodeu = -2 + return + endif + endif + endif + ! + nlay = this%mshape(1) + nrow = 1 + ncpl = this%mshape(2) + ! + lloclocal = 1 + call urword(cellid, lloclocal, istart, istop, 2, k, r, iout, inunit) + call urword(cellid, lloclocal, istart, istop, 2, j, r, iout, inunit) + ! + if (k == 0 .and. j == 0) then + if (present(allow_zero)) then + if (allow_zero) then + nodeu = 0 + return + endif + endif + endif + ! + if(k < 1 .or. k > nlay) then + write(ermsg, *) ' Layer number in list is outside of the grid', k + call store_error(ermsg) + end if + if(j < 1 .or. j > ncpl) then + write(ermsg, *) ' Cell2d number in list is outside of the grid', j + call store_error(ermsg) + end if + nodeu = get_node(k, 1, j, nlay, nrow, ncpl) + ! + if(nodeu < 1 .or. nodeu > this%nodesuser) then + write(ermsg, *) ' Node number in list is outside of the grid', nodeu + call store_error(ermsg) + inquire(unit=inunit, name=fname) + call store_error('Error converting in file: ') + call store_error(trim(adjustl(fname))) + call store_error('Cell number cannot be determined in cellid: ') + call store_error(trim(adjustl(cellid))) + call store_error_unit(inunit) + call ustop() + end if + ! + ! -- return + return + end function nodeu_from_cellid + + logical function supports_layers(this) + implicit none + ! -- dummy + class(GwfDisvType) :: this + ! + supports_layers = .true. + return + end function supports_layers + + function get_ncpl(this) +! ****************************************************************************** +! get_ncpl -- Return number of cells per layer. This is ncpl +! for a DISV grid. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + integer(I4B) :: get_ncpl + ! -- dummy + class(GwfDisvType) :: this +! ------------------------------------------------------------------------------ + ! + get_ncpl = this%ncpl + ! + ! -- Return + return + end function get_ncpl + + subroutine read_int_array(this, line, lloc, istart, istop, iout, in, & + iarray, aname) +! ****************************************************************************** +! read_int_array -- Read a GWF integer array +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: urword + use SimModule, only: store_error, ustop + use ConstantsModule, only: LINELENGTH + ! -- dummy + class(GwfDisvType), intent(inout) :: this + character(len=*), intent(inout) :: line + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: iarray + character(len=*), intent(in) :: aname + ! -- local + integer(I4B) :: ival + real(DP) :: rval + integer(I4B) :: nlay + integer(I4B) :: nrow + integer(I4B) :: ncol + integer(I4B) :: nval + integer(I4B), dimension(:), pointer, contiguous :: itemp +! ------------------------------------------------------------------------------ + ! + ! -- Point the temporary pointer array, which is passed to the reading + ! subroutine. The temporary array will point to ibuff if it is a + ! reduced structured system, or to iarray if it is an unstructured + ! model. + nlay = this%mshape(1) + nrow = 1 + ncol = this%mshape(2) + ! + if(this%nodes < this%nodesuser) then + nval = this%nodesuser + itemp => this%ibuff + else + nval = this%nodes + itemp => iarray + endif + ! + ! -- Read the array + call urword(line, lloc, istart, istop, 1, ival, rval, iout, in) + if (line(istart:istop).EQ.'LAYERED') then + ! + ! -- Read layered input + call ReadArray(in, itemp, aname, this%ndim, ncol, nrow, nlay, nval, & + iout, 1, nlay) + else + ! + ! -- Read unstructured input + call ReadArray(in, itemp, aname, this%ndim, nval, iout, 0) + end if + ! + ! -- If reduced model, then need to copy from itemp(=>ibuff) to iarray + if(this%nodes < this%nodesuser) then + call this%fill_grid_array(itemp, iarray) + endif + ! + ! -- return + return + end subroutine read_int_array + + subroutine read_dbl_array(this, line, lloc, istart, istop, iout, in, & + darray, aname) +! ****************************************************************************** +! read_dbl_array -- Read a GWF double precision array +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: urword + use SimModule, only: ustop, store_error + use ConstantsModule, only: LINELENGTH + ! -- dummy + class(GwfDisvType), intent(inout) :: this + character(len=*), intent(inout) :: line + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout + real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray + character(len=*), intent(in) :: aname + ! -- local + integer(I4B) :: ival + real(DP) :: rval + integer(I4B) :: nlay + integer(I4B) :: nrow + integer(I4B) :: ncol + integer(I4B) :: nval + real(DP), dimension(:), pointer, contiguous :: dtemp +! ------------------------------------------------------------------------------ + ! + ! -- Point the temporary pointer array, which is passed to the reading + ! subroutine. The temporary array will point to dbuff if it is a + ! reduced structured system, or to darray if it is an unstructured + ! model. + nlay = this%mshape(1) + nrow = 1 + ncol = this%mshape(2) + ! + if(this%nodes < this%nodesuser) then + nval = this%nodesuser + dtemp => this%dbuff + else + nval = this%nodes + dtemp => darray + endif + ! + ! -- Read the array + call urword(line, lloc, istart, istop, 1, ival, rval, iout, in) + if (line(istart:istop).EQ.'LAYERED') then + ! + ! -- Read structured input + call ReadArray(in, dtemp, aname, this%ndim, ncol, nrow, nlay, nval, & + iout, 1, nlay) + else + ! + ! -- Read unstructured input + call ReadArray(in, dtemp, aname, this%ndim, nval, iout, 0) + end if + ! + ! -- If reduced model, then need to copy from dtemp(=>dbuff) to darray + if(this%nodes < this%nodesuser) then + call this%fill_grid_array(dtemp, darray) + endif + ! + ! -- return + return + end subroutine read_dbl_array + + subroutine read_layer_array(this, nodelist, darray, ncolbnd, maxbnd, & + icolbnd, aname, inunit, iout) +! ****************************************************************************** +! read_layer_array -- Read a 2d double array into col icolbnd of darray. +! For cells that are outside of the active domain, +! do not copy the array value into darray. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: get_node + ! -- dummy + class(GwfDisvType) :: this + integer(I4B), intent(in) :: ncolbnd + integer(I4B), intent(in) :: maxbnd + integer(I4B), dimension(maxbnd) :: nodelist + real(DP), dimension(ncolbnd, maxbnd), intent(inout) :: darray + integer(I4B), intent(in) :: icolbnd + character(len=*), intent(in) :: aname + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + ! -- local + integer(I4B) :: il, ir, ic, ncol, nrow, nlay, nval, ipos, noder, nodeu + logical :: found +! ------------------------------------------------------------------------------ + ! + nlay = this%mshape(1) + nrow = 1 + ncol = this%mshape(2) + ! + ! -- Read the array + nval = ncol * nrow + call ReadArray(inunit, this%dbuff, aname, this%ndim, nval, iout, 0) + ! + ! -- Copy array into bound + ipos = 1 + do ir = 1, nrow + columnloop: do ic = 1, ncol + ! + ! -- look down through all layers and see if nodeu == nodelist(ipos) + ! cycle if not, because node must be inactive or pass through + found = .false. + layerloop: do il = 1, nlay + nodeu = get_node(il, ir, ic, nlay, nrow, ncol) + noder = this%get_nodenumber(nodeu, 0) + if(noder == 0) cycle layerloop + if(noder == nodelist(ipos)) then + found = .true. + exit layerloop + endif + enddo layerloop + if(.not. found) cycle columnloop + ! + ! -- Assign the array value to darray + nodeu = get_node(1, ir, ic, nlay, nrow, ncol) + darray(icolbnd, ipos) = this%dbuff(nodeu) + ipos = ipos + 1 + ! + enddo columnloop + enddo + ! + ! -- return + end subroutine read_layer_array + + subroutine record_array(this, darray, iout, iprint, idataun, aname, & + cdatafmp, nvaluesp, nwidthp, editdesc, dinact) +! ****************************************************************************** +! record_array -- Record a double precision array. The array will be +! printed to an external file and/or written to an unformatted external file +! depending on the argument specifications. +! ****************************************************************************** +! +! SPECIFICATIONS: +! darray is the double precision array to record +! iout is the unit number for ascii output +! iprint is a flag indicating whether or not to print the array +! idataun is the unit number to which the array will be written in binary +! form; if negative then do not write by layers, write entire array +! aname is the text descriptor of the array +! cdatafmp is the fortran format for writing the array +! nvaluesp is the number of values per line for printing +! nwidthp is the width of the number for printing +! editdesc is the format type (I, G, F, S, E) +! dinact is the double precision value to use for cells that are excluded +! from the model domain +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfDisvType), intent(inout) :: this + real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray + integer(I4B), intent(in) :: iout + integer(I4B), intent(in) :: iprint + integer(I4B), intent(in) :: idataun + character(len=*), intent(in) :: aname + character(len=*), intent(in) :: cdatafmp + integer(I4B), intent(in) :: nvaluesp + integer(I4B), intent(in) :: nwidthp + character(len=*), intent(in) :: editdesc + real(DP), intent(in) :: dinact + ! -- local + integer(I4B) :: k, ifirst + integer(I4B) :: nlay + integer(I4B) :: nrow + integer(I4B) :: ncol + integer(I4B) :: nval + integer(I4B) :: nodeu, noder + integer(I4B) :: istart, istop + real(DP), dimension(:), pointer, contiguous :: dtemp + ! -- formats + character(len=*),parameter :: fmthsv = & + "(1X,/1X,a,' WILL BE SAVED ON UNIT ',I4, & + &' AT END OF TIME STEP',I5,', STRESS PERIOD ',I4)" +! ------------------------------------------------------------------------------ + ! + ! -- set variables + nlay = this%mshape(1) + nrow = 1 + ncol = this%mshape(2) + ! + ! -- If this is a reduced model, then copy the values from darray into + ! dtemp. + if(this%nodes < this%nodesuser) then + nval = this%nodes + dtemp => this%dbuff + do nodeu = 1, this%nodesuser + noder = this%get_nodenumber(nodeu, 0) + if(noder <= 0) then + dtemp(nodeu) = dinact + cycle + endif + dtemp(nodeu) = darray(noder) + enddo + else + nval = this%nodes + dtemp => darray + endif + ! + ! -- Print to iout if iprint /= 0 + if(iprint /= 0) then + istart = 1 + do k = 1, nlay + istop = istart + nrow * ncol - 1 + call ulaprufw(ncol, nrow, kstp, kper, k, iout, dtemp(istart:istop), & + aname, cdatafmp, nvaluesp, nwidthp, editdesc) + istart = istop + 1 + enddo + endif + ! + ! -- Save array to an external file. + if(idataun > 0) then + ! -- write to binary file by layer + ifirst = 1 + istart = 1 + do k=1, nlay + istop = istart + nrow * ncol - 1 + if(ifirst == 1) write(iout, fmthsv) & + trim(adjustl(aname)), idataun, & + kstp, kper + ifirst = 0 + call ulasav(dtemp(istart:istop), aname, kstp, kper, & + pertim, totim, ncol, nrow, k, idataun) + istart = istop + 1 + enddo + elseif(idataun < 0) then + ! + ! -- write entire array as one record + call ubdsv1(kstp, kper, aname, -idataun, dtemp, ncol, nrow, nlay, & + iout, delt, pertim, totim) + endif + ! + ! -- return + return + end subroutine record_array + + subroutine record_srcdst_list_header(this, text, textmodel, textpackage, & + dstmodel, dstpackage, naux, auxtxt, & + ibdchn, nlist, iout) +! ****************************************************************************** +! record_srcdst_list_header -- Record list header for imeth=6 +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfDisvType) :: this + character(len=16), intent(in) :: text + character(len=16), intent(in) :: textmodel + character(len=16), intent(in) :: textpackage + character(len=16), intent(in) :: dstmodel + character(len=16), intent(in) :: dstpackage + integer(I4B), intent(in) :: naux + character(len=16), dimension(:), intent(in) :: auxtxt + integer(I4B), intent(in) :: ibdchn + integer(I4B), intent(in) :: nlist + integer(I4B), intent(in) :: iout + ! -- local + integer(I4B) :: nlay, nrow, ncol +! ------------------------------------------------------------------------------ + ! + nlay = this%mshape(1) + nrow = 1 + ncol = this%mshape(2) + ! + ! -- Use ubdsv06 to write list header + call ubdsv06(kstp, kper, text, textmodel, textpackage, dstmodel, dstpackage,& + ibdchn, naux, auxtxt, ncol, nrow, nlay, & + nlist, iout, delt, pertim, totim) + ! + ! -- return + return + end subroutine record_srcdst_list_header + + subroutine nlarray_to_nodelist(this, nodelist, maxbnd, nbound, aname, & + inunit, iout) +! ****************************************************************************** +! nlarray_to_nodelist -- Read an integer array into nodelist. For structured +! model, integer array is layer number; for unstructured +! model, integer array is node number. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: get_node + use SimModule, only: ustop, store_error + use ConstantsModule, only: LINELENGTH + ! -- dummy + class(GwfDisvType) :: this + integer(I4B), intent(in) :: maxbnd + integer(I4B), dimension(maxbnd), intent(inout) :: nodelist + integer(I4B), intent(inout) :: nbound + character(len=*), intent(in) :: aname + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + ! -- local + integer(I4B) :: il, ir, ic, ncol, nrow, nlay, nval, nodeu, noder, ipos, ierr + character(len=LINELENGTH) :: errmsg +! ------------------------------------------------------------------------------ + ! + ! -- set variables + nlay = this%mshape(1) + nrow = 1 + ncol = this%mshape(2) + ! + nval = ncol * nrow + call ReadArray(inunit, this%ibuff, aname, this%ndim, nval, iout, 0) + ! + ! -- Copy array into nodelist + ipos = 1 + ierr = 0 + do ir = 1, nrow + do ic = 1, ncol + nodeu = get_node(1, ir, ic, nlay, nrow, ncol) + il = this%ibuff(nodeu) + if(il < 1 .or. il > nlay) then + write(errmsg, *) 'ERROR. INVALID LAYER NUMBER: ', il + call store_error(errmsg) + call ustop() + endif + nodeu = get_node(il, ir, ic, nlay, nrow, ncol) + noder = this%get_nodenumber(nodeu, 0) + if(noder > 0) then + if(ipos > maxbnd) then + ierr = ipos + else + nodelist(ipos) = noder + endif + ipos = ipos + 1 + endif + enddo + enddo + ! + ! -- Check for errors + nbound = ipos - 1 + if(ierr > 0) then + write(errmsg, *) 'ERROR. MAXBOUND DIMENSION IS TOO SMALL.' + call store_error(errmsg) + write(errmsg, *) 'INCREASE MAXBOUND TO: ', ierr + call store_error(errmsg) + call ustop() + endif + ! + ! -- If nbound < maxbnd, then initialize nodelist to zero in this range + if(nbound < maxbnd) then + do ipos = nbound+1, maxbnd + nodelist(ipos) = 0 + enddo + endif + ! + ! -- return + end subroutine nlarray_to_nodelist + +end module GwfDisvModule diff --git a/src/Model/GroundWaterFlow/gwf3drn8.f90 b/src/Model/GroundWaterFlow/gwf3drn8.f90 index 466d3e44a99..2704342b230 100644 --- a/src/Model/GroundWaterFlow/gwf3drn8.f90 +++ b/src/Model/GroundWaterFlow/gwf3drn8.f90 @@ -1,362 +1,362 @@ -module DrnModule - use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, LENFTYPE, LENPACKAGENAME - use BndModule, only: BndType - use ObsModule, only: DefaultObsIdProcessor - use TimeSeriesLinkModule, only: TimeSeriesLinkType, & - GetTimeSeriesLinkFromList - ! - implicit none - ! - private - public :: drn_create - public :: DrnType - ! - character(len=LENFTYPE) :: ftype = 'DRN' - character(len=LENPACKAGENAME) :: text = ' DRN' - ! - type, extends(BndType) :: DrnType - contains - procedure :: bnd_options => drn_options - procedure :: bnd_ck => drn_ck - procedure :: bnd_cf => drn_cf - procedure :: bnd_fc => drn_fc - procedure :: define_listlabel - ! -- methods for observations - procedure, public :: bnd_obs_supported => drn_obs_supported - procedure, public :: bnd_df_obs => drn_df_obs - ! -- method for time series - procedure, public :: bnd_rp_ts => drn_rp_ts - end type DrnType - -contains - - subroutine drn_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) -! ****************************************************************************** -! drn_create -- Create a New Drn Package -! Subroutine: (1) create new-style package -! (2) point packobj to the new package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout - character(len=*), intent(in) :: namemodel - character(len=*), intent(in) :: pakname - ! -- local - type(DrnType), pointer :: drnobj -! ------------------------------------------------------------------------------ - ! - ! -- allocate the object and assign values to object variables - allocate(drnobj) - packobj => drnobj - ! - ! -- create name and origin - call packobj%set_names(ibcnum, namemodel, pakname, ftype) - packobj%text = text - ! - ! -- allocate scalars - call drnobj%allocate_scalars() - !s - ! -- initialize package - call packobj%pack_initialize() - ! - ! -- initialize - packobj%inunit=inunit - packobj%iout=iout - packobj%id=id - packobj%ibcnum = ibcnum - packobj%ncolbnd=2 ! drnelev, conductance - packobj%iscloc=2 !sfac applies to conductance - packobj%ictorigin = 'NPF' - ! - ! -- return - return - end subroutine drn_create - - subroutine drn_options(this, option, found) -! ****************************************************************************** -! drn_options -- set options specific to DrnType -! -! drn_options overrides BndType%bnd_options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use InputOutputModule, only: urword - ! -- dummy - class(DrnType), intent(inout) :: this - character(len=*), intent(inout) :: option - logical, intent(inout) :: found - ! -- local -! ------------------------------------------------------------------------------ - ! - select case (option) - case('MOVER') - this%imover = 1 - write(this%iout, '(4x,A)') 'MOVER OPTION ENABLED' - found = .true. - case default - ! - ! -- No options found - found = .false. - end select - ! - ! -- return - return - end subroutine drn_options - - subroutine drn_ck(this) -! ****************************************************************************** -! drn_ck -- Check drain boundary condition data -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors, store_error_unit - ! -- dummy - class(DrnType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: errmsg - integer(I4B) :: i - integer(I4B) :: node - real(DP) :: bt - ! -- formats - character(len=*), parameter :: fmtdrnerr = & - "('DRN BOUNDARY (',i0,') ELEVATION (',f10.3,') IS LESS THAN CELL " // & - "BOTTOM (',f10.3,')')" -! ------------------------------------------------------------------------------ - ! - ! -- check stress period data - do i = 1, this%nbound - node = this%nodelist(i) - bt = this%dis%bot(node) - ! -- accumulate errors - if (this%bound(1,i) < bt .and. this%icelltype(node) /= 0) then - write(errmsg, fmt=fmtdrnerr) i, this%bound(1,i), bt - call store_error(errmsg) - end if - end do - ! - ! -- write summary of drain package error messages - if (count_errors() > 0) then - call store_error_unit(this%inunit) - call ustop() - end if - ! - ! -- return - return - end subroutine drn_ck - - subroutine drn_cf(this, reset_mover) -! ****************************************************************************** -! drn_cf -- Formulate the HCOF and RHS terms -! Subroutine: (1) skip if no drains -! (2) calculate hcof and rhs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(DrnType) :: this - logical, intent(in), optional :: reset_mover - ! -- local - integer(I4B) :: i, node - real(DP) :: drnelev, cdrn - logical :: lrm -! ------------------------------------------------------------------------------ - ! - ! -- Return if no drains - if(this%nbound == 0) return - ! - ! -- pakmvrobj cf - lrm = .true. - if (present(reset_mover)) lrm = reset_mover - if(this%imover == 1 .and. lrm) then - call this%pakmvrobj%cf() - endif - ! - ! -- Calculate hcof and rhs for each drn entry - do i = 1, this%nbound - node = this%nodelist(i) - if(this%ibound(node) <= 0) then - this%hcof(i) = DZERO - this%rhs(i) = DZERO - cycle - endif - drnelev = this%bound(1,i) - cdrn = this%bound(2,i) - if(this%xnew(node) <= drnelev) then - this%rhs(i) = DZERO - this%hcof(i) = DZERO - else - this%rhs(i) = -cdrn * drnelev - this%hcof(i) = -cdrn - endif - enddo - ! - ! -- return - return - end subroutine drn_cf - - subroutine drn_fc(this, rhs, ia, idxglo, amatsln) -! ************************************************************************** -! drn_fc -- Copy rhs and hcof into solution rhs and amat -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - ! -- dummy - class(DrnType) :: this - real(DP), dimension(:), intent(inout) :: rhs - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln - ! -- local - integer(I4B) :: i, n, ipos - real(DP) :: drncond, drnelev, qdrn -! -------------------------------------------------------------------------- - ! - ! -- packmvrobj fc - if(this%imover == 1) then - call this%pakmvrobj%fc() - endif - ! - ! -- Copy package rhs and hcof into solution rhs and amat - do i = 1, this%nbound - n = this%nodelist(i) - rhs(n) = rhs(n) + this%rhs(i) - ipos = ia(n) - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) - ! - ! -- If mover is active and this drain is discharging, - ! store available water (as positive value). - drnelev = this%bound(1,i) - if(this%imover == 1 .and. this%xnew(n) > drnelev) then - drncond = this%bound(2,i) - qdrn = drncond * (this%xnew(n) - drnelev) - call this%pakmvrobj%accumulate_qformvr(i, qdrn) - endif - enddo - ! - ! -- return - return - end subroutine drn_fc - - subroutine define_listlabel(this) -! ****************************************************************************** -! define_listlabel -- Define the list heading that is written to iout when -! PRINT_INPUT option is used. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(DrnType), intent(inout) :: this -! ------------------------------------------------------------------------------ - ! - ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' - else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'DRAIN EL.' - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'CONDUCTANCE' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif - ! - ! -- return - return - end subroutine define_listlabel - - ! -- Procedures related to observations - - logical function drn_obs_supported(this) -! ****************************************************************************** -! drn_obs_supported -! -- Return true because DRN package supports observations. -! -- Overrides BndType%bnd_obs_supported() -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - class(DrnType) :: this -! ------------------------------------------------------------------------------ - drn_obs_supported = .true. - ! - ! -- return - return - end function drn_obs_supported - - subroutine drn_df_obs(this) -! ****************************************************************************** -! drn_df_obs (implements bnd_df_obs) -! -- Store observation type supported by DRN package. -! -- Overrides BndType%bnd_df_obs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - class(DrnType) :: this - ! -- local - integer(I4B) :: indx -! ------------------------------------------------------------------------------ - call this%obs%StoreObsType('drn', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor - ! - ! -- Store obs type and assign procedure pointer - ! for to-mvr observation type. - call this%obs%StoreObsType('to-mvr', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor - ! - ! -- return - return - end subroutine drn_df_obs - - ! -- Procedure related to time series - - subroutine drn_rp_ts(this) - ! -- Assign tsLink%Text appropriately for - ! all time series in use by package. - ! In DRN package variables ELEV and COND - ! can be controlled by time series. - ! -- dummy - class(DrnType), intent(inout) :: this - ! -- local - integer(I4B) :: i, nlinks - type(TimeSeriesLinkType), pointer :: tslink => null() - ! - nlinks = this%TsManager%boundtslinks%Count() - do i=1,nlinks - tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) - if (associated(tslink)) then - select case (tslink%JCol) - case (1) - tslink%Text = 'ELEV' - case (2) - tslink%Text = 'COND' - end select - endif - enddo - ! - return - end subroutine drn_rp_ts - -end module DrnModule +module DrnModule + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, LENFTYPE, LENPACKAGENAME + use BndModule, only: BndType + use ObsModule, only: DefaultObsIdProcessor + use TimeSeriesLinkModule, only: TimeSeriesLinkType, & + GetTimeSeriesLinkFromList + ! + implicit none + ! + private + public :: drn_create + public :: DrnType + ! + character(len=LENFTYPE) :: ftype = 'DRN' + character(len=LENPACKAGENAME) :: text = ' DRN' + ! + type, extends(BndType) :: DrnType + contains + procedure :: bnd_options => drn_options + procedure :: bnd_ck => drn_ck + procedure :: bnd_cf => drn_cf + procedure :: bnd_fc => drn_fc + procedure :: define_listlabel + ! -- methods for observations + procedure, public :: bnd_obs_supported => drn_obs_supported + procedure, public :: bnd_df_obs => drn_df_obs + ! -- method for time series + procedure, public :: bnd_rp_ts => drn_rp_ts + end type DrnType + +contains + + subroutine drn_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) +! ****************************************************************************** +! drn_create -- Create a New Drn Package +! Subroutine: (1) create new-style package +! (2) point packobj to the new package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BndType), pointer :: packobj + integer(I4B),intent(in) :: id + integer(I4B),intent(in) :: ibcnum + integer(I4B),intent(in) :: inunit + integer(I4B),intent(in) :: iout + character(len=*), intent(in) :: namemodel + character(len=*), intent(in) :: pakname + ! -- local + type(DrnType), pointer :: drnobj +! ------------------------------------------------------------------------------ + ! + ! -- allocate the object and assign values to object variables + allocate(drnobj) + packobj => drnobj + ! + ! -- create name and origin + call packobj%set_names(ibcnum, namemodel, pakname, ftype) + packobj%text = text + ! + ! -- allocate scalars + call drnobj%allocate_scalars() + !s + ! -- initialize package + call packobj%pack_initialize() + ! + ! -- initialize + packobj%inunit=inunit + packobj%iout=iout + packobj%id=id + packobj%ibcnum = ibcnum + packobj%ncolbnd=2 ! drnelev, conductance + packobj%iscloc=2 !sfac applies to conductance + packobj%ictorigin = 'NPF' + ! + ! -- return + return + end subroutine drn_create + + subroutine drn_options(this, option, found) +! ****************************************************************************** +! drn_options -- set options specific to DrnType +! +! drn_options overrides BndType%bnd_options +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use InputOutputModule, only: urword + ! -- dummy + class(DrnType), intent(inout) :: this + character(len=*), intent(inout) :: option + logical, intent(inout) :: found + ! -- local +! ------------------------------------------------------------------------------ + ! + select case (option) + case('MOVER') + this%imover = 1 + write(this%iout, '(4x,A)') 'MOVER OPTION ENABLED' + found = .true. + case default + ! + ! -- No options found + found = .false. + end select + ! + ! -- return + return + end subroutine drn_options + + subroutine drn_ck(this) +! ****************************************************************************** +! drn_ck -- Check drain boundary condition data +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors, store_error_unit + ! -- dummy + class(DrnType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + integer(I4B) :: i + integer(I4B) :: node + real(DP) :: bt + ! -- formats + character(len=*), parameter :: fmtdrnerr = & + "('DRN BOUNDARY (',i0,') ELEVATION (',f10.3,') IS LESS THAN CELL " // & + "BOTTOM (',f10.3,')')" +! ------------------------------------------------------------------------------ + ! + ! -- check stress period data + do i = 1, this%nbound + node = this%nodelist(i) + bt = this%dis%bot(node) + ! -- accumulate errors + if (this%bound(1,i) < bt .and. this%icelltype(node) /= 0) then + write(errmsg, fmt=fmtdrnerr) i, this%bound(1,i), bt + call store_error(errmsg) + end if + end do + ! + ! -- write summary of drain package error messages + if (count_errors() > 0) then + call store_error_unit(this%inunit) + call ustop() + end if + ! + ! -- return + return + end subroutine drn_ck + + subroutine drn_cf(this, reset_mover) +! ****************************************************************************** +! drn_cf -- Formulate the HCOF and RHS terms +! Subroutine: (1) skip if no drains +! (2) calculate hcof and rhs +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(DrnType) :: this + logical, intent(in), optional :: reset_mover + ! -- local + integer(I4B) :: i, node + real(DP) :: drnelev, cdrn + logical :: lrm +! ------------------------------------------------------------------------------ + ! + ! -- Return if no drains + if(this%nbound == 0) return + ! + ! -- pakmvrobj cf + lrm = .true. + if (present(reset_mover)) lrm = reset_mover + if(this%imover == 1 .and. lrm) then + call this%pakmvrobj%cf() + endif + ! + ! -- Calculate hcof and rhs for each drn entry + do i = 1, this%nbound + node = this%nodelist(i) + if(this%ibound(node) <= 0) then + this%hcof(i) = DZERO + this%rhs(i) = DZERO + cycle + endif + drnelev = this%bound(1,i) + cdrn = this%bound(2,i) + if(this%xnew(node) <= drnelev) then + this%rhs(i) = DZERO + this%hcof(i) = DZERO + else + this%rhs(i) = -cdrn * drnelev + this%hcof(i) = -cdrn + endif + enddo + ! + ! -- return + return + end subroutine drn_cf + + subroutine drn_fc(this, rhs, ia, idxglo, amatsln) +! ************************************************************************** +! drn_fc -- Copy rhs and hcof into solution rhs and amat +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + ! -- dummy + class(DrnType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + real(DP), dimension(:), intent(inout) :: amatsln + ! -- local + integer(I4B) :: i, n, ipos + real(DP) :: drncond, drnelev, qdrn +! -------------------------------------------------------------------------- + ! + ! -- packmvrobj fc + if(this%imover == 1) then + call this%pakmvrobj%fc() + endif + ! + ! -- Copy package rhs and hcof into solution rhs and amat + do i = 1, this%nbound + n = this%nodelist(i) + rhs(n) = rhs(n) + this%rhs(i) + ipos = ia(n) + amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) + ! + ! -- If mover is active and this drain is discharging, + ! store available water (as positive value). + drnelev = this%bound(1,i) + if(this%imover == 1 .and. this%xnew(n) > drnelev) then + drncond = this%bound(2,i) + qdrn = drncond * (this%xnew(n) - drnelev) + call this%pakmvrobj%accumulate_qformvr(i, qdrn) + endif + enddo + ! + ! -- return + return + end subroutine drn_fc + + subroutine define_listlabel(this) +! ****************************************************************************** +! define_listlabel -- Define the list heading that is written to iout when +! PRINT_INPUT option is used. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(DrnType), intent(inout) :: this +! ------------------------------------------------------------------------------ + ! + ! -- create the header list label + this%listlabel = trim(this%filtyp) // ' NO.' + if(this%dis%ndim == 3) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif(this%dis%ndim == 2) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + else + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + endif + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'DRAIN EL.' + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'CONDUCTANCE' + if(this%inamedbound == 1) then + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + endif + ! + ! -- return + return + end subroutine define_listlabel + + ! -- Procedures related to observations + + logical function drn_obs_supported(this) +! ****************************************************************************** +! drn_obs_supported +! -- Return true because DRN package supports observations. +! -- Overrides BndType%bnd_obs_supported() +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + class(DrnType) :: this +! ------------------------------------------------------------------------------ + drn_obs_supported = .true. + ! + ! -- return + return + end function drn_obs_supported + + subroutine drn_df_obs(this) +! ****************************************************************************** +! drn_df_obs (implements bnd_df_obs) +! -- Store observation type supported by DRN package. +! -- Overrides BndType%bnd_df_obs +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + ! -- dummy + class(DrnType) :: this + ! -- local + integer(I4B) :: indx +! ------------------------------------------------------------------------------ + call this%obs%StoreObsType('drn', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor + ! + ! -- Store obs type and assign procedure pointer + ! for to-mvr observation type. + call this%obs%StoreObsType('to-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor + ! + ! -- return + return + end subroutine drn_df_obs + + ! -- Procedure related to time series + + subroutine drn_rp_ts(this) + ! -- Assign tsLink%Text appropriately for + ! all time series in use by package. + ! In DRN package variables ELEV and COND + ! can be controlled by time series. + ! -- dummy + class(DrnType), intent(inout) :: this + ! -- local + integer(I4B) :: i, nlinks + type(TimeSeriesLinkType), pointer :: tslink => null() + ! + nlinks = this%TsManager%boundtslinks%Count() + do i=1,nlinks + tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) + if (associated(tslink)) then + select case (tslink%JCol) + case (1) + tslink%Text = 'ELEV' + case (2) + tslink%Text = 'COND' + end select + endif + enddo + ! + return + end subroutine drn_rp_ts + +end module DrnModule diff --git a/src/Model/GroundWaterFlow/gwf3evt8.f90 b/src/Model/GroundWaterFlow/gwf3evt8.f90 index fdbce22f112..82612fdf35d 100644 --- a/src/Model/GroundWaterFlow/gwf3evt8.f90 +++ b/src/Model/GroundWaterFlow/gwf3evt8.f90 @@ -1,1229 +1,1229 @@ -module EvtModule - ! - use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, DONE, LENFTYPE, LENPACKAGENAME, MAXCHARLEN - use BndModule, only: BndType - use SimModule, only: store_error, store_error_unit, ustop - use ObsModule, only: DefaultObsIdProcessor - use TimeArraySeriesLinkModule, only: TimeArraySeriesLinkType - use TimeSeriesLinkModule, only: TimeSeriesLinkType, & - GetTimeSeriesLinkFromList - use BlockParserModule, only: BlockParserType - ! - implicit none - ! - private - public :: evt_create - ! - character(len=LENFTYPE) :: ftype = 'EVT' - character(len=LENPACKAGENAME) :: text = ' EVT' - ! - type, extends(BndType) :: EvtType - ! -- logicals - logical, private :: segsdefined = .true. - logical, private :: fixed_cell = .false. - logical, private :: read_as_arrays = .false. - logical, private:: surfratespecified = .false. - ! -- integers - integer(I4B), pointer :: inievt => null() - integer(I4B), pointer, private :: nseg => null() - ! -- arrays - integer(I4B), dimension(:), pointer, contiguous :: nodesontop => null() - contains - procedure :: evt_allocate_scalars - procedure :: bnd_options => evt_options - procedure :: read_dimensions => evt_read_dimensions - procedure :: read_initial_attr => evt_read_initial_attr - procedure :: bnd_rp => evt_rp - procedure :: set_nodesontop - procedure :: bnd_cf => evt_cf - procedure :: bnd_fc => evt_fc - procedure :: bnd_da => evt_da - procedure :: define_listlabel => evt_define_listlabel - procedure, private :: evt_rp_array - procedure, private :: evt_rp_list - procedure, private :: default_nodelist - ! -- for observations - procedure, public :: bnd_obs_supported => evt_obs_supported - procedure, public :: bnd_df_obs => evt_df_obs - ! -- for time series - procedure, public :: bnd_rp_ts => evt_rp_ts - end type EvtType - - ! EVT uses BndType%bound array columns: - ! Index Description old name Keyword - ! (1,n) ET Surface elevation ETSS SURFACE - ! (2,n) Max ET Rate ETSR RATE - ! (3,n) Extinction Depth ETSX DEPTH - ! Used only if nseg > 1 and surfratespecified is false: - ! 4->2+nseg Proportion of Extinction Depth PXDP PXDP - ! 3+nseg->3+2(nseg-1) Proportion of Max ET Rate PETM PETM - ! If nseg > 1 and surfratespecified is true: - ! 4->3+nseg Proportion of Extinction Depth PXDP PXDP - ! 4+nseg->3+2(nseg) Proportion of Max ET Rate PETM PETM - - contains - - subroutine evt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) -! ****************************************************************************** -! evt_create -- Create a new Evapotranspiration Segments Package -! Subroutine: (1) create new-style package -! (2) point packobj to the new package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout - character(len=*), intent(in) :: namemodel - character(len=*), intent(in) :: pakname - ! -- local - type(EvtType), pointer :: evtobj -! ------------------------------------------------------------------------------ - ! - ! -- allocate evt object and scalar variables - allocate(evtobj) - packobj => evtobj - ! - ! -- create name and origin - call packobj%set_names(ibcnum, namemodel, pakname, ftype) - packobj%text = text - ! - ! -- allocate scalars - call evtobj%evt_allocate_scalars() - ! - ! -- initialize package - call packobj%pack_initialize() - - packobj%inunit = inunit - packobj%iout = iout - packobj%id = id - packobj%ibcnum = ibcnum - packobj%ncolbnd = 3 ! Assumes NSEG = 1 - packobj%iscloc = 2 ! sfac applies to max. ET rate - packobj%ictorigin = 'NPF' - ! indxconvertflux is Column index of bound that will be multiplied by - ! cell area to convert flux rates to flow rates - packobj%indxconvertflux = 2 - packobj%AllowTimeArraySeries = .true. - ! - ! -- return - return - end subroutine evt_create - - subroutine evt_allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -- allocate scalar members -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(EvtType), intent(inout) :: this -! ------------------------------------------------------------------------------ - ! - ! -- call standard BndType allocate scalars - call this%BndType%allocate_scalars() - ! - ! -- allocate the object and assign values to object variables - call mem_allocate(this%inievt, 'INIEVT', this%origin) - call mem_allocate(this%nseg, 'NSEG', this%origin) - ! - ! -- Set values - this%inievt = 0 - this%nseg = 1 - this%fixed_cell = .false. - ! - ! -- return - return - end subroutine evt_allocate_scalars - - subroutine evt_options(this, option, found) -! ****************************************************************************** -! evt_options -- set options specific to EvtType -! evt_options overrides BndType%bnd_options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(EvtType), intent(inout) :: this - character(len=*), intent(inout) :: option - logical, intent(inout) :: found - ! -- local - character(len=MAXCHARLEN) :: ermsg - ! -- formats - character(len=*),parameter :: fmtihact = & - "(4x, 'EVAPOTRANSPIRATION WILL BE APPLIED TO HIGHEST ACTIVE CELL.')" - character(len=*),parameter :: fmtfixedcell = & - "(4x, 'EVAPOTRANSPIRATION WILL BE APPLIED TO SPECIFIED CELL.')" - character(len=*), parameter :: fmtreadasarrays = & - "(4x, 'EVAPOTRANSPIRATION INPUT WILL BE READ AS ARRAYS.')" - character(len=*), parameter :: fmtsrz = & - "(4x, 'ET RATE AT SURFACE WILL BE ZERO.')" - character(len=*), parameter :: fmtsrs = & - "(4x, 'ET RATE AT SURFACE WILL BE AS SPECIFIED BY PETM0.')" -! ------------------------------------------------------------------------------ - ! - ! -- Check for FIXED_CELL AND LAYERED - select case (option) - case ('FIXED_CELL') - this%fixed_cell = .true. - write(this%iout, fmtfixedcell) - found = .true. - case ('SURF_RATE_SPECIFIED') - this%surfratespecified = .true. - write(this%iout, fmtsrs) - found = .true. - ! - if (this%read_as_arrays) then - ermsg = 'READASARRAYS option is not compatible with the' // & - ' SURF_RATE_SPECIFIED option.' - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - case ('READASARRAYS') - if (this%dis%supports_layers()) then - this%read_as_arrays = .true. - else - ermsg = 'READASARRAYS option is not compatible with selected' // & - ' discretization type.' - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - if (this%surfratespecified) then - ermsg = 'READASARRAYS option is not compatible with the' // & - ' SURF_RATE_SPECIFIED option.' - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Write option - write(this%iout, fmtreadasarrays) - ! - found = .true. - case default - ! - ! -- No options found - found = .false. - end select - ! - ! -- return - return - end subroutine evt_options - - subroutine evt_read_dimensions(this) -! ****************************************************************************** -! bnd_read_dimensions -- Read the dimensions for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, store_error_unit - ! -- dummy - class(EvtType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock - ! -- format - character(len=*), parameter :: fmtnsegerr = & - "('Error: In EVT, NSEG must be > 0 but is specified as ',i0)" -! ------------------------------------------------------------------------------ - ! - ! Dimensions block is not required if: - ! (1) discretization is DIS or DISV, and - ! (2) READASARRAYS option has been specified. - if (this%read_as_arrays) then - this%maxbound = this%dis%get_ncpl() - else - ! -- 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 '//trim(adjustl(this%text))// & - ' DIMENSIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('MAXBOUND') - if (this%read_as_arrays) then - errmsg = 'When READASARRAYS option is used for the selected' // & - ' discretization package, MAXBOUND may not be specified.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - else - this%maxbound = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)') 'MAXBOUND = ', this%maxbound - endif - case ('NSEG') - this%nseg = this%parser%GetInteger() - write(this%iout,'(4x,a,i0)') 'NSEG = ', this%nseg - if (this%nseg < 1) then - write(errmsg,fmtnsegerr)this%nseg - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - elseif (this%nseg > 1) then - ! NSEG>1 is supported only if readasarrays is false - if (this%read_as_arrays) then - errmsg = 'In the EVT package, NSEG cannot be greater than 1' // & - ' when READASARRAYS is used.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! -- Recalculate number of columns required in bound array. - if (this%surfratespecified) then - this%ncolbnd = 4 + 2*(this%nseg-1) - else - this%ncolbnd = 3 + 2*(this%nseg-1) - endif - endif - case default - write(errmsg,'(4x,a,a)') & - '****ERROR. UNKNOWN '//trim(this%text)//' DIMENSION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - end do - ! - write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' DIMENSIONS' - else - call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') - call this%parser%StoreErrorUnit() - call ustop() - endif - endif - ! - ! -- verify dimensions were set - if(this%maxbound <= 0) then - write(errmsg, '(1x,a)') & - 'ERROR. MAXBOUND MUST BE AN INTEGER GREATER THAN ZERO.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Call define_listlabel to construct the list label that is written - ! when PRINT_INPUT option is used. - call this%define_listlabel() - ! - ! -- return - return - end subroutine evt_read_dimensions - - subroutine evt_read_initial_attr(this) -! ****************************************************************************** -! evt_read_initial_attr -- Part of allocate and read -! If READASARRAYS has been specified, assign default IEVT = 1 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(EvtType),intent(inout) :: this - ! - if (this%read_as_arrays) then - call this%default_nodelist() - endif - ! - return - end subroutine evt_read_initial_attr - - subroutine evt_rp(this) -! ****************************************************************************** -! evt_rp -- Read and Prepare -! Read new boundaries -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use TdisModule, only: kper, nper - use SimModule, only: ustop, store_error - use ArrayHandlersModule, only: ifind - ! -- dummy - class(EvtType),intent(inout) :: this - ! -- local - integer(I4B) :: ierr - integer(I4B) :: node, n - integer(I4B) :: inievt, inrate, insurf, indepth - integer(I4B) :: kpxdp, kpetm - logical :: isfound, supportopenclose - character(len=LINELENGTH) :: line, msg, errmsg - ! -- formats - character(len=*),parameter :: fmtblkerr = & - "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - character(len=*),parameter :: fmtlsp = & - "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" - character(len=*), parameter :: fmtnbd = & - "(1X,/1X,'THE NUMBER OF ACTIVE ',A,'S (',I6," // & - "') IS GREATER THAN MAXIMUM(',I6,')')" -! ------------------------------------------------------------------------------ - ! - ! -- Set ionper to the stress period number for which a new block of data - ! will be read. - if(this%inunit == 0) return - ! - ! -- get stress period data - if (this%ionper < kper) then - ! - ! -- get period block - supportopenclose = .not. this%read_as_arrays - ! When reading a list, OPEN/CLOSE is handled by list reader, - ! so supportOpenClose needs to be false in call the GetBlock. - ! When reading as arrays, set supportOpenClose as desired. - call this%parser%GetBlock('PERIOD', isfound, ierr) - if(isfound) then - ! - ! -- read ionper and check for increasing period numbers - call this%read_check_ionper() - else - ! - ! -- PERIOD block not found - if (ierr < 0) then - ! -- End of file found; data applies for remainder of simulation. - this%ionper = nper + 1 - else - ! -- Found invalid block - write(errmsg, fmtblkerr) adjustl(trim(line)) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - endif - end if - ! - ! -- Read data if ionper == kper - inrate = 0 - insurf = 0 - indepth = 0 - inievt = 0 - if (this%ionper == kper) then - ! - ! -- Remove all time-series links associated with this package - call this%TsManager%Reset(this%name) - call this%TasManager%Reset(this%name) - ! - ! -- Read IEVT, SURFACE, RATE, DEPTH, PXDP, PETM, and AUX - ! variables, if any - kpetm = 0 - kpxdp = 0 - ! - if (.not. this%read_as_arrays) then - ! -- Read EVT input as a list - call this%evt_rp_list(inrate) - else - ! -- Read Evt input as arrays - call this%evt_rp_array(line, inrate, insurf, indepth, & - kpxdp, kpetm) - endif - ! - ! -- Ensure that all required PXDP and PETM arrays - ! have been defined or redefined. - if (this%surfratespecified) then - if (kpxdp == this%nseg .and. kpxdp == this%nseg) then - this%segsdefined = .true. - endif - else - if (kpxdp == this%nseg-1 .and. kpxdp == this%nseg-1) then - this%segsdefined = .true. - endif - endif - if (.not. this%segsdefined) then - msg = 'Error in EVT input: Definition of PXDP or PETM is incomplete.' - call store_error(msg) - call this%parser%StoreErrorUnit() - call ustop() - endif - else - write(this%iout,fmtlsp) trim(this%filtyp) - endif - ! - ! -- If rate was read, then multiply by cell area. If inrate = 2, then - ! rate is begin managed as a time series, and the time series object - ! will multiply the rate by the cell area. - if (inrate == 1) then - do n = 1, this%nbound - node = this%nodelist(n) - this%bound(2, n) = this%bound(2, n) * this%dis%get_area(node) - enddo - endif - ! - ! -- return - return - end subroutine evt_rp - - subroutine set_nodesontop(this) -! ****************************************************************************** -! set_nodesontop -- store nodelist in nodesontop -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(EvtType),intent(inout) :: this - ! -- local - integer(I4B) :: n - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- allocate if necessary - if(.not. associated(this%nodesontop)) then - allocate(this%nodesontop(this%maxbound)) - endif - ! - ! -- copy nodelist into nodesontop - do n = 1, this%nbound - this%nodesontop(n) = this%nodelist(n) - enddo - ! - ! -- return - return - end subroutine set_nodesontop - - subroutine evt_cf(this, reset_mover) -! ****************************************************************************** -! evt_cf -- Formulate the HCOF and RHS terms -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(EvtType) :: this - logical, intent(in), optional :: reset_mover - ! -- local - integer(I4B) :: i, iseg, node - integer(I4B) :: idxdepth, idxrate - real(DP) :: c, d, h, s, x - real(DP) :: petm0 - real(DP) :: petm1, petm2, pxdp1, pxdp2, thcof, trhs -! ------------------------------------------------------------------------------ - ! - ! -- Return if no ET nodes - if (this%nbound == 0) return - ! - ! -- Calculate hcof and rhs for each ET node - do i=1,this%nbound - ! - ! -- Find the node number - if (this%fixed_cell) then - node = this%nodelist(i) - else - node = this%nodesontop(i) - if (this%ibound(node) == 0) & - call this%dis%highest_active(node, this%ibound) - this%nodelist(i) = node - endif - ! - ! -- set rhs and hcof to zero - this%rhs(i) = DZERO - this%hcof(i) = DZERO - ! - ! -- if ibound is positive, then add terms - if (this%ibound(node) > 0) then - ! - c = this%bound(2,i) ! RATE -- max. ET rate - s = this%bound(1,i) ! SURFACE -- ET surface elevation - h = this%xnew(node) - if (this%surfratespecified) then - petm0 = this%bound(4+2*(this%nseg-1),i) ! PETM0 - endif - ! - ! -- If head in cell is greater than or equal to SURFACE, ET is constant - if (h >= s) then - if (this%surfratespecified) then - ! -- Subtract -PETM0 * max rate from RHS - this%rhs(i) = this%rhs(i) + petm0 * c - else - ! -- Subtract -RATE from RHS - this%rhs(i) = this%rhs(i) + c - endif - else - ! -- If depth to water >= extinction depth, then ET is 0 - d = S - h - x = this%bound(3,i) ! DEPTH -- extinction depth - if (d < x) then - ! -- Variable range. add ET terms to both RHS and HCOF. - if (this%nseg > 1) then - ! -- Determine which segment applies based on head, and - ! calculate terms to add to RHS and HCOF - ! - ! -- Set proportions corresponding to surface elevation - ! and initial indices for depth and rate. - ! -- Idxdepth will point to the elements of bound containing - ! proportion of depth at the bottom of each segment. - ! Idxrate will point to the elements of bound containing - ! proportion of ET rate at the bottom of each segment. - ! If surfratespecified is true, skip over the elements - ! containing pxdp0 (=0.0) and petm0. - pxdp1 = DZERO - if (this%surfratespecified) then - petm1 = petm0 - else - petm1 = DONE - endif - ! -- Initialize indices to point to elements preceding - ! pxdp1 and petm1 (values for lower end of segment 1). - idxdepth = 3 - idxrate = 2 + this%nseg - ! -- Iterate through segments to find segment that contains - ! current depth of head below ET surface. - segloop: do iseg = 1, this%nseg - ! -- Set proportions corresponding to lower end of - ! segment - if (iseg < this%nseg) then - ! -- Increment the indices for depth and rate - idxdepth = idxdepth + 1 - idxrate = idxrate + 1 - ! -- Get proportions for lower end of segment - pxdp2 = this%bound(idxdepth,i) - petm2 = this%bound(idxrate,i) - else - pxdp2 = DONE - petm2 = DZERO - endif - if (d <= pxdp2*x) then - ! -- head is in domain of this segment - exit segloop - endif - ! -- Proportions at lower end of segment will be for - ! upper end of segment next time through loop - pxdp1 = pxdp2 - petm1 = petm2 - enddo segloop - ! -- Calculate terms to add to RHS and HCOF based on - ! segment that applies at head elevation - thcof = - (petm1 - petm2) * c / ((pxdp2 - pxdp1) * x) - trhs = thcof * (s - pxdp1 * x) + petm1 * c - else - ! -- Calculate terms to add to RHS and HCOF based on simple - ! linear relation of ET vs. head for single segment - trhs = c - c * s / x - thcof = -c / x - endif - this%rhs(i) = this%rhs(i) + trhs - this%hcof(i) = this%hcof(i) + thcof - endif - endif - endif - ! - enddo - ! - ! -- return - return - end subroutine evt_cf - - subroutine evt_fc(this, rhs, ia, idxglo, amatsln) -! ************************************************************************** -! evt_fc -- Copy rhs and hcof into solution rhs and amat -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - ! -- dummy - class(EvtType) :: this - real(DP), dimension(:), intent(inout) :: rhs - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln - ! -- local - integer(I4B) :: i, n, ipos -! -------------------------------------------------------------------------- - ! - ! -- Copy package rhs and hcof into solution rhs and amat - do i = 1, this%nbound - n = this%nodelist(i) - ! -- reset hcof and rhs for excluded cells - if (this%ibound(n) == 10000) then - this%hcof(i) = DZERO - this%rhs(i) = DZERO - cycle - end if - rhs(n) = rhs(n) + this%rhs(i) - ipos = ia(n) - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) - enddo - ! - ! -- return - return - end subroutine evt_fc - - subroutine evt_da(this) -! ****************************************************************************** -! evt_da -- deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(EvtType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- arrays - if(associated(this%nodesontop)) deallocate(this%nodesontop) - ! - ! -- scalars - call mem_deallocate(this%inievt) - call mem_deallocate(this%nseg) - ! - ! -- Deallocate parent package - call this%BndType%bnd_da() - ! - ! -- return - return - end subroutine evt_da - - subroutine evt_rp_array(this, line, inrate, insurf, indepth, & - kpxdp, kpetm) -! ****************************************************************************** -! evt_rp_array -- Read and Prepare EVT as arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LENTIMESERIESNAME, LINELENGTH - use SimModule, only: ustop, store_error - use ArrayHandlersModule, only: ifind - ! -- dummy - class(EvtType), intent(inout) :: this - character(len=LINELENGTH), intent(inout) :: line - integer(I4B), intent(inout) :: inrate - integer(I4B), intent(inout) :: insurf - integer(I4B), intent(inout) :: indepth - integer(I4B), intent(inout) :: kpxdp - integer(I4B), intent(inout) :: kpetm - ! -- local - integer(I4B) :: n - integer(I4B) :: indx, ipos - integer(I4B) :: jcol, jauxcol, lpos, ivarsread - character(len=LENTIMESERIESNAME) :: tasName - character(len=24), dimension(6) :: aname - character(len=100) :: ermsg, keyword, atemp - logical :: found, endOfBlock - logical :: convertFlux - ! - ! -- these time array series pointers need to be non-contiguous - ! beacuse a slice of bound is passed - real(DP), dimension(:), pointer :: bndArrayPtr => null() - real(DP), dimension(:), pointer :: auxArrayPtr => null() - real(DP), dimension(:), pointer :: auxMultArray => null() - type(TimeArraySeriesLinkType), pointer :: tasLink => null() - ! -- formats - character(len=*),parameter :: fmtevtauxmult = & - "(4x, 'THE ET RATE ARRAY IS BEING MULTIPLED BY THE AUXILIARY ARRAY WITH & - &THE NAME: ', A)" - ! -- data - data aname(1) /' LAYER OR NODE INDEX'/ - data aname(2) /' ET SURFACE'/ - data aname(3) /' EVAPOTRANSPIRATION RATE'/ - data aname(4) /' EXTINCTION DEPTH'/ - data aname(5) /'EXTINCT. DEP. PROPORTION'/ - data aname(6) /' ET RATE PROPORTION'/ -! ------------------------------------------------------------------------------ - ! - ! -- Initialize - jauxcol = 0 - ivarsread = 0 - ! - ! -- Read IEVT, SURFACE, RATE, DEPTH, PXDP, PETM, and AUX - ! as arrays - kpetm = 0 - kpxdp = 0 - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - ! - ! -- Parse the keywords - select case (keyword) - case ('IEVT') - ! - ! -- Check to see if other variables have already been read. If so, - ! then terminate with an error that IEVT must be read first. - if (ivarsread > 0) then - call store_error('****ERROR. IEVT IS NOT FIRST VARIABLE IN & - &PERIOD BLOCK OR IT IS SPECIFIED MORE THAN ONCE.') - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Read the IEVT array - call this%dis%nlarray_to_nodelist(this%nodelist, this%maxbound, & - this%nbound, aname(1), this%parser%iuactive, this%iout) - ! - ! -- set flag to indicate that IEVT has been read - this%inievt = 1 - ! - ! -- if highest_active option set, then need to store nodelist - ! in the nodesontop array - if (.not. this%fixed_cell) call this%set_nodesontop() - ! - case ('SURFACE') - ! - if (this%inievt == 0) then - call store_error('Error. IEVT must be read at least once ') - call store_error('prior to reading the SURFACE array.') - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Read the surface array, then indicate - ! that surface array was read by setting insurf - call this%dis%read_layer_array(this%nodelist, this%bound, & - this%ncolbnd, this%maxbound, 1, aname(2), this%parser%iuactive, & - this%iout) - insurf = 1 - ! - case ('RATE') - ! - ! -- Look for keyword TIMEARRAYSERIES and time-array series - ! name on line, following RATE - call this%parser%GetStringCaps(keyword) - if (keyword == 'TIMEARRAYSERIES') then - ! -- Get time-array series name - call this%parser%GetStringCaps(tasName) - ! -- Ensure that time-array series has been defined and that name - ! of time-array series is valid. - jcol = 2 ! for max ET rate - bndArrayPtr => this%bound(jcol,:) - ! Make a time-array-series link and add it to the list of links - ! contained in the TimeArraySeriesManagerType object. - convertflux = .true. - call this%TasManager%MakeTasLink(this%name, bndArrayPtr, & - this%iprpak, tasName, 'RATE', & - convertFlux, this%nodelist, & - this%parser%iuactive) - lpos = this%TasManager%CountLinks() - tasLink => this%TasManager%GetLink(lpos) - inrate = 2 - else - ! - ! -- Read the Max. ET Rate array, then indicate - ! that rate array was read by setting inrate - call this%dis%read_layer_array(this%nodelist, this%bound, & - this%ncolbnd, this%maxbound, 2, aname(3), this%parser%iuactive, & - this%iout) - inrate = 1 - endif - ! - case ('DEPTH') - ! - if (this%inievt == 0) then - call store_error('Error. IEVT must be read at least once ') - call store_error('prior to reading the DEPTH array.') - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Read the extinction-depth array, then indicate - ! that depth array was read by setting indepth - call this%dis%read_layer_array(this%nodelist, this%bound, & - this%ncolbnd, this%maxbound, 3, aname(4), this%parser%iuactive, & - this%iout) - indepth = 1 - ! - case ('PXDP') - if (this%nseg < 2) then - ermsg = 'Error in EVT input: PXDP cannot be specified when NSEG < 2' - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - if (this%inievt == 0) then - call store_error('Error. IEVT must be read at least once ') - call store_error('prior to reading any PXDP array.') - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Assign column for this PXDP vector in bound array - kpxdp = kpxdp + 1 - if (kpxdp < this%nseg-1) this%segsdefined = .false. - if (kpxdp > this%nseg-1) then - ermsg = 'Error in EVT: Number of PXDP arrays exceeds NSEG-1.' - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - indx = 3 + kpxdp - ! - ! -- Read the PXDP array - call this%dis%read_layer_array(this%nodelist, this%bound, & - this%ncolbnd, this%maxbound, indx, aname(5), & - this%parser%iuactive, this%iout) - ! - case ('PETM') - if (this%nseg < 2) then - ermsg = 'Error in EVT input: PETM cannot be specified when NSEG < 2' - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - if (this%inievt == 0) then - call store_error('Error. IEVT must be read at least once ') - call store_error('prior to reading any PETM array.') - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Assign column for this PETM vector in bound array - kpetm = kpetm + 1 - if (kpetm < this%nseg-1) this%segsdefined = .false. - if (kpetm > this%nseg-1) then - ermsg = 'Error in EVT: Number of PETM arrays exceeds NSEG-1.' - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - indx = 3 + this%nseg - 1 + kpetm - ! - ! -- Read the PETM array - call this%dis%read_layer_array(this%nodelist, this%bound, & - this%ncolbnd, this%maxbound, indx, aname(6), & - this%parser%iuactive, this%iout) - ! - case default - ! - ! -- Check for auxname, and if found, then read into auxvar array - found = .false. - ipos = ifind(this%auxname, keyword) - if (ipos > 0) then - found = .true. - atemp = keyword - ! - ! -- Look for keyword TIMEARRAYSERIES and time-array series - ! name on line, following auxname - call this%parser%GetStringCaps(keyword) - if (keyword == 'TIMEARRAYSERIES') then - ! -- Get time-array series name - call this%parser%GetStringCaps(tasName) - jauxcol = jauxcol + 1 - auxArrayPtr => this%auxvar(jauxcol,:) - ! Make a time-array-series link and add it to the list of links - ! contained in the TimeArraySeriesManagerType object. - convertflux = .false. - call this%TasManager%MakeTasLink(this%name, auxArrayPtr, & - this%iprpak, tasName, & - this%auxname(ipos), convertFlux, & - this%nodelist, this%parser%iuactive) - else - ! - ! -- Read the aux variable array - call this%dis%read_layer_array(this%nodelist, this%auxvar, & - this%naux, this%maxbound, ipos, atemp, this%parser%iuactive, & - this%iout) - endif - endif - ! - ! -- Nothing found - if (.not. found) then - call this%parser%GetCurrentLine(line) - call store_error('****ERROR. LOOKING FOR VALID VARIABLE NAME. FOUND: ') - call store_error(trim(line)) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! If this aux variable has been designated as a multiplier array - ! by presence of AUXMULTNAME, set local pointer appropriately. - if (this%iauxmultcol > 0 .and. this%iauxmultcol == ipos) then - auxMultArray => this%auxvar(this%iauxmultcol,:) - endif - end select - ! - ! -- Increment the number of variables read - ivarsread = ivarsread + 1 - ! - end do - ! - ! -- Ensure that all required PXDP and PETM arrays - ! have been defined or redefined. - if (kpxdp == this%nseg-1 .and. kpxdp == this%nseg-1) then - this%segsdefined = .true. - endif - if (.not. this%segsdefined) then - ermsg = 'Error in EVT input: Definition of PXDP or PETM is incomplete.' - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! If the multiplier-array pointer has been assigned and - ! stress is controlled by a time-array series, assign - ! multiplier-array pointer in time-array series link. - if (associated(auxMultArray)) then - if (associated(tasLink)) then - tasLink%RMultArray => auxMultArray - endif - endif - ! - ! -- If et rate was read and auxmultcol was specified, then multiply - ! the et rate by the multplier column - if(inrate == 1 .and. this%iauxmultcol > 0) then - write(this%iout, fmtevtauxmult) this%auxname(this%iauxmultcol) - do n = 1, this%nbound - this%bound(this%iscloc, n) = this%bound(this%iscloc, n) * & - this%auxvar(this%iauxmultcol, n) - enddo - endif - ! - return - end subroutine evt_rp_array - - subroutine evt_rp_list(this, inrate) -! ****************************************************************************** -! evt_rp_list -- Read and Prepare EVT as a list -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(EvtType), intent(inout) :: this - integer(I4B), intent(inout) :: inrate - ! -- local - integer(I4B) :: maxboundorig, nlist -! ------------------------------------------------------------------------------ - ! - nlist = -1 - maxboundorig = this%maxbound - call this%dis%read_list(this%parser%iuactive, this%iout, this%iprpak, & - nlist, this%inamedbound, this%iauxmultcol, & - this%nodelist, this%bound, this%auxvar, & - this%auxname, this%boundname, this%listlabel, & - this%name, this%tsManager, this%iscloc, & - this%indxconvertflux) - this%nbound = nlist - if (this%maxbound > maxboundorig) then - ! -- The arrays that belong to BndType have been extended. - ! Now, EVT array nodesontop needs to be recreated. - if (associated(this%nodesontop)) then - deallocate(this%nodesontop) - endif - endif - if (.not. this%fixed_cell) call this%set_nodesontop() - inrate = 1 - ! - ! -- terminate the period block - call this%parser%terminateblock() - ! - return - end subroutine evt_rp_list - - subroutine evt_define_listlabel(this) -! ****************************************************************************** -! define_listlabel -- Define the list heading that is written to iout when -! PRINT_INPUT option is used. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(EvtType), intent(inout) :: this - integer(I4B) :: nsegm1, i -! ------------------------------------------------------------------------------ - ! - ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' - else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'SURFACE' - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'MAX. RATE' - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'EXT. DEPTH' - ! - ! -- add headings for as many PXDP and PETM columns as needed - nsegm1 = this%nseg - 1 - if (nsegm1 > 0) then - do i = 1,nsegm1 - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'PXDP' - enddo - do i = 1,nsegm1 - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'PETM' - enddo - endif - ! - ! -- PETM0, if SURF_RATE_SPECIFIED is used - if (this%surfratespecified) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'PETM0' - endif - ! -! ! -- multiplier -! if(this%multindex > 0) & -! write(this%listlabel, '(a, a16)') trim(this%listlabel), 'MULTIPLIER' - ! - ! -- boundary name - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif - ! - ! -- return - return - end subroutine evt_define_listlabel - - subroutine default_nodelist(this) -! ****************************************************************************** -! default_nodelist -- Assign default nodelist when READASARRAYS is specified. -! Equivalent to reading IEVT as CONSTANT 1 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: get_node - use SimModule, only: ustop, store_error - use ConstantsModule, only: LINELENGTH - ! -- dummy - class(EvtType) :: this - ! -- local - integer(I4B) :: il, ir, ic, ncol, nrow, nlay, nodeu, noder, ipos -! ------------------------------------------------------------------------------ - ! - ! -- set variables - if(this%dis%ndim == 3) then - nlay = this%dis%mshape(1) - nrow = this%dis%mshape(2) - ncol = this%dis%mshape(3) - elseif(this%dis%ndim == 2) then - nlay = this%dis%mshape(1) - nrow = 1 - ncol = this%dis%mshape(2) - endif - ! - ! -- Populate nodelist - ipos = 1 - il = 1 - do ir = 1, nrow - do ic = 1, ncol - nodeu = get_node(il, ir, ic, nlay, nrow, ncol) - noder = this%dis%get_nodenumber(nodeu, 0) - if(noder > 0) then - this%nodelist(ipos) = noder - ipos = ipos + 1 - endif - enddo - enddo - ! - ! Set flag that indicates IEVT has been assigned, and assign nbound. - this%inievt = 1 - this%nbound = ipos - 1 - ! - ! -- if fixed_cell option not set, then need to store nodelist - ! in the nodesontop array - if(.not. this%fixed_cell) call this%set_nodesontop() - ! - ! -- return - end subroutine default_nodelist - - ! -- Procedures related to observations - - logical function evt_obs_supported(this) -! ****************************************************************************** -! evt_obs_supported -! -- Return true because EVT package supports observations. -! -- Overrides BndType%bnd_obs_supported() -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(EvtType) :: this -! ------------------------------------------------------------------------------ - evt_obs_supported = .true. - ! - ! -- return - return - end function evt_obs_supported - - subroutine evt_df_obs(this) -! ****************************************************************************** -! evt_df_obs (implements bnd_df_obs) -! -- Store observation type supported by EVT package. -! -- Overrides BndType%bnd_df_obs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(EvtType) :: this - ! -- local - integer(I4B) :: indx -! ------------------------------------------------------------------------------ - call this%obs%StoreObsType('evt', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor - ! - ! -- return - return - end subroutine evt_df_obs - - ! -- Procedure related to time series - - subroutine evt_rp_ts(this) -! ****************************************************************************** -! evt_rp_ts -- Assign tsLink%Text appropriately for -! all time series in use by package. -! In EVT package the SURFACE, RATE, DEPTH, PXDP, and PETM variables -! can be controlled by time series. -! Define Text only when time series is used for SURFACE, RATE, or DEPTH. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(EvtType), intent(inout) :: this - ! -- local - integer(I4B) :: i, nlinks - type(TimeSeriesLinkType), pointer :: tslink => null() -! ------------------------------------------------------------------------------ - ! - nlinks = this%TsManager%boundtslinks%Count() - do i = 1, nlinks - tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) - if (associated(tslink)) then - select case (tslink%JCol) - case (1) - tslink%Text = 'SURFACE' - case (2) - tslink%Text = 'RATE' - case (3) - tslink%Text = 'DEPTH' - end select - endif - enddo - ! - return - end subroutine evt_rp_ts - -end module EvtModule - +module EvtModule + ! + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, DONE, LENFTYPE, LENPACKAGENAME, MAXCHARLEN + use BndModule, only: BndType + use SimModule, only: store_error, store_error_unit, ustop + use ObsModule, only: DefaultObsIdProcessor + use TimeArraySeriesLinkModule, only: TimeArraySeriesLinkType + use TimeSeriesLinkModule, only: TimeSeriesLinkType, & + GetTimeSeriesLinkFromList + use BlockParserModule, only: BlockParserType + ! + implicit none + ! + private + public :: evt_create + ! + character(len=LENFTYPE) :: ftype = 'EVT' + character(len=LENPACKAGENAME) :: text = ' EVT' + ! + type, extends(BndType) :: EvtType + ! -- logicals + logical, private :: segsdefined = .true. + logical, private :: fixed_cell = .false. + logical, private :: read_as_arrays = .false. + logical, private:: surfratespecified = .false. + ! -- integers + integer(I4B), pointer :: inievt => null() + integer(I4B), pointer, private :: nseg => null() + ! -- arrays + integer(I4B), dimension(:), pointer, contiguous :: nodesontop => null() + contains + procedure :: evt_allocate_scalars + procedure :: bnd_options => evt_options + procedure :: read_dimensions => evt_read_dimensions + procedure :: read_initial_attr => evt_read_initial_attr + procedure :: bnd_rp => evt_rp + procedure :: set_nodesontop + procedure :: bnd_cf => evt_cf + procedure :: bnd_fc => evt_fc + procedure :: bnd_da => evt_da + procedure :: define_listlabel => evt_define_listlabel + procedure, private :: evt_rp_array + procedure, private :: evt_rp_list + procedure, private :: default_nodelist + ! -- for observations + procedure, public :: bnd_obs_supported => evt_obs_supported + procedure, public :: bnd_df_obs => evt_df_obs + ! -- for time series + procedure, public :: bnd_rp_ts => evt_rp_ts + end type EvtType + + ! EVT uses BndType%bound array columns: + ! Index Description old name Keyword + ! (1,n) ET Surface elevation ETSS SURFACE + ! (2,n) Max ET Rate ETSR RATE + ! (3,n) Extinction Depth ETSX DEPTH + ! Used only if nseg > 1 and surfratespecified is false: + ! 4->2+nseg Proportion of Extinction Depth PXDP PXDP + ! 3+nseg->3+2(nseg-1) Proportion of Max ET Rate PETM PETM + ! If nseg > 1 and surfratespecified is true: + ! 4->3+nseg Proportion of Extinction Depth PXDP PXDP + ! 4+nseg->3+2(nseg) Proportion of Max ET Rate PETM PETM + + contains + + subroutine evt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) +! ****************************************************************************** +! evt_create -- Create a new Evapotranspiration Segments Package +! Subroutine: (1) create new-style package +! (2) point packobj to the new package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BndType), pointer :: packobj + integer(I4B),intent(in) :: id + integer(I4B),intent(in) :: ibcnum + integer(I4B),intent(in) :: inunit + integer(I4B),intent(in) :: iout + character(len=*), intent(in) :: namemodel + character(len=*), intent(in) :: pakname + ! -- local + type(EvtType), pointer :: evtobj +! ------------------------------------------------------------------------------ + ! + ! -- allocate evt object and scalar variables + allocate(evtobj) + packobj => evtobj + ! + ! -- create name and origin + call packobj%set_names(ibcnum, namemodel, pakname, ftype) + packobj%text = text + ! + ! -- allocate scalars + call evtobj%evt_allocate_scalars() + ! + ! -- initialize package + call packobj%pack_initialize() + + packobj%inunit = inunit + packobj%iout = iout + packobj%id = id + packobj%ibcnum = ibcnum + packobj%ncolbnd = 3 ! Assumes NSEG = 1 + packobj%iscloc = 2 ! sfac applies to max. ET rate + packobj%ictorigin = 'NPF' + ! indxconvertflux is Column index of bound that will be multiplied by + ! cell area to convert flux rates to flow rates + packobj%indxconvertflux = 2 + packobj%AllowTimeArraySeries = .true. + ! + ! -- return + return + end subroutine evt_create + + subroutine evt_allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars -- allocate scalar members +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(EvtType), intent(inout) :: this +! ------------------------------------------------------------------------------ + ! + ! -- call standard BndType allocate scalars + call this%BndType%allocate_scalars() + ! + ! -- allocate the object and assign values to object variables + call mem_allocate(this%inievt, 'INIEVT', this%origin) + call mem_allocate(this%nseg, 'NSEG', this%origin) + ! + ! -- Set values + this%inievt = 0 + this%nseg = 1 + this%fixed_cell = .false. + ! + ! -- return + return + end subroutine evt_allocate_scalars + + subroutine evt_options(this, option, found) +! ****************************************************************************** +! evt_options -- set options specific to EvtType +! evt_options overrides BndType%bnd_options +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(EvtType), intent(inout) :: this + character(len=*), intent(inout) :: option + logical, intent(inout) :: found + ! -- local + character(len=MAXCHARLEN) :: ermsg + ! -- formats + character(len=*),parameter :: fmtihact = & + "(4x, 'EVAPOTRANSPIRATION WILL BE APPLIED TO HIGHEST ACTIVE CELL.')" + character(len=*),parameter :: fmtfixedcell = & + "(4x, 'EVAPOTRANSPIRATION WILL BE APPLIED TO SPECIFIED CELL.')" + character(len=*), parameter :: fmtreadasarrays = & + "(4x, 'EVAPOTRANSPIRATION INPUT WILL BE READ AS ARRAYS.')" + character(len=*), parameter :: fmtsrz = & + "(4x, 'ET RATE AT SURFACE WILL BE ZERO.')" + character(len=*), parameter :: fmtsrs = & + "(4x, 'ET RATE AT SURFACE WILL BE AS SPECIFIED BY PETM0.')" +! ------------------------------------------------------------------------------ + ! + ! -- Check for FIXED_CELL AND LAYERED + select case (option) + case ('FIXED_CELL') + this%fixed_cell = .true. + write(this%iout, fmtfixedcell) + found = .true. + case ('SURF_RATE_SPECIFIED') + this%surfratespecified = .true. + write(this%iout, fmtsrs) + found = .true. + ! + if (this%read_as_arrays) then + ermsg = 'READASARRAYS option is not compatible with the' // & + ' SURF_RATE_SPECIFIED option.' + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + case ('READASARRAYS') + if (this%dis%supports_layers()) then + this%read_as_arrays = .true. + else + ermsg = 'READASARRAYS option is not compatible with selected' // & + ' discretization type.' + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + if (this%surfratespecified) then + ermsg = 'READASARRAYS option is not compatible with the' // & + ' SURF_RATE_SPECIFIED option.' + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Write option + write(this%iout, fmtreadasarrays) + ! + found = .true. + case default + ! + ! -- No options found + found = .false. + end select + ! + ! -- return + return + end subroutine evt_options + + subroutine evt_read_dimensions(this) +! ****************************************************************************** +! bnd_read_dimensions -- Read the dimensions for this package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, store_error_unit + ! -- dummy + class(EvtType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: errmsg, keyword + integer(I4B) :: ierr + logical :: isfound, endOfBlock + ! -- format + character(len=*), parameter :: fmtnsegerr = & + "('Error: In EVT, NSEG must be > 0 but is specified as ',i0)" +! ------------------------------------------------------------------------------ + ! + ! Dimensions block is not required if: + ! (1) discretization is DIS or DISV, and + ! (2) READASARRAYS option has been specified. + if (this%read_as_arrays) then + this%maxbound = this%dis%get_ncpl() + else + ! -- 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 '//trim(adjustl(this%text))// & + ' DIMENSIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('MAXBOUND') + if (this%read_as_arrays) then + errmsg = 'When READASARRAYS option is used for the selected' // & + ' discretization package, MAXBOUND may not be specified.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + else + this%maxbound = this%parser%GetInteger() + write(this%iout,'(4x,a,i7)') 'MAXBOUND = ', this%maxbound + endif + case ('NSEG') + this%nseg = this%parser%GetInteger() + write(this%iout,'(4x,a,i0)') 'NSEG = ', this%nseg + if (this%nseg < 1) then + write(errmsg,fmtnsegerr)this%nseg + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + elseif (this%nseg > 1) then + ! NSEG>1 is supported only if readasarrays is false + if (this%read_as_arrays) then + errmsg = 'In the EVT package, NSEG cannot be greater than 1' // & + ' when READASARRAYS is used.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! -- Recalculate number of columns required in bound array. + if (this%surfratespecified) then + this%ncolbnd = 4 + 2*(this%nseg-1) + else + this%ncolbnd = 3 + 2*(this%nseg-1) + endif + endif + case default + write(errmsg,'(4x,a,a)') & + '****ERROR. UNKNOWN '//trim(this%text)//' DIMENSION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + end do + ! + write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' DIMENSIONS' + else + call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') + call this%parser%StoreErrorUnit() + call ustop() + endif + endif + ! + ! -- verify dimensions were set + if(this%maxbound <= 0) then + write(errmsg, '(1x,a)') & + 'ERROR. MAXBOUND MUST BE AN INTEGER GREATER THAN ZERO.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Call define_listlabel to construct the list label that is written + ! when PRINT_INPUT option is used. + call this%define_listlabel() + ! + ! -- return + return + end subroutine evt_read_dimensions + + subroutine evt_read_initial_attr(this) +! ****************************************************************************** +! evt_read_initial_attr -- Part of allocate and read +! If READASARRAYS has been specified, assign default IEVT = 1 +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(EvtType),intent(inout) :: this + ! + if (this%read_as_arrays) then + call this%default_nodelist() + endif + ! + return + end subroutine evt_read_initial_attr + + subroutine evt_rp(this) +! ****************************************************************************** +! evt_rp -- Read and Prepare +! Read new boundaries +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use TdisModule, only: kper, nper + use SimModule, only: ustop, store_error + use ArrayHandlersModule, only: ifind + ! -- dummy + class(EvtType),intent(inout) :: this + ! -- local + integer(I4B) :: ierr + integer(I4B) :: node, n + integer(I4B) :: inievt, inrate, insurf, indepth + integer(I4B) :: kpxdp, kpetm + logical :: isfound, supportopenclose + character(len=LINELENGTH) :: line, msg, errmsg + ! -- formats + character(len=*),parameter :: fmtblkerr = & + "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + character(len=*),parameter :: fmtlsp = & + "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" + character(len=*), parameter :: fmtnbd = & + "(1X,/1X,'THE NUMBER OF ACTIVE ',A,'S (',I6," // & + "') IS GREATER THAN MAXIMUM(',I6,')')" +! ------------------------------------------------------------------------------ + ! + ! -- Set ionper to the stress period number for which a new block of data + ! will be read. + if(this%inunit == 0) return + ! + ! -- get stress period data + if (this%ionper < kper) then + ! + ! -- get period block + supportopenclose = .not. this%read_as_arrays + ! When reading a list, OPEN/CLOSE is handled by list reader, + ! so supportOpenClose needs to be false in call the GetBlock. + ! When reading as arrays, set supportOpenClose as desired. + call this%parser%GetBlock('PERIOD', isfound, ierr) + if(isfound) then + ! + ! -- read ionper and check for increasing period numbers + call this%read_check_ionper() + else + ! + ! -- PERIOD block not found + if (ierr < 0) then + ! -- End of file found; data applies for remainder of simulation. + this%ionper = nper + 1 + else + ! -- Found invalid block + write(errmsg, fmtblkerr) adjustl(trim(line)) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end if + endif + end if + ! + ! -- Read data if ionper == kper + inrate = 0 + insurf = 0 + indepth = 0 + inievt = 0 + if (this%ionper == kper) then + ! + ! -- Remove all time-series links associated with this package + call this%TsManager%Reset(this%name) + call this%TasManager%Reset(this%name) + ! + ! -- Read IEVT, SURFACE, RATE, DEPTH, PXDP, PETM, and AUX + ! variables, if any + kpetm = 0 + kpxdp = 0 + ! + if (.not. this%read_as_arrays) then + ! -- Read EVT input as a list + call this%evt_rp_list(inrate) + else + ! -- Read Evt input as arrays + call this%evt_rp_array(line, inrate, insurf, indepth, & + kpxdp, kpetm) + endif + ! + ! -- Ensure that all required PXDP and PETM arrays + ! have been defined or redefined. + if (this%surfratespecified) then + if (kpxdp == this%nseg .and. kpxdp == this%nseg) then + this%segsdefined = .true. + endif + else + if (kpxdp == this%nseg-1 .and. kpxdp == this%nseg-1) then + this%segsdefined = .true. + endif + endif + if (.not. this%segsdefined) then + msg = 'Error in EVT input: Definition of PXDP or PETM is incomplete.' + call store_error(msg) + call this%parser%StoreErrorUnit() + call ustop() + endif + else + write(this%iout,fmtlsp) trim(this%filtyp) + endif + ! + ! -- If rate was read, then multiply by cell area. If inrate = 2, then + ! rate is begin managed as a time series, and the time series object + ! will multiply the rate by the cell area. + if (inrate == 1) then + do n = 1, this%nbound + node = this%nodelist(n) + this%bound(2, n) = this%bound(2, n) * this%dis%get_area(node) + enddo + endif + ! + ! -- return + return + end subroutine evt_rp + + subroutine set_nodesontop(this) +! ****************************************************************************** +! set_nodesontop -- store nodelist in nodesontop +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(EvtType),intent(inout) :: this + ! -- local + integer(I4B) :: n + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- allocate if necessary + if(.not. associated(this%nodesontop)) then + allocate(this%nodesontop(this%maxbound)) + endif + ! + ! -- copy nodelist into nodesontop + do n = 1, this%nbound + this%nodesontop(n) = this%nodelist(n) + enddo + ! + ! -- return + return + end subroutine set_nodesontop + + subroutine evt_cf(this, reset_mover) +! ****************************************************************************** +! evt_cf -- Formulate the HCOF and RHS terms +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(EvtType) :: this + logical, intent(in), optional :: reset_mover + ! -- local + integer(I4B) :: i, iseg, node + integer(I4B) :: idxdepth, idxrate + real(DP) :: c, d, h, s, x + real(DP) :: petm0 + real(DP) :: petm1, petm2, pxdp1, pxdp2, thcof, trhs +! ------------------------------------------------------------------------------ + ! + ! -- Return if no ET nodes + if (this%nbound == 0) return + ! + ! -- Calculate hcof and rhs for each ET node + do i=1,this%nbound + ! + ! -- Find the node number + if (this%fixed_cell) then + node = this%nodelist(i) + else + node = this%nodesontop(i) + if (this%ibound(node) == 0) & + call this%dis%highest_active(node, this%ibound) + this%nodelist(i) = node + endif + ! + ! -- set rhs and hcof to zero + this%rhs(i) = DZERO + this%hcof(i) = DZERO + ! + ! -- if ibound is positive, then add terms + if (this%ibound(node) > 0) then + ! + c = this%bound(2,i) ! RATE -- max. ET rate + s = this%bound(1,i) ! SURFACE -- ET surface elevation + h = this%xnew(node) + if (this%surfratespecified) then + petm0 = this%bound(4+2*(this%nseg-1),i) ! PETM0 + endif + ! + ! -- If head in cell is greater than or equal to SURFACE, ET is constant + if (h >= s) then + if (this%surfratespecified) then + ! -- Subtract -PETM0 * max rate from RHS + this%rhs(i) = this%rhs(i) + petm0 * c + else + ! -- Subtract -RATE from RHS + this%rhs(i) = this%rhs(i) + c + endif + else + ! -- If depth to water >= extinction depth, then ET is 0 + d = S - h + x = this%bound(3,i) ! DEPTH -- extinction depth + if (d < x) then + ! -- Variable range. add ET terms to both RHS and HCOF. + if (this%nseg > 1) then + ! -- Determine which segment applies based on head, and + ! calculate terms to add to RHS and HCOF + ! + ! -- Set proportions corresponding to surface elevation + ! and initial indices for depth and rate. + ! -- Idxdepth will point to the elements of bound containing + ! proportion of depth at the bottom of each segment. + ! Idxrate will point to the elements of bound containing + ! proportion of ET rate at the bottom of each segment. + ! If surfratespecified is true, skip over the elements + ! containing pxdp0 (=0.0) and petm0. + pxdp1 = DZERO + if (this%surfratespecified) then + petm1 = petm0 + else + petm1 = DONE + endif + ! -- Initialize indices to point to elements preceding + ! pxdp1 and petm1 (values for lower end of segment 1). + idxdepth = 3 + idxrate = 2 + this%nseg + ! -- Iterate through segments to find segment that contains + ! current depth of head below ET surface. + segloop: do iseg = 1, this%nseg + ! -- Set proportions corresponding to lower end of + ! segment + if (iseg < this%nseg) then + ! -- Increment the indices for depth and rate + idxdepth = idxdepth + 1 + idxrate = idxrate + 1 + ! -- Get proportions for lower end of segment + pxdp2 = this%bound(idxdepth,i) + petm2 = this%bound(idxrate,i) + else + pxdp2 = DONE + petm2 = DZERO + endif + if (d <= pxdp2*x) then + ! -- head is in domain of this segment + exit segloop + endif + ! -- Proportions at lower end of segment will be for + ! upper end of segment next time through loop + pxdp1 = pxdp2 + petm1 = petm2 + enddo segloop + ! -- Calculate terms to add to RHS and HCOF based on + ! segment that applies at head elevation + thcof = - (petm1 - petm2) * c / ((pxdp2 - pxdp1) * x) + trhs = thcof * (s - pxdp1 * x) + petm1 * c + else + ! -- Calculate terms to add to RHS and HCOF based on simple + ! linear relation of ET vs. head for single segment + trhs = c - c * s / x + thcof = -c / x + endif + this%rhs(i) = this%rhs(i) + trhs + this%hcof(i) = this%hcof(i) + thcof + endif + endif + endif + ! + enddo + ! + ! -- return + return + end subroutine evt_cf + + subroutine evt_fc(this, rhs, ia, idxglo, amatsln) +! ************************************************************************** +! evt_fc -- Copy rhs and hcof into solution rhs and amat +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + ! -- dummy + class(EvtType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + real(DP), dimension(:), intent(inout) :: amatsln + ! -- local + integer(I4B) :: i, n, ipos +! -------------------------------------------------------------------------- + ! + ! -- Copy package rhs and hcof into solution rhs and amat + do i = 1, this%nbound + n = this%nodelist(i) + ! -- reset hcof and rhs for excluded cells + if (this%ibound(n) == 10000) then + this%hcof(i) = DZERO + this%rhs(i) = DZERO + cycle + end if + rhs(n) = rhs(n) + this%rhs(i) + ipos = ia(n) + amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) + enddo + ! + ! -- return + return + end subroutine evt_fc + + subroutine evt_da(this) +! ****************************************************************************** +! evt_da -- deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(EvtType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- arrays + if(associated(this%nodesontop)) deallocate(this%nodesontop) + ! + ! -- scalars + call mem_deallocate(this%inievt) + call mem_deallocate(this%nseg) + ! + ! -- Deallocate parent package + call this%BndType%bnd_da() + ! + ! -- return + return + end subroutine evt_da + + subroutine evt_rp_array(this, line, inrate, insurf, indepth, & + kpxdp, kpetm) +! ****************************************************************************** +! evt_rp_array -- Read and Prepare EVT as arrays +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LENTIMESERIESNAME, LINELENGTH + use SimModule, only: ustop, store_error + use ArrayHandlersModule, only: ifind + ! -- dummy + class(EvtType), intent(inout) :: this + character(len=LINELENGTH), intent(inout) :: line + integer(I4B), intent(inout) :: inrate + integer(I4B), intent(inout) :: insurf + integer(I4B), intent(inout) :: indepth + integer(I4B), intent(inout) :: kpxdp + integer(I4B), intent(inout) :: kpetm + ! -- local + integer(I4B) :: n + integer(I4B) :: indx, ipos + integer(I4B) :: jcol, jauxcol, lpos, ivarsread + character(len=LENTIMESERIESNAME) :: tasName + character(len=24), dimension(6) :: aname + character(len=100) :: ermsg, keyword, atemp + logical :: found, endOfBlock + logical :: convertFlux + ! + ! -- these time array series pointers need to be non-contiguous + ! beacuse a slice of bound is passed + real(DP), dimension(:), pointer :: bndArrayPtr => null() + real(DP), dimension(:), pointer :: auxArrayPtr => null() + real(DP), dimension(:), pointer :: auxMultArray => null() + type(TimeArraySeriesLinkType), pointer :: tasLink => null() + ! -- formats + character(len=*),parameter :: fmtevtauxmult = & + "(4x, 'THE ET RATE ARRAY IS BEING MULTIPLED BY THE AUXILIARY ARRAY WITH & + &THE NAME: ', A)" + ! -- data + data aname(1) /' LAYER OR NODE INDEX'/ + data aname(2) /' ET SURFACE'/ + data aname(3) /' EVAPOTRANSPIRATION RATE'/ + data aname(4) /' EXTINCTION DEPTH'/ + data aname(5) /'EXTINCT. DEP. PROPORTION'/ + data aname(6) /' ET RATE PROPORTION'/ +! ------------------------------------------------------------------------------ + ! + ! -- Initialize + jauxcol = 0 + ivarsread = 0 + ! + ! -- Read IEVT, SURFACE, RATE, DEPTH, PXDP, PETM, and AUX + ! as arrays + kpetm = 0 + kpxdp = 0 + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + ! + ! -- Parse the keywords + select case (keyword) + case ('IEVT') + ! + ! -- Check to see if other variables have already been read. If so, + ! then terminate with an error that IEVT must be read first. + if (ivarsread > 0) then + call store_error('****ERROR. IEVT IS NOT FIRST VARIABLE IN & + &PERIOD BLOCK OR IT IS SPECIFIED MORE THAN ONCE.') + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Read the IEVT array + call this%dis%nlarray_to_nodelist(this%nodelist, this%maxbound, & + this%nbound, aname(1), this%parser%iuactive, this%iout) + ! + ! -- set flag to indicate that IEVT has been read + this%inievt = 1 + ! + ! -- if highest_active option set, then need to store nodelist + ! in the nodesontop array + if (.not. this%fixed_cell) call this%set_nodesontop() + ! + case ('SURFACE') + ! + if (this%inievt == 0) then + call store_error('Error. IEVT must be read at least once ') + call store_error('prior to reading the SURFACE array.') + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Read the surface array, then indicate + ! that surface array was read by setting insurf + call this%dis%read_layer_array(this%nodelist, this%bound, & + this%ncolbnd, this%maxbound, 1, aname(2), this%parser%iuactive, & + this%iout) + insurf = 1 + ! + case ('RATE') + ! + ! -- Look for keyword TIMEARRAYSERIES and time-array series + ! name on line, following RATE + call this%parser%GetStringCaps(keyword) + if (keyword == 'TIMEARRAYSERIES') then + ! -- Get time-array series name + call this%parser%GetStringCaps(tasName) + ! -- Ensure that time-array series has been defined and that name + ! of time-array series is valid. + jcol = 2 ! for max ET rate + bndArrayPtr => this%bound(jcol,:) + ! Make a time-array-series link and add it to the list of links + ! contained in the TimeArraySeriesManagerType object. + convertflux = .true. + call this%TasManager%MakeTasLink(this%name, bndArrayPtr, & + this%iprpak, tasName, 'RATE', & + convertFlux, this%nodelist, & + this%parser%iuactive) + lpos = this%TasManager%CountLinks() + tasLink => this%TasManager%GetLink(lpos) + inrate = 2 + else + ! + ! -- Read the Max. ET Rate array, then indicate + ! that rate array was read by setting inrate + call this%dis%read_layer_array(this%nodelist, this%bound, & + this%ncolbnd, this%maxbound, 2, aname(3), this%parser%iuactive, & + this%iout) + inrate = 1 + endif + ! + case ('DEPTH') + ! + if (this%inievt == 0) then + call store_error('Error. IEVT must be read at least once ') + call store_error('prior to reading the DEPTH array.') + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Read the extinction-depth array, then indicate + ! that depth array was read by setting indepth + call this%dis%read_layer_array(this%nodelist, this%bound, & + this%ncolbnd, this%maxbound, 3, aname(4), this%parser%iuactive, & + this%iout) + indepth = 1 + ! + case ('PXDP') + if (this%nseg < 2) then + ermsg = 'Error in EVT input: PXDP cannot be specified when NSEG < 2' + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + if (this%inievt == 0) then + call store_error('Error. IEVT must be read at least once ') + call store_error('prior to reading any PXDP array.') + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Assign column for this PXDP vector in bound array + kpxdp = kpxdp + 1 + if (kpxdp < this%nseg-1) this%segsdefined = .false. + if (kpxdp > this%nseg-1) then + ermsg = 'Error in EVT: Number of PXDP arrays exceeds NSEG-1.' + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + indx = 3 + kpxdp + ! + ! -- Read the PXDP array + call this%dis%read_layer_array(this%nodelist, this%bound, & + this%ncolbnd, this%maxbound, indx, aname(5), & + this%parser%iuactive, this%iout) + ! + case ('PETM') + if (this%nseg < 2) then + ermsg = 'Error in EVT input: PETM cannot be specified when NSEG < 2' + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + if (this%inievt == 0) then + call store_error('Error. IEVT must be read at least once ') + call store_error('prior to reading any PETM array.') + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Assign column for this PETM vector in bound array + kpetm = kpetm + 1 + if (kpetm < this%nseg-1) this%segsdefined = .false. + if (kpetm > this%nseg-1) then + ermsg = 'Error in EVT: Number of PETM arrays exceeds NSEG-1.' + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + indx = 3 + this%nseg - 1 + kpetm + ! + ! -- Read the PETM array + call this%dis%read_layer_array(this%nodelist, this%bound, & + this%ncolbnd, this%maxbound, indx, aname(6), & + this%parser%iuactive, this%iout) + ! + case default + ! + ! -- Check for auxname, and if found, then read into auxvar array + found = .false. + ipos = ifind(this%auxname, keyword) + if (ipos > 0) then + found = .true. + atemp = keyword + ! + ! -- Look for keyword TIMEARRAYSERIES and time-array series + ! name on line, following auxname + call this%parser%GetStringCaps(keyword) + if (keyword == 'TIMEARRAYSERIES') then + ! -- Get time-array series name + call this%parser%GetStringCaps(tasName) + jauxcol = jauxcol + 1 + auxArrayPtr => this%auxvar(jauxcol,:) + ! Make a time-array-series link and add it to the list of links + ! contained in the TimeArraySeriesManagerType object. + convertflux = .false. + call this%TasManager%MakeTasLink(this%name, auxArrayPtr, & + this%iprpak, tasName, & + this%auxname(ipos), convertFlux, & + this%nodelist, this%parser%iuactive) + else + ! + ! -- Read the aux variable array + call this%dis%read_layer_array(this%nodelist, this%auxvar, & + this%naux, this%maxbound, ipos, atemp, this%parser%iuactive, & + this%iout) + endif + endif + ! + ! -- Nothing found + if (.not. found) then + call this%parser%GetCurrentLine(line) + call store_error('****ERROR. LOOKING FOR VALID VARIABLE NAME. FOUND: ') + call store_error(trim(line)) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! If this aux variable has been designated as a multiplier array + ! by presence of AUXMULTNAME, set local pointer appropriately. + if (this%iauxmultcol > 0 .and. this%iauxmultcol == ipos) then + auxMultArray => this%auxvar(this%iauxmultcol,:) + endif + end select + ! + ! -- Increment the number of variables read + ivarsread = ivarsread + 1 + ! + end do + ! + ! -- Ensure that all required PXDP and PETM arrays + ! have been defined or redefined. + if (kpxdp == this%nseg-1 .and. kpxdp == this%nseg-1) then + this%segsdefined = .true. + endif + if (.not. this%segsdefined) then + ermsg = 'Error in EVT input: Definition of PXDP or PETM is incomplete.' + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! If the multiplier-array pointer has been assigned and + ! stress is controlled by a time-array series, assign + ! multiplier-array pointer in time-array series link. + if (associated(auxMultArray)) then + if (associated(tasLink)) then + tasLink%RMultArray => auxMultArray + endif + endif + ! + ! -- If et rate was read and auxmultcol was specified, then multiply + ! the et rate by the multplier column + if(inrate == 1 .and. this%iauxmultcol > 0) then + write(this%iout, fmtevtauxmult) this%auxname(this%iauxmultcol) + do n = 1, this%nbound + this%bound(this%iscloc, n) = this%bound(this%iscloc, n) * & + this%auxvar(this%iauxmultcol, n) + enddo + endif + ! + return + end subroutine evt_rp_array + + subroutine evt_rp_list(this, inrate) +! ****************************************************************************** +! evt_rp_list -- Read and Prepare EVT as a list +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(EvtType), intent(inout) :: this + integer(I4B), intent(inout) :: inrate + ! -- local + integer(I4B) :: maxboundorig, nlist +! ------------------------------------------------------------------------------ + ! + nlist = -1 + maxboundorig = this%maxbound + call this%dis%read_list(this%parser%iuactive, this%iout, this%iprpak, & + nlist, this%inamedbound, this%iauxmultcol, & + this%nodelist, this%bound, this%auxvar, & + this%auxname, this%boundname, this%listlabel, & + this%name, this%tsManager, this%iscloc, & + this%indxconvertflux) + this%nbound = nlist + if (this%maxbound > maxboundorig) then + ! -- The arrays that belong to BndType have been extended. + ! Now, EVT array nodesontop needs to be recreated. + if (associated(this%nodesontop)) then + deallocate(this%nodesontop) + endif + endif + if (.not. this%fixed_cell) call this%set_nodesontop() + inrate = 1 + ! + ! -- terminate the period block + call this%parser%terminateblock() + ! + return + end subroutine evt_rp_list + + subroutine evt_define_listlabel(this) +! ****************************************************************************** +! define_listlabel -- Define the list heading that is written to iout when +! PRINT_INPUT option is used. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(EvtType), intent(inout) :: this + integer(I4B) :: nsegm1, i +! ------------------------------------------------------------------------------ + ! + ! -- create the header list label + this%listlabel = trim(this%filtyp) // ' NO.' + if(this%dis%ndim == 3) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif(this%dis%ndim == 2) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + else + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + endif + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'SURFACE' + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'MAX. RATE' + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'EXT. DEPTH' + ! + ! -- add headings for as many PXDP and PETM columns as needed + nsegm1 = this%nseg - 1 + if (nsegm1 > 0) then + do i = 1,nsegm1 + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'PXDP' + enddo + do i = 1,nsegm1 + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'PETM' + enddo + endif + ! + ! -- PETM0, if SURF_RATE_SPECIFIED is used + if (this%surfratespecified) then + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'PETM0' + endif + ! +! ! -- multiplier +! if(this%multindex > 0) & +! write(this%listlabel, '(a, a16)') trim(this%listlabel), 'MULTIPLIER' + ! + ! -- boundary name + if(this%inamedbound == 1) then + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + endif + ! + ! -- return + return + end subroutine evt_define_listlabel + + subroutine default_nodelist(this) +! ****************************************************************************** +! default_nodelist -- Assign default nodelist when READASARRAYS is specified. +! Equivalent to reading IEVT as CONSTANT 1 +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: get_node + use SimModule, only: ustop, store_error + use ConstantsModule, only: LINELENGTH + ! -- dummy + class(EvtType) :: this + ! -- local + integer(I4B) :: il, ir, ic, ncol, nrow, nlay, nodeu, noder, ipos +! ------------------------------------------------------------------------------ + ! + ! -- set variables + if(this%dis%ndim == 3) then + nlay = this%dis%mshape(1) + nrow = this%dis%mshape(2) + ncol = this%dis%mshape(3) + elseif(this%dis%ndim == 2) then + nlay = this%dis%mshape(1) + nrow = 1 + ncol = this%dis%mshape(2) + endif + ! + ! -- Populate nodelist + ipos = 1 + il = 1 + do ir = 1, nrow + do ic = 1, ncol + nodeu = get_node(il, ir, ic, nlay, nrow, ncol) + noder = this%dis%get_nodenumber(nodeu, 0) + if(noder > 0) then + this%nodelist(ipos) = noder + ipos = ipos + 1 + endif + enddo + enddo + ! + ! Set flag that indicates IEVT has been assigned, and assign nbound. + this%inievt = 1 + this%nbound = ipos - 1 + ! + ! -- if fixed_cell option not set, then need to store nodelist + ! in the nodesontop array + if(.not. this%fixed_cell) call this%set_nodesontop() + ! + ! -- return + end subroutine default_nodelist + + ! -- Procedures related to observations + + logical function evt_obs_supported(this) +! ****************************************************************************** +! evt_obs_supported +! -- Return true because EVT package supports observations. +! -- Overrides BndType%bnd_obs_supported() +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(EvtType) :: this +! ------------------------------------------------------------------------------ + evt_obs_supported = .true. + ! + ! -- return + return + end function evt_obs_supported + + subroutine evt_df_obs(this) +! ****************************************************************************** +! evt_df_obs (implements bnd_df_obs) +! -- Store observation type supported by EVT package. +! -- Overrides BndType%bnd_df_obs +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(EvtType) :: this + ! -- local + integer(I4B) :: indx +! ------------------------------------------------------------------------------ + call this%obs%StoreObsType('evt', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor + ! + ! -- return + return + end subroutine evt_df_obs + + ! -- Procedure related to time series + + subroutine evt_rp_ts(this) +! ****************************************************************************** +! evt_rp_ts -- Assign tsLink%Text appropriately for +! all time series in use by package. +! In EVT package the SURFACE, RATE, DEPTH, PXDP, and PETM variables +! can be controlled by time series. +! Define Text only when time series is used for SURFACE, RATE, or DEPTH. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(EvtType), intent(inout) :: this + ! -- local + integer(I4B) :: i, nlinks + type(TimeSeriesLinkType), pointer :: tslink => null() +! ------------------------------------------------------------------------------ + ! + nlinks = this%TsManager%boundtslinks%Count() + do i = 1, nlinks + tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) + if (associated(tslink)) then + select case (tslink%JCol) + case (1) + tslink%Text = 'SURFACE' + case (2) + tslink%Text = 'RATE' + case (3) + tslink%Text = 'DEPTH' + end select + endif + enddo + ! + return + end subroutine evt_rp_ts + +end module EvtModule + diff --git a/src/Model/GroundWaterFlow/gwf3ghb8.f90 b/src/Model/GroundWaterFlow/gwf3ghb8.f90 index a4fa500a2d8..720ee0bfd55 100644 --- a/src/Model/GroundWaterFlow/gwf3ghb8.f90 +++ b/src/Model/GroundWaterFlow/gwf3ghb8.f90 @@ -1,349 +1,349 @@ -module ghbmodule - use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, LENFTYPE, LENPACKAGENAME - use BndModule, only: BndType - use ObsModule, only: DefaultObsIdProcessor - use TimeSeriesLinkModule, only: TimeSeriesLinkType, & - GetTimeSeriesLinkFromList - ! - implicit none - ! - private - public :: ghb_create - public :: GhbType - ! - character(len=LENFTYPE) :: ftype = 'GHB' - character(len=LENPACKAGENAME) :: text = ' GHB' - ! - type, extends(BndType) :: GhbType - contains - procedure :: bnd_options => ghb_options - procedure :: bnd_ck => ghb_ck - procedure :: bnd_cf => ghb_cf - procedure :: bnd_fc => ghb_fc - procedure :: define_listlabel - ! -- methods for observations - procedure, public :: bnd_obs_supported => ghb_obs_supported - procedure, public :: bnd_df_obs => ghb_df_obs - ! -- method for time series - procedure, public :: bnd_rp_ts => ghb_rp_ts - end type GhbType - -contains - - subroutine ghb_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) -! ****************************************************************************** -! ghb_create -- Create a New Ghb Package -! Subroutine: (1) create new-style package -! (2) point bndobj to the new package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout - character(len=*), intent(in) :: namemodel - character(len=*), intent(in) :: pakname - ! -- local - type(GhbType), pointer :: ghbobj -! ------------------------------------------------------------------------------ - ! - ! -- allocate the object and assign values to object variables - allocate(ghbobj) - packobj => ghbobj - ! - ! -- create name and origin - call packobj%set_names(ibcnum, namemodel, pakname, ftype) - packobj%text = text - ! - ! -- allocate scalars - call packobj%allocate_scalars() - ! - ! -- initialize package - call packobj%pack_initialize() - ! - packobj%inunit=inunit - packobj%iout=iout - packobj%id=id - packobj%ibcnum = ibcnum - packobj%ncolbnd=2 - packobj%iscloc=2 - packobj%ictorigin = 'NPF' - ! - ! -- return - return - end subroutine ghb_create - - subroutine ghb_options(this, option, found) -! ****************************************************************************** -! ghb_options -- set options specific to GhbType -! -! ghb_options overrides BndType%bnd_options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GhbType), intent(inout) :: this - character(len=*), intent(inout) :: option - logical, intent(inout) :: found -! ------------------------------------------------------------------------------ - ! - select case (option) - case('MOVER') - this%imover = 1 - write(this%iout, '(4x,A)') 'MOVER OPTION ENABLED' - found = .true. - case default - ! - ! -- No options found - found = .false. - end select - ! - ! -- return - return - end subroutine ghb_options - - subroutine ghb_ck(this) -! ****************************************************************************** -! ghb_ck -- Check ghb boundary condition data -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors, store_error_unit - ! -- dummy - class(GhbType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: errmsg - integer(I4B) :: i - integer(I4B) :: node - real(DP) :: bt - ! -- formats - character(len=*), parameter :: fmtghberr = & - "('GHB BOUNDARY (',i0,') HEAD (',f10.3,') IS LESS THAN CELL " // & - "BOTTOM (',f10.3,')')" -! ------------------------------------------------------------------------------ - ! - ! -- check stress period data - do i = 1, this%nbound - node = this%nodelist(i) - bt = this%dis%bot(node) - ! -- accumulate errors - if (this%bound(1,i) < bt .and. this%icelltype(node) /= 0) then - write(errmsg, fmt=fmtghberr) i, this%bound(1,i), bt - call store_error(errmsg) - end if - end do - ! - !write summary of ghb package error messages - if (count_errors() > 0) then - call store_error_unit(this%inunit) - call ustop() - end if - ! - ! -- return - return - end subroutine ghb_ck - - subroutine ghb_cf(this, reset_mover) -! ****************************************************************************** -! ghb_cf -- Formulate the HCOF and RHS terms -! Subroutine: (1) skip if no ghbs -! (2) calculate hcof and rhs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GhbType) :: this - logical, intent(in), optional :: reset_mover - ! -- local - integer(I4B) :: i, node - logical :: lrm -! ------------------------------------------------------------------------------ - ! - ! -- Return if no ghbs - if(this%nbound.eq.0) return - ! - ! -- packmvrobj cf - lrm = .true. - if (present(reset_mover)) lrm = reset_mover - if(this%imover == 1 .and. lrm) then - call this%pakmvrobj%cf() - endif - ! - ! -- Calculate hcof and rhs for each ghb entry - do i=1,this%nbound - node=this%nodelist(i) - if(this%ibound(node).le.0) then - this%hcof(i)=DZERO - this%rhs(i)=DZERO - cycle - endif - this%hcof(i) = -this%bound(2,i) - this%rhs(i) = -this%bound(2,i) * this%bound(1,i) - end do - ! - ! -- return - return - end subroutine ghb_cf - - subroutine ghb_fc(this, rhs, ia, idxglo, amatsln) -! ************************************************************************** -! ghb_fc -- Copy rhs and hcof into solution rhs and amat -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - ! -- dummy - class(GhbType) :: this - real(DP), dimension(:), intent(inout) :: rhs - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln - ! -- local - integer(I4B) :: i, n, ipos - real(DP) :: cond, bhead, qghb -! -------------------------------------------------------------------------- - ! - ! -- pakmvrobj fc - if(this%imover == 1) then - call this%pakmvrobj%fc() - endif - ! - ! -- Copy package rhs and hcof into solution rhs and amat - do i = 1, this%nbound - n = this%nodelist(i) - rhs(n) = rhs(n) + this%rhs(i) - ipos = ia(n) - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) - ! - ! -- If mover is active and this boundary is discharging, - ! store available water (as positive value). - bhead = this%bound(1,i) - if(this%imover == 1 .and. this%xnew(n) > bhead) then - cond = this%bound(2,i) - qghb = cond * (this%xnew(n) - bhead) - call this%pakmvrobj%accumulate_qformvr(i, qghb) - endif - enddo - ! - ! -- return - return - end subroutine ghb_fc - - subroutine define_listlabel(this) -! ****************************************************************************** -! define_listlabel -- Define the list heading that is written to iout when -! PRINT_INPUT option is used. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GhbType), intent(inout) :: this -! ------------------------------------------------------------------------------ - ! - ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' - else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STAGE' - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'CONDUCTANCE' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif - ! - ! -- return - return - end subroutine define_listlabel - - ! -- Procedures related to observations - - logical function ghb_obs_supported(this) - ! ****************************************************************************** - ! ghb_obs_supported - ! -- Return true because GHB package supports observations. - ! -- Overrides BndType%bnd_obs_supported() - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - implicit none - class(GhbType) :: this - ! ------------------------------------------------------------------------------ - ghb_obs_supported = .true. - return - end function ghb_obs_supported - - subroutine ghb_df_obs(this) - ! ****************************************************************************** - ! ghb_df_obs (implements bnd_df_obs) - ! -- Store observation type supported by GHB package. - ! -- Overrides BndType%bnd_df_obs - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - class(GhbType) :: this - ! -- local - integer(I4B) :: indx - ! ------------------------------------------------------------------------------ - call this%obs%StoreObsType('ghb', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor - ! - ! -- Store obs type and assign procedure pointer - ! for to-mvr observation type. - call this%obs%StoreObsType('to-mvr', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor - ! - ! -- return - return - end subroutine ghb_df_obs - ! - ! -- Procedure related to time series - ! - subroutine ghb_rp_ts(this) - ! -- Assign tsLink%Text appropriately for - ! all time series in use by package. - ! In GHB package variables BHEAD and COND - ! can be controlled by time series. - ! -- dummy - class(GhbType), intent(inout) :: this - ! -- local - integer(I4B) :: i, nlinks - type(TimeSeriesLinkType), pointer :: tslink => null() - ! - nlinks = this%TsManager%boundtslinks%Count() - do i=1,nlinks - tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) - if (associated(tslink)) then - select case (tslink%JCol) - case (1) - tslink%Text = 'BHEAD' - case (2) - tslink%Text = 'COND' - end select - endif - enddo - ! - return - end subroutine ghb_rp_ts - -end module ghbmodule +module ghbmodule + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, LENFTYPE, LENPACKAGENAME + use BndModule, only: BndType + use ObsModule, only: DefaultObsIdProcessor + use TimeSeriesLinkModule, only: TimeSeriesLinkType, & + GetTimeSeriesLinkFromList + ! + implicit none + ! + private + public :: ghb_create + public :: GhbType + ! + character(len=LENFTYPE) :: ftype = 'GHB' + character(len=LENPACKAGENAME) :: text = ' GHB' + ! + type, extends(BndType) :: GhbType + contains + procedure :: bnd_options => ghb_options + procedure :: bnd_ck => ghb_ck + procedure :: bnd_cf => ghb_cf + procedure :: bnd_fc => ghb_fc + procedure :: define_listlabel + ! -- methods for observations + procedure, public :: bnd_obs_supported => ghb_obs_supported + procedure, public :: bnd_df_obs => ghb_df_obs + ! -- method for time series + procedure, public :: bnd_rp_ts => ghb_rp_ts + end type GhbType + +contains + + subroutine ghb_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) +! ****************************************************************************** +! ghb_create -- Create a New Ghb Package +! Subroutine: (1) create new-style package +! (2) point bndobj to the new package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BndType), pointer :: packobj + integer(I4B),intent(in) :: id + integer(I4B),intent(in) :: ibcnum + integer(I4B),intent(in) :: inunit + integer(I4B),intent(in) :: iout + character(len=*), intent(in) :: namemodel + character(len=*), intent(in) :: pakname + ! -- local + type(GhbType), pointer :: ghbobj +! ------------------------------------------------------------------------------ + ! + ! -- allocate the object and assign values to object variables + allocate(ghbobj) + packobj => ghbobj + ! + ! -- create name and origin + call packobj%set_names(ibcnum, namemodel, pakname, ftype) + packobj%text = text + ! + ! -- allocate scalars + call packobj%allocate_scalars() + ! + ! -- initialize package + call packobj%pack_initialize() + ! + packobj%inunit=inunit + packobj%iout=iout + packobj%id=id + packobj%ibcnum = ibcnum + packobj%ncolbnd=2 + packobj%iscloc=2 + packobj%ictorigin = 'NPF' + ! + ! -- return + return + end subroutine ghb_create + + subroutine ghb_options(this, option, found) +! ****************************************************************************** +! ghb_options -- set options specific to GhbType +! +! ghb_options overrides BndType%bnd_options +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GhbType), intent(inout) :: this + character(len=*), intent(inout) :: option + logical, intent(inout) :: found +! ------------------------------------------------------------------------------ + ! + select case (option) + case('MOVER') + this%imover = 1 + write(this%iout, '(4x,A)') 'MOVER OPTION ENABLED' + found = .true. + case default + ! + ! -- No options found + found = .false. + end select + ! + ! -- return + return + end subroutine ghb_options + + subroutine ghb_ck(this) +! ****************************************************************************** +! ghb_ck -- Check ghb boundary condition data +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors, store_error_unit + ! -- dummy + class(GhbType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + integer(I4B) :: i + integer(I4B) :: node + real(DP) :: bt + ! -- formats + character(len=*), parameter :: fmtghberr = & + "('GHB BOUNDARY (',i0,') HEAD (',f10.3,') IS LESS THAN CELL " // & + "BOTTOM (',f10.3,')')" +! ------------------------------------------------------------------------------ + ! + ! -- check stress period data + do i = 1, this%nbound + node = this%nodelist(i) + bt = this%dis%bot(node) + ! -- accumulate errors + if (this%bound(1,i) < bt .and. this%icelltype(node) /= 0) then + write(errmsg, fmt=fmtghberr) i, this%bound(1,i), bt + call store_error(errmsg) + end if + end do + ! + !write summary of ghb package error messages + if (count_errors() > 0) then + call store_error_unit(this%inunit) + call ustop() + end if + ! + ! -- return + return + end subroutine ghb_ck + + subroutine ghb_cf(this, reset_mover) +! ****************************************************************************** +! ghb_cf -- Formulate the HCOF and RHS terms +! Subroutine: (1) skip if no ghbs +! (2) calculate hcof and rhs +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GhbType) :: this + logical, intent(in), optional :: reset_mover + ! -- local + integer(I4B) :: i, node + logical :: lrm +! ------------------------------------------------------------------------------ + ! + ! -- Return if no ghbs + if(this%nbound.eq.0) return + ! + ! -- packmvrobj cf + lrm = .true. + if (present(reset_mover)) lrm = reset_mover + if(this%imover == 1 .and. lrm) then + call this%pakmvrobj%cf() + endif + ! + ! -- Calculate hcof and rhs for each ghb entry + do i=1,this%nbound + node=this%nodelist(i) + if(this%ibound(node).le.0) then + this%hcof(i)=DZERO + this%rhs(i)=DZERO + cycle + endif + this%hcof(i) = -this%bound(2,i) + this%rhs(i) = -this%bound(2,i) * this%bound(1,i) + end do + ! + ! -- return + return + end subroutine ghb_cf + + subroutine ghb_fc(this, rhs, ia, idxglo, amatsln) +! ************************************************************************** +! ghb_fc -- Copy rhs and hcof into solution rhs and amat +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + ! -- dummy + class(GhbType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + real(DP), dimension(:), intent(inout) :: amatsln + ! -- local + integer(I4B) :: i, n, ipos + real(DP) :: cond, bhead, qghb +! -------------------------------------------------------------------------- + ! + ! -- pakmvrobj fc + if(this%imover == 1) then + call this%pakmvrobj%fc() + endif + ! + ! -- Copy package rhs and hcof into solution rhs and amat + do i = 1, this%nbound + n = this%nodelist(i) + rhs(n) = rhs(n) + this%rhs(i) + ipos = ia(n) + amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) + ! + ! -- If mover is active and this boundary is discharging, + ! store available water (as positive value). + bhead = this%bound(1,i) + if(this%imover == 1 .and. this%xnew(n) > bhead) then + cond = this%bound(2,i) + qghb = cond * (this%xnew(n) - bhead) + call this%pakmvrobj%accumulate_qformvr(i, qghb) + endif + enddo + ! + ! -- return + return + end subroutine ghb_fc + + subroutine define_listlabel(this) +! ****************************************************************************** +! define_listlabel -- Define the list heading that is written to iout when +! PRINT_INPUT option is used. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GhbType), intent(inout) :: this +! ------------------------------------------------------------------------------ + ! + ! -- create the header list label + this%listlabel = trim(this%filtyp) // ' NO.' + if(this%dis%ndim == 3) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif(this%dis%ndim == 2) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + else + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + endif + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STAGE' + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'CONDUCTANCE' + if(this%inamedbound == 1) then + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + endif + ! + ! -- return + return + end subroutine define_listlabel + + ! -- Procedures related to observations + + logical function ghb_obs_supported(this) + ! ****************************************************************************** + ! ghb_obs_supported + ! -- Return true because GHB package supports observations. + ! -- Overrides BndType%bnd_obs_supported() + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + implicit none + class(GhbType) :: this + ! ------------------------------------------------------------------------------ + ghb_obs_supported = .true. + return + end function ghb_obs_supported + + subroutine ghb_df_obs(this) + ! ****************************************************************************** + ! ghb_df_obs (implements bnd_df_obs) + ! -- Store observation type supported by GHB package. + ! -- Overrides BndType%bnd_df_obs + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + implicit none + ! -- dummy + class(GhbType) :: this + ! -- local + integer(I4B) :: indx + ! ------------------------------------------------------------------------------ + call this%obs%StoreObsType('ghb', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor + ! + ! -- Store obs type and assign procedure pointer + ! for to-mvr observation type. + call this%obs%StoreObsType('to-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor + ! + ! -- return + return + end subroutine ghb_df_obs + ! + ! -- Procedure related to time series + ! + subroutine ghb_rp_ts(this) + ! -- Assign tsLink%Text appropriately for + ! all time series in use by package. + ! In GHB package variables BHEAD and COND + ! can be controlled by time series. + ! -- dummy + class(GhbType), intent(inout) :: this + ! -- local + integer(I4B) :: i, nlinks + type(TimeSeriesLinkType), pointer :: tslink => null() + ! + nlinks = this%TsManager%boundtslinks%Count() + do i=1,nlinks + tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) + if (associated(tslink)) then + select case (tslink%JCol) + case (1) + tslink%Text = 'BHEAD' + case (2) + tslink%Text = 'COND' + end select + endif + enddo + ! + return + end subroutine ghb_rp_ts + +end module ghbmodule diff --git a/src/Model/GroundWaterFlow/gwf3hfb8.f90 b/src/Model/GroundWaterFlow/gwf3hfb8.f90 index 51a46737511..558f3d97ddc 100644 --- a/src/Model/GroundWaterFlow/gwf3hfb8.f90 +++ b/src/Model/GroundWaterFlow/gwf3hfb8.f90 @@ -1,872 +1,872 @@ - -module GwfHfbModule - - use KindModule, only: DP, I4B - use Xt3dModule, only: Xt3dType - use NumericalPackageModule, only: NumericalPackageType - use BlockParserModule, only: BlockParserType - use BaseDisModule, only: DisBaseType - - implicit none - - private - public :: GwfHfbType - public :: hfb_cr - - type, extends(NumericalPackageType) :: GwfHfbType - integer(I4B), pointer :: maxhfb => null() !max number of hfb's - integer(I4B), pointer :: nhfb => null() !number of hfb's - integer(I4B), dimension(:), pointer, contiguous :: noden => null() !first cell - integer(I4B), dimension(:), pointer, contiguous :: nodem => null() !second cell - integer(I4B), dimension(:), pointer, contiguous :: idxloc => null() !position in model ja - real(DP), dimension(:), pointer, contiguous :: hydchr => null() !hydraulic characteristic of the barrier - real(DP), dimension(:), pointer, contiguous :: csatsav => null() !value of condsat prior to hfb modification - real(DP), dimension(:), pointer, contiguous :: condsav => null() !saved conductance of combined npf and hfb - type(Xt3dType), pointer :: xt3d => null() !pointer to xt3d object - ! - integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !pointer to model ibound - integer(I4B), dimension(:), pointer, contiguous :: icelltype => null() !pointer to model icelltype - integer(I4B), dimension(:), pointer, contiguous :: ihc => null() !pointer to model ihc - integer(I4B), dimension(:), pointer, contiguous :: ia => null() !pointer to model ia - integer(I4B), dimension(:), pointer, contiguous :: ja => null() !pointer to model ja - integer(I4B), dimension(:), pointer, contiguous :: jas => null() !pointer to model jas - integer(I4B), dimension(:), pointer, contiguous :: isym => null() !pointer to model isym - real(DP), dimension(:), pointer, contiguous :: condsat => null() !pointer to model condsat - real(DP), dimension(:), pointer, contiguous :: top => null() !pointer to model top - real(DP), dimension(:), pointer, contiguous :: bot => null() !pointer to model bot - real(DP), dimension(:), pointer, contiguous :: hwva => null() !pointer to model hwva - contains - procedure :: hfb_ar - procedure :: hfb_rp - procedure :: hfb_fc - procedure :: hfb_flowja - procedure :: hfb_da - procedure :: allocate_scalars - procedure, private :: allocate_arrays - procedure, private :: read_options - procedure, private :: read_dimensions - procedure, private :: read_data - procedure, private :: check_data - procedure, private :: condsat_reset - procedure, private :: condsat_modify - end type GwfHfbType - - contains - - subroutine hfb_cr(hfbobj, name_model, inunit, iout) -! ****************************************************************************** -! hfb_cr -- Create a new hfb object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - type(GwfHfbType), pointer :: hfbobj - character(len=*), intent(in) :: name_model - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout -! ------------------------------------------------------------------------------ - ! - ! -- Create the object - allocate(hfbobj) - ! - ! -- create name and origin - call hfbobj%set_names(1, name_model, 'HFB', 'HFB') - ! - ! -- Allocate scalars - call hfbobj%allocate_scalars() - ! - ! -- Save unit numbers - hfbobj%inunit = inunit - hfbobj%iout = iout - ! - ! -- Initialize block parser - call hfbobj%parser%Initialize(hfbobj%inunit, hfbobj%iout) - ! - ! -- Return - return - end subroutine hfb_cr - - subroutine hfb_ar(this, ibound, xt3d, dis) -! ****************************************************************************** -! hfb_ar -- Allocate and read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_setptr - ! -- dummy - class(GwfHfbType) :: this - integer(I4B), dimension(:), pointer, contiguous :: ibound - type(Xt3dType), pointer :: xt3d - class(DisBaseType), pointer, intent(inout) :: dis - ! -- formats - character(len=*), parameter :: fmtheader = & - &"(1x, /1x, 'HFB -- HORIZONTAL FLOW BARRIER PACKAGE, VERSION 8, ', & - &'4/24/2015 INPUT READ FROM UNIT ', i4, //)" -! ------------------------------------------------------------------------------ - ! - ! -- Print a message identifying the node property flow package. - write(this%iout, fmtheader) this%inunit - ! - ! -- Set pointers - this%dis => dis - this%ibound => ibound - this%xt3d => xt3d - call mem_setptr(this%icelltype, 'ICELLTYPE', trim(adjustl(this%name_model))//' NPF') - call mem_setptr(this%ihc, 'IHC', trim(adjustl(this%name_model))//' CON') - call mem_setptr(this%ia, 'IA', trim(adjustl(this%name_model))//' CON') - call mem_setptr(this%ja, 'JA', trim(adjustl(this%name_model))//' CON') - call mem_setptr(this%jas, 'JAS', trim(adjustl(this%name_model))//' CON') - call mem_setptr(this%isym, 'ISYM', trim(adjustl(this%name_model))//' CON') - call mem_setptr(this%condsat, 'CONDSAT', trim(adjustl(this%name_model))//' NPF') - call mem_setptr(this%top, 'TOP', trim(adjustl(this%name_model))//' DIS') - call mem_setptr(this%bot, 'BOT', trim(adjustl(this%name_model))//' DIS') - call mem_setptr(this%hwva, 'HWVA', trim(adjustl(this%name_model))//' CON') - ! - call this%read_options() - call this%read_dimensions() - call this%allocate_arrays() - ! - ! -- return - return - end subroutine hfb_ar - - subroutine hfb_rp(this) -! ****************************************************************************** -! hfb_rp -- Check for new hfb stress period data -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors, store_error_unit - use TdisModule, only: kper, nper - ! -- dummy - class(GwfHfbType) :: this - ! -- local - character(len=LINELENGTH) :: line, errmsg - integer(I4B) :: ierr - logical :: isfound - ! -- formats - character(len=*),parameter :: fmtblkerr = & - "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - character(len=*),parameter :: fmtlsp = & - "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" -! ------------------------------------------------------------------------------ - ! - ! -- Set ionper to the stress period number for which a new block of data - ! will be read. - if (this%ionper < kper) then - ! - ! -- get period block - call this%parser%GetBlock('PERIOD', isfound, ierr, & - supportOpenClose=.true.) - if(isfound) then - ! - ! -- read ionper and check for increasing period numbers - call this%read_check_ionper() - else - ! - ! -- PERIOD block not found - if (ierr < 0) then - ! -- End of file found; data applies for remainder of simulation. - this%ionper = nper + 1 - else - ! -- Found invalid block - write(errmsg, fmtblkerr) adjustl(trim(line)) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - endif - end if - ! - if(this%ionper == kper) then - call this%condsat_reset() - call this%read_data() - call this%condsat_modify() - else - write(this%iout,fmtlsp) 'HFB' - endif - ! - ! -- return - return - end subroutine hfb_rp - - subroutine hfb_fc(this, kiter, njasln, amat, idxglo, rhs, hnew) -! ****************************************************************************** -! hfb_fc -- Fill amatsln for the following conditions: -! 1. Not Newton, and -! 2. Cell type n is convertible or cell type m is convertible -! OR -! 3. XT3D -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DHALF, DZERO - ! -- dummy - class(GwfHfbType) :: this - integer(I4B) :: kiter - integer(I4B),intent(in) :: njasln - real(DP),dimension(njasln),intent(inout) :: amat - integer(I4B),intent(in),dimension(:) :: idxglo - real(DP),intent(inout),dimension(:) :: rhs - real(DP),intent(inout),dimension(:) :: hnew - ! -- local - integer(I4B) :: nodes, nja - integer(I4B) :: ihfb, n, m - integer(I4B) :: ipos - integer(I4B) :: idiag, isymcon - integer(I4B) :: ixt3d - real(DP) :: cond, condhfb, aterm - real(DP) :: fawidth, faheight - real(DP) :: topn, topm, botn, botm -! ------------------------------------------------------------------------------ - ! - nodes = this%dis%nodes - nja = this%dis%con%nja - if (associated(this%xt3d%ixt3d)) then - ixt3d = this%xt3d%ixt3d - else - ixt3d = 0 - end if - ! - if(ixt3d > 0) then - ! - do ihfb = 1, this%nhfb - n = min(this%noden(ihfb), this%nodem(ihfb)) - m = max(this%noden(ihfb), this%nodem(ihfb)) - ! -- Skip if either cell is inactive. - if(this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle - !!! if(this%icelltype(n) == 1 .or. this%icelltype(m) == 1) then - ! -- Compute scale factor for hfb correction - if(this%hydchr(ihfb) > DZERO) then - if(this%inewton == 0) then - ipos = this%idxloc(ihfb) - topn = this%top(n) - topm = this%top(m) - botn = this%bot(n) - botm = this%bot(m) - if(this%icelltype(n) == 1) then - if(hnew(n) < topn) topn = hnew(n) - endif - if(this%icelltype(m) == 1) then - if(hnew(m) < topm) topm = hnew(m) - endif - if(this%ihc(this%jas(ipos)) == 2) then - faheight = min(topn, topm) - max(botn, botm) - else - faheight = DHALF * ( (topn - botn) + (topm - botm) ) - endif - fawidth = this%hwva(this%jas(ipos)) - condhfb = this%hydchr(ihfb) * fawidth * faheight - else - condhfb = this%hydchr(ihfb) - end if - else - condhfb = this%hydchr(ihfb) - endif - ! -- Make hfb corrections for xt3d - call this%xt3d%xt3d_fhfb(kiter, nodes, nja, njasln, amat, idxglo, & - rhs, hnew, n, m, condhfb) - end do - ! - else - ! - ! -- For Newton, the effect of the barrier is included in condsat. - if(this%inewton == 0) then - do ihfb = 1, this%nhfb - ipos = this%idxloc(ihfb) - aterm = amat(idxglo(ipos)) - n = this%noden(ihfb) - m = this%nodem(ihfb) - if(this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle - if(this%icelltype(n) == 1 .or. this%icelltype(m) == 1) then - ! - ! -- Calculate hfb conductance - topn = this%top(n) - topm = this%top(m) - botn = this%bot(n) - botm = this%bot(m) - if(this%icelltype(n) == 1) then - if(hnew(n) < topn) topn = hnew(n) - endif - if(this%icelltype(m) == 1) then - if(hnew(m) < topm) topm = hnew(m) - endif - if(this%ihc(this%jas(ipos)) == 2) then - faheight = min(topn, topm) - max(botn, botm) - else - faheight = DHALF * ( (topn - botn) + (topm - botm) ) - endif - if(this%hydchr(ihfb) > DZERO) then - fawidth = this%hwva(this%jas(ipos)) - condhfb = this%hydchr(ihfb) * fawidth * faheight - cond = aterm * condhfb / (aterm + condhfb) - else - cond = - aterm * this%hydchr(ihfb) - endif - ! - ! -- Save cond for budget calculation - this%condsav(ihfb) = cond - ! - ! -- Fill row n diag and off diag - idiag = this%ia(n) - amat(idxglo(idiag)) = amat(idxglo(idiag)) + aterm - cond - amat(idxglo(ipos)) = cond - ! - ! -- Fill row m diag and off diag - isymcon = this%isym(ipos) - idiag = this%ia(m) - amat(idxglo(idiag)) = amat(idxglo(idiag)) + aterm - cond - amat(idxglo(isymcon)) = cond - ! - endif - enddo - endif - ! - endif - ! - ! -- return - return - end subroutine hfb_fc - - subroutine hfb_flowja(this, hnew, flowja) -! ****************************************************************************** -! hfb_flowja -- flowja will automatically include the effects of the hfb -! for confined and newton cases when xt3d is not used. This method -! recalculates flowja for the other cases. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DHALF, DZERO - ! -- dummy - class(GwfHfbType) :: this - real(DP),intent(inout),dimension(:) :: hnew - real(DP),intent(inout),dimension(:) :: flowja - ! -- local - integer(I4B) :: ihfb, n, m - integer(I4B) :: ipos - real(DP) :: qnm - real(DP) :: cond - integer(I4B) :: ixt3d - real(DP) :: condhfb - real(DP) :: fawidth, faheight - real(DP) :: topn, topm, botn, botm -! ------------------------------------------------------------------------------ -! - if (associated(this%xt3d%ixt3d)) then - ixt3d = this%xt3d%ixt3d - else - ixt3d = 0 - end if - ! - if(ixt3d > 0) then - ! - do ihfb = 1, this%nhfb - n = min(this%noden(ihfb), this%nodem(ihfb)) - m = max(this%noden(ihfb), this%nodem(ihfb)) - ! -- Skip if either cell is inactive. - if(this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle - !!! if(this%icelltype(n) == 1 .or. this%icelltype(m) == 1) then - ! -- Compute scale factor for hfb correction - if(this%hydchr(ihfb) > DZERO) then - if(this%inewton == 0) then - ipos = this%idxloc(ihfb) - topn = this%top(n) - topm = this%top(m) - botn = this%bot(n) - botm = this%bot(m) - if(this%icelltype(n) == 1) then - if(hnew(n) < topn) topn = hnew(n) - endif - if(this%icelltype(m) == 1) then - if(hnew(m) < topm) topm = hnew(m) - endif - if(this%ihc(this%jas(ipos)) == 2) then - faheight = min(topn, topm) - max(botn, botm) - else - faheight = DHALF * ( (topn - botn) + (topm - botm) ) - endif - fawidth = this%hwva(this%jas(ipos)) - condhfb = this%hydchr(ihfb) * fawidth * faheight - else - condhfb = this%hydchr(ihfb) - end if - else - condhfb = this%hydchr(ihfb) - endif - ! -- Make hfb corrections for xt3d - call this%xt3d%xt3d_flowjahfb(n, m, hnew, flowja, condhfb) - end do - ! - else - ! - ! -- Recalculate flowja for non-newton unconfined. - if(this%inewton == 0) then - do ihfb = 1, this%nhfb - n = this%noden(ihfb) - m = this%nodem(ihfb) - if(this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle - if(this%icelltype(n) == 1 .or. this%icelltype(m) == 1) then - ipos = this%dis%con%getjaindex(n, m) - cond = this%condsav(ihfb) - qnm = cond * (hnew(m) - hnew(n)) - flowja(ipos) = qnm - ipos = this%dis%con%getjaindex(m, n) - flowja(ipos) = -qnm - ! - endif - enddo - endif - ! - end if - ! - ! -- return - return - end subroutine hfb_flowja - - subroutine hfb_da(this) -! ****************************************************************************** -! hfb_da -- Deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(GwfHfbType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Strings - ! - ! -- Scalars - call mem_deallocate(this%maxhfb) - call mem_deallocate(this%nhfb) - ! - ! -- Arrays - if (this%inunit > 0) then - call mem_deallocate(this%noden) - call mem_deallocate(this%nodem) - call mem_deallocate(this%hydchr) - call mem_deallocate(this%idxloc) - call mem_deallocate(this%csatsav) - call mem_deallocate(this%condsav) - endif - ! - ! -- deallocate parent - call this%NumericalPackageType%da() - ! - ! -- nullify pointers - this%xt3d => null() - this%inewton => null() - this%ibound => null() - this%icelltype => null() - this%ihc => null() - this%ia => null() - this%ja => null() - this%jas => null() - this%isym => null() - this%condsat => null() - this%top => null() - this%bot => null() - this%hwva => null() - ! - ! -- return - return - end subroutine hfb_da - - subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -- Allocate scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(GwfHfbType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- allocate scalars in NumericalPackageType - call this%NumericalPackageType%allocate_scalars() - ! - ! -- allocate scalars - call mem_allocate(this%maxhfb, 'MAXHFB', this%origin) - call mem_allocate(this%nhfb, 'NHFB', this%origin) - ! - ! -- initialize - this%maxhfb = 0 - this%nhfb = 0 - ! - ! -- return - return - end subroutine allocate_scalars - - subroutine allocate_arrays(this) -! ****************************************************************************** -! allocate_arrays -- Allocate arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(GwfHfbType) :: this - ! -- local - integer(I4B) :: ihfb -! ------------------------------------------------------------------------------ - ! - call mem_allocate(this%noden, this%maxhfb, 'NODEN', this%origin) - call mem_allocate(this%nodem, this%maxhfb, 'NODEM', this%origin) - call mem_allocate(this%hydchr, this%maxhfb, 'HYDCHR', this%origin) - call mem_allocate(this%idxloc, this%maxhfb, 'IDXLOC', this%origin) - call mem_allocate(this%csatsav, this%maxhfb, 'CSATSAV', this%origin) - call mem_allocate(this%condsav, this%maxhfb, 'CONDSAV', this%origin) - ! - ! -- initialize idxloc to 0 - do ihfb = 1, this%maxhfb - this%idxloc(ihfb) = 0 - enddo - ! - ! -- return - return - end subroutine allocate_arrays - - subroutine read_options(this) -! ****************************************************************************** -! read_options -- read a hfb options block -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, store_error_unit - ! -- dummy - class(GwfHfbType) :: this - ! -- local - 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.) - ! - ! -- parse options block if detected - if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING HFB OPTIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('PRINT_INPUT') - this%iprpak = 1 - write(this%iout,'(4x,a)') & - 'THE LIST OF HFBS WILL BE PRINTED.' - case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN HFB OPTION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - end do - write(this%iout,'(1x,a)')'END OF HFB OPTIONS' - end if - ! - ! -- return - return - end subroutine read_options - - subroutine read_dimensions(this) -! ****************************************************************************** -! read_dimensions -- Read the dimensions for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, store_error_unit - ! -- dummy - class(GwfHfbType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock - ! -- format -! ------------------------------------------------------------------------------ - ! - ! -- 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 HFB DIMENSIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('MAXHFB') - this%maxhfb = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)') 'MAXHFB = ', this%maxhfb - case default - write(errmsg,'(4x,a,a)') & - '****ERROR. UNKNOWN HFB DIMENSION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - end do - ! - write(this%iout,'(1x,a)')'END OF HFB DIMENSIONS' - else - call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- verify dimensions were set - if(this%maxhfb <= 0) then - write(errmsg, '(1x,a)') & - 'ERROR. MAXHFB MUST BE SPECIFIED WITH VALUE GREATER THAN ZERO.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- return - return - end subroutine read_dimensions - - subroutine read_data(this) -! ****************************************************************************** -! read_data -- Read hfb period block -! Data are in form of L, IROW1, ICOL1, IROW2, ICOL2, HYDCHR -! or for unstructured -! N1, N2, HYDCHR -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors, store_error_unit - use TdisModule, only: kper - ! -- dummy - class(GwfHfbType) :: this - ! -- local - character(len=LINELENGTH) :: nodenstr, nodemstr, cellidm, cellidn - integer(I4B) :: ihfb, nerr - logical :: endOfBlock - ! -- formats - character(len=*), parameter :: fmthfb = "(i10, 2a10, 1(1pg15.6))" -! ------------------------------------------------------------------------------ - ! - write(this%iout,'(//,1x,a)')'READING HFB DATA' - if(this%iprpak > 0) then - write(this%iout, '(3a10, 1a15)') 'HFB NUM', 'CELL1', 'CELL2', & - 'HYDCHR' - endif - ! - ihfb = 0 - this%nhfb = 0 - readloop: do - ! - ! -- Check for END of block - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - ! - ! -- Reset lloc and read noden, nodem, and hydchr - ihfb = ihfb + 1 - if(ihfb > this%maxhfb) then - call store_error('MAXHFB not large enough.') - call this%parser%StoreErrorUnit() - call ustop() - endif - call this%parser%GetCellid(this%dis%ndim, cellidn) - this%noden(ihfb) = this%dis%noder_from_cellid(cellidn, & - this%parser%iuactive, this%iout) - call this%parser%GetCellid(this%dis%ndim, cellidm) - this%nodem(ihfb) = this%dis%noder_from_cellid(cellidm, & - this%parser%iuactive, this%iout) - this%hydchr(ihfb) = this%parser%GetDouble() - ! - ! -- Print input if requested - if(this%iprpak /= 0) then - call this%dis%noder_to_string(this%noden(ihfb), nodenstr) - call this%dis%noder_to_string(this%nodem(ihfb), nodemstr) - write(this%iout, fmthfb) ihfb, trim(adjustl(nodenstr)), & - trim(adjustl(nodemstr)), this%hydchr(ihfb) - endif - ! - this%nhfb = ihfb - enddo readloop - ! - ! -- Stop if errors - nerr = count_errors() - if(nerr > 0) then - call store_error('Errors encountered in HFB input file.') - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - write(this%iout, '(3x,i0,a,i0)') this%nhfb, & - ' HFBs READ FOR STRESS PERIOD ', kper - call this%check_data() - write(this%iout, '(1x,a)')'END READING HFB DATA' - ! - ! -- return - return - end subroutine read_data - - subroutine check_data(this) -! ****************************************************************************** -! check_data -- Check for hfb's between two unconnected cells and write a -! warning. Store ipos in idxloc. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error, count_errors, ustop, store_error_unit - ! -- dummy - class(GwfHfbType) :: this - ! -- local - integer(I4B) :: ihfb, n, m - integer(I4B) :: ipos - character(len=LINELENGTH) :: nodenstr, nodemstr - character(len=LINELENGTH) :: errmsg - logical :: found - ! -- formats - character(len=*), parameter :: fmterr = "(1x, 'Error. HFB no. ',i0, & - &' is between two unconnected cells: ', a, ' and ', a)" -! ------------------------------------------------------------------------------ - ! - do ihfb = 1, this%nhfb - n = this%noden(ihfb) - m = this%nodem(ihfb) - found = .false. - do ipos = this%ia(n)+1, this%ia(n+1)-1 - if(m == this%ja(ipos)) then - found = .true. - this%idxloc(ihfb) = ipos - exit - endif - enddo - if(.not. found) then - call this%dis%noder_to_string(n, nodenstr) - call this%dis%noder_to_string(m, nodemstr) - write(errmsg, fmterr) ihfb, trim(adjustl(nodenstr)), & - trim(adjustl(nodemstr)) - call store_error(errmsg) - endif - enddo - ! - ! -- Stop if errors detected - if(count_errors() > 0) then - call store_error_unit(this%inunit) - call ustop() - endif - ! - ! -- return - return - end subroutine check_data - - subroutine condsat_reset(this) -! ****************************************************************************** -! condsat_reset -- Reset condsat to its value prior to being modified by hfb's -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(GwfHfbType) :: this - ! -- local - integer(I4B) :: ihfb - integer(I4B) :: ipos -! ------------------------------------------------------------------------------ - ! - do ihfb = 1, this%nhfb - ipos = this%idxloc(ihfb) - this%condsat(this%jas(ipos)) = this%csatsav(ihfb) - enddo - ! - ! -- return - return - end subroutine condsat_reset - - subroutine condsat_modify(this) -! ****************************************************************************** -! condsat_modify -- Modify condsat for the following conditions: -! 1. If Newton is active -! 2. If icelltype for n and icelltype for m is 0 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DHALF, DZERO - ! -- dummy - class(GwfHfbType) :: this - ! -- local - integer(I4B) :: ihfb, n, m - integer(I4B) :: ipos - real(DP) :: cond, condhfb - real(DP) :: fawidth, faheight - real(DP) :: topn, topm, botn, botm -! ------------------------------------------------------------------------------ - ! - do ihfb = 1, this%nhfb - ipos = this%idxloc(ihfb) - cond = this%condsat(this%jas(ipos)) - this%csatsav(ihfb) = cond - n = this%noden(ihfb) - m = this%nodem(ihfb) - if(this%inewton == 1 .or. & - (this%icelltype(n) == 0 .and. this%icelltype(m) == 0) ) then - ! - ! -- Calculate hfb conductance - topn = this%top(n) - topm = this%top(m) - botn = this%bot(n) - botm = this%bot(m) - if(this%ihc(this%jas(ipos)) == 2) then - faheight = min(topn, topm) - max(botn, botm) - else - faheight = DHALF * ( (topn - botn) + (topm - botm) ) - endif - if(this%hydchr(ihfb) > DZERO) then - fawidth = this%hwva(this%jas(ipos)) - condhfb = this%hydchr(ihfb) * fawidth * faheight - cond = cond * condhfb / (cond + condhfb) - else - cond = - cond * this%hydchr(ihfb) - endif - this%condsat(this%jas(ipos)) = cond - endif - enddo - ! - ! -- return - return - end subroutine condsat_modify - -end module GwfHfbModule + +module GwfHfbModule + + use KindModule, only: DP, I4B + use Xt3dModule, only: Xt3dType + use NumericalPackageModule, only: NumericalPackageType + use BlockParserModule, only: BlockParserType + use BaseDisModule, only: DisBaseType + + implicit none + + private + public :: GwfHfbType + public :: hfb_cr + + type, extends(NumericalPackageType) :: GwfHfbType + integer(I4B), pointer :: maxhfb => null() !max number of hfb's + integer(I4B), pointer :: nhfb => null() !number of hfb's + integer(I4B), dimension(:), pointer, contiguous :: noden => null() !first cell + integer(I4B), dimension(:), pointer, contiguous :: nodem => null() !second cell + integer(I4B), dimension(:), pointer, contiguous :: idxloc => null() !position in model ja + real(DP), dimension(:), pointer, contiguous :: hydchr => null() !hydraulic characteristic of the barrier + real(DP), dimension(:), pointer, contiguous :: csatsav => null() !value of condsat prior to hfb modification + real(DP), dimension(:), pointer, contiguous :: condsav => null() !saved conductance of combined npf and hfb + type(Xt3dType), pointer :: xt3d => null() !pointer to xt3d object + ! + integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !pointer to model ibound + integer(I4B), dimension(:), pointer, contiguous :: icelltype => null() !pointer to model icelltype + integer(I4B), dimension(:), pointer, contiguous :: ihc => null() !pointer to model ihc + integer(I4B), dimension(:), pointer, contiguous :: ia => null() !pointer to model ia + integer(I4B), dimension(:), pointer, contiguous :: ja => null() !pointer to model ja + integer(I4B), dimension(:), pointer, contiguous :: jas => null() !pointer to model jas + integer(I4B), dimension(:), pointer, contiguous :: isym => null() !pointer to model isym + real(DP), dimension(:), pointer, contiguous :: condsat => null() !pointer to model condsat + real(DP), dimension(:), pointer, contiguous :: top => null() !pointer to model top + real(DP), dimension(:), pointer, contiguous :: bot => null() !pointer to model bot + real(DP), dimension(:), pointer, contiguous :: hwva => null() !pointer to model hwva + contains + procedure :: hfb_ar + procedure :: hfb_rp + procedure :: hfb_fc + procedure :: hfb_flowja + procedure :: hfb_da + procedure :: allocate_scalars + procedure, private :: allocate_arrays + procedure, private :: read_options + procedure, private :: read_dimensions + procedure, private :: read_data + procedure, private :: check_data + procedure, private :: condsat_reset + procedure, private :: condsat_modify + end type GwfHfbType + + contains + + subroutine hfb_cr(hfbobj, name_model, inunit, iout) +! ****************************************************************************** +! hfb_cr -- Create a new hfb object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + type(GwfHfbType), pointer :: hfbobj + character(len=*), intent(in) :: name_model + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout +! ------------------------------------------------------------------------------ + ! + ! -- Create the object + allocate(hfbobj) + ! + ! -- create name and origin + call hfbobj%set_names(1, name_model, 'HFB', 'HFB') + ! + ! -- Allocate scalars + call hfbobj%allocate_scalars() + ! + ! -- Save unit numbers + hfbobj%inunit = inunit + hfbobj%iout = iout + ! + ! -- Initialize block parser + call hfbobj%parser%Initialize(hfbobj%inunit, hfbobj%iout) + ! + ! -- Return + return + end subroutine hfb_cr + + subroutine hfb_ar(this, ibound, xt3d, dis) +! ****************************************************************************** +! hfb_ar -- Allocate and read +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_setptr + ! -- dummy + class(GwfHfbType) :: this + integer(I4B), dimension(:), pointer, contiguous :: ibound + type(Xt3dType), pointer :: xt3d + class(DisBaseType), pointer, intent(inout) :: dis + ! -- formats + character(len=*), parameter :: fmtheader = & + &"(1x, /1x, 'HFB -- HORIZONTAL FLOW BARRIER PACKAGE, VERSION 8, ', & + &'4/24/2015 INPUT READ FROM UNIT ', i4, //)" +! ------------------------------------------------------------------------------ + ! + ! -- Print a message identifying the node property flow package. + write(this%iout, fmtheader) this%inunit + ! + ! -- Set pointers + this%dis => dis + this%ibound => ibound + this%xt3d => xt3d + call mem_setptr(this%icelltype, 'ICELLTYPE', trim(adjustl(this%name_model))//' NPF') + call mem_setptr(this%ihc, 'IHC', trim(adjustl(this%name_model))//' CON') + call mem_setptr(this%ia, 'IA', trim(adjustl(this%name_model))//' CON') + call mem_setptr(this%ja, 'JA', trim(adjustl(this%name_model))//' CON') + call mem_setptr(this%jas, 'JAS', trim(adjustl(this%name_model))//' CON') + call mem_setptr(this%isym, 'ISYM', trim(adjustl(this%name_model))//' CON') + call mem_setptr(this%condsat, 'CONDSAT', trim(adjustl(this%name_model))//' NPF') + call mem_setptr(this%top, 'TOP', trim(adjustl(this%name_model))//' DIS') + call mem_setptr(this%bot, 'BOT', trim(adjustl(this%name_model))//' DIS') + call mem_setptr(this%hwva, 'HWVA', trim(adjustl(this%name_model))//' CON') + ! + call this%read_options() + call this%read_dimensions() + call this%allocate_arrays() + ! + ! -- return + return + end subroutine hfb_ar + + subroutine hfb_rp(this) +! ****************************************************************************** +! hfb_rp -- Check for new hfb stress period data +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors, store_error_unit + use TdisModule, only: kper, nper + ! -- dummy + class(GwfHfbType) :: this + ! -- local + character(len=LINELENGTH) :: line, errmsg + integer(I4B) :: ierr + logical :: isfound + ! -- formats + character(len=*),parameter :: fmtblkerr = & + "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + character(len=*),parameter :: fmtlsp = & + "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" +! ------------------------------------------------------------------------------ + ! + ! -- Set ionper to the stress period number for which a new block of data + ! will be read. + if (this%ionper < kper) then + ! + ! -- get period block + call this%parser%GetBlock('PERIOD', isfound, ierr, & + supportOpenClose=.true.) + if(isfound) then + ! + ! -- read ionper and check for increasing period numbers + call this%read_check_ionper() + else + ! + ! -- PERIOD block not found + if (ierr < 0) then + ! -- End of file found; data applies for remainder of simulation. + this%ionper = nper + 1 + else + ! -- Found invalid block + write(errmsg, fmtblkerr) adjustl(trim(line)) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end if + endif + end if + ! + if(this%ionper == kper) then + call this%condsat_reset() + call this%read_data() + call this%condsat_modify() + else + write(this%iout,fmtlsp) 'HFB' + endif + ! + ! -- return + return + end subroutine hfb_rp + + subroutine hfb_fc(this, kiter, njasln, amat, idxglo, rhs, hnew) +! ****************************************************************************** +! hfb_fc -- Fill amatsln for the following conditions: +! 1. Not Newton, and +! 2. Cell type n is convertible or cell type m is convertible +! OR +! 3. XT3D +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DHALF, DZERO + ! -- dummy + class(GwfHfbType) :: this + integer(I4B) :: kiter + integer(I4B),intent(in) :: njasln + real(DP),dimension(njasln),intent(inout) :: amat + integer(I4B),intent(in),dimension(:) :: idxglo + real(DP),intent(inout),dimension(:) :: rhs + real(DP),intent(inout),dimension(:) :: hnew + ! -- local + integer(I4B) :: nodes, nja + integer(I4B) :: ihfb, n, m + integer(I4B) :: ipos + integer(I4B) :: idiag, isymcon + integer(I4B) :: ixt3d + real(DP) :: cond, condhfb, aterm + real(DP) :: fawidth, faheight + real(DP) :: topn, topm, botn, botm +! ------------------------------------------------------------------------------ + ! + nodes = this%dis%nodes + nja = this%dis%con%nja + if (associated(this%xt3d%ixt3d)) then + ixt3d = this%xt3d%ixt3d + else + ixt3d = 0 + end if + ! + if(ixt3d > 0) then + ! + do ihfb = 1, this%nhfb + n = min(this%noden(ihfb), this%nodem(ihfb)) + m = max(this%noden(ihfb), this%nodem(ihfb)) + ! -- Skip if either cell is inactive. + if(this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle + !!! if(this%icelltype(n) == 1 .or. this%icelltype(m) == 1) then + ! -- Compute scale factor for hfb correction + if(this%hydchr(ihfb) > DZERO) then + if(this%inewton == 0) then + ipos = this%idxloc(ihfb) + topn = this%top(n) + topm = this%top(m) + botn = this%bot(n) + botm = this%bot(m) + if(this%icelltype(n) == 1) then + if(hnew(n) < topn) topn = hnew(n) + endif + if(this%icelltype(m) == 1) then + if(hnew(m) < topm) topm = hnew(m) + endif + if(this%ihc(this%jas(ipos)) == 2) then + faheight = min(topn, topm) - max(botn, botm) + else + faheight = DHALF * ( (topn - botn) + (topm - botm) ) + endif + fawidth = this%hwva(this%jas(ipos)) + condhfb = this%hydchr(ihfb) * fawidth * faheight + else + condhfb = this%hydchr(ihfb) + end if + else + condhfb = this%hydchr(ihfb) + endif + ! -- Make hfb corrections for xt3d + call this%xt3d%xt3d_fhfb(kiter, nodes, nja, njasln, amat, idxglo, & + rhs, hnew, n, m, condhfb) + end do + ! + else + ! + ! -- For Newton, the effect of the barrier is included in condsat. + if(this%inewton == 0) then + do ihfb = 1, this%nhfb + ipos = this%idxloc(ihfb) + aterm = amat(idxglo(ipos)) + n = this%noden(ihfb) + m = this%nodem(ihfb) + if(this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle + if(this%icelltype(n) == 1 .or. this%icelltype(m) == 1) then + ! + ! -- Calculate hfb conductance + topn = this%top(n) + topm = this%top(m) + botn = this%bot(n) + botm = this%bot(m) + if(this%icelltype(n) == 1) then + if(hnew(n) < topn) topn = hnew(n) + endif + if(this%icelltype(m) == 1) then + if(hnew(m) < topm) topm = hnew(m) + endif + if(this%ihc(this%jas(ipos)) == 2) then + faheight = min(topn, topm) - max(botn, botm) + else + faheight = DHALF * ( (topn - botn) + (topm - botm) ) + endif + if(this%hydchr(ihfb) > DZERO) then + fawidth = this%hwva(this%jas(ipos)) + condhfb = this%hydchr(ihfb) * fawidth * faheight + cond = aterm * condhfb / (aterm + condhfb) + else + cond = - aterm * this%hydchr(ihfb) + endif + ! + ! -- Save cond for budget calculation + this%condsav(ihfb) = cond + ! + ! -- Fill row n diag and off diag + idiag = this%ia(n) + amat(idxglo(idiag)) = amat(idxglo(idiag)) + aterm - cond + amat(idxglo(ipos)) = cond + ! + ! -- Fill row m diag and off diag + isymcon = this%isym(ipos) + idiag = this%ia(m) + amat(idxglo(idiag)) = amat(idxglo(idiag)) + aterm - cond + amat(idxglo(isymcon)) = cond + ! + endif + enddo + endif + ! + endif + ! + ! -- return + return + end subroutine hfb_fc + + subroutine hfb_flowja(this, hnew, flowja) +! ****************************************************************************** +! hfb_flowja -- flowja will automatically include the effects of the hfb +! for confined and newton cases when xt3d is not used. This method +! recalculates flowja for the other cases. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DHALF, DZERO + ! -- dummy + class(GwfHfbType) :: this + real(DP),intent(inout),dimension(:) :: hnew + real(DP),intent(inout),dimension(:) :: flowja + ! -- local + integer(I4B) :: ihfb, n, m + integer(I4B) :: ipos + real(DP) :: qnm + real(DP) :: cond + integer(I4B) :: ixt3d + real(DP) :: condhfb + real(DP) :: fawidth, faheight + real(DP) :: topn, topm, botn, botm +! ------------------------------------------------------------------------------ +! + if (associated(this%xt3d%ixt3d)) then + ixt3d = this%xt3d%ixt3d + else + ixt3d = 0 + end if + ! + if(ixt3d > 0) then + ! + do ihfb = 1, this%nhfb + n = min(this%noden(ihfb), this%nodem(ihfb)) + m = max(this%noden(ihfb), this%nodem(ihfb)) + ! -- Skip if either cell is inactive. + if(this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle + !!! if(this%icelltype(n) == 1 .or. this%icelltype(m) == 1) then + ! -- Compute scale factor for hfb correction + if(this%hydchr(ihfb) > DZERO) then + if(this%inewton == 0) then + ipos = this%idxloc(ihfb) + topn = this%top(n) + topm = this%top(m) + botn = this%bot(n) + botm = this%bot(m) + if(this%icelltype(n) == 1) then + if(hnew(n) < topn) topn = hnew(n) + endif + if(this%icelltype(m) == 1) then + if(hnew(m) < topm) topm = hnew(m) + endif + if(this%ihc(this%jas(ipos)) == 2) then + faheight = min(topn, topm) - max(botn, botm) + else + faheight = DHALF * ( (topn - botn) + (topm - botm) ) + endif + fawidth = this%hwva(this%jas(ipos)) + condhfb = this%hydchr(ihfb) * fawidth * faheight + else + condhfb = this%hydchr(ihfb) + end if + else + condhfb = this%hydchr(ihfb) + endif + ! -- Make hfb corrections for xt3d + call this%xt3d%xt3d_flowjahfb(n, m, hnew, flowja, condhfb) + end do + ! + else + ! + ! -- Recalculate flowja for non-newton unconfined. + if(this%inewton == 0) then + do ihfb = 1, this%nhfb + n = this%noden(ihfb) + m = this%nodem(ihfb) + if(this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle + if(this%icelltype(n) == 1 .or. this%icelltype(m) == 1) then + ipos = this%dis%con%getjaindex(n, m) + cond = this%condsav(ihfb) + qnm = cond * (hnew(m) - hnew(n)) + flowja(ipos) = qnm + ipos = this%dis%con%getjaindex(m, n) + flowja(ipos) = -qnm + ! + endif + enddo + endif + ! + end if + ! + ! -- return + return + end subroutine hfb_flowja + + subroutine hfb_da(this) +! ****************************************************************************** +! hfb_da -- Deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(GwfHfbType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Strings + ! + ! -- Scalars + call mem_deallocate(this%maxhfb) + call mem_deallocate(this%nhfb) + ! + ! -- Arrays + if (this%inunit > 0) then + call mem_deallocate(this%noden) + call mem_deallocate(this%nodem) + call mem_deallocate(this%hydchr) + call mem_deallocate(this%idxloc) + call mem_deallocate(this%csatsav) + call mem_deallocate(this%condsav) + endif + ! + ! -- deallocate parent + call this%NumericalPackageType%da() + ! + ! -- nullify pointers + this%xt3d => null() + this%inewton => null() + this%ibound => null() + this%icelltype => null() + this%ihc => null() + this%ia => null() + this%ja => null() + this%jas => null() + this%isym => null() + this%condsat => null() + this%top => null() + this%bot => null() + this%hwva => null() + ! + ! -- return + return + end subroutine hfb_da + + subroutine allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars -- Allocate scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GwfHfbType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- allocate scalars in NumericalPackageType + call this%NumericalPackageType%allocate_scalars() + ! + ! -- allocate scalars + call mem_allocate(this%maxhfb, 'MAXHFB', this%origin) + call mem_allocate(this%nhfb, 'NHFB', this%origin) + ! + ! -- initialize + this%maxhfb = 0 + this%nhfb = 0 + ! + ! -- return + return + end subroutine allocate_scalars + + subroutine allocate_arrays(this) +! ****************************************************************************** +! allocate_arrays -- Allocate arrays +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GwfHfbType) :: this + ! -- local + integer(I4B) :: ihfb +! ------------------------------------------------------------------------------ + ! + call mem_allocate(this%noden, this%maxhfb, 'NODEN', this%origin) + call mem_allocate(this%nodem, this%maxhfb, 'NODEM', this%origin) + call mem_allocate(this%hydchr, this%maxhfb, 'HYDCHR', this%origin) + call mem_allocate(this%idxloc, this%maxhfb, 'IDXLOC', this%origin) + call mem_allocate(this%csatsav, this%maxhfb, 'CSATSAV', this%origin) + call mem_allocate(this%condsav, this%maxhfb, 'CONDSAV', this%origin) + ! + ! -- initialize idxloc to 0 + do ihfb = 1, this%maxhfb + this%idxloc(ihfb) = 0 + enddo + ! + ! -- return + return + end subroutine allocate_arrays + + subroutine read_options(this) +! ****************************************************************************** +! read_options -- read a hfb options block +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, store_error_unit + ! -- dummy + class(GwfHfbType) :: this + ! -- local + 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.) + ! + ! -- parse options block if detected + if (isfound) then + write(this%iout,'(1x,a)')'PROCESSING HFB OPTIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('PRINT_INPUT') + this%iprpak = 1 + write(this%iout,'(4x,a)') & + 'THE LIST OF HFBS WILL BE PRINTED.' + case default + write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN HFB OPTION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + end do + write(this%iout,'(1x,a)')'END OF HFB OPTIONS' + end if + ! + ! -- return + return + end subroutine read_options + + subroutine read_dimensions(this) +! ****************************************************************************** +! read_dimensions -- Read the dimensions for this package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, store_error_unit + ! -- dummy + class(GwfHfbType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: errmsg, keyword + integer(I4B) :: ierr + logical :: isfound, endOfBlock + ! -- format +! ------------------------------------------------------------------------------ + ! + ! -- 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 HFB DIMENSIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('MAXHFB') + this%maxhfb = this%parser%GetInteger() + write(this%iout,'(4x,a,i7)') 'MAXHFB = ', this%maxhfb + case default + write(errmsg,'(4x,a,a)') & + '****ERROR. UNKNOWN HFB DIMENSION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + end do + ! + write(this%iout,'(1x,a)')'END OF HFB DIMENSIONS' + else + call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- verify dimensions were set + if(this%maxhfb <= 0) then + write(errmsg, '(1x,a)') & + 'ERROR. MAXHFB MUST BE SPECIFIED WITH VALUE GREATER THAN ZERO.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- return + return + end subroutine read_dimensions + + subroutine read_data(this) +! ****************************************************************************** +! read_data -- Read hfb period block +! Data are in form of L, IROW1, ICOL1, IROW2, ICOL2, HYDCHR +! or for unstructured +! N1, N2, HYDCHR +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors, store_error_unit + use TdisModule, only: kper + ! -- dummy + class(GwfHfbType) :: this + ! -- local + character(len=LINELENGTH) :: nodenstr, nodemstr, cellidm, cellidn + integer(I4B) :: ihfb, nerr + logical :: endOfBlock + ! -- formats + character(len=*), parameter :: fmthfb = "(i10, 2a10, 1(1pg15.6))" +! ------------------------------------------------------------------------------ + ! + write(this%iout,'(//,1x,a)')'READING HFB DATA' + if(this%iprpak > 0) then + write(this%iout, '(3a10, 1a15)') 'HFB NUM', 'CELL1', 'CELL2', & + 'HYDCHR' + endif + ! + ihfb = 0 + this%nhfb = 0 + readloop: do + ! + ! -- Check for END of block + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + ! + ! -- Reset lloc and read noden, nodem, and hydchr + ihfb = ihfb + 1 + if(ihfb > this%maxhfb) then + call store_error('MAXHFB not large enough.') + call this%parser%StoreErrorUnit() + call ustop() + endif + call this%parser%GetCellid(this%dis%ndim, cellidn) + this%noden(ihfb) = this%dis%noder_from_cellid(cellidn, & + this%parser%iuactive, this%iout) + call this%parser%GetCellid(this%dis%ndim, cellidm) + this%nodem(ihfb) = this%dis%noder_from_cellid(cellidm, & + this%parser%iuactive, this%iout) + this%hydchr(ihfb) = this%parser%GetDouble() + ! + ! -- Print input if requested + if(this%iprpak /= 0) then + call this%dis%noder_to_string(this%noden(ihfb), nodenstr) + call this%dis%noder_to_string(this%nodem(ihfb), nodemstr) + write(this%iout, fmthfb) ihfb, trim(adjustl(nodenstr)), & + trim(adjustl(nodemstr)), this%hydchr(ihfb) + endif + ! + this%nhfb = ihfb + enddo readloop + ! + ! -- Stop if errors + nerr = count_errors() + if(nerr > 0) then + call store_error('Errors encountered in HFB input file.') + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + write(this%iout, '(3x,i0,a,i0)') this%nhfb, & + ' HFBs READ FOR STRESS PERIOD ', kper + call this%check_data() + write(this%iout, '(1x,a)')'END READING HFB DATA' + ! + ! -- return + return + end subroutine read_data + + subroutine check_data(this) +! ****************************************************************************** +! check_data -- Check for hfb's between two unconnected cells and write a +! warning. Store ipos in idxloc. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error, count_errors, ustop, store_error_unit + ! -- dummy + class(GwfHfbType) :: this + ! -- local + integer(I4B) :: ihfb, n, m + integer(I4B) :: ipos + character(len=LINELENGTH) :: nodenstr, nodemstr + character(len=LINELENGTH) :: errmsg + logical :: found + ! -- formats + character(len=*), parameter :: fmterr = "(1x, 'Error. HFB no. ',i0, & + &' is between two unconnected cells: ', a, ' and ', a)" +! ------------------------------------------------------------------------------ + ! + do ihfb = 1, this%nhfb + n = this%noden(ihfb) + m = this%nodem(ihfb) + found = .false. + do ipos = this%ia(n)+1, this%ia(n+1)-1 + if(m == this%ja(ipos)) then + found = .true. + this%idxloc(ihfb) = ipos + exit + endif + enddo + if(.not. found) then + call this%dis%noder_to_string(n, nodenstr) + call this%dis%noder_to_string(m, nodemstr) + write(errmsg, fmterr) ihfb, trim(adjustl(nodenstr)), & + trim(adjustl(nodemstr)) + call store_error(errmsg) + endif + enddo + ! + ! -- Stop if errors detected + if(count_errors() > 0) then + call store_error_unit(this%inunit) + call ustop() + endif + ! + ! -- return + return + end subroutine check_data + + subroutine condsat_reset(this) +! ****************************************************************************** +! condsat_reset -- Reset condsat to its value prior to being modified by hfb's +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfHfbType) :: this + ! -- local + integer(I4B) :: ihfb + integer(I4B) :: ipos +! ------------------------------------------------------------------------------ + ! + do ihfb = 1, this%nhfb + ipos = this%idxloc(ihfb) + this%condsat(this%jas(ipos)) = this%csatsav(ihfb) + enddo + ! + ! -- return + return + end subroutine condsat_reset + + subroutine condsat_modify(this) +! ****************************************************************************** +! condsat_modify -- Modify condsat for the following conditions: +! 1. If Newton is active +! 2. If icelltype for n and icelltype for m is 0 +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DHALF, DZERO + ! -- dummy + class(GwfHfbType) :: this + ! -- local + integer(I4B) :: ihfb, n, m + integer(I4B) :: ipos + real(DP) :: cond, condhfb + real(DP) :: fawidth, faheight + real(DP) :: topn, topm, botn, botm +! ------------------------------------------------------------------------------ + ! + do ihfb = 1, this%nhfb + ipos = this%idxloc(ihfb) + cond = this%condsat(this%jas(ipos)) + this%csatsav(ihfb) = cond + n = this%noden(ihfb) + m = this%nodem(ihfb) + if(this%inewton == 1 .or. & + (this%icelltype(n) == 0 .and. this%icelltype(m) == 0) ) then + ! + ! -- Calculate hfb conductance + topn = this%top(n) + topm = this%top(m) + botn = this%bot(n) + botm = this%bot(m) + if(this%ihc(this%jas(ipos)) == 2) then + faheight = min(topn, topm) - max(botn, botm) + else + faheight = DHALF * ( (topn - botn) + (topm - botm) ) + endif + if(this%hydchr(ihfb) > DZERO) then + fawidth = this%hwva(this%jas(ipos)) + condhfb = this%hydchr(ihfb) * fawidth * faheight + cond = cond * condhfb / (cond + condhfb) + else + cond = - cond * this%hydchr(ihfb) + endif + this%condsat(this%jas(ipos)) = cond + endif + enddo + ! + ! -- return + return + end subroutine condsat_modify + +end module GwfHfbModule diff --git a/src/Model/GroundWaterFlow/gwf3ic8.f90 b/src/Model/GroundWaterFlow/gwf3ic8.f90 index 6f22c5b4169..c32bdf953d4 100644 --- a/src/Model/GroundWaterFlow/gwf3ic8.f90 +++ b/src/Model/GroundWaterFlow/gwf3ic8.f90 @@ -1,252 +1,252 @@ -module GwfIcModule - - use KindModule, only: DP, I4B - use NumericalPackageModule, only: NumericalPackageType - use BlockParserModule, only: BlockParserType - use BaseDisModule, only: DisBaseType - - implicit none - private - public :: GwfIcType - public :: ic_cr - - type, extends(NumericalPackageType) :: GwfIcType - real(DP), dimension(:), pointer, contiguous :: strt => null() ! starting head - contains - procedure :: ic_ar - procedure :: ic_da - procedure, private :: allocate_arrays - procedure, private :: read_options - procedure, private :: read_data - end type GwfIcType - - contains - - subroutine ic_cr(ic, name_model, inunit, iout, dis) -! ****************************************************************************** -! ic_cr -- Create a new initial conditions object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - type(GwfIcType), pointer :: ic - character(len=*), intent(in) :: name_model - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - class(DisBaseType), pointer, intent(in) :: dis -! ------------------------------------------------------------------------------ - ! - ! -- Create the object - allocate(ic) - ! - ! -- create name and origin - call ic%set_names(1, name_model, 'IC', 'IC') - ! - ! -- Allocate scalars - call ic%allocate_scalars() - ! - ic%inunit = inunit - ic%iout = iout - ! - ! -- set pointers - ic%dis => dis - ! - ! -- Initialize block parser - call ic%parser%Initialize(ic%inunit, ic%iout) - ! - ! -- Return - return - end subroutine ic_cr - - subroutine ic_ar(this, x) -! ****************************************************************************** -! ic_ar -- Allocate and read initial conditions -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use BaseDisModule, only: DisBaseType - use SimModule, only: ustop, store_error - ! -- dummy - class(GwfIcType) :: this - real(DP), dimension(:), intent(inout) :: x - ! -- locals - integer(I4B) :: n -! ------------------------------------------------------------------------------ - ! - ! -- Print a message identifying the initial conditions package. - write(this%iout,1) this%inunit - 1 format(1x,/1x,'IC -- INITIAL CONDITIONS PACKAGE, VERSION 8, 3/28/2015', & - ' INPUT READ FROM UNIT ',i0) - ! - ! -- Allocate arrays - call this%allocate_arrays(this%dis%nodes) - ! - ! -- Read options - call this%read_options() - ! - ! -- Read data - call this%read_data() - ! - ! -- Assign x equal to strt - do n = 1, this%dis%nodes - x(n) = this%strt(n) - enddo - ! - ! -- Return - return - end subroutine ic_ar - - subroutine ic_da(this) -! ****************************************************************************** -! ic_da -- Deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(GwfIcType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- deallocate parent - call this%NumericalPackageType%da() - ! - ! -- Scalars - ! - ! -- Arrays - call mem_deallocate(this%strt) - ! - ! -- Return - return - end subroutine ic_da - - subroutine allocate_arrays(this, nodes) -! ****************************************************************************** -! allocate_arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(GwfIcType) :: this - integer(I4B), intent(in) :: nodes - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- Allocate - call mem_allocate(this%strt, nodes, 'STRT', this%origin) - ! - ! -- Return - return - end subroutine allocate_arrays - - subroutine read_options(this) -! ****************************************************************************** -! read_options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error - ! -- dummy - class(GwfIcType) :: this - ! -- local - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- 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 IC OPTIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN IC OPTION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - end do - write(this%iout,'(1x,a)')'END OF IC OPTIONS' - end if - ! - ! -- Return - return - end subroutine read_options - - subroutine read_data(this) -! ****************************************************************************** -! read_data -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error - ! -- dummy - class(GwfIcType) :: this - ! -- local - character(len=LINELENGTH) :: line, errmsg, keyword - integer(I4B) :: istart, istop, lloc, ierr - logical :: isfound, endOfBlock - character(len=24) :: aname(1) - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- Setup the label - aname(1) = ' INITIAL HEAD' - ! - ! -- 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 ('STRT') - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%strt, & - aname(1)) - case default - write(errmsg,'(4x,a,a)')'ERROR. UNKNOWN GRIDDATA TAG: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - 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() - call ustop() - end if - ! - ! -- Return - return - end subroutine read_data - -end module GwfIcModule +module GwfIcModule + + use KindModule, only: DP, I4B + use NumericalPackageModule, only: NumericalPackageType + use BlockParserModule, only: BlockParserType + use BaseDisModule, only: DisBaseType + + implicit none + private + public :: GwfIcType + public :: ic_cr + + type, extends(NumericalPackageType) :: GwfIcType + real(DP), dimension(:), pointer, contiguous :: strt => null() ! starting head + contains + procedure :: ic_ar + procedure :: ic_da + procedure, private :: allocate_arrays + procedure, private :: read_options + procedure, private :: read_data + end type GwfIcType + + contains + + subroutine ic_cr(ic, name_model, inunit, iout, dis) +! ****************************************************************************** +! ic_cr -- Create a new initial conditions object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + type(GwfIcType), pointer :: ic + character(len=*), intent(in) :: name_model + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + class(DisBaseType), pointer, intent(in) :: dis +! ------------------------------------------------------------------------------ + ! + ! -- Create the object + allocate(ic) + ! + ! -- create name and origin + call ic%set_names(1, name_model, 'IC', 'IC') + ! + ! -- Allocate scalars + call ic%allocate_scalars() + ! + ic%inunit = inunit + ic%iout = iout + ! + ! -- set pointers + ic%dis => dis + ! + ! -- Initialize block parser + call ic%parser%Initialize(ic%inunit, ic%iout) + ! + ! -- Return + return + end subroutine ic_cr + + subroutine ic_ar(this, x) +! ****************************************************************************** +! ic_ar -- Allocate and read initial conditions +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use BaseDisModule, only: DisBaseType + use SimModule, only: ustop, store_error + ! -- dummy + class(GwfIcType) :: this + real(DP), dimension(:), intent(inout) :: x + ! -- locals + integer(I4B) :: n +! ------------------------------------------------------------------------------ + ! + ! -- Print a message identifying the initial conditions package. + write(this%iout,1) this%inunit + 1 format(1x,/1x,'IC -- INITIAL CONDITIONS PACKAGE, VERSION 8, 3/28/2015', & + ' INPUT READ FROM UNIT ',i0) + ! + ! -- Allocate arrays + call this%allocate_arrays(this%dis%nodes) + ! + ! -- Read options + call this%read_options() + ! + ! -- Read data + call this%read_data() + ! + ! -- Assign x equal to strt + do n = 1, this%dis%nodes + x(n) = this%strt(n) + enddo + ! + ! -- Return + return + end subroutine ic_ar + + subroutine ic_da(this) +! ****************************************************************************** +! ic_da -- Deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(GwfIcType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- deallocate parent + call this%NumericalPackageType%da() + ! + ! -- Scalars + ! + ! -- Arrays + call mem_deallocate(this%strt) + ! + ! -- Return + return + end subroutine ic_da + + subroutine allocate_arrays(this, nodes) +! ****************************************************************************** +! allocate_arrays +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GwfIcType) :: this + integer(I4B), intent(in) :: nodes + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Allocate + call mem_allocate(this%strt, nodes, 'STRT', this%origin) + ! + ! -- Return + return + end subroutine allocate_arrays + + subroutine read_options(this) +! ****************************************************************************** +! read_options +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error + ! -- dummy + class(GwfIcType) :: this + ! -- local + character(len=LINELENGTH) :: errmsg, keyword + integer(I4B) :: ierr + logical :: isfound, endOfBlock + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- 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 IC OPTIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case default + write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN IC OPTION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + end do + write(this%iout,'(1x,a)')'END OF IC OPTIONS' + end if + ! + ! -- Return + return + end subroutine read_options + + subroutine read_data(this) +! ****************************************************************************** +! read_data +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error + ! -- dummy + class(GwfIcType) :: this + ! -- local + character(len=LINELENGTH) :: line, errmsg, keyword + integer(I4B) :: istart, istop, lloc, ierr + logical :: isfound, endOfBlock + character(len=24) :: aname(1) + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- Setup the label + aname(1) = ' INITIAL HEAD' + ! + ! -- 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 ('STRT') + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%strt, & + aname(1)) + case default + write(errmsg,'(4x,a,a)')'ERROR. UNKNOWN GRIDDATA TAG: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + 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() + call ustop() + end if + ! + ! -- Return + return + end subroutine read_data + +end module GwfIcModule diff --git a/src/Model/GroundWaterFlow/gwf3lak8.f90 b/src/Model/GroundWaterFlow/gwf3lak8.f90 index dc8f98e1fae..e9a6288fa96 100644 --- a/src/Model/GroundWaterFlow/gwf3lak8.f90 +++ b/src/Model/GroundWaterFlow/gwf3lak8.f90 @@ -1,6222 +1,6222 @@ -module LakModule - ! - use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, LENTIMESERIESNAME, & - DZERO, DPREC, DEM30, DEM9, DEM6, DEM5, & - DEM4, DEM2, DEM1, DHALF, DP7, DONE, & - DTWO, DPI, DTHREE, DEIGHT, DTEN, DHUNDRED, DEP20, & - DONETHIRD, DTWOTHIRDS, DFIVETHIRDS, & - DGRAVITY, DCD, & - NAMEDBOUNDFLAG, LENFTYPE, LENPACKAGENAME, & - LENPAKLOC, DNODATA, & - TABLEFT, TABCENTER, TABRIGHT, & - TABSTRING, TABUCSTRING, TABINTEGER, TABREAL - use MemoryTypeModule, only: MemoryTSType - use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_setptr, & - mem_deallocate - use SmoothingModule, only: sQuadraticSaturation, sQSaturation, & - sQuadraticSaturationDerivative, & - sQSaturationDerivative - use BndModule, only: BndType - use BudgetObjectModule, only: BudgetObjectType, budgetobject_cr - use TableModule, only: TableType, table_cr - use ObserveModule, only: ObserveType - use ObsModule, only: ObsType - use InputOutputModule, only: get_node, URWORD, extract_idnum_or_bndname - use BaseDisModule, only: DisBaseType - use SimModule, only: count_errors, store_error, ustop - use GenericUtilitiesModule, only: sim_message - use ArrayHandlersModule, only: ExpandArray - use BlockParserModule, only: BlockParserType - use BaseDisModule, only: DisBaseType - ! - implicit none - ! - private - public :: LakType - public :: lak_create - ! - character(len=LENFTYPE) :: ftype = 'LAK' - character(len=LENPACKAGENAME) :: text = ' LAK' - ! - type LakTabType - real(DP), dimension(:), pointer, contiguous :: tabstage => null() - real(DP), dimension(:), pointer, contiguous :: tabvolume => null() - real(DP), dimension(:), pointer, contiguous :: tabsarea => null() - real(DP), dimension(:), pointer, contiguous :: tabwarea => null() - end type LakTabType - ! - type, extends(BndType) :: LakType - ! -- scalars - ! -- characters - character(len=16), dimension(:), pointer, contiguous :: clakbudget => NULL() - character(len=16), dimension(:), pointer, contiguous :: cauxcbc => NULL() - ! -- integers - integer(I4B), pointer :: iprhed => null() - integer(I4B), pointer :: istageout => null() - integer(I4B), pointer :: ibudgetout => null() - integer(I4B), pointer :: ipakcsv => null() - integer(I4B), pointer :: cbcauxitems => NULL() - integer(I4B), pointer :: nlakes => NULL() - integer(I4B), pointer :: noutlets => NULL() - integer(I4B), pointer :: ntables => NULL() - real(DP), pointer :: convlength => NULL() - real(DP), pointer :: convtime => NULL() - real(DP), pointer :: outdmax => NULL() - integer(I4B), pointer :: igwhcopt => NULL() - integer(I4B), pointer :: iconvchk => NULL() - integer(I4B), pointer :: iconvresidchk => NULL() - real(DP), pointer :: surfdep => NULL() - real(DP), pointer :: delh => NULL() - real(DP), pointer :: pdmax => NULL() - integer(I4B), pointer :: check_attr => NULL() - ! -- for budgets - integer(I4B), pointer :: bditems => NULL() - ! -- vectors - ! -- lake data - integer(I4B), dimension(:), pointer, contiguous :: nlakeconn => null() - integer(I4B), dimension(:), pointer, contiguous :: idxlakeconn => null() - integer(I4B), dimension(:), pointer, contiguous :: ntabrow => null() - real(DP), dimension(:), pointer, contiguous :: strt => null() - real(DP), dimension(:), pointer, contiguous :: laketop => null() - real(DP), dimension(:), pointer, contiguous :: lakebot => null() - real(DP), dimension(:), pointer, contiguous :: sareamax => null() - character(len=LENBOUNDNAME), dimension(:), pointer, & - contiguous :: lakename => null() - character (len=8), dimension(:), pointer, contiguous :: status => null() - real(DP), dimension(:), pointer, contiguous :: avail => null() - real(DP), dimension(:), pointer, contiguous :: lkgwsink => null() - ! -- time series aware data - type (MemoryTSType), dimension(:), pointer, contiguous :: stage => null() - type (MemoryTSType), dimension(:), pointer, contiguous :: rainfall => null() - type (MemoryTSType), dimension(:), pointer, & - contiguous :: evaporation => null() - type (MemoryTSType), dimension(:), pointer, contiguous :: runoff => null() - type (MemoryTSType), dimension(:), pointer, contiguous :: inflow => null() - type (MemoryTSType), dimension(:), pointer, & - contiguous :: withdrawal => null() - type (MemoryTSType), dimension(:), pointer, contiguous :: lauxvar => null() - ! - ! -- table data - type (LakTabType), dimension(:), pointer, contiguous :: laketables => null() - ! - ! -- lake solution data - integer(I4B), dimension(:), pointer, contiguous :: ncncvr => null() - real(DP), dimension(:), pointer, contiguous :: surfin => null() - real(DP), dimension(:), pointer, contiguous :: surfout => null() - real(DP), dimension(:), pointer, contiguous :: surfout1 => null() - real(DP), dimension(:), pointer, contiguous :: precip => null() - real(DP), dimension(:), pointer, contiguous :: precip1 => null() - real(DP), dimension(:), pointer, contiguous :: evap => null() - real(DP), dimension(:), pointer, contiguous :: evap1 => null() - real(DP), dimension(:), pointer, contiguous :: evapo => null() - real(DP), dimension(:), pointer, contiguous :: withr => null() - real(DP), dimension(:), pointer, contiguous :: withr1 => null() - real(DP), dimension(:), pointer, contiguous :: flwin => null() - real(DP), dimension(:), pointer, contiguous :: flwiter => null() - real(DP), dimension(:), pointer, contiguous :: flwiter1 => null() - real(DP), dimension(:), pointer, contiguous :: seep => null() - real(DP), dimension(:), pointer, contiguous :: seep1 => null() - real(DP), dimension(:), pointer, contiguous :: seep0 => null() - real(DP), dimension(:), pointer, contiguous :: stageiter => null() - real(DP), dimension(:), pointer, contiguous :: chterm => null() - ! - ! -- lake convergence - integer(I4B), dimension(:), pointer, contiguous :: iseepc => null() - integer(I4B), dimension(:), pointer, contiguous :: idhc => null() - real(DP), dimension(:), pointer, contiguous :: en1 => null() - real(DP), dimension(:), pointer, contiguous :: en2 => null() - real(DP), dimension(:), pointer, contiguous :: r1 => null() - real(DP), dimension(:), pointer, contiguous :: r2 => null() - real(DP), dimension(:), pointer, contiguous :: dh0 => null() - real(DP), dimension(:), pointer, contiguous :: s0 => null() - real(DP), dimension(:), pointer, contiguous :: qgwf0 => null() - ! - ! -- lake connection data - integer(I4B), dimension(:), pointer, contiguous :: imap => null() - integer(I4B), dimension(:), pointer, contiguous :: cellid => null() - integer(I4B), dimension(:), pointer, contiguous :: nodesontop => null() - integer(I4B), dimension(:), pointer, contiguous :: ictype => null() - real(DP), dimension(:), pointer, contiguous :: bedleak => null() - real(DP), dimension(:), pointer, contiguous :: belev => null() - real(DP), dimension(:), pointer, contiguous :: telev => null() - real(DP), dimension(:), pointer, contiguous :: connlength => null() - real(DP), dimension(:), pointer, contiguous :: connwidth => null() - real(DP), dimension(:), pointer, contiguous :: sarea => null() - real(DP), dimension(:), pointer, contiguous :: warea => null() - real(DP), dimension(:), pointer, contiguous :: satcond => null() - real(DP), dimension(:), pointer, contiguous :: simcond => null() - real(DP), dimension(:), pointer, contiguous :: simlakgw => null() - ! - ! -- lake outlet data - integer(I4B), dimension(:), pointer, contiguous :: lakein => null() - integer(I4B), dimension(:), pointer, contiguous :: lakeout => null() - integer(I4B), dimension(:), pointer, contiguous :: iouttype => null() - type (MemoryTSType), dimension(:), pointer, contiguous :: outrate => null() - type (MemoryTSType), dimension(:), pointer, & - contiguous :: outinvert => null() - type (MemoryTSType), dimension(:), pointer, contiguous :: outwidth => null() - type (MemoryTSType), dimension(:), pointer, contiguous :: outrough => null() - type (MemoryTSType), dimension(:), pointer, contiguous :: outslope => null() - real(DP), dimension(:), pointer, contiguous :: simoutrate => null() - ! - ! -- lake output data - real(DP), dimension(:), pointer, contiguous :: qauxcbc => null() - real(DP), dimension(:), pointer, contiguous :: dbuff => null() - real(DP), dimension(:), pointer, contiguous :: qleak => null() - real(DP), dimension(:), pointer, contiguous :: qsto => null() - ! - ! -- pointer to gwf iss and gwf hk - integer(I4B), pointer :: gwfiss => NULL() - real(DP), dimension(:), pointer, contiguous :: gwfk11 => NULL() - real(DP), dimension(:), pointer, contiguous :: gwfk33 => NULL() - real(DP), dimension(:), pointer, contiguous :: gwfsat => NULL() - integer(I4B), pointer :: gwfik33 => NULL() - ! - ! -- package x, xold, and ibound - integer(I4B), dimension(:), pointer, contiguous :: iboundpak => null() !package ibound - real(DP), dimension(:), pointer, contiguous :: xnewpak => null() !package x vector - real(DP), dimension(:), pointer, contiguous :: xoldpak => null() !package xold vector - ! - ! -- lake budget object - type(BudgetObjectType), pointer :: budobj => null() - ! - ! -- laketable objects - type(TableType), pointer :: pakcsvtab => null() - ! - ! -- type bound procedures - contains - procedure :: lak_allocate_scalars - procedure :: lak_allocate_arrays - procedure :: bnd_options => lak_options - procedure :: read_dimensions => lak_read_dimensions - procedure :: read_initial_attr => lak_read_initial_attr - procedure :: set_pointers => lak_set_pointers - procedure :: bnd_ar => lak_ar - procedure :: bnd_rp => lak_rp - procedure :: bnd_ad => lak_ad - procedure :: bnd_cf => lak_cf - procedure :: bnd_fc => lak_fc - procedure :: bnd_fn => lak_fn - procedure :: bnd_cc => lak_cc - procedure :: bnd_bd => lak_bd - procedure :: bnd_ot => lak_ot - procedure :: bnd_da => lak_da - procedure :: define_listlabel - ! -- methods for observations - procedure, public :: bnd_obs_supported => lak_obs_supported - procedure, public :: bnd_df_obs => lak_df_obs - procedure, public :: bnd_rp_obs => lak_rp_obs - ! -- private procedures - procedure, private :: lak_read_lakes - procedure, private :: lak_read_lake_connections - procedure, private :: lak_read_outlets - procedure, private :: lak_read_tables - procedure, private :: lak_read_table - !procedure, private :: lak_check_attributes - procedure, private :: lak_check_valid - procedure, private :: lak_set_stressperiod - procedure, private :: lak_set_attribute_error - procedure, private :: lak_cfupdate - procedure, private :: lak_bound_update - procedure, private :: lak_bd_obs - procedure, private :: lak_calculate_sarea - procedure, private :: lak_calculate_warea - procedure, private :: lak_calculate_conn_warea - procedure, public :: lak_calculate_vol - procedure, private :: lak_calculate_conductance - procedure, private :: lak_calculate_cond_head - procedure, private :: lak_calculate_conn_conductance - procedure, private :: lak_calculate_exchange - procedure, private :: lak_calculate_conn_exchange - procedure, private :: lak_estimate_conn_exchange - procedure, private :: lak_calculate_storagechange - procedure, private :: lak_calculate_rainfall - procedure, private :: lak_calculate_runoff - procedure, private :: lak_calculate_inflow - procedure, private :: lak_calculate_external - procedure, private :: lak_calculate_withdrawal - procedure, private :: lak_calculate_evaporation - procedure, private :: lak_calculate_outlet_inflow - procedure, private :: lak_calculate_outlet_outflow - procedure, private :: lak_get_internal_inlet - procedure, private :: lak_get_internal_outlet - procedure, private :: lak_get_external_outlet - procedure, private :: lak_get_internal_mover - procedure, private :: lak_get_external_mover - procedure, private :: lak_get_outlet_tomover - procedure, private :: lak_accumulate_chterm - procedure, private :: lak_vol2stage - procedure, private :: lak_solve - procedure, private :: lak_calculate_available - procedure, private :: lak_calculate_residual - procedure, private :: lak_linear_interpolation - procedure, private :: lak_setup_budobj - procedure, private :: lak_fill_budobj - end type LakType - -contains - - subroutine lak_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) -! ****************************************************************************** -! lak_create -- Create a New LAKE Package -! Subroutine: (1) create new-style package -! (2) point bndobj to the new package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout - character(len=*), intent(in) :: namemodel - character(len=*), intent(in) :: pakname - type(LakType), pointer :: lakobj -! ------------------------------------------------------------------------------ - ! - ! -- allocate the object and assign values to object variables - allocate(lakobj) - packobj => lakobj - ! - ! -- create name and origin - call packobj%set_names(ibcnum, namemodel, pakname, ftype) - packobj%text = text - ! - ! -- allocate scalars - call lakobj%lak_allocate_scalars() - ! - ! -- initialize package - call packobj%pack_initialize() - - packobj%inunit = inunit - packobj%iout = iout - packobj%id = id - packobj%ibcnum = ibcnum - packobj%ncolbnd = 3 - packobj%iscloc = 0 ! not supported - packobj%ictorigin = 'NPF' - ! - ! -- return - return - end subroutine lak_create - - subroutine lak_allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -- allocate scalar members -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType), intent(inout) :: this -! ------------------------------------------------------------------------------ - ! - ! -- call standard BndType allocate scalars - call this%BndType%allocate_scalars() - ! - ! -- allocate the object and assign values to object variables - call mem_allocate(this%iprhed, 'IPRHED', this%origin) - call mem_allocate(this%istageout, 'ISTAGEOUT', this%origin) - call mem_allocate(this%ibudgetout, 'IBUDGETOUT', this%origin) - call mem_allocate(this%ipakcsv, 'IPAKCSV', this%origin) - call mem_allocate(this%nlakes, 'NLAKES', this%origin) - call mem_allocate(this%noutlets, 'NOUTLETS', this%origin) - call mem_allocate(this%ntables, 'NTABLES', this%origin) - call mem_allocate(this%convlength, 'CONVLENGTH', this%origin) - call mem_allocate(this%convtime, 'CONVTIME', this%origin) - call mem_allocate(this%outdmax, 'OUTDMAX', this%origin) - call mem_allocate(this%igwhcopt, 'IGWHCOPT', this%origin) - call mem_allocate(this%iconvchk, 'ICONVCHK', this%origin) - call mem_allocate(this%iconvresidchk, 'ICONVRESIDCHK', this%origin) - call mem_allocate(this%surfdep, 'SURFDEP', this%origin) - call mem_allocate(this%delh, 'DELH', this%origin) - call mem_allocate(this%pdmax, 'PDMAX', this%origin) - call mem_allocate(this%check_attr, 'check_attr', this%origin) - call mem_allocate(this%bditems, 'BDITEMS', this%origin) - call mem_allocate(this%cbcauxitems, 'CBCAUXITEMS', this%origin) - ! - ! -- Set values - this%iprhed = 0 - this%istageout = 0 - this%ibudgetout = 0 - this%ipakcsv = 0 - this%nlakes = 0 - this%noutlets = 0 - this%ntables = 0 - this%convlength = DONE - this%convtime = DONE - this%outdmax = DZERO - this%igwhcopt = 0 - this%iconvchk = 1 - this%iconvresidchk = 1 - this%surfdep = DZERO - this%delh = DEM5 - this%pdmax = DEM1 - this%bditems = 11 - this%cbcauxitems = 1 - ! - ! -- return - return - end subroutine lak_allocate_scalars - - subroutine lak_allocate_arrays(this) -! ****************************************************************************** -! allocate_scalars -- allocate scalar members -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(LakType), intent(inout) :: this - ! -- local - integer(I4B) :: i -! ------------------------------------------------------------------------------ - ! - ! -- call standard BndType allocate scalars - call this%BndType%allocate_arrays() - ! - ! -- allocate character array for budget text - allocate(this%clakbudget(this%bditems)) - ! - !-- fill clakbudget - this%clakbudget(1) = ' GWF' - this%clakbudget(2) = ' RAINFALL' - this%clakbudget(3) = ' EVAPORATION' - this%clakbudget(4) = ' RUNOFF' - this%clakbudget(5) = ' EXT-INFLOW' - this%clakbudget(6) = ' WITHDRAWAL' - this%clakbudget(7) = ' EXT-OUTFLOW' - this%clakbudget(8) = ' STORAGE' - this%clakbudget(9) = ' CONSTANT' - this%clakbudget(10) = ' FROM-MVR' - this%clakbudget(11) = ' TO-MVR' - ! - ! -- allocate and initialize dbuff - if (this%istageout > 0) then - call mem_allocate(this%dbuff, this%nlakes, 'DBUFF', this%origin) - do i = 1, this%nlakes - this%dbuff(i) = DZERO - end do - else - call mem_allocate(this%dbuff, 0, 'DBUFF', this%origin) - end if - ! - ! -- allocate character array for budget text - allocate(this%cauxcbc(this%cbcauxitems)) - ! - ! -- allocate and initialize qauxcbc - call mem_allocate(this%qauxcbc, this%cbcauxitems, 'QAUXCBC', this%origin) - do i = 1, this%cbcauxitems - this%qauxcbc(i) = DZERO - end do - ! - ! -- allocate qleak and qsto - call mem_allocate(this%qleak, this%maxbound, 'QLEAK', this%origin) - do i = 1, this%maxbound - this%qleak(i) = DZERO - end do - call mem_allocate(this%qsto, this%nlakes, 'QSTO', this%origin) - do i = 1, this%nlakes - this%qsto(i) = DZERO - end do - ! - ! -- return - return - end subroutine lak_allocate_arrays - - subroutine lak_read_lakes(this) -! ****************************************************************************** -! pak1read_dimensions -- Read the dimensions for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors, store_error_unit - use TimeSeriesManagerModule, only: read_single_value_or_time_series - ! -- dummy - class(LakType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: errmsg - character(len=LINELENGTH) :: text - character(len=LENBOUNDNAME) :: bndName, bndNameTemp - character(len=9) :: cno - character(len=50), dimension(:), allocatable :: caux - integer(I4B) :: ierr, ival - logical :: isfound, endOfBlock - integer(I4B) :: n - integer(I4B) :: ii, jj - integer(I4B) :: iaux - integer(I4B) :: itmp - integer(I4B) :: nlak - integer(I4B) :: nconn - integer(I4B), dimension(:), pointer, contiguous :: nboundchk - ! -- format - ! - ! -- code - ! - ! -- initialize itmp - itmp = 0 - ! - ! -- allocate lake data - call mem_allocate(this%nlakeconn, this%nlakes, 'NLAKECONN', this%origin) - call mem_allocate(this%idxlakeconn, this%nlakes+1, 'IDXLAKECONN', this%origin) - call mem_allocate(this%ntabrow, this%nlakes, 'NTABROW', this%origin) - call mem_allocate(this%strt, this%nlakes, 'STRT', this%origin) - call mem_allocate(this%laketop, this%nlakes, 'LAKETOP', this%origin) - call mem_allocate(this%lakebot, this%nlakes, 'LAKEBOT', this%origin) - call mem_allocate(this%sareamax, this%nlakes, 'SAREAMAX', this%origin) - call mem_allocate(this%stage, this%nlakes, 'STAGE', this%origin) - call mem_allocate(this%rainfall, this%nlakes, 'RAINFALL', this%origin) - call mem_allocate(this%evaporation, this%nlakes, 'EVAPORATION', this%origin) - call mem_allocate(this%runoff, this%nlakes, 'RUNOFF', this%origin) - call mem_allocate(this%inflow, this%nlakes, 'INFLOW', this%origin) - call mem_allocate(this%withdrawal, this%nlakes, 'WITHDRAWAL', this%origin) - call mem_allocate(this%lauxvar, this%naux*this%nlakes, 'LAUXVAR', this%origin) - call mem_allocate(this%avail, this%nlakes, 'AVAIL', this%origin) - call mem_allocate(this%lkgwsink, this%nlakes, 'LKGWSINK', this%origin) - call mem_allocate(this%ncncvr, this%nlakes, 'NCNCVR', this%origin) - call mem_allocate(this%surfin, this%nlakes, 'SURFIN', this%origin) - call mem_allocate(this%surfout, this%nlakes, 'SURFOUT', this%origin) - call mem_allocate(this%surfout1, this%nlakes, 'SURFOUT1', this%origin) - call mem_allocate(this%precip, this%nlakes, 'PRECIP', this%origin) - call mem_allocate(this%precip1, this%nlakes, 'PRECIP1', this%origin) - call mem_allocate(this%evap, this%nlakes, 'EVAP', this%origin) - call mem_allocate(this%evap1, this%nlakes, 'EVAP1', this%origin) - call mem_allocate(this%evapo, this%nlakes, 'EVAPO', this%origin) - call mem_allocate(this%withr, this%nlakes, 'WITHR', this%origin) - call mem_allocate(this%withr1, this%nlakes, 'WITHR1', this%origin) - call mem_allocate(this%flwin, this%nlakes, 'FLWIN', this%origin) - call mem_allocate(this%flwiter, this%nlakes, 'FLWITER', this%origin) - call mem_allocate(this%flwiter1, this%nlakes, 'FLWITER1', this%origin) - call mem_allocate(this%seep, this%nlakes, 'SEEP', this%origin) - call mem_allocate(this%seep1, this%nlakes, 'SEEP1', this%origin) - call mem_allocate(this%seep0, this%nlakes, 'SEEP0', this%origin) - call mem_allocate(this%stageiter, this%nlakes, 'STAGEITER', this%origin) - call mem_allocate(this%chterm, this%nlakes, 'CHTERM', this%origin) - ! - ! -- lake boundary and stages - call mem_allocate(this%iboundpak, this%nlakes, 'IBOUND', this%origin) - call mem_allocate(this%xnewpak, this%nlakes, 'XNEWPAK', this%origin) - call mem_allocate(this%xoldpak, this%nlakes, 'XOLDPAK', this%origin) - ! - ! -- lake iteration variables - call mem_allocate(this%iseepc, this%nlakes, 'ISEEPC', this%origin) - call mem_allocate(this%idhc, this%nlakes, 'IDHC', this%origin) - call mem_allocate(this%en1, this%nlakes, 'EN1', this%origin) - call mem_allocate(this%en2, this%nlakes, 'EN2', this%origin) - call mem_allocate(this%r1, this%nlakes, 'R1', this%origin) - call mem_allocate(this%r2, this%nlakes, 'R2', this%origin) - call mem_allocate(this%dh0, this%nlakes, 'DH0', this%origin) - call mem_allocate(this%s0, this%nlakes, 'S0', this%origin) - call mem_allocate(this%qgwf0, this%nlakes, 'QGWF0', this%origin) - ! - ! -- allocate character storage not managed by the memory manager - allocate(this%lakename(this%nlakes)) ! ditch after boundnames allocated?? - allocate(this%status(this%nlakes)) - ! - do n = 1, this%nlakes - this%ntabrow(n) = 0 - this%status(n) = 'ACTIVE' - this%laketop(n) = -DEP20 - this%lakebot(n) = DEP20 - this%sareamax(n) = DZERO - this%iboundpak(n) = 1 - this%xnewpak(n) = DEP20 - this%xoldpak(n) = DEP20 - end do - ! - ! -- allocate local storage for aux variables - if (this%naux > 0) then - allocate(caux(this%naux)) - end if - ! - ! -- allocate and initialize temporary variables - allocate(nboundchk(this%nlakes)) - do n = 1, this%nlakes - nboundchk(n) = 0 - end do - ! - ! -- read lake well data - ! -- get lakes block - call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & - supportOpenClose=.true.) - ! - ! -- parse locations block if detected - if (isfound) then - write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & - ' PACKAGEDATA' - nlak = 0 - nconn = 0 - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - n = this%parser%GetInteger() - - if (n < 1 .or. n > this%nlakes) then - write(errmsg,'(4x,a,1x,i6)') & - '****ERROR. lakeno MUST BE > 0 and <= ', this%nlakes - call store_error(errmsg) - cycle - end if - - ! -- increment nboundchk - nboundchk(n) = nboundchk(n) + 1 - - ! -- strt - this%strt(n) = this%parser%GetDouble() - - ! nlakeconn - ival = this%parser%GetInteger() - - if (ival < 0) then - write(errmsg,'(4x,a,1x,i6)') & - '****ERROR. nlakeconn MUST BE >= 0 for lake ', n - call store_error(errmsg) - end if - - nconn = nconn + ival - this%nlakeconn(n) = ival - - ! -- get aux data - do iaux = 1, this%naux - call this%parser%GetString(caux(iaux)) - end do - - ! -- set default bndName - write(cno,'(i9.9)') n - bndName = 'Lake' // cno - - ! -- lakename - if (this%inamedbound /= 0) then - call this%parser%GetStringCaps(bndNameTemp) - if (bndNameTemp /= '') then - bndName = bndNameTemp(1:16) - endif - end if - this%lakename(n) = bndName - - ! -- fill time series aware data - ! -- fill aux data - do iaux = 1, this%naux - ! - ! -- Assign boundary name - if (this%inamedbound==1) then - bndName = this%lakename(n) - else - bndName = '' - end if - text = caux(iaux) - jj = 1 !iaux - ii = (n-1) * this%naux + iaux - call read_single_value_or_time_series(text, & - this%lauxvar(ii)%value, & - this%lauxvar(ii)%name, & - DZERO, & - this%Name, 'AUX', this%TsManager, & - this%iprpak, n, jj, & - this%auxname(iaux), & - bndName, this%parser%iuactive) - end do - - nlak = nlak + 1 - end do - ! - ! -- check for duplicate or missing lakes - do n = 1, this%nlakes - if (nboundchk(n) == 0) then - write(errmsg,'(a,1x,i0)') 'ERROR. NO DATA SPECIFIED FOR LAKE', n - call store_error(errmsg) - else if (nboundchk(n) > 1) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & - 'ERROR. DATA FOR LAKE', n, 'SPECIFIED', nboundchk(n), 'TIMES' - call store_error(errmsg) - end if - end do - - write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' PACKAGEDATA' - else - call store_error('ERROR. REQUIRED PACKAGEDATA BLOCK NOT FOUND.') - end if - ! - ! -- terminate if any errors were detected - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- set MAXBOUND - this%MAXBOUND = nconn - write(this%iout,'(//4x,a,i7)') 'MAXBOUND = ', this%maxbound - - ! -- set idxlakeconn - this%idxlakeconn(1) = 1 - do n = 1, this%nlakes - this%idxlakeconn(n+1) = this%idxlakeconn(n) + this%nlakeconn(n) - end do - ! - ! -- deallocate local storage for aux variables - if (this%naux > 0) then - deallocate(caux) - end if - ! - ! -- deallocate local storage for nboundchk - deallocate(nboundchk) - ! - ! -- return - return - end subroutine lak_read_lakes - - subroutine lak_read_lake_connections(this) -! ****************************************************************************** -! lak_read_lake_connections -- Read the lake connections for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors - ! -- dummy - class(LakType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: errmsg - character(len=LINELENGTH) :: keyword, cellid - integer(I4B) :: ierr, ival - logical :: isfound, endOfBlock - real(DP) :: rval - integer(I4B) :: j, n - integer(I4B) :: nn - integer(I4B) :: ipos, ipos0 - integer(I4B) :: icellid, icellid0 - real(DP) :: top, bot - integer(I4B), dimension(:), pointer, contiguous :: nboundchk - - ! -- format - ! - ! -- code - ! - ! -- allocate local storage - allocate(nboundchk(this%MAXBOUND)) - do n = 1, this%MAXBOUND - nboundchk(n) = 0 - end do - ! - ! -- get connectiondata block - call this%parser%GetBlock('CONNECTIONDATA', isfound, ierr, & - supportOpenClose=.true.) - ! - ! -- parse connectiondata block if detected - if (isfound) then - - ! -- allocate connection data using memory manager - call mem_allocate(this%imap, this%MAXBOUND, 'IMAP', this%origin) - call mem_allocate(this%cellid, this%MAXBOUND, 'CELLID', this%origin) - call mem_allocate(this%nodesontop, this%MAXBOUND, 'NODESONTOP', this%origin) - call mem_allocate(this%ictype, this%MAXBOUND, 'ICTYPE', this%origin) - call mem_allocate(this%bedleak, this%MAXBOUND, 'BEDLEAK', this%origin) ! don't need to save this - use a temporary vector - call mem_allocate(this%belev, this%MAXBOUND, 'BELEV', this%origin) - call mem_allocate(this%telev, this%MAXBOUND, 'TELEV', this%origin) - call mem_allocate(this%connlength, this%MAXBOUND, 'CONNLENGTH', this%origin) - call mem_allocate(this%connwidth, this%MAXBOUND, 'CONNWIDTH', this%origin) - call mem_allocate(this%sarea, this%MAXBOUND, 'SAREA', this%origin) - call mem_allocate(this%warea, this%MAXBOUND, 'WAREA', this%origin) - call mem_allocate(this%satcond, this%MAXBOUND, 'SATCOND', this%origin) - call mem_allocate(this%simcond, this%MAXBOUND, 'SIMCOND', this%origin) - call mem_allocate(this%simlakgw, this%MAXBOUND, 'SIMLAKGW', this%origin) - - - ! -- process the lake connection data - write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & - ' LAKE_CONNECTIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - n = this%parser%GetInteger() - - if (n < 1 .or. n > this%nlakes) then - write(errmsg,'(4x,a,1x,i6)') & - '****ERROR. lakeno MUST BE > 0 and <= ', this%nlakes - call store_error(errmsg) - cycle - end if - - ! -- read connection number - ival = this%parser%GetInteger() - if (ival <1 .or. ival > this%nlakeconn(n)) then - write(errmsg,'(4x,a,1x,i4,1x,a,1x,i6)') & - '****ERROR. iconn FOR LAKE ', n, 'MUST BE > 1 and <= ', this%nlakeconn(n) - call store_error(errmsg) - cycle - end if - - j = ival - ipos = this%idxlakeconn(n) + ival - 1 - - ! -- set imap - this%imap(ipos) = n - - ! - ! -- increment nboundchk - nboundchk(ipos) = nboundchk(ipos) + 1 - - ! -- read gwfnodes from the line - call this%parser%GetCellid(this%dis%ndim, cellid) - nn = this%dis%noder_from_cellid(cellid, & - this%parser%iuactive, this%iout) - ! - ! -- determine if a valid cell location was provided - if (nn < 1) then - write(errmsg,'(4x,a,1x,i4,1x,a,1x,i4)') & - '****ERROR. INVALID cellid FOR LAKE ', n, 'connection', j - call store_error(errmsg) - end if - - ! -- set gwf cellid for connection - this%cellid(ipos) = nn - this%nodesontop(ipos) = nn - - ! -- read ictype - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('VERTICAL') - this%ictype(ipos) = 0 - case ('HORIZONTAL') - this%ictype(ipos) = 1 - case ('EMBEDDEDH') - this%ictype(ipos) = 2 - case ('EMBEDDEDV') - this%ictype(ipos) = 3 - case default - write(errmsg,'(4x,a,1x,i4,1x,a,1x,i4,1x,a,a,a)') & - '****ERROR. UNKNOWN ctype FOR LAKE ', n, 'connection', j, & - '(', trim(keyword), ')' - call store_error(errmsg) - end select - - ! -- bed leakance - !this%bedleak(ipos) = this%parser%GetDouble() - call this%parser%GetStringCaps(keyword) - select case(keyword) - case ('NONE') - this%bedleak(ipos) = -DONE - case default - read(keyword, *) this%bedleak(ipos) - end select - - if (keyword /= 'NONE' .and. this%bedleak(ipos) < dzero) then - write(errmsg,'(4x,a,1x,i4,1x,a)') & - '****ERROR. bedleak FOR LAKE ', n, 'MUST BE >= 0' - call store_error(errmsg) - end if - - ! -- belev - this%belev(ipos) = this%parser%GetDouble() - - ! -- telev - this%telev(ipos) = this%parser%GetDouble() - - ! -- connection length - rval = this%parser%GetDouble() - if (rval < dzero) then - if (this%ictype(ipos) == 1 .or. this%ictype(ipos) == 2 .or. this%ictype(ipos) == 3) then - write(errmsg,'(4x,a,1x,i4,1x,a,1x,i4,1x,a)') & - '****ERROR. connection length (connlength) FOR LAKE ', n, ' HORIZONTAL CONNECTION ', j, & - 'MUST BE >= 0' - call store_error(errmsg) - else - rval = DZERO - end if - end if - this%connlength(ipos) = rval - - ! -- connection width - rval = this%parser%GetDouble() - if (rval < dzero) then - if (this%ictype(ipos) == 1) then - write(errmsg,'(4x,a,1x,i4,1x,a,1x,i4,1x,a)') & - '****ERROR. cell width (connwidth) FOR LAKE ', n, ' HORIZONTAL CONNECTION ', j, & - 'MUST BE >= 0' - call store_error(errmsg) - else - rval = DZERO - end if - end if - this%connwidth(ipos) = rval - end do - write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' CONNECTIONDATA' - else - call store_error('ERROR. REQUIRED CONNECTIONDATA BLOCK NOT FOUND.') - end if - ! - ! -- terminate if any errors were detected - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- check that embedded lakes have only one connection - do n = 1, this%nlakes - j = 0 - do ipos = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 - if (this%ictype(ipos) /= 2 .and. this%ictype(ipos) /= 3) cycle - j = j + 1 - if (j > 1) then - write(errmsg,'(4x,a,1x,i4,1x,a,1x,i4,1x,a)') & - '****ERROR. nlakeconn FOR LAKE', n, 'EMBEDDED CONNECTION', j, & - ' EXCEEDS 1.' - call store_error(errmsg) - end if - end do - end do - ! -- check that an embedded lake is not in the same cell as a lake - ! with a vertical connection - do n = 1, this%nlakes - ipos0 = this%idxlakeconn(n) - icellid0 = this%cellid(ipos0) - if (this%ictype(ipos0) /= 2 .and. this%ictype(ipos0) /= 3) cycle - do nn = 1, this%nlakes - if (nn == n) cycle - j = 0 - do ipos = this%idxlakeconn(nn), this%idxlakeconn(nn+1)-1 - j = j + 1 - icellid = this%cellid(ipos) - if (icellid == icellid0) then - if (this%ictype(ipos) == 0) then - write(errmsg,'(4x,a,1x,i4,1x,a,1x,i4,1x,a,1x,i4,1x,a)') & - '****ERROR. EMBEDDED LAKE', n, & - 'CANNOT COINCIDE WITH VERTICAL CONNECTION', j, & - 'IN LAKE', nn, '.' - call store_error(errmsg) - end if - end if - end do - end do - end do - ! - ! -- process the data - do n = 1, this%nlakes - j = 0 - do ipos = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 - j = j + 1 - nn = this%cellid(ipos) - top = this%dis%top(nn) - bot = this%dis%bot(nn) - ! vertical connection - if (this%ictype(ipos) == 0) then - this%telev(ipos) = top + this%surfdep - this%belev(ipos) = top - this%lakebot(n) = min(this%belev(ipos), this%lakebot(n)) - ! horizontal connection - else if (this%ictype(ipos) == 1) then - if (this%belev(ipos) == this%telev(ipos)) then - this%telev(ipos) = top - this%belev(ipos) = bot - else - if (this%belev(ipos) >= this%telev(ipos)) then - write(errmsg,'(4x,a,1x,i4,1x,a,1x,i4,1x,a)') & - '****ERROR. telev FOR LAKE ', n, ' HORIZONTAL CONNECTION ', j, & - 'MUST BE >= belev' - call store_error(errmsg) - else if (this%belev(ipos) < bot) then - write(errmsg,'(4x,a,1x,i4,1x,a,1x,i4,1x,a,1x,g15.7,1x,a)') & - '****ERROR. belev FOR LAKE ', n, ' HORIZONTAL CONNECTION ', j, & - 'MUST BE >= cell bottom (', bot, ')' - call store_error(errmsg) - else if (this%telev(ipos) > top) then - write(errmsg,'(4x,a,1x,i4,1x,a,1x,i4,1x,a,1x,g15.7,1x,a)') & - '****ERROR. telev FOR LAKE ', n, ' HORIZONTAL CONNECTION ', j, & - 'MUST BE <= cell top (', top, ')' - call store_error(errmsg) - end if - end if - this%laketop(n) = max(this%telev(ipos), this%laketop(n)) - this%lakebot(n) = min(this%belev(ipos), this%lakebot(n)) - ! embedded connections - else if (this%ictype(ipos) == 2 .or. this%ictype(ipos) == 3) then - this%telev(ipos) = top - this%belev(ipos) = bot - this%lakebot(n) = bot - end if - ! - ! -- check for missing or duplicate lake connections - if (nboundchk(ipos) == 0) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0)') & - 'ERROR. NO DATA SPECIFIED FOR LAKE', n, 'CONNECTION', j - call store_error(errmsg) - else if (nboundchk(ipos) > 1) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & - 'ERROR. DATA FOR LAKE', n, 'CONNECTION', j, & - 'SPECIFIED', nboundchk(ipos), 'TIMES' - call store_error(errmsg) - end if - ! - ! -- set laketop if it has not been assigned - end do - if (this%laketop(n) == -DEP20) then - this%laketop(n) = this%lakebot(n) + 100. - end if - end do - ! - ! -- deallocate local variable - deallocate(nboundchk) - ! - ! -- write summary of lake_connection error messages - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- return - return - end subroutine lak_read_lake_connections - - subroutine lak_read_tables(this) -! ****************************************************************************** -! lak_read_tables -- Read the lake tables for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors - ! -- dummy - class(LakType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: line, errmsg - character(len=LINELENGTH) :: keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock - integer(I4B) :: n - integer(I4B) :: ntabs - integer(I4B), dimension(:), pointer, contiguous :: nboundchk -! ------------------------------------------------------------------------------ - - ! -- format - ! - ! -- code - ! - ! -- skip of no outlets - if (this%ntables < 1) return - ! - ! -- allocate and initialize nboundchk - allocate(nboundchk(this%nlakes)) - do n = 1, this%nlakes - nboundchk(n) = 0 - end do - ! - ! -- allocate derived type for table data - allocate(this%laketables(this%nlakes)) - ! - ! -- get lake_tables block - call this%parser%GetBlock('TABLES', isfound, ierr, & - supportOpenClose=.true.) - ! - ! -- parse lake_tables block if detected - if (isfound) then - ntabs = 0 - ! -- process the lake connection data - write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & - ' LAKE_TABLES' - readtable: do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - n = this%parser%GetInteger() - - if (n < 1 .or. n > this%nlakes) then - write(errmsg,'(4x,a,1x,i6)') & - '****ERROR. lakeno MUST BE > 0 and <= ', this%nlakes - call store_error(errmsg) - cycle readtable - end if - - ! -- increment ntab and nboundchk - ntabs = ntabs + 1 - nboundchk(n) = nboundchk(n) + 1 - - ! -- read FILE keyword - call this%parser%GetStringCaps(keyword) - select case (keyword) - case('TAB6') - call this%parser%GetStringCaps(keyword) - if(trim(adjustl(keyword)) /= 'FILEIN') then - errmsg = 'TAB6 keyword must be followed by "FILEIN" ' // & - 'then by filename.' - call store_error(errmsg) - cycle readtable - end if - call this%parser%GetString(line) - call this%lak_read_table(n, line) - case default - write(errmsg,'(4x,a,1x,i4,1x,a)') & - '****ERROR. LAKE TABLE ENTRY for LAKE ', n, 'MUST INCLUDE TAB6 KEYWORD' - call store_error(errmsg) - cycle readtable - end select - end do readtable - - write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' LAKE_TABLES' - ! - ! -- check for missing or duplicate lake connections - if (ntabs < this%ntables) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0)') & - 'ERROR. TABLE DATA ARE SPECIFIED', ntabs, & - 'TIMES BUT NTABLES IS SET TO', this%ntables - call store_error(errmsg) - end if - do n = 1, this%nlakes - if (this%ntabrow(n) > 0 .and. nboundchk(n) > 1) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & - 'ERROR. TABLE DATA FOR LAKE', n, 'SPECIFIED', nboundchk(n), 'TIMES' - call store_error(errmsg) - end if - end do - else - call store_error('ERROR. REQUIRED TABLES BLOCK NOT FOUND.') - end if - ! - ! -- deallocate local storage - deallocate(nboundchk) - ! - ! -- write summary of lake_table error messages - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - - ! - ! -- return - return - end subroutine lak_read_tables - - subroutine lak_read_table(this, ilak, filename) -! ****************************************************************************** -! lak_read_table -- Read the lake table for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use InputOutputModule, only: openfile - use SimModule, only: ustop, store_error, count_errors - ! -- dummy - class(LakType), intent(inout) :: this - integer(I4B), intent(in) :: ilak - character (len=*), intent(in) :: filename - - ! -- local - character(len=LINELENGTH) :: errmsg - character(len=LINELENGTH) :: keyword - character(len=13) :: arrName - character(len=4) :: citem - integer(I4B) :: ierr - logical :: isfound, endOfBlock - integer(I4B) :: iu - integer(I4B) :: n - integer(I4B) :: ipos - integer(I4B) :: j - integer(I4B) :: jmin - integer(I4B) :: iconn - real(DP) :: vol - real(DP) :: sa - real(DP) :: wa - real(DP) :: v - type(BlockParserType) :: parser -! ------------------------------------------------------------------------------ - - ! -- format - ! - ! -- code - ! - ! -- initialize locals - n = 0 - j = 0 - ! - ! -- open the table file - iu = 0 - call openfile(iu, this%iout, filename, 'LAKE TABLE') - call parser%Initialize(iu, this%iout) - ! - ! -- get dimensions block - call parser%GetBlock('DIMENSIONS', isfound, ierr, supportOpenClose=.true.) - ! - ! -- parse well_connections block if detected - if (isfound) then - ! -- process the lake connection data - if (this%iprpak /= 0) then - write(this%iout,'(/1x,a)') & - 'PROCESSING '//trim(adjustl(this%text))//' DIMENSIONS' - end if - readdims: do - call parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call parser%GetStringCaps(keyword) - select case (keyword) - case ('NROW') - n = parser%GetInteger() - - if (n < 1) then - write(errmsg,'(4x,a)') & - '****ERROR. LAKE TABLE NROW MUST BE > 0' - call store_error(errmsg) - end if - case ('NCOL') - j = parser%GetInteger() - - if (this%ictype(ilak) == 2 .or. this%ictype(ilak) == 3) then - jmin = 4 - else - jmin = 3 - end if - if (j < jmin) then - write(errmsg,'(4x,a,1x,i0)') & - '****ERROR. LAKE TABLE NCOL MUST BE >= ', jmin - call store_error(errmsg) - end if - - case default - write(errmsg,'(4x,a,a)') & - '****ERROR. UNKNOWN '//trim(this%text)//' DIMENSIONS KEYWORD: ', & - trim(keyword) - call store_error(errmsg) - end select - end do readdims - if (this%iprpak /= 0) then - write(this%iout,'(1x,a)') & - 'END OF '//trim(adjustl(this%text))//' DIMENSIONS' - end if - else - call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') - end if - ! - ! -- check that ncol and nrow have been specified - if (n < 1) then - write(errmsg,'(4x,a)') & - '****ERROR. NROW NOT SPECIFIED IN THE LAKE TABLE DIMENSIONS BLOCK' - call store_error(errmsg) - end if - if (j < 1) then - write(errmsg,'(4x,a)') & - '****ERROR. NCOL NOT SPECIFIED IN THE LAKE TABLE DIMENSIONS BLOCK' - call store_error(errmsg) - end if - ! - ! -- only read the lake table data if n and j are specified to be greater - ! than zero - if (n * j > 0) then - ! - ! -- allocate space - this%ntabrow(ilak) = n - write(citem,'(i4.4)') ilak - ! -- build arrName for outlet - arrName = 'TABSTAGE' // citem - call mem_allocate(this%laketables(ilak)%tabstage, n, arrName, this%origin) - arrName = 'TABVOLUME' // citem - call mem_allocate(this%laketables(ilak)%tabvolume, n, arrName, this%origin) - arrName = 'TABSAREA' // citem - call mem_allocate(this%laketables(ilak)%tabsarea, n, arrName, this%origin) - ipos = this%idxlakeconn(ilak) - if (this%ictype(ipos) == 2 .or. this%ictype(ipos) == 3) then - arrName = 'tabwarea' // citem - call mem_allocate(this%laketables(ilak)%tabwarea, n, arrName, this%origin) - end if - - - ! -- get table block - call parser%GetBlock('TABLE', isfound, ierr, supportOpenClose=.true.) - ! - ! -- parse well_connections block if detected - if (isfound) then - - ! -- process the table data - if (this%iprpak /= 0) then - write(this%iout,'(/1x,a)') & - 'PROCESSING '//trim(adjustl(this%text))//' TABLE' - end if - iconn = this%idxlakeconn(ilak) - ipos = 0 - readtabledata: do - call parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - ipos = ipos + 1 - if (ipos > this%ntabrow(ilak)) then - cycle readtabledata - end if - this%laketables(ilak)%tabstage(ipos) = parser%GetDouble() - this%laketables(ilak)%tabvolume(ipos) = parser%GetDouble() - this%laketables(ilak)%tabsarea(ipos) = parser%GetDouble() - if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then - this%laketables(ilak)%tabwarea(ipos) = parser%GetDouble() - end if - end do readtabledata - - if (this%iprpak /= 0) then - write(this%iout,'(1x,a)') & - 'END OF '//trim(adjustl(this%text))//' TABLE' - end if - else - call store_error('ERROR. REQUIRED TABLE BLOCK NOT FOUND.') - end if - ! - ! -- error condition if number of rows read are not equal to nrow - if (ipos /= this%ntabrow(ilak)) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & - 'ERROR. NROW SET TO',this%ntabrow(ilak), 'BUT', ipos, 'ROWS WERE READ' - call store_error(errmsg) - end if - ! - ! -- set lake bottom based on table if it is an embedded lake - iconn = this%idxlakeconn(ilak) - if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then - do n = 1, this%ntabrow(ilak) - vol = this%laketables(ilak)%tabvolume(n) - sa = this%laketables(ilak)%tabsarea(n) - wa = this%laketables(ilak)%tabwarea(n) - v = vol * sa * wa - ! -- check if all entries are zero - if (v > DZERO) exit - ! -- set lake bottom - this%lakebot(ilak) = this%laketables(ilak)%tabstage(n) - this%belev(ilak) = this%laketables(ilak)%tabstage(n) - end do - ! -- set maximum surface area for rainfall - n = this%ntabrow(ilak) - this%sareamax(ilak) = this%laketables(ilak)%tabsarea(n) - end if - ! - ! -- verify the table data - do n = 2, this%ntabrow(ilak) - if (this%laketables(ilak)%tabstage(n) <= this%laketables(ilak)%tabstage(n-1)) then - write(errmsg,'(4x,a,1x,i4,1x,a,1x,g15.6,1x,a,1x,i6,1x,a,1x,i4,1x,a,1x,g15.6,1x,a)') & - '****ERROR. TABLE STAGE ENTRY', n, '(', this%laketables(ilak)%tabstage(n), & - ') FOR LAKE ', ilak, 'MUST BE GREATER THAN THE PREVIOUS STAGE ENTRY', & - n-1, '(', this%laketables(ilak)%tabstage(n-1), ')' - call store_error(errmsg) - end if - if (this%laketables(ilak)%tabvolume(n) <= this%laketables(ilak)%tabvolume(n-1)) then - write(errmsg,'(4x,a,1x,i4,1x,a,1x,g15.6,1x,a,1x,i6,1x,a,1x,i4,1x,a,1x,g15.6,1x,a)') & - '****ERROR. TABLE VOLUME ENTRY', n, '(', this%laketables(ilak)%tabvolume(n), & - ') FOR LAKE ', ilak, 'MUST BE GREATER THAN THE PREVIOUS VOLUME ENTRY', & - n-1, '(', this%laketables(ilak)%tabvolume(n-1), ')' - call store_error(errmsg) - end if - if (this%laketables(ilak)%tabsarea(n) < this%laketables(ilak)%tabsarea(n-1)) then - write(errmsg,'(4x,a,1x,i4,1x,a,1x,g15.6,1x,a,1x,i6,1x,a,1x,i4,1x,a,1x,g15.6,1x,a)') & - '****ERROR. TABLE SURFACE AREA ENTRY', n, '(', this%laketables(ilak)%tabsarea(n), & - ') FOR LAKE ', ilak, 'MUST BE GREATER THAN OR EQUAL TO THE PREVIOUS SURFACE AREA ENTRY', & - n-1, '(', this%laketables(ilak)%tabsarea(n-1), ')' - call store_error(errmsg) - end if - iconn = this%idxlakeconn(ilak) - if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then - if (this%laketables(ilak)%tabwarea(n) < this%laketables(ilak)%tabwarea(n-1)) then - write(errmsg,'(4x,a,1x,i4,1x,a,1x,g15.6,1x,a,1x,i6,1x,a,1x,i4,1x,a,1x,g15.6,1x,a)') & - '****ERROR. TABLE EXCHANGE AREA ENTRY', n, '(', this%laketables(ilak)%tabwarea(n), & - ') FOR LAKE ', ilak, 'MUST BE GREATER THAN OR EQUAL TO THE PREVIOUS EXCHANGE AREA ENTRY', & - n-1, '(', this%laketables(ilak)%tabwarea(n-1), ')' - call store_error(errmsg) - end if - end if - end do - end if - ! - ! -- write summary of lake table error messages - if (count_errors() > 0) then - call parser%StoreErrorUnit() - call ustop() - end if - ! - ! Close the table file and clear other parser members - call parser%Clear() - ! - ! -- return - return - end subroutine lak_read_table - - subroutine lak_read_outlets(this) -! ****************************************************************************** -! lak_read_outlets -- Read the lake outlets for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors - use TimeSeriesManagerModule, only: read_single_value_or_time_series - ! -- dummy - class(LakType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: errmsg - character(len=LINELENGTH) :: text, keyword - character(len=LENBOUNDNAME) :: bndName - character(len=9) :: citem - integer(I4B) :: ierr, ival - logical :: isfound, endOfBlock - integer(I4B) :: n - !integer(I4B) :: ii, jj, kk, nn - integer(I4B) :: jj - real(DP) :: endtim - integer(I4B), dimension(:), pointer, contiguous :: nboundchk - ! - ! -- format - ! - ! -- code -! ------------------------------------------------------------------------------ - ! - ! -- get well_connections block - call this%parser%GetBlock('OUTLETS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) - ! - ! -- parse outlets block if detected - if (isfound) then - if (this%noutlets > 0) then - ! - ! -- allocate and initialize local variables - allocate(nboundchk(this%noutlets)) - do n = 1, this%noutlets - nboundchk(n) = 0 - end do - ! - ! -- allocate outlet data using memory manager - call mem_allocate(this%lakein, this%NOUTLETS, 'LAKEIN', this%origin) - call mem_allocate(this%lakeout, this%NOUTLETS, 'LAKEOUT', this%origin) - call mem_allocate(this%iouttype, this%NOUTLETS, 'IOUTTYPE', this%origin) - call mem_allocate(this%outrate, this%NOUTLETS, 'OUTRATE', this%origin) - call mem_allocate(this%outinvert, this%NOUTLETS, 'OUTINVERT', & - this%origin) - call mem_allocate(this%outwidth, this%NOUTLETS, 'OUTWIDTH', this%origin) - call mem_allocate(this%outrough, this%NOUTLETS, 'OUTROUGH', this%origin) - call mem_allocate(this%outslope, this%NOUTLETS, 'OUTSLOPE', this%origin) - call mem_allocate(this%simoutrate, this%NOUTLETS, 'SIMOUTRATE', & - this%origin) - - ! -- process the lake connection data - write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & - ' OUTLETS' - readoutlet: do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - n = this%parser%GetInteger() - - if (n < 1 .or. n > this%noutlets) then - write(errmsg,'(4x,a,1x,i6)') & - '****ERROR. outletno MUST BE > 0 and <= ', this%noutlets - call store_error(errmsg) - cycle readoutlet - end if - ! - ! -- increment nboundchk - nboundchk(n) = nboundchk(n) + 1 - ! - ! -- read outlet lakein - ival = this%parser%GetInteger() - if (ival <1 .or. ival > this%nlakes) then - write(errmsg,'(4x,a,1x,i4,1x,a,1x,i6)') & - '****ERROR. lakein FOR OUTLET ', n, 'MUST BE > 0 and <= ', & - this%nlakes - call store_error(errmsg) - cycle readoutlet - end if - this%lakein(n) = ival - - ! -- read outlet lakeout - ival = this%parser%GetInteger() - if (ival <0 .or. ival > this%nlakes) then - write(errmsg,'(4x,a,1x,i4,1x,a,1x,i6)') & - '****ERROR. lakeout FOR OUTLET ', n, 'MUST BE >= 0 and <= ', & - this%nlakes - call store_error(errmsg) - cycle readoutlet - end if - this%lakeout(n) = ival - - ! -- read ictype - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('SPECIFIED') - this%iouttype(n) = 0 - case ('MANNING') - this%iouttype(n) = 1 - case ('WEIR') - this%iouttype(n) = 2 - case default - write(errmsg,'(4x,a,1x,i4,1x,a,a,a)') & - '****ERROR. UNKNOWN couttype FOR OUTLET ', n, & - '(', trim(keyword), ')' - call store_error(errmsg) - cycle readoutlet - end select - - ! -- build bndname for outlet - write(citem,'(i9.9)') n - bndName = 'OUTLET' // citem - - ! -- set a few variables for timeseries aware variables - endtim = DZERO - jj = 1 - - ! -- outlet invert - call this%parser%GetString(text) - call read_single_value_or_time_series(text, & - this%outinvert(n)%value, & - this%outinvert(n)%name, & - endtim, & - this%name, 'BND', & - this%TsManager, & - this%iprpak, n, jj, 'INVERT', & - bndName, this%parser%iuactive) - - ! -- outlet width - call this%parser%GetString(text) - call read_single_value_or_time_series(text, & - this%outwidth(n)%value, & - this%outwidth(n)%name, & - endtim, & - this%name, 'BND', & - this%TsManager, & - this%iprpak, n, jj, 'WIDTH', & - bndName, this%parser%iuactive) - - ! -- outlet roughness - call this%parser%GetString(text) - call read_single_value_or_time_series(text, & - this%outrough(n)%value, & - this%outrough(n)%name, & - endtim, & - this%name, 'BND', & - this%TsManager, & - this%iprpak, n, jj, 'ROUGH', & - bndName, this%parser%iuactive) - - ! -- outlet slope - call this%parser%GetString(text) - call read_single_value_or_time_series(text, & - this%outslope(n)%value, & - this%outslope(n)%name, & - endtim, & - this%name, 'BND', & - this%TsManager, & - this%iprpak, n, jj, 'SLOPE', & - bndName, this%parser%iuactive) - - - end do readoutlet - write(this%iout,'(1x,a)') 'END OF ' // trim(adjustl(this%text)) // & - ' OUTLETS' - ! - ! -- check for duplicate or missing outlets - do n = 1, this%noutlets - if (nboundchk(n) == 0) then - write(errmsg,'(a,1x,i0)') 'ERROR. NO DATA SPECIFIED FOR OUTLET', n - call store_error(errmsg) - else if (nboundchk(n) > 1) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & - 'ERROR. DATA FOR OUTLET', n, 'SPECIFIED', nboundchk(n), 'TIMES' - call store_error(errmsg) - end if - end do - ! - ! -- deallocate local storage - deallocate(nboundchk) - else - write(errmsg,'(a,1x,a)') 'ERROR. AN OUTLETS BLOCK SHOULD NOT BE', & - 'SPECIFIED IF NOUTLETS IS NOT SPECIFIED OR IS SPECIFIED TO BE 0.' - call store_error(errmsg) - end if - - else - if (this%noutlets > 0) then - call store_error('ERROR. REQUIRED OUTLETS BLOCK NOT FOUND.') - end if - end if - ! - ! -- write summary of lake_connection error messages - ierr = count_errors() - if (ierr > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- return - return - end subroutine lak_read_outlets - - subroutine lak_read_dimensions(this) -! ****************************************************************************** -! pak1read_dimensions -- Read the dimensions for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors - ! -- dummy - class(LakType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: errmsg - character(len=LINELENGTH) :: keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock - ! -- format -! ------------------------------------------------------------------------------ - ! - ! -- initialize dimensions to -1 - this%nlakes= -1 - this%maxbound = -1 - ! - ! -- 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 '//trim(adjustl(this%text))// & - ' DIMENSIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('NLAKES') - this%nlakes = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)')'NLAKES = ', this%nlakes - case ('NOUTLETS') - this%noutlets = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)')'NOUTLETS = ', this%noutlets - case ('NTABLES') - this%ntables = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)')'NTABLES = ', this%ntables - case default - write(errmsg,'(4x,a,a)') & - '****ERROR. UNKNOWN '//trim(this%text)//' DIMENSION: ', & - trim(keyword) - call store_error(errmsg) - end select - end do - write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' DIMENSIONS' - else - call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') - end if - - if (this%nlakes < 0) then - write(errmsg, '(1x,a)') & - 'ERROR: NLAKES WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.' - call store_error(errmsg) - end if - ! - ! -- stop if errors were encountered in the DIMENSIONS block - ierr = count_errors() - if (ierr > 0) then - call ustop() - end if - ! - ! -- read lakes block - call this%lak_read_lakes() - ! - ! -- read lake_connections block - call this%lak_read_lake_connections() - ! - ! -- read tables block - call this%lak_read_tables() - ! - ! -- read outlets block - call this%lak_read_outlets() - ! - ! -- Call define_listlabel to construct the list label that is written - ! when PRINT_INPUT option is used. - call this%define_listlabel() - ! - ! -- setup the budget object - call this%lak_setup_budobj() - ! - ! -- return - return - end subroutine lak_read_dimensions - - - subroutine lak_read_initial_attr(this) -! ****************************************************************************** -! pak1read_dimensions -- Read the initial parameters for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors - use TimeSeriesManagerModule, only: read_single_value_or_time_series - ! -- dummy - class(LakType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: text - integer(I4B) :: j, jj, n - integer(I4B) :: nn - integer(I4B) :: idx - real(DP) :: endtim - real(DP) :: top - real(DP) :: bot - real(DP) :: k - real(DP) :: area - real(DP) :: length - real(DP) :: s - real(DP) :: dx - real(DP) :: c - real(DP) :: sa - real(DP) :: wa - real(DP) :: v - real(DP) :: fact - real(DP) :: c1 - real(DP) :: c2 - real(DP), allocatable, dimension(:) :: clb, caq - character (len=14) :: cbedleak - character (len=14) :: cbedcond - character (len=10), dimension(0:3) :: ctype - character (len=15) :: nodestr - !data - data ctype(0) /'VERTICAL '/ - data ctype(1) /'HORIZONTAL'/ - data ctype(2) /'EMBEDDEDH '/ - data ctype(3) /'EMBEDDEDV '/ - ! -- format -! ------------------------------------------------------------------------------ - ! - ! -- initialize xnewpak and set stage - do n = 1, this%nlakes - this%xnewpak(n) = this%strt(n) - write(text,'(g15.7)') this%strt(n) - endtim = DZERO - jj = 1 ! For STAGE - call read_single_value_or_time_series(text, & - this%stage(n)%value, & - this%stage(n)%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, n, jj, 'STAGE', & - this%lakename(n), this%inunit) - - end do - ! - ! -- initialize status (iboundpak) of lakes to active - do n = 1, this%nlakes - if (this%status(n) == 'CONSTANT') then - this%iboundpak(n) = -1 - else if (this%status(n) == 'INACTIVE') then - this%iboundpak(n) = 0 - else if (this%status(n) == 'ACTIVE ') then - this%iboundpak(n) = 1 - end if - end do - ! - ! -- set boundname for each connection - if (this%inamedbound /= 0) then - do n = 1, this%nlakes - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 - this%boundname(j) = this%lakename(n) - end do - end do - endif - ! - ! -- set pointer to gwf iss and gwf hk - call mem_setptr(this%gwfiss, 'ISS', trim(this%name_model)) - call mem_setptr(this%gwfk11, 'K11', trim(this%name_model)//' NPF') - call mem_setptr(this%gwfk33, 'K33', trim(this%name_model)//' NPF') - call mem_setptr(this%gwfik33, 'IK33', trim(this%name_model)//' NPF') - call mem_setptr(this%gwfsat, 'SAT', trim(this%name_model)//' NPF') - ! - ! -- allocate temporary storage - allocate(clb(this%MAXBOUND)) - allocate(caq(this%MAXBOUND)) - - ! -- calculate saturated conductance for each connection - do n = 1, this%nlakes - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 - nn = this%cellid(j) - top = this%dis%top(nn) - bot = this%dis%bot(nn) - ! vertical connection - if (this%ictype(j) == 0) then - area = this%dis%area(nn) - this%sarea(j) = area - this%warea(j) = area - this%sareamax(n) = this%sareamax(n) + area - if (this%gwfik33 == 0) then - k = this%gwfk11(nn) - else - k = this%gwfk33(nn) - endif - length = DHALF * (top - bot) - ! horizontal connection - else if (this%ictype(j) == 1) then - area = (this%telev(j) - this%belev(j)) * this%connwidth(j) - ! -- recalculate area if connected cell is confined and lake - ! connection top and bot are equal to the cell top and bot - if (top == this%telev(j) .and. bot == this%belev(j)) then - if (this%icelltype(nn) == 0) then - area = this%gwfsat(nn) * (top - bot) * this%connwidth(j) - end if - end if - this%sarea(j) = DZERO - this%warea(j) = area - this%sareamax(n) = this%sareamax(n) + DZERO - k = this%gwfk11(nn) - length = this%connlength(j) - ! embedded horizontal connection - else if (this%ictype(j) == 2) then - area = DONE - this%sarea(j) = DZERO - this%warea(j) = area - this%sareamax(n) = this%sareamax(n) + DZERO - k = this%gwfk11(nn) - length = this%connlength(j) - ! embedded vertical connection - else if (this%ictype(j) == 3) then - area = DONE - this%sarea(j) = DZERO - this%warea(j) = area - this%sareamax(n) = this%sareamax(n) + DZERO - if (this%gwfik33 == 0) then - k = this%gwfk11(nn) - else - k = this%gwfk33(nn) - endif - length = this%connlength(j) - end if - if (this%bedleak(j) < DZERO) then - clb(j) = -DONE - else if (this%bedleak(j) > DZERO) then - clb(j) = done / this%bedleak(j) - else - clb(j) = DZERO - end if - if (k > DZERO) then - caq(j) = length / k - else - caq(j) = DZERO - end if - if (this%bedleak(j) < DZERO) then - this%satcond(j) = area / caq(j) - else if (clb(j)*caq(j) > DZERO) then - this%satcond(j) = area / (clb(j) + caq(j)) - else - this%satcond(j) = DZERO - end if - end do - end do - ! - ! -- write a summary of the conductance - if (this%iprpak > 0) then - write(this%iout,'(//,29x,a,/)') 'INTERFACE CONDUCTANCE BETWEEN LAKE AND AQUIFER CELLS' - write(this%iout,'(1x,a)') & - & ' LAKE CONNECTION CONNECTION LAKEBED' // & - & ' C O N D U C T A N C E S ' - write(this%iout,'(1x,a)') & - & ' NUMBER NUMBER CELLID DIRECTION LEAKANCE' // & - & ' LAKEBED AQUIFER COMBINED' - write(this%iout,"(1x,108('-'))") - do n = 1, this%nlakes - idx = 0 - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 - idx = idx + 1 - fact = DONE - if (this%ictype(j) == 1) then - fact = this%telev(j) - this%belev(j) - if (ABS(fact) > DZERO) then - fact = DONE / fact - end if - end if - nn = this%cellid(j) - area = this%warea(j) - c1 = DZERO - if (clb(j) < DZERO) then - cbedleak = ' NONE ' - cbedcond = ' NONE ' - else if (clb(j) > DZERO) then - c1 = area * fact / clb(j) - write(cbedleak,'(g14.5)') this%bedleak(j) - write(cbedcond,'(g14.5)') c1 - else - write(cbedleak,'(g14.5)') c1 - write(cbedcond,'(g14.5)') c1 - end if - c2 = DZERO - if (caq(j) > DZERO) then - c2 = area * fact / caq(j) - end if - call this%dis%noder_to_string(nn, nodestr) - write(this%iout,'(1x,i10,1x,i10,1x,a15,1x,a10,2(1x,a14),2(1x,g14.5))') & - & n, idx, nodestr, ctype(this%ictype(j)), cbedleak, & - & cbedcond, c2, this%satcond(j) * fact - end do - end do - write(this%iout,"(1x,108('-'))") - write(this%iout,'(1x,a)') 'IF VERTICAL CONNECTION, CONDUCTANCE (L^2/T) IS BETWEEN AQUIFER CELL AND OVERLYING LAKE CELL.' - write(this%iout,'(1x,a)') 'IF HORIZONTAL CONNECTION, CONDUCTANCES ARE PER UNIT SATURATED THICKNESS (L/T).' - write(this%iout,'(1x,a)') 'IF EMBEDDED CONNECTION, CONDUCTANCES ARE PER UNIT EXCHANGE AREA (1/T).' - - ! write(this%iout,*) n, idx, nodestr, this%sarea(j), this%warea(j) - ! - ! -- calculate stage, surface area, wetted area, volume relation - do n = 1, this%nlakes - write(this%iout,'(//1x,a,1x,i10)') 'STAGE/VOLUME RELATION FOR LAKE ', n - write(this%iout,'(/1x,5(a14))') ' STAGE', ' SURFACE AREA', & - & ' WETTED AREA', ' CONDUCTANCE', & - & ' VOLUME' - write(this%iout,"(1x,70('-'))") - dx = (this%laketop(n) - this%lakebot(n)) / 150. - s = this%lakebot(n) - do j = 1, 151 - call this%lak_calculate_conductance(n, s, c) - call this%lak_calculate_sarea(n, s, sa) - call this%lak_calculate_warea(n, s, wa, s) - call this%lak_calculate_vol(n, s, v) - write(this%iout,'(1x,5(E14.5))') s, sa, wa, c, v - s = s + dx - end do - write(this%iout,"(1x,70('-'))") - - write(this%iout,'(//1x,a,1x,i10)') 'STAGE/VOLUME RELATION FOR LAKE ', n - write(this%iout,'(/1x,4(a14))') ' ', ' ', & - & ' CALCULATED', ' STAGE' - write(this%iout,'(1x,4(a14))') ' STAGE', ' VOLUME', & - & ' STAGE', ' DIFFERENCE' - write(this%iout,"(1x,56('-'))") - s = this%lakebot(n) - dx - do j = 1, 156 - call this%lak_calculate_vol(n, s, v) - call this%lak_vol2stage(n, v, c) - write(this%iout,'(1x,4(E14.5))') s, v, c, s-c - s = s + dx - end do - write(this%iout,"(1x,56('-'))") - end do - end if - ! - ! -- finished with pointer to gwf hydraulic conductivity - this%gwfk11 => null() - this%gwfk33 => null() - this%gwfsat => null() - this%gwfik33 => null() - ! - ! -- deallocate temporary storage - deallocate(clb) - deallocate(caq) - ! - ! -- return - return - end subroutine lak_read_initial_attr - -! -- simple subroutine for linear interpolation of two vectors -! function assumes x data is sorted in ascending order - subroutine lak_linear_interpolation(this, n, x, y, z, v) - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: n - real(DP), dimension(n), intent(in) :: x - real(DP), dimension(n), intent(in) :: y - real(DP), intent(in) :: z - real(DP), intent(inout) :: v - ! -- local - integer(I4B) :: i - real(DP) :: dx, dydx - ! code - v = DZERO - ! below bottom of range - set to lowest value - if (z <= x(1)) then - v = y(1) - ! above highest value - ! slope calculated from interval between n and n-1 - else if (z > x(n)) then - dx = x(n) - x(n-1) - dydx = DZERO - if (ABS(dx) > DZERO) then - dydx = ( y(n) - y(n-1) ) / dx - end if - dx = (z - x(n)) - v = y(n) + dydx * dx - ! between lowest and highest value in current interval - else - do i = 2, n - dx = x(i) - x(i-1) - dydx = DZERO - if (z >= x(i-1) .and. z <= x(i)) then - if (ABS(dx) > DZERO) then - dydx = ( y(i) - y(i-1) ) / dx - end if - dx = (z - x(i-1)) - v = y(i-1) + dydx * dx - exit - end if - end do - end if - ! return - return - end subroutine lak_linear_interpolation - - subroutine lak_calculate_sarea(this, ilak, stage, sarea) -! ****************************************************************************** -! lak_calculate_sarea -- Calculate the surface area of a lake at a given stage. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - real(DP), intent(in) :: stage - real(DP), intent(inout) :: sarea - ! -- local - integer(I4B) :: i - real(DP) :: topl - real(DP) :: botl - real(DP) :: sat - real(DP) :: sa - ! -- formats -! ------------------------------------------------------------------------------ - sarea = DZERO - if (this%ntabrow(ilak) > 0) then - i = this%ntabrow(ilak) - if (stage <= this%laketables(ilak)%tabstage(1)) then - sarea = this%laketables(ilak)%tabsarea(1) - else if (stage >= this%laketables(ilak)%tabstage(i)) then - sarea = this%laketables(ilak)%tabsarea(i) - else - call this%lak_linear_interpolation(i, this%laketables(ilak)%tabstage, & - this%laketables(ilak)%tabsarea, & - stage, sarea) - end if - else - do i = this%idxlakeconn(ilak), this%idxlakeconn(ilak+1)-1 - topl = this%telev(i) - botl = this%belev(i) - sat = sQuadraticSaturation(topl, botl, stage) - sa = sat * this%sarea(i) - sarea = sarea + sa - end do - end if - ! - ! -- return - return - end subroutine lak_calculate_sarea - - subroutine lak_calculate_warea(this, ilak, stage, warea, hin) -! ****************************************************************************** -! lak_calculate_warea -- Calculate the wetted area of a lake at a given stage. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - real(DP), intent(in) :: stage - real(DP), intent(inout) :: warea - real(DP), optional, intent(inout) :: hin - ! -- local - integer(I4B) :: i - integer(I4B) :: igwfnode - real(DP) :: head - real(DP) :: wa - ! -- formats -! ------------------------------------------------------------------------------ - warea = DZERO - do i = this%idxlakeconn(ilak), this%idxlakeconn(ilak+1)-1 - if (present(hin)) then - head = hin - else - igwfnode = this%cellid(i) - head = this%xnew(igwfnode) - end if - call this%lak_calculate_conn_warea(ilak, i, stage, head, wa) - warea = warea + wa - end do - ! - ! -- return - return - end subroutine lak_calculate_warea - - subroutine lak_calculate_conn_warea(this, ilak, iconn, stage, head, wa) -! ****************************************************************************** -! lak_calculate_conn_warea -- Calculate the wetted area of a lake connection -! at a given stage. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - integer(I4B), intent(in) :: iconn - real(DP), intent(in) :: stage - real(DP), intent(in) :: head - real(DP), intent(inout) :: wa - ! -- local - integer(I4B) :: i - integer(I4B) :: node - real(DP) :: topl - real(DP) :: botl - real(DP) :: vv - real(DP) :: sat - ! -- formats -! ------------------------------------------------------------------------------ - wa = DZERO - topl = this%telev(iconn) - botl = this%belev(iconn) - call this%lak_calculate_cond_head(iconn, stage, head, vv) - if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then - if (vv > topl) vv = topl - i = this%ntabrow(ilak) - if (vv <= this%laketables(ilak)%tabstage(1)) then - wa = this%laketables(ilak)%tabwarea(1) - else if (vv >= this%laketables(ilak)%tabstage(i)) then - wa = this%laketables(ilak)%tabwarea(i) - else - call this%lak_linear_interpolation(i, this%laketables(ilak)%tabstage, & - this%laketables(ilak)%tabwarea, & - vv, wa) - end if - else - node = this%cellid(iconn) - ! -- confined cell - if (this%icelltype(node) == 0) then - sat = DONE - ! -- convertible cell - else - sat = sQuadraticSaturation(topl, botl, vv) - end if - wa = sat * this%warea(iconn) - end if - ! - ! -- return - return - end subroutine lak_calculate_conn_warea - - - subroutine lak_calculate_vol(this, ilak, stage, volume) -! ****************************************************************************** -! lak_calculate_vol -- Calculate the volume of a lake at a given stage. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - real(DP), intent(in) :: stage - real(DP), intent(inout) :: volume - ! -- local - integer(I4B) :: i - real(DP) :: topl - real(DP) :: botl - real(DP) :: ds - real(DP) :: sa - real(DP) :: v - real(DP) :: sat - ! -- formats -! ------------------------------------------------------------------------------ - volume = DZERO - if (this%ntabrow(ilak) > 0) then - i = this%ntabrow(ilak) - if (stage <= this%laketables(ilak)%tabstage(1)) then - volume = this%laketables(ilak)%tabvolume(1) - else if (stage >= this%laketables(ilak)%tabstage(i)) then - ds = stage - this%laketables(ilak)%tabstage(i) - sa = this%laketables(ilak)%tabsarea(i) - volume = this%laketables(ilak)%tabvolume(i) + ds * sa - else - call this%lak_linear_interpolation(i, this%laketables(ilak)%tabstage, & - this%laketables(ilak)%tabvolume, & - stage, volume) - end if - else - do i = this%idxlakeconn(ilak), this%idxlakeconn(ilak+1)-1 - topl = this%telev(i) - botl = this%belev(i) - sat = sQuadraticSaturation(topl, botl, stage) - sa = sat * this%sarea(i) - if (stage < botl) then - v = DZERO - else if (stage > botl .and. stage < topl) then - v = sa * (stage - botl) - else - v = sa * (topl - botl) + sa * (stage - topl) - end if - volume = volume + v - end do - end if - ! - ! -- return - return - end subroutine lak_calculate_vol - - - subroutine lak_calculate_conductance(this, ilak, stage, conductance) -! ****************************************************************************** -! lak_calculate_conductance -- Calculate the total conductance for a lake at a -! provided stage. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - real(DP), intent(in) :: stage - real(DP), intent(inout) :: conductance - ! -- local - integer(I4B) :: i - real(DP) :: c - ! -- formats -! ------------------------------------------------------------------------------ - conductance = DZERO - do i = this%idxlakeconn(ilak), this%idxlakeconn(ilak+1)-1 - call this%lak_calculate_conn_conductance(ilak, i, stage, stage, c) - conductance = conductance + c - end do - ! - ! -- return - return - end subroutine lak_calculate_conductance - - subroutine lak_calculate_cond_head(this, iconn, stage, head, vv) -! ****************************************************************************** -! lak_calculate_conn_head -- Calculate the controlling lake stage or groundwater -! head used to calculate the conductance for a lake -! connection from a provided stage and groundwater -! head. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: iconn - real(DP), intent(in) :: stage - real(DP), intent(in) :: head - real(DP), intent(inout) :: vv - ! -- local - real(DP) :: ss - real(DP) :: hh - real(DP) :: topl - real(DP) :: botl - ! -- formats -! ------------------------------------------------------------------------------ - topl = this%telev(iconn) - botl = this%belev(iconn) - ss = min(stage, topl) - hh = min(head, topl) - if (this%igwhcopt > 0) then - vv = hh - else if (this%inewton > 0) then - vv = max(ss, hh) - else - vv = DHALF * (ss + hh) - end if - ! - ! -- return - return - end subroutine lak_calculate_cond_head - - - subroutine lak_calculate_conn_conductance(this, ilak, iconn, stage, head, cond) -! ****************************************************************************** -! lak_calculate_conn_conductance -- Calculate the conductance for a lake -! connection at a provided stage -! and groundwater head. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - integer(I4B), intent(in) :: iconn - real(DP), intent(in) :: stage - real(DP), intent(in) :: head - real(DP), intent(inout) :: cond - ! -- local - integer(I4B) :: node - !real(DP) :: ss - !real(DP) :: hh - real(DP) :: vv - real(DP) :: topl - real(DP) :: botl - real(DP) :: sat - real(DP) :: wa - ! -- formats -! ------------------------------------------------------------------------------ - cond = DZERO - topl = this%telev(iconn) - botl = this%belev(iconn) - call this%lak_calculate_cond_head(iconn, stage, head, vv) - sat = sQuadraticSaturation(topl, botl, vv) - ! vertical connection - ! use full saturated conductance if top and bottom of the lake connection - ! are equal - if (this%ictype(iconn) == 0) then - if (ABS(topl-botl) < DPREC) then - sat = DONE - end if - ! horizontal connection - ! use full saturated conductance if the connected cell is not convertible - else if (this%ictype(iconn) == 1) then - node = this%cellid(iconn) - if (this%icelltype(node) == 0) then - sat = DONE - end if - ! embedded connection - else if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then - node = this%cellid(iconn) - if (this%icelltype(node) == 0) then - vv = this%telev(iconn) - call this%lak_calculate_conn_warea(ilak, iconn, vv, vv, wa) - else - call this%lak_calculate_conn_warea(ilak, iconn, stage, head, wa) - end if - sat = wa - end if - cond = sat * this%satcond(iconn) - ! - ! -- return - return - end subroutine lak_calculate_conn_conductance - - - subroutine lak_calculate_exchange(this, ilak, stage, totflow) -! ****************************************************************************** -! lak_calculate_exchange -- Calculate the total groundwater-lake flow at a -! provided stage. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - real(DP), intent(in) :: stage - real(DP), intent(inout) :: totflow - ! -- local - integer(I4B) :: j - integer(I4B) :: igwfnode - real(DP) :: flow - real(DP) :: hgwf - real(DP) :: cond - ! -- formats -! ------------------------------------------------------------------------------ - totflow = DZERO - do j = this%idxlakeconn(ilak), this%idxlakeconn(ilak+1)-1 - igwfnode = this%cellid(j) - hgwf = this%xnew(igwfnode) - call this%lak_calculate_conn_exchange(ilak, j, stage, hgwf, flow, cond) - totflow = totflow + flow - end do - ! - ! -- return - return - end subroutine lak_calculate_exchange - - - subroutine lak_calculate_conn_exchange(this, ilak, iconn, stage, head, flow, cond) -! ****************************************************************************** -! lak_calculate_conn_exchange -- Calculate the groundwater-lake flow at a -! provided stage and groundwater head. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - integer(I4B), intent(in) :: iconn - real(DP), intent(in) :: stage - real(DP), intent(in) :: head - real(DP), intent(inout) :: flow - real(DP), intent(inout) :: cond - ! -- local - real(DP) :: botl - real(DP) :: ss - real(DP) :: hh - ! -- formats -! ------------------------------------------------------------------------------ - flow = DZERO - call this%lak_calculate_conn_conductance(ilak, iconn, stage, head, cond) - botl = this%belev(iconn) - ss = max(stage, botl) - hh = max(head, botl) - flow = cond * (hh - ss) - ! - ! -- return - return - end subroutine lak_calculate_conn_exchange - - - subroutine lak_estimate_conn_exchange(this, iflag, ilak, iconn, idry, stage, & - head, flow, cond, source) -! ****************************************************************************** -! lak_estimate_conn_exchange -- Calculate the groundwater-lake flow at a -! provided stage and groundwater head. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: iflag - integer(I4B), intent(in) :: ilak - integer(I4B), intent(in) :: iconn - integer(I4B), intent(inout) :: idry - real(DP), intent(in) :: stage - real(DP), intent(in) :: head - real(DP), intent(inout) :: flow - real(DP), intent(inout) :: cond - real(DP), intent(inout) :: source - ! -- local - ! -- formats -! ------------------------------------------------------------------------------ - flow = DZERO - idry = 0 - call this%lak_calculate_conn_exchange(ilak, iconn, stage, head, flow, cond) - if (iflag == 1) then - if (flow > DZERO) then - source = source + flow - end if - else if (iflag == 2) then - if (-flow > source) then - flow = -source - source = DZERO - idry = 1 - else if (flow < DZERO) then - source = source + flow - end if - end if - ! - ! -- return - return - end subroutine lak_estimate_conn_exchange - - subroutine lak_calculate_storagechange(this, ilak, stage, stage0, delt, dvr) -! ****************************************************************************** -! lak_calculate_storagechange -- Calculate the storage change in a lake based on -! provided stages and a passed delt. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - real(DP), intent(in) :: stage - real(DP), intent(in) :: stage0 - real(DP), intent(in) :: delt - real(DP), intent(inout) :: dvr - ! -- local - real(DP) :: v - real(DP) :: v0 - ! -- formats -! ------------------------------------------------------------------------------ - dvr = DZERO - if (this%gwfiss /= 1) then - call this%lak_calculate_vol(ilak, stage, v) - call this%lak_calculate_vol(ilak, stage0, v0) - dvr = (v0 - v) / delt - end if - ! - ! -- return - return - end subroutine lak_calculate_storagechange - - subroutine lak_calculate_rainfall(this, ilak, stage, ra) -! ****************************************************************************** -! lak_calculate_rainfall -- Calculate the rainfall for a lake . -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - real(DP), intent(in) :: stage - real(DP), intent(inout) :: ra - ! -- local - integer(I4B) :: iconn - real(DP) :: sa - ! -- formats -! ------------------------------------------------------------------------------ - ! -- rainfall - iconn = this%idxlakeconn(ilak) - if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then - sa = this%sareamax(ilak) - else - call this%lak_calculate_sarea(ilak, stage, sa) - end if - ra = this%rainfall(ilak)%value * sa !this%sareamax(ilak) - ! - ! -- return - return - end subroutine lak_calculate_rainfall - - subroutine lak_calculate_runoff(this, ilak, ro) -! ****************************************************************************** -! lak_calculate_runoff -- Calculate runoff to a lake. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - real(DP), intent(inout) :: ro - ! -- formats -! ------------------------------------------------------------------------------ - ! -- runoff - ro = this%runoff(ilak)%value - ! - ! -- return - return - end subroutine lak_calculate_runoff - - subroutine lak_calculate_inflow(this, ilak, qin) -! ****************************************************************************** -! lak_calculate_inflow -- Calculate specified inflow to a lake. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - real(DP), intent(inout) :: qin - ! -- formats -! ------------------------------------------------------------------------------ - ! -- inflow to lake - qin = this%inflow(ilak)%value - ! - ! -- return - return - end subroutine lak_calculate_inflow - - subroutine lak_calculate_external(this, ilak, ex) -! ****************************************************************************** -! lak_calculate_external -- Calculate the external flow terms to a lake. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - real(DP), intent(inout) :: ex - ! -- local - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- If mover is active, add receiver water to rhs and - ! store available water (as positive value) - ex = DZERO - if (this%imover == 1) then - ex = this%pakmvrobj%get_qfrommvr(ilak) - end if - ! - ! -- return - return - end subroutine lak_calculate_external - - subroutine lak_calculate_withdrawal(this, ilak, avail, wr) -! ****************************************************************************** -! lak_calculate_withdrawal -- Calculate the withdrawal from a lake subject to -! an available volume. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - real(DP), intent(inout) :: avail - real(DP), intent(inout) :: wr - ! -- local - ! -- formats -! ------------------------------------------------------------------------------ - ! -- withdrawals - limit to sum of inflows and available volume - wr = this%withdrawal(ilak)%value - if (wr > avail) then - wr = -avail - else - if (wr > DZERO) then - wr = -wr - end if - end if - avail = avail + wr - ! - ! -- return - return - end subroutine lak_calculate_withdrawal - - subroutine lak_calculate_evaporation(this, ilak, stage, avail, ev) -! ****************************************************************************** -! lak_calculate_evaporation -- Calculate the evaporation from a lake at a -! provided stage subject to an available volume. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - real(DP), intent(in) :: stage - real(DP), intent(inout) :: avail - real(DP), intent(inout) :: ev - ! -- local - real(DP) :: sa - ! -- formats -! ------------------------------------------------------------------------------ - ! -- evaporation - limit to sum of inflows and available volume - call this%lak_calculate_sarea(ilak, stage, sa) - ev = sa * this%evaporation(ilak)%value - if (ev > avail) then - ev = -avail - else - ev = -ev - end if - avail = avail + ev - ! - ! -- return - return - end subroutine lak_calculate_evaporation - - subroutine lak_calculate_outlet_inflow(this, ilak, outinf) -! ****************************************************************************** -! lak_calculate_outlet_inflow -- Calculate the outlet inflow to a lake. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - real(DP), intent(inout) :: outinf - ! -- local - integer(I4B) :: n - ! -- formats -! ------------------------------------------------------------------------------ - ! - outinf = DZERO - do n = 1, this%noutlets - if (this%lakeout(n) == ilak) then - outinf = outinf - this%simoutrate(n) - if (this%imover == 1) then - outinf = outinf - this%pakmvrobj%get_qtomvr(n) - end if - end if - end do - ! - ! -- return - return - end subroutine lak_calculate_outlet_inflow - - subroutine lak_calculate_outlet_outflow(this, ilak, stage, avail, outoutf) -! ****************************************************************************** -! lak_calculate_outlet_outflow -- Calculate the outlet outflow from a lake. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - real(DP), intent(in) :: stage - real(DP), intent(inout) :: avail - real(DP), intent(inout) :: outoutf - ! -- local - integer(I4B) :: n - real(DP) :: g - real(DP) :: d - real(DP) :: c - real(DP) :: gsm - real(DP) :: rate - ! -- formats -! ------------------------------------------------------------------------------ - ! - outoutf = DZERO - do n = 1, this%noutlets - if (this%lakein(n) == ilak) then - rate = DZERO - d = stage - this%outinvert(n)%value - if (this%outdmax > DZERO) then - if (d > this%outdmax) d = this%outdmax - end if - g = DGRAVITY * this%convlength * this%convtime * this%convtime - select case (this%iouttype(n)) - ! specified rate - case(0) - rate = this%outrate(n)%value - if (-rate > avail) then - rate = -avail - end if - ! manning - case (1) - if (d > DZERO) then - c = (this%convlength**DONETHIRD) * this%convtime - gsm = DZERO - if (this%outrough(n)%value > DZERO) then - gsm = DONE / this%outrough(n)%value - end if - rate = -c * gsm * this%outwidth(n)%value * ( d**DFIVETHIRDS ) * sqrt(this%outslope(n)%value) - end if - ! weir - case (2) - if (d > DZERO) then - rate = -DTWOTHIRDS * DCD * this%outwidth(n)%value * d * sqrt(DTWO * g * d) - end if - end select - !if (-rate > avail) then - ! rate = -avail - !end if - this%simoutrate(n) = rate - avail = avail + rate - outoutf = outoutf + rate - end if - end do - ! - ! -- return - return - end subroutine lak_calculate_outlet_outflow - - subroutine lak_get_internal_inlet(this, ilak, outinf) -! ****************************************************************************** -! lak_get_internal_inlet -- Get the outlet inflow to a lake from another lake. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - real(DP), intent(inout) :: outinf - ! -- local - integer(I4B) :: n - ! -- formats -! ------------------------------------------------------------------------------ - outinf = DZERO - do n = 1, this%noutlets - if (this%lakeout(n) == ilak) then - outinf = outinf - this%simoutrate(n) - if (this%imover == 1) then - outinf = outinf - this%pakmvrobj%get_qtomvr(n) - end if - end if - end do - ! - ! -- return - return - end subroutine lak_get_internal_inlet - - subroutine lak_get_internal_outlet(this, ilak, outoutf) -! ****************************************************************************** -! lak_get_internal_outlet -- Get the outlet from a lake to another lake. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - real(DP), intent(inout) :: outoutf - ! -- local - integer(I4B) :: n - ! -- formats -! ------------------------------------------------------------------------------ - outoutf = DZERO - do n = 1, this%noutlets - if (this%lakein(n) == ilak) then - if (this%lakeout(n) < 1) cycle - outoutf = outoutf + this%simoutrate(n) - end if - end do - ! - ! -- return - return - end subroutine lak_get_internal_outlet - - subroutine lak_get_external_outlet(this, ilak, outoutf) -! ****************************************************************************** -! lak_get_external_outlet -- Get the outlet outflow from a lake to an external -! boundary. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - real(DP), intent(inout) :: outoutf - ! -- local - integer(I4B) :: n - ! -- formats -! ------------------------------------------------------------------------------ - outoutf = DZERO - do n = 1, this%noutlets - if (this%lakein(n) == ilak) then - if (this%lakeout(n) > 0) cycle - outoutf = outoutf + this%simoutrate(n) - end if - end do - ! - ! -- return - return - end subroutine lak_get_external_outlet - - subroutine lak_get_external_mover(this, ilak, outoutf) -! ****************************************************************************** -! lak_get_external_mover -- Get the mover outflow from a lake to an external -! boundary. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - real(DP), intent(inout) :: outoutf - ! -- local - integer(I4B) :: n - ! -- formats -! ------------------------------------------------------------------------------ - outoutf = DZERO - if (this%imover == 1) then - do n = 1, this%noutlets - if (this%lakein(n) == ilak) then - if (this%lakeout(n) > 0) cycle - outoutf = outoutf + this%pakmvrobj%get_qtomvr(n) - end if - end do - end if - ! - ! -- return - return - end subroutine lak_get_external_mover - - subroutine lak_get_internal_mover(this, ilak, outoutf) -! ****************************************************************************** -! lak_get_internal_mover -- Get the mover outflow from a lake to another lake. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - real(DP), intent(inout) :: outoutf - ! -- local - integer(I4B) :: n - ! -- formats -! ------------------------------------------------------------------------------ - outoutf = DZERO - if (this%imover == 1) then - do n = 1, this%noutlets - if (this%lakein(n) == ilak) then - if (this%lakeout(n) < 1) cycle - outoutf = outoutf + this%pakmvrobj%get_qtomvr(n) - end if - end do - end if - ! - ! -- return - return - end subroutine lak_get_internal_mover - - subroutine lak_get_outlet_tomover(this, ilak, outoutf) -! ****************************************************************************** -! llak_get_outlet_tomover -- Get the outlet to mover from a lake. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - real(DP), intent(inout) :: outoutf - ! -- local - integer(I4B) :: n - ! -- formats -! ------------------------------------------------------------------------------ - outoutf = DZERO - if (this%imover == 1) then - do n = 1, this%noutlets - if (this%lakein(n) == ilak) then - outoutf = outoutf + this%pakmvrobj%get_qtomvr(n) - end if - end do - end if - ! - ! -- return - return - end subroutine lak_get_outlet_tomover - - subroutine lak_vol2stage(this, ilak, vol, stage) -! ****************************************************************************** -! lak_vol2stage-- Determine the stage from a provided volume. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - real(DP), intent(in) :: vol - real(DP), intent(inout) :: stage - ! -- local - integer(I4B) :: i - integer(I4B) :: ibs - real(DP) :: s0, s1, sm - real(DP) :: v0, v1, vm - real(DP) :: f0, f1, fm - real(DP) :: sa - real(DP) :: en0, en1 - real(DP) :: ds, ds0 - real(DP) :: denom - ! -- formats -! ------------------------------------------------------------------------------ - s0 = this%lakebot(ilak) - call this%lak_calculate_vol(ilak, s0, v0) - s1 = this%laketop(ilak) - call this%lak_calculate_vol(ilak, s1, v1) - ! -- zero volume - if (vol <= v0) then - stage = s0 - ! -- linear relation between stage and volume above top of lake - else if (vol >= v1) then - call this%lak_calculate_sarea(ilak, s1, sa) - stage = s1 + (vol - v1) / sa - ! -- use combination of secant and bisection - else - en0 = s0 - en1 = s1 - ! sm = s1 ! causes divide by zero in 1st line in secantbisection loop - ! sm = s0 ! causes divide by zero in 1st line in secantbisection loop - sm = DZERO - f0 = vol - v0 - f1 = vol - v1 - ibs = 0 - secantbisection: do i = 1, 150 - denom = f1 - f0 - if (denom /= DZERO) then - ds = f1 * (s1 - s0) / denom - else - ibs = 13 - end if - if (i == 1) then - ds0 = ds - end if - ! -- use bisection if end points are exceeded - if (sm < en0 .or. sm > en1) ibs = 13 - ! -- use bisection if secant method stagnates or if - ! ds exceeds previous ds - bisection would occur - ! after conditions exceeded in 13 iterations - if (ds*ds0 < DPREC .or. ABS(ds) > ABS(ds0)) ibs = ibs + 1 - if (ibs > 12) then - ds = DHALF * (s1 - s0) - ibs = 0 - end if - sm = s1 - ds - if (ABS(ds) < DEM6) then - exit secantbisection - end if - call this%lak_calculate_vol(ilak, sm, vm) - fm = vol - vm - s0 = s1 - f0 = f1 - s1 = sm - f1 = fm - ds0 = ds - end do secantbisection - stage = sm - if (ABS(ds) >= DEM6) then - write(this%iout, '(1x,a,1x,i5,4(1x,a,1x,g15.6))') & - & 'LAK_VOL2STAGE failed for lake', ilak, 'volume error =', fm, & - & 'finding stage (', stage, ') for volume =', vol, & - & 'final change in stage =', ds - end if - end if - ! - ! -- return - return - end subroutine lak_vol2stage - - - function lak_check_valid(this, itemno) result(ierr) -! ****************************************************************************** -! lak_check_valid -- Determine if a valid lake or outlet number has been -! specified. -! ****************************************************************************** - use SimModule, only: ustop, store_error - ! -- return - integer(I4B) :: ierr - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: itemno - ! -- local - character(len=LINELENGTH) :: errmsg - integer(I4B) :: ival - ! -- formats -! ------------------------------------------------------------------------------ - ierr = 0 - ival = abs(itemno) - if (itemno > 0) then - if (ival < 1 .or. ival > this%nlakes) then - write(errmsg,'(4x,a,1x,i6,1x,a,1x,i6)') & - '****ERROR. LAKENO ', itemno, 'MUST BE > 0 and <= ', this%nlakes - call store_error(errmsg) - ierr = 1 - end if - else - if (ival < 1 .or. ival > this%noutlets) then - write(errmsg,'(4x,a,1x,i6,1x,a,1x,i6)') & - '****ERROR. IOUTLET ', itemno, 'MUST BE > 0 and <= ', this%noutlets - call store_error(errmsg) - ierr = 1 - end if - end if - end function lak_check_valid - - subroutine lak_set_stressperiod(this, itemno, line) -! ****************************************************************************** -! lak_set_stressperiod -- Set a stress period attribute for lakweslls(itemno) -! using keywords. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - !use ConstantsModule, only: LINELENGTH, DTWO - use TdisModule, only: kper, perlen, totimsav - use TimeSeriesManagerModule, only: read_single_value_or_time_series - use InputOutputModule, only: urword - use SimModule, only: ustop, store_error - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: itemno - character (len=*), intent(in) :: line - ! -- local - character(len=LINELENGTH) :: text - character(len=LINELENGTH) :: caux - character(len=LINELENGTH) :: keyword - character(len=LINELENGTH) :: errmsg - character(len=LENBOUNDNAME) :: bndName - character(len=9) :: citem - integer(I4B) :: ierr - integer(I4B) :: itmp - integer(I4B) :: ival, istart, istop - integer(I4B) :: i0 - integer(I4B) :: lloc - integer(I4B) :: ii - integer(I4B) :: jj - integer(I4B) :: iaux - real(DP) :: rval - real(DP) :: endtim - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- Find time interval of current stress period. - endtim = totimsav + perlen(kper) - ! - ! -- write abs(itemno) to citem string - itmp = ABS(itemno) - write(citem,'(i9.9)') itmp - ! - ! -- Assign boundary name - if (this%inamedbound==1) then - bndName = this%boundname(itemno) - else - bndName = '' - end if - ! - ! -- read line - lloc = 1 - call urword(line, lloc, istart, istop, 1, ival, rval, this%iout, this%inunit) - i0 = istart - keyword = line(istart:istop) - select case (line(istart:istop)) - case ('STATUS') - ierr = this%lak_check_valid(itemno) - if (ierr /= 0) goto 999 - !bndName = this%boundname(itemno) - call urword(line, lloc, istart, istop, 1, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - this%status(itmp) = text(1:8) - if (text == 'CONSTANT') then - this%iboundpak(itmp) = -1 - else if (text == 'INACTIVE') then - this%iboundpak(itmp) = 0 - else if (text == 'ACTIVE') then - this%iboundpak(itmp) = 1 - else - write(errmsg,'(4x,a,a)') & - '****ERROR. UNKNOWN '//trim(this%text)//' LAK STATUS KEYWORD: ', & - text - call store_error(errmsg) - end if - case ('STAGE') - ierr = this%lak_check_valid(itemno) - if (ierr /= 0) goto 999 - !bndName = this%boundname(itemno) - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 1 ! For STAGE - call read_single_value_or_time_series(text, & - this%stage(itmp)%value, & - this%stage(itmp)%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, itmp, jj, 'STAGE', & - bndName, this%inunit) - case ('RAINFALL') - ierr = this%lak_check_valid(itemno) - if (ierr /= 0) goto 999 - !bndName = this%boundname(itemno) - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 1 ! For RAINFALL - call read_single_value_or_time_series(text, & - this%rainfall(itmp)%value, & - this%rainfall(itmp)%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, itmp, jj, 'RAINFALL', & - bndName, this%inunit) - if (this%rainfall(itmp)%value < DZERO) then - write(errmsg, '(4x, a, i0, a, G0, a)') & - '****ERROR. LAKE ', itmp, ' WAS ASSIGNED A RAINFALL VALUE OF ', & - this%rainfall(itmp)%value, '. RAINFALL MUST BE POSITIVE.' - call store_error(errmsg) - end if - case ('EVAPORATION') - ierr = this%lak_check_valid(itemno) - if (ierr /= 0) goto 999 - !bndName = this%boundname(itemno) - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 1 ! For EVAPORATION - call read_single_value_or_time_series(text, & - this%evaporation(itmp)%value, & - this%evaporation(itmp)%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, itmp, jj, 'EVAPORATION', & - bndName, this%inunit) - if (this%evaporation(itmp)%value < DZERO) then - write(errmsg, '(4x, a, i0, a, G0, a)') & - '****ERROR. LAKE ', itmp, ' WAS ASSIGNED AN EVAPORATION VALUE OF ', & - this%evaporation(itmp)%value, '. EVAPORATION MUST BE POSITIVE.' - call store_error(errmsg) - end if - case ('RUNOFF') - ierr = this%lak_check_valid(itemno) - if (ierr /= 0) goto 999 - !bndName = this%boundname(itemno) - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 1 ! For RUNOFF - call read_single_value_or_time_series(text, & - this%runoff(itmp)%value, & - this%runoff(itmp)%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, itmp, jj, 'RUNOFF', & - bndName, this%inunit) - if (this%runoff(itmp)%value < DZERO) then - write(errmsg, '(4x, a, i0, a, G0, a)') & - '****ERROR. LAKE ', itmp, ' WAS ASSIGNED A RUNOFF VALUE OF ', & - this%runoff(itmp)%value, '. RUNOFF MUST BE POSITIVE.' - call store_error(errmsg) - end if - case ('INFLOW') - ierr = this%lak_check_valid(itemno) - if (ierr /= 0) goto 999 - !bndName = this%boundname(itemno) - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 1 ! For specified INFLOW - call read_single_value_or_time_series(text, & - this%inflow(itmp)%value, & - this%inflow(itmp)%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, itmp, jj, 'INFLOW', & - bndName, this%inunit) - if (this%inflow(itmp)%value < DZERO) then - write(errmsg, '(4x, a, i0, a, G0, a)') & - '****ERROR. LAKE ', itmp, ' WAS ASSIGNED AN INFLOW VALUE OF ', & - this%inflow(itmp)%value, '. INFLOW MUST BE POSITIVE.' - call store_error(errmsg) - end if - case ('WITHDRAWAL') - ierr = this%lak_check_valid(itemno) - if (ierr /= 0) goto 999 - !bndName = this%boundname(itemno) - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 1 ! For specified WITHDRAWAL - call read_single_value_or_time_series(text, & - this%withdrawal(itmp)%value, & - this%withdrawal(itmp)%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, itmp, jj, 'WITHDRAWAL', & - bndName, this%inunit) - if (this%withdrawal(itmp)%value < DZERO) then - write(errmsg, '(4x, a, i0, a, G0, a)') & - '****ERROR. LAKE ', itmp, ' WAS ASSIGNED A WITHDRAWAL VALUE OF ', & - this%withdrawal(itmp)%value, '. WITHDRAWAL MUST BE POSITIVE.' - call store_error(errmsg) - end if - case ('RATE') - ierr = this%lak_check_valid(-itemno) - if (ierr /= 0) goto 999 - bndName = 'OUTLET' // citem - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 1 ! For specified OUTLET RATE - call read_single_value_or_time_series(text, & - this%outrate(itmp)%value, & - this%outrate(itmp)%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, itmp, jj, 'OUTRATE', & - bndName, this%inunit) - case ('INVERT') - ierr = this%lak_check_valid(-itemno) - if (ierr /= 0) goto 999 - bndName = 'OUTLET' // citem - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 1 ! For OUTLET INVERT - call read_single_value_or_time_series(text, & - this%outinvert(itmp)%value, & - this%outinvert(itmp)%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, itmp, jj, 'OUTINVERT', & - bndName,this%inunit) - case ('WIDTH') - ierr = this%lak_check_valid(-itemno) - if (ierr /= 0) goto 999 - bndName = 'OUTLET' // citem - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 1 ! For OUTLET WIDTH - call read_single_value_or_time_series(text, & - this%outwidth(itmp)%value, & - this%outwidth(itmp)%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, itmp, jj, 'OUTWIDTH', & - bndName, this%inunit) - case ('ROUGH') - ierr = this%lak_check_valid(-itemno) - if (ierr /= 0) goto 999 - bndName = 'OUTLET' // citem - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 1 ! For OUTLET ROUGHNESS - call read_single_value_or_time_series(text, & - this%outrough(itmp)%value, & - this%outrough(itmp)%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, itmp, jj, 'OUTROUGH', & - bndName, this%inunit) - case ('SLOPE') - ierr = this%lak_check_valid(-itemno) - if (ierr /= 0) goto 999 - bndName = 'OUTLET' // citem - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 1 ! For OUTLET SLOPE - call read_single_value_or_time_series(text, & - this%outslope(itmp)%value, & - this%outslope(itmp)%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, itmp, jj, 'OUTSLOPE', & - bndName, this%inunit) - case ('AUXILIARY') - ierr = this%lak_check_valid(itemno) - if (ierr /= 0) goto 999 - !bndName = this%boundname(itemno) - call urword(line, lloc, istart, istop, 1, ival, rval, this%iout, this%inunit) - caux = line(istart:istop) - do iaux = 1, this%naux - if (trim(adjustl(caux)) /= trim(adjustl(this%auxname(iaux)))) cycle - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 1 !iaux - ii = (itmp-1) * this%naux + iaux - call read_single_value_or_time_series(text, & - this%lauxvar(ii)%value, & - this%lauxvar(ii)%name, & - endtim, & - this%Name, 'AUX', this%TsManager, & - this%iprpak, itmp, jj, & - this%auxname(iaux), bndName, & - this%inunit) - exit - end do - case default - write(errmsg,'(4x,a,a)') & - '****ERROR. UNKNOWN '//trim(this%text)//' LAK DATA KEYWORD: ', & - line(istart:istop) - call store_error(errmsg) - call ustop() - end select - ! - ! -- terminate if any errors were detected -999 if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- write keyword data to output file - if (this%iprpak /= 0) then - write(this%iout, '(3x,i10,1x,a)') itmp, line(i0:istop) - end if - ! - ! -- return - return - end subroutine lak_set_stressperiod - - - subroutine lak_set_attribute_error(this, ilak, keyword, msg) -! ****************************************************************************** -! lak_set_attribute_error -- Issue a parameter error for lakweslls(ilak) -! Subroutine: (1) read itmp -! (2) read new boundaries if itmp>0 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use SimModule, only: store_error - ! -- dummy - class(LakType),intent(inout) :: this - integer(I4B), intent(in) :: ilak - character (len=*), intent(in) :: keyword - character (len=*), intent(in) :: msg - ! -- local - character(len=LINELENGTH) :: errmsg - ! -- formats -! ------------------------------------------------------------------------------ - if (len(msg) == 0) then - write(errmsg,'(4x,a,1x,a,1x,a,1x,i6,1x,a)') & - '****ERROR.', keyword, ' for LAKE', ilak, 'has already been set.' - else - write(errmsg,'(4x,a,1x,a,1x,a,1x,i6,1x,a)') & - '****ERROR.', keyword, ' for LAKE', ilak, msg - end if - call store_error(errmsg) - ! -- return - return - end subroutine lak_set_attribute_error - - subroutine lak_options(this, option, found) -! ****************************************************************************** -! lak_options -- set options specific to LakType -! -! lak_options overrides BndType%bnd_options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: MAXCHARLEN, DZERO - use OpenSpecModule, only: access, form - use SimModule, only: ustop, store_error - use InputOutputModule, only: urword, getunit, openfile - ! -- dummy - class(LakType), intent(inout) :: this - character(len=*), intent(inout) :: option - logical, intent(inout) :: found - ! -- local - character(len=MAXCHARLEN) :: fname, keyword - real(DP) :: r - ! -- formats - character(len=*),parameter :: fmtlengthconv = & - "(4x, 'LENGTH CONVERSION VALUE (',g15.7,') SPECIFIED.')" - character(len=*),parameter :: fmttimeconv = & - "(4x, 'TIME CONVERSION VALUE (',g15.7,') SPECIFIED.')" - character(len=*),parameter :: fmtoutdmax = & - "(4x, 'MAXIMUM OUTLET WATER DEPTH (',g15.7,') SPECIFIED.')" - character(len=*),parameter :: fmtlakeopt = & - "(4x, 'LAKE ', a, ' VALUE (',g15.7,') SPECIFIED.')" - character(len=*),parameter :: fmtlakbin = & - "(4x, 'LAK ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" -! ------------------------------------------------------------------------------ - ! - select case (option) - case ('PRINT_STAGE') - this%iprhed = 1 - write(this%iout,'(4x,a)') trim(adjustl(this%text))// & - ' STAGES WILL BE PRINTED TO LISTING FILE.' - found = .true. - case('STAGE') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%istageout = getunit() - call openfile(this%istageout, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE') - write(this%iout,fmtlakbin) 'STAGE', fname, this%istageout - found = .true. - else - call store_error('OPTIONAL STAGE KEYWORD MUST BE FOLLOWED BY FILEOUT') - end if - case('BUDGET') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ibudgetout = getunit() - call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE') - write(this%iout,fmtlakbin) 'BUDGET', fname, this%ibudgetout - found = .true. - else - call store_error('OPTIONAL BUDGET KEYWORD MUST BE FOLLOWED BY FILEOUT') - end if - case('PACKAGE_CONVERGENCE') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ipakcsv = getunit() - call openfile(this%ipakcsv, this%iout, fname, 'CSV', & - filstat_opt='REPLACE') - write(this%iout,fmtlakbin) 'PACKAGE_CONVERGENCE', fname, this%ipakcsv - found = .true. - else - call store_error('OPTIONAL PACKAGE_CONVERGENCE KEYWORD MUST BE ' // & - 'FOLLOWED BY FILEOUT') - end if - case('MOVER') - this%imover = 1 - write(this%iout, '(4x,A)') 'MOVER OPTION ENABLED' - found = .true. - case('LENGTH_CONVERSION') - this%convlength = this%parser%GetDouble() - write(this%iout, fmtlengthconv) this%convlength - found = .true. - case('TIME_CONVERSION') - this%convtime = this%parser%GetDouble() - write(this%iout, fmttimeconv) this%convtime - found = .true. - case('SURFDEP') - r = this%parser%GetDouble() - if (r < DZERO) then - r = DZERO - end if - this%surfdep = r - write(this%iout, fmtlakeopt) 'SURFDEP', this%surfdep - found = .true. - ! - ! -- right now these 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_GROUNDWATER_HEAD_CONDUCTANCE') - call this%parser%DevOpt() - this%igwhcopt = 1 - write(this%iout, '(4x,a)') & - & 'CONDUCTANCE FOR HORIZONTAL CONNECTIONS WILL BE CALCULATED ' // & - & 'USING THE GROUNDWATER HEAD' - found = .true. - case('DEV_MAXIMUM_OUTLET_DEPTH') - call this%parser%DevOpt() - this%outdmax = this%parser%GetDouble() - write(this%iout, fmtoutdmax) this%outdmax - found = .true. - case('DEV_NO_FINAL_CHECK') - call this%parser%DevOpt() - this%iconvchk = 0 - write(this%iout, '(4x,a)') & - & 'A FINAL CONVERGENCE CHECK OF THE CHANGE IN LAKE STAGES ' // & - & 'WILL NOT BE MADE' - found = .true. - case('DEV_NO_FINAL_RESIDUAL_CHECK') - call this%parser%DevOpt() - this%iconvresidchk = 0 - write(this%iout, '(4x,a)') & - & 'A FINAL CONVERGENCE CHECK OF THE CHANGE IN LAKE RESIDUALS ' // & - & 'WILL NOT BE MADE' - found = .true. - case('DEV_MAXIMUM_PERCENT_DIFFERENCE') - call this%parser%DevOpt() - r = this%parser%GetDouble() - if (r < DZERO) then - r = DEM1 - end if - this%pdmax = r - write(this%iout, fmtlakeopt) 'MAXIMUM_PERCENT_DIFFERENCE', this%pdmax - found = .true. - case default - ! - ! -- No options found - found = .false. - end select - ! - ! -- return - return - end subroutine lak_options - - subroutine lak_ar(this) - ! ****************************************************************************** - ! lak_ar -- Allocate and Read - ! Subroutine: (1) create new-style package - ! (2) point bndobj to the new package - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - ! -- local - ! -- format - ! ------------------------------------------------------------------------------ - ! - call this%obs%obs_ar() - ! - ! -- Allocate arrays in LAK and in package superclass - call this%lak_allocate_arrays() - ! - ! -- read optional initial package parameters - call this%read_initial_attr() - ! - ! -- setup pakmvrobj - if (this%imover /= 0) then - allocate(this%pakmvrobj) - call this%pakmvrobj%ar(this%noutlets, this%nlakes, this%origin) - endif - ! - ! -- return - return - end subroutine lak_ar - - - subroutine lak_rp(this) -! ****************************************************************************** -! lak_rp -- Read and Prepare -! Subroutine: (1) read itmp -! (2) read new boundaries if itmp>0 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use TdisModule, only: kper, nper - use SimModule, only: ustop, store_error, count_errors - ! -- dummy - class(LakType),intent(inout) :: this - ! -- local - integer(I4B) :: ierr - integer(I4B) :: node, n - logical :: isfound, endOfBlock - character(len=LINELENGTH) :: line - character(len=LINELENGTH) :: errmsg - integer(I4B) :: itemno - integer(I4B) :: j - integer(I4B) :: isfirst - ! -- formats - character(len=*),parameter :: fmtblkerr = & - "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - character(len=*),parameter :: fmtlsp = & - "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" -! ------------------------------------------------------------------------------ - ! - ! -- initialize flags - isfirst = 1 - ! - ! -- set nbound to maxbound - this%nbound = this%maxbound - ! - ! -- Set ionper to the stress period number for which a new block of data - ! will be read. - if(this%inunit == 0) return - ! - ! -- get stress period data - if (this%ionper < kper) then - ! - ! -- get period block - call this%parser%GetBlock('PERIOD', isfound, ierr, & - supportOpenClose=.true.) - if(isfound) then - ! - ! -- read ionper and check for increasing period numbers - call this%read_check_ionper() - else - ! - ! -- PERIOD block not found - if (ierr < 0) then - ! -- End of file found; data applies for remainder of simulation. - this%ionper = nper + 1 - else - ! -- Found invalid block - write(errmsg, fmtblkerr) adjustl(trim(line)) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - endif - end if - ! - ! -- Read data if ionper == kper - if(this%ionper == kper) then - - this%check_attr = 1 - stressperiod: do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - if (isfirst /= 0) then - isfirst = 0 - if (this%iprpak /= 0) then - write(this%iout,'(/1x,a,1x,i6,/)') & - 'READING '//trim(adjustl(this%text))//' DATA FOR PERIOD', kper - write(this%iout,'(3x,a)') ' LAKE KEYWORD AND DATA' - write(this%iout,'(3x,78("-"))') - end if - end if - itemno = this%parser%GetInteger() - call this%parser%GetRemainingLine(line) - call this%lak_set_stressperiod(itemno, line) - end do stressperiod - - if (this%iprpak /= 0) then - write(this%iout,'(/1x,a,1x,i6,/)') & - 'END OF '//trim(adjustl(this%text))//' DATA FOR PERIOD', kper - end if - ! - else - write(this%iout,fmtlsp) trim(this%filtyp) - endif - ! - !write summary of lake stress period error messages - ierr = count_errors() - if (ierr > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- fill arrays - do n = 1, this%nlakes - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 - node = this%cellid(j) - this%nodelist(j) = node - - this%bound(1,j) = this%xnewpak(n) - - this%bound(2,j) = this%satcond(j) - - this%bound(3,j) = this%belev(j) - - end do - end do - ! - ! -- return - return - end subroutine lak_rp - - subroutine lak_ad(this) -! ****************************************************************************** -! lak_ad -- Add package connection to matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType) :: this - ! -- local - integer(I4B) :: n - integer(I4B) :: j, iaux, ii -! ------------------------------------------------------------------------------ - ! - ! -- Advance the time series - call this%TsManager%ad() - ! - ! -- update auxiliary variables by copying from the derived-type time - ! series variable into the bndpackage auxvar variable so that this - ! information is properly written to the GWF budget file - if (this%naux > 0) then - do n = 1, this%nlakes - do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1 - do iaux = 1, this%naux - ii = (n - 1) * this%naux + iaux - this%auxvar(iaux, j) = this%lauxvar(ii)%value - end do - end do - end do - end if - ! - ! -- copy xnew into xold and set xnewpak to stage%value for - ! constant stage lakes - do n = 1, this%nlakes - this%xoldpak(n) = this%xnewpak(n) - this%stageiter(n) = this%xnewpak(n) - if (this%iboundpak(n) < 0) then - this%xnewpak(n) = this%stage(n)%value - end if - this%seep0(n) = DZERO - end do - ! - ! -- pakmvrobj ad - if (this%imover == 1) then - call this%pakmvrobj%ad() - end if - ! - ! -- For each observation, push simulated value and corresponding - ! simulation time from "current" to "preceding" and reset - ! "current" value. - call this%obs%obs_ad() - ! - ! -- return - return - end subroutine lak_ad - - subroutine lak_cf(this, reset_mover) - ! ****************************************************************************** - ! lak_cf -- Formulate the HCOF and RHS terms - ! Subroutine: (1) skip if no lakes - ! (2) calculate hcof and rhs - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType) :: this - logical, intent(in), optional :: reset_mover - ! -- local - integer(I4B) :: j, n - integer(I4B) :: igwfnode - real(DP) :: hlak, blak - logical :: lrm - ! ------------------------------------------------------------------------------ - !! - !! -- Calculate lak conductance and update package RHS and HCOF - !call this%lak_cfupdate() - ! - ! -- save groundwater seepage for lake solution - do n = 1, this%nlakes - this%seep0(n) = this%seep(n) - end do - ! - ! -- save variables for convergence check - do n = 1, this%nlakes - this%s0(n) = this%xnewpak(n) - call this%lak_calculate_exchange(n, this%s0(n), this%qgwf0(n)) - end do - ! - ! -- pakmvrobj cf - lrm = .true. - if (present(reset_mover)) lrm = reset_mover - if(this%imover == 1 .and. lrm) then - call this%pakmvrobj%cf() - end if - ! - ! -- find highest active cell - do n = 1, this%nlakes - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 - ! -- skip horizontal connections - if (this%ictype(j) /= 0) then - cycle - end if - igwfnode = this%nodesontop(j) - if (this%ibound(igwfnode) == 0) then - call this%dis%highest_active(igwfnode, this%ibound) - end if - this%nodelist(j) = igwfnode - this%cellid(j) = igwfnode - end do - end do - ! - ! -- reset ibound for cells where lake stage is above the bottom - ! of the lake in the cell or the lake is inactive - only applied to - ! vertical connections - do n = 1, this%nlakes - ! - hlak = this%xnewpak(n) - ! - ! -- Go through lake connections - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 - ! - ! -- assign gwf node number - igwfnode = this%cellid(j) - ! - ! -- skip inactive or constant head GWF cells - if (this%ibound(igwfnode) < 1) then - cycle - end if - ! - ! -- skip horizontal connections - if (this%ictype(j) /= 0) then - cycle - end if - ! - ! -- skip embedded lakes - if (this%ictype(j) == 2 .or. this%ictype(j) == 3) then - cycle - end if - ! - ! -- Mark ibound for dry lakes; reset to 1 otherwise - blak = this%belev(j) - if (hlak > blak .or. this%iboundpak(n) == 0) then - this%ibound(igwfnode) = 10000 - else - this%ibound(igwfnode) = 1 - end if - end do - - end do - ! - ! -- Store the lake stage and cond in bound array for other - ! packages, such as the BUY package - call this%lak_bound_update() - ! - ! -- Return - return - end subroutine lak_cf - - subroutine lak_fc(this, rhs, ia, idxglo, amatsln) - ! ************************************************************************** - ! lak_fc -- Copy rhs and hcof into solution rhs and amat - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - ! -- dummy - class(LakType) :: this - real(DP), dimension(:), intent(inout) :: rhs - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln - ! -- local - integer(I4B) :: j, n - integer(I4B) :: igwfnode - integer(I4B) :: ipossymd -! -------------------------------------------------------------------------- - ! - ! -- pakmvrobj fc - if(this%imover == 1) then - call this%pakmvrobj%fc() - end if - ! - ! - ! -- make a stab at a solution - call this%lak_solve() - ! - ! -- add terms to the gwf matrix - do n = 1, this%nlakes - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 - igwfnode = this%cellid(j) - if (this%ibound(igwfnode) < 1) cycle - ipossymd = idxglo(ia(igwfnode)) - amatsln(ipossymd) = amatsln(ipossymd) + this%hcof(j) - rhs(igwfnode) = rhs(igwfnode) + this%rhs(j) - end do - end do - ! - ! -- return - return - end subroutine lak_fc - - subroutine lak_fn(this, rhs, ia, idxglo, amatsln) -! ************************************************************************** -! lak_fn -- Fill newton terms -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - ! -- dummy - class(LakType) :: this - real(DP), dimension(:), intent(inout) :: rhs - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln - ! -- local - integer(I4B) :: j, n - integer(I4B) :: ipos - integer(I4B) :: igwfnode - integer(I4B) :: idry - real(DP) :: hlak - real(DP) :: avail - real(DP) :: ra - real(DP) :: ro - real(DP) :: qinf - real(DP) :: ex - real(DP) :: head - real(DP) :: clak1 - real(DP) :: q - real(DP) :: q1 - real(DP) :: rterm - real(DP) :: drterm -! -------------------------------------------------------------------------- - do n = 1, this%nlakes - if (this%iboundpak(n) == 0) cycle - hlak = this%xnewpak(n) - call this%lak_calculate_available(n, hlak, avail, & - ra, ro, qinf, ex, this%delh) - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 - igwfnode = this%cellid(j) - ipos = ia(igwfnode) - head = this%xnew(igwfnode) - if (-this%hcof(j) > DZERO) then - if (this%ibound(igwfnode) > 0) then - ! -- estimate lake-aquifer exchange with perturbed groundwater head - ! exchange is relative to the lake - !avail = DEP20 - call this%lak_estimate_conn_exchange(2, n, j, idry, hlak, head+this%delh, q1, clak1, avail) - q1 = -q1 - ! -- calculate unperturbed lake-aquifer exchange - q = this%hcof(j) * head - this%rhs(j) - ! -- calculate rterm - rterm = this%hcof(j) * head - ! -- calculate derivative - drterm = (q1 - q) / this%delh - ! -- add terms to convert conductance formulation into - ! newton-raphson formulation - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + drterm - this%hcof(j) - rhs(igwfnode) = rhs(igwfnode) - rterm + drterm * head - end if - end if - end do - end do - - ! - ! -- return - return - end subroutine lak_fn - - subroutine lak_cc(this, kiter, iend, icnvgmod, cpak, dpak) -! ************************************************************************** -! lak_cc -- Final convergence check for package -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - use TdisModule, only: totim, kstp, kper, delt - ! -- dummy - class(LakType), intent(inout) :: this - integer(I4B), intent(in) :: kiter - integer(I4B), intent(in) :: iend - integer(I4B), intent(in) :: icnvgmod - character(len=LENPAKLOC), intent(inout) :: cpak - real(DP), intent(inout) :: dpak - ! -- local - character(len=LENPAKLOC) :: cloc - character(len=LINELENGTH) :: tag - integer(I4B) :: icheck - integer(I4B) :: ipakfail - integer(I4B) :: locdhmax - integer(I4B) :: locdgwfmax - integer(I4B) :: locdqoutmax - integer(I4B) :: ntabrows - integer(I4B) :: ntabcols - integer(I4B) :: n - real(DP) :: area - real(DP) :: gwf0 - real(DP) :: gwf - real(DP) :: dh - real(DP) :: dgwf - real(DP) :: hlak0 - real(DP) :: hlak - real(DP) :: qout0 - real(DP) :: qout - real(DP) :: dqout - real(DP) :: inf - real(DP) :: ra - real(DP) :: ro - real(DP) :: qinf - real(DP) :: ex - real(DP) :: dhmax - real(DP) :: dgwfmax - real(DP) :: dqoutmax - ! format -! -------------------------------------------------------------------------- - ! - ! -- initialize local variables - icheck = this%iconvchk - ipakfail = 0 - locdhmax = 0 - locdgwfmax = 0 - locdqoutmax = 0 - dhmax = DZERO - dgwfmax = DZERO - dqoutmax = DZERO - ! - ! -- if not saving package convergence data on check convergence if - ! the model is considered converged - if (this%ipakcsv == 0) then - if (icnvgmod == 0) then - icheck = 0 - end if - ! - ! -- saving package convergence data - else - ! - ! -- header for package csv - if (.not. associated(this%pakcsvtab)) then - ! - ! -- determine the number of columns and rows - ntabrows = 1 - ntabcols = 8 - if (this%noutlets > 0) then - ntabcols = ntabcols + 2 - end if - ! - ! -- setup table - call table_cr(this%pakcsvtab, this%name, '') - call this%pakcsvtab%table_df(ntabrows, ntabcols, this%ipakcsv, & - lineseparator=.FALSE., separator=',', & - finalize=.FALSE.) - ! - ! -- add columns to package csv - tag = 'totim' - call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'kper' - call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'kstp' - call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'nouter' - call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'dvmax' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - tag = 'dvmax_loc' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - tag = 'dgwfmax' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - tag = 'dgwfmax_loc' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - if (this%noutlets > 0) then - tag = 'dqoutmax' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - tag = 'dqoutmax_loc' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - end if - end if - end if - ! - ! -- perform package convergence check - if (icheck /= 0) then - final_check: do n = 1, this%nlakes - if (this%iboundpak(n) < 1) cycle - ! - ! -- set previous and current lake stage - hlak0 = this%s0(n) - hlak = this%xnewpak(n) - ! - ! -- stage difference - dh = hlak0 - hlak - ! - ! -- calculate surface area - call this%lak_calculate_sarea(n, hlak, area) - ! - ! -- change in gwf exchange - dgwf = DZERO - if (area > DZERO) then - gwf0 = this%qgwf0(n) - call this%lak_calculate_exchange(n, hlak, gwf) - dgwf = (gwf0 - gwf) * delt / area - end if - ! - ! -- change in outflows - dqout = DZERO - if (this%noutlets > 0) then - if (area > DZERO) then - call this%lak_calculate_available(n, hlak0, inf, ra, ro, qinf, ex) - call this%lak_calculate_outlet_outflow(n, hlak0, inf, qout0) - call this%lak_calculate_available(n, hlak, inf, ra, ro, qinf, ex) - call this%lak_calculate_outlet_outflow(n, hlak, inf, qout) - dqout = (qout0 - qout) * delt / area - end if - end if - ! - ! -- evaluate magnitude of differences - if (n == 1) then - locdhmax = n - dhmax = dh - locdgwfmax = n - dgwfmax = dgwf - locdqoutmax = n - dqoutmax = dqout - else - if (abs(dh) > abs(dhmax)) then - locdhmax = n - dhmax = dh - end if - if (abs(dgwf) > abs(dgwfmax)) then - locdgwfmax = n - dgwfmax = dgwf - end if - if (abs(dqout) > abs(dqoutmax)) then - locdqoutmax = n - dqoutmax = dqout - end if - end if - end do final_check - ! - ! -- set dpak and cpak - if (ABS(dhmax) > abs(dpak)) then - dpak = dhmax - write(cloc, "(a,'-(',i0,')-',a)") & - trim(this%name), locdhmax, 'stage' - cpak = trim(cloc) - end if - if (ABS(dgwfmax) > abs(dpak)) then - dpak = dgwfmax - write(cloc, "(a,'-(',i0,')-',a)") & - trim(this%name), locdhmax, 'gwf' - cpak = trim(cloc) - end if - if (this%noutlets > 0) then - if (ABS(dqoutmax) > abs(dpak)) then - dpak = dqoutmax - write(cloc, "(a,'-(',i0,')-',a)") & - trim(this%name), locdhmax, 'outlet' - cpak = trim(cloc) - end if - end if - ! - ! -- write convergence data to package csv - if (this%ipakcsv /= 0) then - ! - ! -- write the data - call this%pakcsvtab%add_term(totim) - call this%pakcsvtab%add_term(kper) - call this%pakcsvtab%add_term(kstp) - call this%pakcsvtab%add_term(kiter) - call this%pakcsvtab%add_term(dhmax) - call this%pakcsvtab%add_term(locdhmax) - call this%pakcsvtab%add_term(dgwfmax) - call this%pakcsvtab%add_term(locdgwfmax) - if (this%noutlets > 0) then - call this%pakcsvtab%add_term(dqoutmax) - call this%pakcsvtab%add_term(locdqoutmax) - end if - ! - ! -- finalize the package csv - if (iend == 1) then - call this%pakcsvtab%finalize_table() - end if - end if - end if - ! - ! -- return - return - end subroutine lak_cc - - subroutine lak_bd(this, x, idvfl, icbcfl, ibudfl, icbcun, iprobs, & - isuppress_output, model_budget, imap, iadv) -! ****************************************************************************** -! lak_bd -- Calculate Volumetric Budget for the lake -! Note that the compact budget will always be used. -! Subroutine: (1) Process each package entry -! (2) Write output -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: kstp, kper, delt, pertim, totim - use ConstantsModule, only: LENBOUNDNAME, DHNOFLO, DHDRY - use BudgetModule, only: BudgetType - use InputOutputModule, only: ulasav, ubdsv06 - ! -- dummy - class(LakType) :: this - real(DP),dimension(:),intent(in) :: x - integer(I4B), intent(in) :: idvfl - integer(I4B), intent(in) :: icbcfl - integer(I4B), intent(in) :: ibudfl - integer(I4B), intent(in) :: icbcun - integer(I4B), intent(in) :: iprobs - integer(I4B), intent(in) :: isuppress_output - type(BudgetType), intent(inout) :: model_budget - integer(I4B), dimension(:), optional, intent(in) :: imap - integer(I4B), optional, intent(in) :: iadv - ! -- local - integer(I4B) :: ibinun - real(DP) :: rrate - real(DP) :: chratin, chratout - ! -- for budget - integer(I4B) :: j, n - integer(I4B) :: igwfnode - real(DP) :: hlak, hgwf - real(DP) :: v0, v1 - real(DP) :: cond - !real(DP) :: blak - !real(DP) :: s - real(DP) :: d - real(DP) :: v - ! -- for observations - integer(I4B) :: iprobslocal - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- recalculate package HCOF and RHS terms with latest groundwater and - ! lak heads prior to calling base budget functionality - !call this%lak_cfupdate() - ! - ! -- update the lake hcof and rhs terms - call this%lak_solve(.false.) - ! - ! -- Suppress saving of simulated values; they - ! will be saved at end of this procedure. - iprobslocal = 0 - ! - ! -- call base functionality in bnd_bd - call this%BndType%bnd_bd(x, idvfl, icbcfl, ibudfl, icbcun, iprobslocal, & - isuppress_output, model_budget, this%imap, & - iadv=1) - ! - ! -- calculate several budget terms - chratin = DZERO - chratout = DZERO - do n = 1, this%nlakes - this%chterm(n) = DZERO - if (this%iboundpak(n) == 0) cycle - hlak = this%xnewpak(n) - call this%lak_calculate_vol(n, hlak, v1) - ! -- add budget terms for active lakes - if (this%iboundpak(n) /= 0) then - ! - ! -- rainfall - rrate = this%precip(n) - call this%lak_accumulate_chterm(n, rrate, chratin, chratout) - ! - ! -- evaporation - rrate = this%evap(n) - call this%lak_accumulate_chterm(n, rrate, chratin, chratout) - ! - ! -- runoff - rrate = this%runoff(n)%value - call this%lak_accumulate_chterm(n, rrate, chratin, chratout) - ! - ! -- inflow - rrate = this%inflow(n)%value - call this%lak_accumulate_chterm(n, rrate, chratin, chratout) - ! - ! -- withdrawals - rrate = this%withr(n) - call this%lak_accumulate_chterm(n, rrate, chratin, chratout) - ! - ! -- add lake storage changes - rrate = DZERO - if (this%iboundpak(n) > 0) then - if (this%gwfiss /= 1) then - call this%lak_calculate_vol(n, this%xoldpak(n), v0) - rrate = -(v1 - v0) / delt - call this%lak_accumulate_chterm(n, rrate, chratin, chratout) - end if - end if - this%qsto(n) = rrate - ! - ! -- add external outlets - call this%lak_get_external_outlet(n, rrate) - call this%lak_accumulate_chterm(n, rrate, chratin, chratout) - ! - ! -- add mover terms - if (this%imover == 1) then - if (this%iboundpak(n) /= 0) then - rrate = this%pakmvrobj%get_qfrommvr(n) - else - rrate = DZERO - end if - call this%lak_accumulate_chterm(n, rrate, chratin, chratout) - endif - end if - end do - ! - ! -- gwf flow and constant flow to lake - do n = 1, this%nlakes - if (this%iboundpak(n) == 0) cycle - rrate = DZERO - hlak = this%xnewpak(n) - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 - igwfnode = this%cellid(j) - hgwf = this%xnew(igwfnode) - call this%lak_calculate_conn_exchange(n, j, hlak, hgwf, rrate, cond) - !blak = this%belev(j) - !if (-this%hcof(j) > DZERO) then - ! if (hgwf >= blak) then - ! s = max(hlak, blak) - ! rrate = this%hcof(j) * (s - hgwf) - ! else - ! rrate = this%rhs(j) - ! end if - !else - ! rrate = this%rhs(j) - !end if - this%qleak(j) = rrate - call this%lak_accumulate_chterm(n, rrate, chratin, chratout) - end do - end do - ! - ! -- For continuous observations, save simulated values. - if (this%obs%npakobs > 0 .and. iprobs > 0) then - call this%lak_bd_obs() - endif - ! - ! -- set unit number for binary dependent variable output - ibinun = 0 - if(this%istageout /= 0) then - ibinun = this%istageout - end if - if(idvfl == 0) ibinun = 0 - if (isuppress_output /= 0) ibinun = 0 - ! - ! -- write lake binary output - if (ibinun > 0) then - do n = 1, this%nlakes - v = this%xnewpak(n) - d = v - this%lakebot(n) - if (this%iboundpak(n) == 0) then - v = DHNOFLO - else if (d <= DZERO) then - v = DHDRY - end if - this%dbuff(n) = v - end do - call ulasav(this%dbuff, ' STAGE', kstp, kper, pertim, totim, & - this%nlakes, 1, 1, ibinun) - end if - ! - ! -- fill the budget object - call this%lak_fill_budobj() - ! - ! -- write the flows from the budobj - ibinun = 0 - if(this%ibudgetout /= 0) then - ibinun = this%ibudgetout - end if - if(icbcfl == 0) ibinun = 0 - if (isuppress_output /= 0) ibinun = 0 - if (ibinun > 0) then - call this%budobj%save_flows(this%dis, ibinun, kstp, kper, delt, & - pertim, totim, this%iout) - end if - ! - ! -- return - return - end subroutine lak_bd - - subroutine lak_ot(this, kstp, kper, iout, ihedfl, ibudfl) - ! ************************************************************************** - ! lak_ot -- Output package budget - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - use InputOutputModule, only: UWWORD - ! -- dummy - class(LakType) :: this - integer(I4B),intent(in) :: kstp - integer(I4B),intent(in) :: kper - integer(I4B),intent(in) :: iout - integer(I4B),intent(in) :: ihedfl - integer(I4B),intent(in) :: ibudfl - ! -- locals - character(len=LINELENGTH) :: line, linesep - character(len=16) :: text - integer(I4B) :: n - integer(I4B) :: iloc - real(DP) :: q - ! format - 2000 FORMAT ( 1X, ///1X, A, A, A, ' PERIOD ', I6, ' STEP ', I8) - ! -------------------------------------------------------------------------- - ! - ! -- write lake stage - if (ihedfl /= 0 .and. this%iprhed /= 0) then - write(iout, 2000) 'LAKE (', trim(this%name), ') STAGE', kper, kstp - iloc = 1 - line = '' - if (this%inamedbound==1) then - call UWWORD(line, iloc, 16, TABUCSTRING, & - 'lake', n, q, ALIGNMENT=TABLEFT) - end if - call UWWORD(line, iloc, 6, TABUCSTRING, & - 'lake', n, q, ALIGNMENT=TABCENTER, SEP=' ') - call UWWORD(line, iloc, 11, TABUCSTRING, & - 'lake', n, q, ALIGNMENT=TABCENTER) - ! -- create line separator - linesep = repeat('-', iloc) - ! -- write first line - write(iout,'(1X,A)') linesep(1:iloc) - write(iout,'(1X,A)') line(1:iloc) - ! -- create second header line - iloc = 1 - line = '' - if (this%inamedbound==1) then - call UWWORD(line, iloc, 16, TABUCSTRING, & - 'name', n, q, ALIGNMENT=TABLEFT) - end if - call UWWORD(line, iloc, 6, TABUCSTRING, & - 'no.', n, q, ALIGNMENT=TABCENTER, SEP=' ') - call UWWORD(line, iloc, 11, TABUCSTRING, & - 'stage', n, q, ALIGNMENT=TABCENTER) - ! -- write second line - write(iout,'(1X,A)') line(1:iloc) - write(iout,'(1X,A)') linesep(1:iloc) - ! -- write data - do n = 1, this%nlakes - iloc = 1 - line = '' - if (this%inamedbound==1) then - call UWWORD(line, iloc, 16, TABUCSTRING, & - this%lakename(n), n, q, ALIGNMENT=TABLEFT) - end if - call UWWORD(line, iloc, 6, TABINTEGER, text, n, q, SEP=' ') - call UWWORD(line, iloc, 11, TABREAL, text, n, this%xnewpak(n)) - write(iout, '(1X,A)') line(1:iloc) - end do - end if - ! - ! -- Output lake flow table - if (ibudfl /= 0 .and. this%iprflow /= 0) then - call this%budobj%write_flowtable(this%dis) - end if - ! - ! -- Output lake budget - call this%budobj%write_budtable(kstp, kper, iout) - ! - ! -- return - return - end subroutine lak_ot - - subroutine lak_da(this) - ! ************************************************************************** - ! lak_da -- Deallocate objects - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(LakType) :: this - ! -- local - integer(I4B) :: n - integer(I4B) :: iconn - ! -- format - ! -------------------------------------------------------------------------- - ! - ! -- arrays - deallocate(this%lakename) - deallocate(this%status) - deallocate(this%clakbudget) - call mem_deallocate(this%dbuff) - deallocate(this%cauxcbc) - call mem_deallocate(this%qauxcbc) - call mem_deallocate(this%qleak) - call mem_deallocate(this%qsto) - ! - ! -- tables - do n = 1, this%nlakes - if (this%ntabrow(n) > 0) then - call mem_deallocate(this%laketables(n)%tabstage) - call mem_deallocate(this%laketables(n)%tabvolume) - call mem_deallocate(this%laketables(n)%tabsarea) - iconn = this%idxlakeconn(n) - if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then - call mem_deallocate(this%laketables(n)%tabwarea) - end if - end if - end do - if (this%ntables > 0) then - deallocate(this%laketables) - end if - ! - ! -- budobj - call this%budobj%budgetobject_da() - deallocate(this%budobj) - nullify(this%budobj) - ! - ! -- outlets - if (this%noutlets > 0) then - call mem_deallocate(this%lakein) - call mem_deallocate(this%lakeout) - call mem_deallocate(this%iouttype) - call mem_deallocate(this%outrate) - call mem_deallocate(this%outinvert) - call mem_deallocate(this%outwidth) - call mem_deallocate(this%outrough) - call mem_deallocate(this%outslope) - call mem_deallocate(this%simoutrate) - endif - ! - ! -- package csv table - if (this%ipakcsv > 0) then - call this%pakcsvtab%table_da() - deallocate(this%pakcsvtab) - nullify(this%pakcsvtab) - end if - ! - ! -- scalars - call mem_deallocate(this%iprhed) - call mem_deallocate(this%istageout) - call mem_deallocate(this%ibudgetout) - call mem_deallocate(this%ipakcsv) - call mem_deallocate(this%nlakes) - call mem_deallocate(this%noutlets) - call mem_deallocate(this%ntables) - call mem_deallocate(this%convlength) - call mem_deallocate(this%convtime) - call mem_deallocate(this%outdmax) - call mem_deallocate(this%igwhcopt) - call mem_deallocate(this%iconvchk) - call mem_deallocate(this%iconvresidchk) - call mem_deallocate(this%surfdep) - call mem_deallocate(this%delh) - call mem_deallocate(this%pdmax) - call mem_deallocate(this%check_attr) - call mem_deallocate(this%bditems) - call mem_deallocate(this%cbcauxitems) - ! - call mem_deallocate(this%nlakeconn) - call mem_deallocate(this%idxlakeconn) - call mem_deallocate(this%ntabrow) - call mem_deallocate(this%strt) - call mem_deallocate(this%laketop) - call mem_deallocate(this%lakebot) - call mem_deallocate(this%sareamax) - call mem_deallocate(this%stage) - call mem_deallocate(this%rainfall) - call mem_deallocate(this%evaporation) - call mem_deallocate(this%runoff) - call mem_deallocate(this%inflow) - call mem_deallocate(this%withdrawal) - call mem_deallocate(this%lauxvar) - call mem_deallocate(this%avail) - call mem_deallocate(this%lkgwsink) - call mem_deallocate(this%ncncvr) - call mem_deallocate(this%surfin) - call mem_deallocate(this%surfout) - call mem_deallocate(this%surfout1) - call mem_deallocate(this%precip) - call mem_deallocate(this%precip1) - call mem_deallocate(this%evap) - call mem_deallocate(this%evap1) - call mem_deallocate(this%evapo) - call mem_deallocate(this%withr) - call mem_deallocate(this%withr1) - call mem_deallocate(this%flwin) - call mem_deallocate(this%flwiter) - call mem_deallocate(this%flwiter1) - call mem_deallocate(this%seep) - call mem_deallocate(this%seep1) - call mem_deallocate(this%seep0) - call mem_deallocate(this%stageiter) - call mem_deallocate(this%chterm) - ! - ! -- lake boundary and stages - call mem_deallocate(this%iboundpak) - call mem_deallocate(this%xnewpak) - call mem_deallocate(this%xoldpak) - ! - ! -- lake iteration variables - call mem_deallocate(this%iseepc) - call mem_deallocate(this%idhc) - call mem_deallocate(this%en1) - call mem_deallocate(this%en2) - call mem_deallocate(this%r1) - call mem_deallocate(this%r2) - call mem_deallocate(this%dh0) - call mem_deallocate(this%s0) - call mem_deallocate(this%qgwf0) - ! - ! -- lake connection variables - call mem_deallocate(this%imap) - call mem_deallocate(this%cellid) - call mem_deallocate(this%nodesontop) - call mem_deallocate(this%ictype) - call mem_deallocate(this%bedleak) - call mem_deallocate(this%belev) - call mem_deallocate(this%telev) - call mem_deallocate(this%connlength) - call mem_deallocate(this%connwidth) - call mem_deallocate(this%sarea) - call mem_deallocate(this%warea) - call mem_deallocate(this%satcond) - call mem_deallocate(this%simcond) - call mem_deallocate(this%simlakgw) - ! - ! -- pointers to gwf variables - nullify(this%gwfiss) - ! - ! -- Parent object - call this%BndType%bnd_da() - ! - ! -- Return - return - end subroutine lak_da - - - subroutine define_listlabel(this) -! ****************************************************************************** -! define_listlabel -- Define the list heading that is written to iout when -! PRINT_INPUT option is used. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(LakType), intent(inout) :: this -! ------------------------------------------------------------------------------ - ! - ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' - else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif - ! - ! -- return - return - end subroutine define_listlabel - - - subroutine lak_set_pointers(this, neq, ibound, xnew, xold, flowja) -! ****************************************************************************** -! set_pointers -- Set pointers to model arrays and variables so that a package -! has access to these things. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(LakType) :: this - integer(I4B), pointer :: neq - integer(I4B), dimension(:), pointer, contiguous :: ibound - real(DP), dimension(:), pointer, contiguous :: xnew - real(DP), dimension(:), pointer, contiguous :: xold - real(DP), dimension(:), pointer, contiguous :: flowja - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- call base BndType set_pointers - call this%BndType%set_pointers(neq, ibound, xnew, xold, flowja) - ! - ! -- Set the LAK pointers - ! - ! -- set package pointers - !istart = this%dis%nodes + this%ioffset + 1 - !iend = istart + this%nlakes - 1 - !this%iboundpak => this%ibound(istart:iend) - !this%xnewpak => this%xnew(istart:iend) - ! - ! -- initialize xnewpak - !do n = 1, this%nlakes - ! this%xnewpak(n) = DEP20 - !end do - ! - ! -- return - end subroutine lak_set_pointers - - ! - ! -- Procedures related to observations (type-bound) - logical function lak_obs_supported(this) - ! ****************************************************************************** - ! lak_obs_supported - ! -- Return true because LAK package supports observations. - ! -- Overrides BndType%bnd_obs_supported() - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - ! ------------------------------------------------------------------------------ - class(LakType) :: this - lak_obs_supported = .true. - return - end function lak_obs_supported - - - subroutine lak_df_obs(this) - ! ****************************************************************************** - ! lak_df_obs (implements bnd_df_obs) - ! -- Store observation type supported by LAK package. - ! -- Overrides BndType%bnd_df_obs - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType) :: this - ! -- local - integer(I4B) :: indx - ! ------------------------------------------------------------------------------ - ! - ! -- Store obs type and assign procedure pointer - ! for stage observation type. - call this%obs%StoreObsType('stage', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for ext-inflow observation type. - call this%obs%StoreObsType('ext-inflow', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for outlet-inflow observation type. - call this%obs%StoreObsType('outlet-inflow', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for inflow observation type. - call this%obs%StoreObsType('inflow', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for from-mvr observation type. - call this%obs%StoreObsType('from-mvr', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for rainfall observation type. - call this%obs%StoreObsType('rainfall', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for runoff observation type. - call this%obs%StoreObsType('runoff', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for lak observation type. - call this%obs%StoreObsType('lak', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for evaporation observation type. - call this%obs%StoreObsType('evaporation', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for withdrawal observation type. - call this%obs%StoreObsType('withdrawal', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for ext-outflow observation type. - call this%obs%StoreObsType('ext-outflow', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for to-mvr observation type. - call this%obs%StoreObsType('to-mvr', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for storage observation type. - call this%obs%StoreObsType('storage', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for constant observation type. - call this%obs%StoreObsType('constant', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for outlet observation type. - call this%obs%StoreObsType('outlet', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for volume observation type. - call this%obs%StoreObsType('volume', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for surface-area observation type. - call this%obs%StoreObsType('surface-area', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for wetted-area observation type. - call this%obs%StoreObsType('wetted-area', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for conductance observation type. - call this%obs%StoreObsType('conductance', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID - ! - return - end subroutine lak_df_obs - - - subroutine lak_bd_obs(this) - ! ************************************************************************** - ! lak_bd_obs - ! -- Calculate observations this time step and call - ! ObsType%SaveOneSimval for each LakType observation. - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - ! -- dummy - class(LakType), intent(inout) :: this - ! -- local - integer(I4B) :: i, igwfnode, j, jj, n, nn - real(DP) :: hgwf, hlak, v, v2 - character(len=100) :: errmsg - type(ObserveType), pointer :: obsrv => null() - !--------------------------------------------------------------------------- - ! - ! Write simulated values for all LAK observations - if (this%obs%npakobs > 0) then - call this%obs%obs_bd_clear() - do i = 1, this%obs%npakobs - obsrv => this%obs%pakobs(i)%obsrv - nn = size(obsrv%indxbnds) - do j = 1, nn - v = DNODATA - jj = obsrv%indxbnds(j) - select case (obsrv%ObsTypeId) - case ('STAGE') - if (this%iboundpak(jj) /= 0) then - v = this%xnewpak(jj) - end if - case ('EXT-INFLOW') - if (this%iboundpak(jj) /= 0) then - call this%lak_calculate_inflow(jj, v) - end if - case ('OUTLET-INFLOW') - if (this%iboundpak(jj) /= 0) then - call this%lak_calculate_outlet_inflow(jj, v) - end if - case ('INFLOW') - if (this%iboundpak(jj) /= 0) then - call this%lak_calculate_inflow(jj, v) - call this%lak_calculate_outlet_inflow(jj, v2) - v = v + v2 - end if - case ('FROM-MVR') - if (this%iboundpak(jj) /= 0) then - if (this%imover == 1) then - v = this%pakmvrobj%get_qfrommvr(jj) - end if - end if - case ('RAINFALL') - if (this%iboundpak(jj) /= 0) then - v = this%precip(jj) - end if - case ('RUNOFF') - if (this%iboundpak(jj) /= 0) then - v = this%runoff(jj)%value - end if - case ('LAK') - n = this%imap(jj) - if (this%iboundpak(n) /= 0) then - igwfnode = this%cellid(jj) - hgwf = this%xnew(igwfnode) - if (this%hcof(jj) /= DZERO) then - v = -(this%hcof(jj) * (this%xnewpak(n) - hgwf)) - else - v = -this%rhs(jj) - end if - end if - case ('EVAPORATION') - if (this%iboundpak(jj) /= 0) then - v = this%evap(jj) - end if - case ('WITHDRAWAL') - if (this%iboundpak(jj) /= 0) then - v = this%withr(jj) - end if - case ('EXT-OUTFLOW') - n = this%lakein(jj) - if (this%iboundpak(n) /= 0) then - if (this%lakeout(jj) == 0) then - v = this%simoutrate(jj) - if (v < DZERO) then - if (this%imover == 1) then - v = v + this%pakmvrobj%get_qtomvr(jj) - end if - end if - end if - end if - case ('TO-MVR') - n = this%lakein(jj) - if (this%iboundpak(n) /= 0) then - if (this%imover == 1) then - v = this%pakmvrobj%get_qtomvr(jj) - if (v > DZERO) then - v = -v - end if - end if - end if - case ('STORAGE') - if (this%iboundpak(jj) /= 0) then - v = this%qsto(jj) - end if - case ('CONSTANT') - if (this%iboundpak(jj) /= 0) then - v = this%chterm(jj) - end if - case ('OUTLET') - n = this%lakein(jj) - if (this%iboundpak(jj) /= 0) then - v = this%simoutrate(jj) - !if (this%imover == 1) then - ! v = v + this%pakmvrobj%get_qtomvr(jj) - !end if - end if - case ('VOLUME') - if (this%iboundpak(jj) /= 0) then - call this%lak_calculate_vol(jj, this%xnewpak(jj), v) - end if - case ('SURFACE-AREA') - if (this%iboundpak(jj) /= 0) then - hlak = this%xnewpak(jj) - call this%lak_calculate_sarea(jj, hlak, v) - end if - case ('WETTED-AREA') - n = this%imap(jj) - if (this%iboundpak(n) /= 0) then - hlak = this%xnewpak(n) - nn = size(obsrv%indxbnds) - igwfnode = this%cellid(jj) - hgwf = this%xnew(igwfnode) - call this%lak_calculate_conn_warea(n, jj, hlak, hgwf, v) - end if - case ('CONDUCTANCE') - n = this%imap(jj) - if (this%iboundpak(n) /= 0) then - hlak = this%xnewpak(n) - nn = size(obsrv%indxbnds) - igwfnode = this%cellid(jj) - hgwf = this%xnew(igwfnode) - call this%lak_calculate_conn_conductance(n, jj, hlak, hgwf, v) - end if - case default - errmsg = 'Error: Unrecognized observation type: ' // & - trim(obsrv%ObsTypeId) - call store_error(errmsg) - call ustop() - end select - call this%obs%SaveOneSimval(obsrv, v) - end do - end do - end if - ! - return - end subroutine lak_bd_obs - - - subroutine lak_rp_obs(this) - ! -- dummy - class(LakType), intent(inout) :: this - ! -- local - integer(I4B) :: i, j, n, nn1, nn2 - integer(I4B) :: jj - character(len=200) :: ermsg - character(len=LENBOUNDNAME) :: bname - logical :: jfound - class(ObserveType), pointer :: obsrv => null() - ! -------------------------------------------------------------------------- - ! -- formats -10 format('Error: Boundary "',a,'" for observation "',a, & - '" is invalid in package "',a,'"') - ! - do i = 1, this%obs%npakobs - obsrv => this%obs%pakobs(i)%obsrv - ! - ! -- indxbnds needs to be deallocated and reallocated (using - ! ExpandArray) each stress period because list of boundaries - ! can change each stress period. - if (allocated(obsrv%indxbnds)) then - deallocate(obsrv%indxbnds) - end if - ! - ! -- get node number 1 - nn1 = obsrv%NodeNumber - if (nn1 == NAMEDBOUNDFLAG) then - bname = obsrv%FeatureName - if (bname /= '') then - ! -- Observation lake is based on a boundary name. - ! Iterate through all lakes to identify and store - ! corresponding index in bound array. - jfound = .false. - if (obsrv%ObsTypeId=='LAK' .or. & - obsrv%ObsTypeId=='CONDUCTANCE' .or. & - obsrv%ObsTypeId=='WETTED-AREA') then - do j = 1, this%nlakes - do jj = this%idxlakeconn(j), this%idxlakeconn(j+1) - 1 - if (this%boundname(jj) == bname) then - jfound = .true. - call ExpandArray(obsrv%indxbnds) - n = size(obsrv%indxbnds) - obsrv%indxbnds(n) = jj - end if - end do - end do - else if (obsrv%ObsTypeId=='EXT-OUTFLOW' .or. & - obsrv%ObsTypeId=='TO-MVR' .or. & - obsrv%ObsTypeId=='OUTLET') then - do j = 1, this%noutlets - jj = this%lakein(j) - if (this%lakename(jj) == bname) then - jfound = .true. - call ExpandArray(obsrv%indxbnds) - n = size(obsrv%indxbnds) - obsrv%indxbnds(n) = j - end if - end do - else - do j = 1, this%nlakes - if (this%lakename(j) == bname) then - jfound = .true. - call ExpandArray(obsrv%indxbnds) - n = size(obsrv%indxbnds) - obsrv%indxbnds(n) = j - end if - end do - end if - if (.not. jfound) then - write(ermsg,10)trim(bname), trim(obsrv%Name), trim(this%name) - call store_error(ermsg) - end if - end if - else - call ExpandArray(obsrv%indxbnds) - n = size(obsrv%indxbnds) - if (n == 1) then - if (obsrv%ObsTypeId=='LAK' .or. & - obsrv%ObsTypeId=='CONDUCTANCE' .or. & - obsrv%ObsTypeId=='WETTED-AREA') then - nn2 = obsrv%NodeNumber2 - j = this%idxlakeconn(nn1) + nn2 - 1 - obsrv%indxbnds(1) = j - else - obsrv%indxbnds(1) = nn1 - end if - else - ermsg = 'Programming error in lak_rp_obs' - call store_error(ermsg) - endif - end if - ! - ! -- catch non-cumulative observation assigned to observation defined - ! by a boundname that is assigned to more than one element - if (obsrv%ObsTypeId == 'STAGE') then - n = size(obsrv%indxbnds) - if (n > 1) then - write(ermsg, '(4x,a,4(1x,a))') & - 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & - 'for observation', trim(adjustl(obsrv%Name)), & - ' must be assigned to a lake with a unique boundname.' - call store_error(ermsg) - end if - end if - ! - ! -- check that index values are valid - if (obsrv%ObsTypeId=='TO-MVR' .or. & - obsrv%ObsTypeId=='EXT-OUTFLOW' .or. & - obsrv%ObsTypeId=='OUTLET') then - do j = 1, size(obsrv%indxbnds) - nn1 = obsrv%indxbnds(j) - if (nn1 < 1 .or. nn1 > this%noutlets) then - write(ermsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & - 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & - ' outlet must be > 0 and <=', this%noutlets, & - '(specified value is ', nn1, ')' - call store_error(ermsg) - end if - end do - else if (obsrv%ObsTypeId=='LAK' .or. & - obsrv%ObsTypeId=='CONDUCTANCE' .or. & - obsrv%ObsTypeId=='WETTED-AREA') then - do j = 1, size(obsrv%indxbnds) - nn1 = obsrv%indxbnds(j) - if (nn1 < 1 .or. nn1 > this%maxbound) then - write(ermsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & - 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & - ' lake connection number must be > 0 and <=', this%maxbound, & - '(specified value is ', nn1, ')' - call store_error(ermsg) - end if - end do - else - do j = 1, size(obsrv%indxbnds) - nn1 = obsrv%indxbnds(j) - if (nn1 < 1 .or. nn1 > this%nlakes) then - write(ermsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & - 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & - ' lake must be > 0 and <=', this%nlakes, & - '(specified value is ', nn1, ')' - call store_error(ermsg) - end if - end do - end if - end do - if (count_errors() > 0) call ustop() - ! - return - end subroutine lak_rp_obs - - - ! - ! -- Procedures related to observations (NOT type-bound) - subroutine lak_process_obsID(obsrv, dis, inunitobs, iout) - ! -- This procedure is pointed to by ObsDataType%ProcesssIdPtr. It processes - ! the ID string of an observation definition for LAK package observations. - ! -- dummy - type(ObserveType), intent(inout) :: obsrv - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: inunitobs - integer(I4B), intent(in) :: iout - ! -- local - integer(I4B) :: nn1, nn2 - integer(I4B) :: icol, istart, istop - character(len=LINELENGTH) :: strng - character(len=LENBOUNDNAME) :: bndname - ! formats - ! - strng = obsrv%IDstring - ! -- Extract lake number from strng and store it. - ! If 1st item is not an integer(I4B), it should be a - ! lake name--deal with it. - icol = 1 - ! -- get lake number or boundary name - call extract_idnum_or_bndname(strng, icol, istart, istop, nn1, bndname) - if (nn1 == NAMEDBOUNDFLAG) then - obsrv%FeatureName = bndname - else - if (obsrv%ObsTypeId=='LAK' .or. obsrv%ObsTypeId=='CONDUCTANCE' .or. & - obsrv%ObsTypeId=='WETTED-AREA') then - call extract_idnum_or_bndname(strng, icol, istart, istop, nn2, bndname) - if (nn2 == NAMEDBOUNDFLAG) then - obsrv%FeatureName = bndname - ! -- reset nn1 - nn1 = nn2 - else - obsrv%NodeNumber2 = nn2 - end if - !! -- store connection number (NodeNumber2) - !obsrv%NodeNumber2 = nn2 - endif - endif - ! -- store lake number (NodeNumber) - obsrv%NodeNumber = nn1 - ! - return - end subroutine lak_process_obsID - - ! - ! -- private LAK methods - ! - subroutine lak_accumulate_chterm(this, ilak, rrate, chratin, chratout) - ! ************************************************************************** - ! lak_accumulate_chterm -- Accumulate constant head terms for budget. - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - ! -- dummy - class(LakType) :: this - integer(I4B), intent(in) :: ilak - real(DP), intent(in) :: rrate - real(DP), intent(inout) :: chratin - real(DP), intent(inout) :: chratout - ! -- locals - real(DP) :: q - ! format - ! code - if (this%iboundpak(ilak) < 0) then - q = -rrate - this%chterm(ilak) = this%chterm(ilak) + q - ! - ! -- See if flow is into lake or out of lake. - if (q < DZERO) then - ! - ! -- Flow is out of lake subtract rate from ratout. - chratout = chratout - q - else - ! - ! -- Flow is into lake; add rate to ratin. - chratin = chratin + q - end if - end if - ! -- return - return - end subroutine lak_accumulate_chterm - - - subroutine lak_cfupdate(this) - ! ****************************************************************************** - ! lak_cfupdate -- Update LAK satcond and package rhs and hcof - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - class(LakType), intent(inout) :: this - integer(I4B) :: j, n, node - real(DP) :: hlak, head, clak, blak - ! ------------------------------------------------------------------------------ - ! - ! -- Return if no lak lakes - if(this%nbound.eq.0) return - ! - ! -- Calculate hcof and rhs for each lak entry - do n = 1, this%nlakes - hlak = this%xnewpak(n) - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 - node = this%cellid(j) - head = this%xnew(node) - - this%hcof(j) = DZERO - this%rhs(j) = DZERO - ! - ! -- set bound, hcof, and rhs components - call this%lak_calculate_conn_conductance(n, j, hlak, head, clak) - this%simcond(j) = clak - - this%bound(2,j) = clak - - blak = this%bound(3,j) - - this%hcof(j) = -clak - ! - ! -- fill rhs - if (hlak < blak) then - this%rhs(j) = -clak * blak - else - this%rhs(j) = -clak * hlak - end if - end do - end do - ! - ! -- Return - return - end subroutine lak_cfupdate - - subroutine lak_bound_update(this) - ! ****************************************************************************** - ! lak_bound_update -- store the lake head and connection conductance in the - ! bound array - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - class(LakType), intent(inout) :: this - integer(I4B) :: j, n, node - real(DP) :: hlak, head, clak - ! ------------------------------------------------------------------------------ - ! - ! -- Return if no lak lakes - if (this%nbound == 0) return - ! - ! -- Calculate hcof and rhs for each lak entry - do n = 1, this%nlakes - hlak = this%xnewpak(n) - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 - node = this%cellid(j) - head = this%xnew(node) - call this%lak_calculate_conn_conductance(n, j, hlak, head, clak) - this%bound(1, j) = hlak - this%bound(2, j) = clak - end do - end do - ! - ! -- Return - return - end subroutine lak_bound_update - - subroutine lak_solve(this, update) - ! ************************************************************************** - ! lak_solve -- Solve for lake stage - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - use TdisModule,only:delt - logical, intent(in), optional :: update - ! -- dummy - class(LakType), intent(inout) :: this - ! -- local - logical :: lupdate - integer(I4B) :: i - integer(I4B) :: j - integer(I4B) :: n - integer(I4B) :: iicnvg - integer(I4B) :: iter - integer(I4B) :: maxiter - integer(I4B) :: ncnv - integer(I4B) :: idry - integer(I4B) :: igwfnode - integer(I4B) :: ibflg - integer(I4B) :: idhp - real(DP) :: hlak - real(DP) :: hlak0 - real(DP) :: v0 - real(DP) :: v1 - real(DP) :: head - real(DP) :: ra - real(DP) :: ro - real(DP) :: qinf - real(DP) :: ex - real(DP) :: ev - real(DP) :: outinf - real(DP) :: s - real(DP) :: qlakgw - real(DP) :: qlakgw1 - real(DP) :: clak - real(DP) :: clak1 - real(DP) :: avail - real(DP) :: resid - real(DP) :: resid1 - real(DP) :: residb - real(DP) :: wr - real(DP) :: derv - real(DP) :: dh - real(DP) :: adh - real(DP) :: adh0 - real(DP) :: delh - real(DP) :: ts -! -------------------------------------------------------------------------- - ! - ! -- set lupdate - if (present(update)) then - lupdate = update - else - lupdate = .true. - end if - ! - ! -- initialize - avail = DZERO - delh = this%delh - ! - ! -- initialize - do n = 1, this%nlakes - this%ncncvr(n) = 0 - this%surfin(n) = DZERO - this%surfout(n) = DZERO - this%surfout1(n) = DZERO - if (this%xnewpak(n) < this%lakebot(n)) then - this%xnewpak(n) = this%lakebot(n) - end if - if (this%gwfiss /= 0) then - this%xoldpak(n) = this%xnewpak(n) - end if - ! -- lake iteration items - this%iseepc(n) = 0 - this%idhc(n) = 0 - this%en1(n) = this%lakebot(n) - call this%lak_calculate_residual(n, this%en1(n), this%r1(n)) - this%en2(n) = this%laketop(n) - call this%lak_calculate_residual(n, this%en2(n), this%r2(n)) - end do - do n = 1, this%noutlets - this%simoutrate(n) = DZERO - end do - ! - ! -- sum up inflows from mover inflows - do n = 1, this%nlakes - call this%lak_calculate_outlet_inflow(n, this%surfin(n)) - end do - ! - ! -- sum up overland runoff, inflows, and external flows into lake - ! (includes lake volume) - do n = 1, this%nlakes - hlak0 = this%xoldpak(n) - call this%lak_calculate_runoff(n, ro) - call this%lak_calculate_inflow(n, qinf) - call this%lak_calculate_external(n, ex) - ! -- - call this%lak_calculate_vol(n, hlak0, v0) - this%flwin(n) = this%surfin(n) + ro + qinf + ex + v0 / delt - end do - ! - ! -- sum up inflows from upstream outlets - do n = 1, this%nlakes - call this%lak_calculate_outlet_inflow(n, outinf) - this%flwin(n) = this%flwin(n) + outinf - end do - - iicnvg = 0 - maxiter = 150 - - ! -- outer loop - converge: do iter = 1, maxiter - ncnv = 0 - do n = 1, this%nlakes - if (this%ncncvr(n) == 0) ncnv = 1 - end do - if (iter == maxiter) ncnv = 0 - if (ncnv == 0) iicnvg = 1 - - ! -- initialize variables - do n = 1, this%nlakes - this%evap(n) = DZERO - this%precip(n) = DZERO - this%precip1(n) = DZERO - this%seep(n) = DZERO - this%seep1(n) = DZERO - this%evap(n) = DZERO - this%evap1(n) = DZERO - this%evapo(n) = DZERO - this%withr(n) = DZERO - this%withr1(n) = DZERO - this%flwiter(n) = this%flwin(n) - this%flwiter1(n) = this%flwin(n) - if (this%gwfiss /= 0) then - this%flwiter(n) = DEP20 !1.D+10 - this%flwiter1(n) = DEP20 !1.D+10 - end if - end do - - estseep: do i = 1, 2 - lakseep: do n = 1, this%nlakes - ! -- skip inactive lakes - if (this%iboundpak(n) == 0) then - cycle lakseep - end if - ! - set xoldpak to xnewpak if steady-state - if (this%gwfiss /= 0) then - this%xoldpak(n) = this%xnewpak(n) - end if - hlak = this%xnewpak(n) - calcconnseep: do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 - igwfnode = this%cellid(j) - head = this%xnew(igwfnode) - if (this%ncncvr(n) /= 2) then - if (this%ibound(igwfnode) > 0) then - call this%lak_estimate_conn_exchange(i, n, j, idry, hlak, head, qlakgw, clak, this%flwiter(n)) - call this%lak_estimate_conn_exchange(i, n, j, idry, hlak+delh, head, qlakgw1, clak1, this%flwiter1(n)) - !write(1051,'(2(i10),4(g15.7))') j, idry, clak, hlak, head, qlakgw - ! - ! -- add to gwf matrix - if (ncnv == 0 .and. i == 2) then - if (j == this%maxbound) then - this%ncncvr(n) = 2 - end if - if (idry /= 1) then - if (head >= this%belev(j)) then - s = max(hlak, this%belev(j)) - this%hcof(j) = -clak - this%rhs(j) = -clak * s - else - this%hcof(j) = DZERO - this%rhs(j) = qlakgw - end if - else - this%hcof(j) = DZERO - this%rhs(j) = qlakgw - end if - end if - if (i == 2) then - this%seep(n) = this%seep(n) + qlakgw - this%seep1(n) = this%seep1(n) + qlakgw1 - end if - end if - end if - - end do calcconnseep - end do lakseep - end do estseep - - laklevel: do n = 1, this%nlakes - ibflg = 0 - hlak = this%xnewpak(n) - if (iter < maxiter) then - this%stageiter(n) = this%xnewpak(n) - end if - call this%lak_calculate_rainfall(n, hlak, ra) - this%precip(n) = ra - this%flwiter(n) = this%flwiter(n) + ra - call this%lak_calculate_rainfall(n, hlak+delh, ra) - this%precip1(n) = ra - this%flwiter1(n) = this%flwiter1(n) + ra - ! - ! -- limit withdrawals to lake inflows and lake storage - call this%lak_calculate_withdrawal(n, this%flwiter(n), wr) - this%withr = wr - call this%lak_calculate_withdrawal(n, this%flwiter1(n), wr) - this%withr1 = wr - ! - ! -- limit evaporation to lake inflows and lake storage - call this%lak_calculate_evaporation(n, hlak, this%flwiter(n), ev) - this%evap(n) = ev - call this%lak_calculate_evaporation(n, hlak+delh, this%flwiter1(n), ev) - this%evap1(n) = ev - ! - ! -- no outlet flow if evaporation consumes all water - call this%lak_calculate_outlet_outflow(n, hlak+delh, & - this%flwiter1(n), & - this%surfout1(n)) - call this%lak_calculate_outlet_outflow(n, hlak, this%flwiter(n), & - this%surfout(n)) - ! - ! -- update the surface inflow values - call this%lak_calculate_outlet_inflow(n, this%surfin(n)) - ! - ! - if (ncnv == 1) then - if (this%iboundpak(n) > 0 .and. lupdate .eqv. .true.) then - ! - ! -- recalculate flwin - hlak0 = this%xoldpak(n) - call this%lak_calculate_vol(n, hlak0, v0) - call this%lak_calculate_runoff(n, ro) - call this%lak_calculate_inflow(n, qinf) - call this%lak_calculate_external(n, ex) - this%flwin(n) = this%surfin(n) + ro + qinf + ex + v0 / delt - ! - ! -- compute new lake stage using Newton's method - resid = this%precip(n) + this%evap(n) + this%withr(n) + ro + & - qinf + ex + this%surfin(n) + & - this%surfout(n) + this%seep(n) - resid1 = this%precip1(n) + this%evap1(n) + this%withr1(n) + ro + & - qinf + ex + this%surfin(n) + & - this%surfout1(n) + this%seep1(n) - - !call this%lak_calculate_residual(n, this%xnewpak(n), residb) - ! - ! -- add storage changes for transient stress periods - hlak = this%xnewpak(n) - if (this%gwfiss /= 1) then - call this%lak_calculate_vol(n, hlak, v1) - resid = resid + (v0 - v1) / delt - call this%lak_calculate_vol(n, hlak+delh, v1) - resid1 = resid1 + (v0 - v1) / delt - !else - ! call this%lak_calculate_vol(n, hlak, v1) - ! resid = resid - v1 / delt - ! call this%lak_calculate_vol(n, hlak+delh, v1) - ! resid1 = resid1 - v1 / delt - end if - - ! - ! -- determine the derivative and the stage change - if (ABS(resid1-resid) > DZERO) then - derv = (resid1 - resid) / delh - dh = DZERO - if (ABS(derv) > DPREC) then - dh = resid / derv - end if - else - if (resid < DZERO) then - resid = DZERO - end if - call this%lak_vol2stage(n, resid, dh) - dh = hlak - dh - this%ncncvr(n) = 1 - end if - ! - ! -- determine if the updated stage is outside the endpoints - ts = hlak-dh - if (iter == 1) this%dh0(n) = dh - adh = ABS(dh) - adh0 = ABS(this%dh0(n)) - if ((ts >= this%en2(n)) .or. (ts <= this%en1(n))) then - ! -- use bisection if dh is increasing or updated stage is below the - ! bottom of the lake - if ((adh > adh0) .or. (ts-this%lakebot(n)) < DPREC) then - ibflg = 1 - ts = DHALF * (this%en1(n) + this%en2(n)) - call this%lak_calculate_residual(n, ts, residb) - dh = hlak - ts - end if - end if - ! - ! -- set seep0 on the first lake iteration - if (iter == 1) then - this%seep0(n) = this%seep(n) - end if - ! - ! -- check for slow convergence - if (this%seep(n)*this%seep0(n) < DPREC) then - this%iseepc(n) = this%iseepc(n) + 1 - else - this%iseepc(n) = 0 - end if - ! -- determine of convergence is slow and oscillating - idhp = 0 - if (dh*this%dh0(n) < DPREC) idhp = 1 - ! -- determine if stage change is increasing - adh = ABS(dh) - if (adh > adh0) idhp = 1 - ! -- increment idhc convergence flag - if (idhp == 1) then - this%idhc(n) = this%idhc(n) + 1 - end if - ! - ! -- switch to bisection when the Newton-Raphson method oscillates - ! or when convergence is slow - if (ibflg == 1) then - if (this%iseepc(n) > 7 .or. this%idhc(n) > 12) then - ibflg = 1 - ts = DHALF * (this%en1(n) + this%en2(n)) - call this%lak_calculate_residual(n, ts, residb) - dh = hlak - ts - end if - end if - if (ibflg == 1) then - ! -- change end points - ! -- root is between r1 and residb - if (this%r1(n)*residb < DZERO) then - this%en2(n) = ts - this%r2(n) = residb - ! -- root is between fp and f2 - else - this%en1(n) = ts - this%r1(n) = residb - end if - end if - else - dh = DZERO - end if - ! - ! -- update lake stage - hlak = hlak - dh - if (hlak < this%lakebot(n)) then - hlak = this%lakebot(n) - end if - if (ABS(dh) < delh) then - this%ncncvr(n) = 1 - end if - this%xnewpak(n) = hlak - ! - ! -- save iterates for lake - this%seep0(n) = this%seep(n) - this%dh0(n) = dh - end if - end do laklevel - - if (iicnvg == 1) exit converge - - end do converge - ! - ! -- Mover terms: store outflow after diversion loss - ! as qformvr and reduce outflow (qd) - ! by how much was actually sent to the mover - if (this%imover == 1) then - do n = 1, this%noutlets - call this%pakmvrobj%accumulate_qformvr(n, -this%simoutrate(n)) - end do - end if - ! - ! -- return - return - end subroutine lak_solve - - - subroutine lak_calculate_available(this, n, hlak, avail, & - ra, ro, qinf, ex, headp) - ! ************************************************************************** - ! lak_calculate_available -- Calculate the available volumetric rate for - ! a lake given a passed stage - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - use TdisModule,only:delt - ! -- dummy - class(LakType), intent(inout) :: this - integer(I4B), intent(in) :: n - real(DP), intent(in) :: hlak - real(DP), intent(inout) :: avail - real(DP), intent(inout) :: ra - real(DP), intent(inout) :: ro - real(DP), intent(inout) :: qinf - real(DP), intent(inout) :: ex - real(DP), intent(in), optional :: headp - ! -- local - integer(I4B) :: j - integer(I4B) :: idry - integer(I4B) :: igwfnode - real(DP) :: hp - real(DP) :: head - real(DP) :: qlakgw - real(DP) :: clak - real(DP) :: v0 - ! code - ! - ! -- set hp - if (present(headp)) then - hp = headp - else - hp = DZERO - end if - ! - ! -- initialize - avail = DZERO - ! - ! -- calculate the aquifer sources to the lake - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 - igwfnode = this%cellid(j) - if (this%ibound(igwfnode) == 0) cycle - head = this%xnew(igwfnode) + hp - call this%lak_estimate_conn_exchange(1, n, j, idry, hlak, head, qlakgw, clak, avail) - end do - ! - ! -- add rainfall - call this%lak_calculate_rainfall(n, hlak, ra) - avail = avail + ra - ! - ! -- calculate runoff - call this%lak_calculate_runoff(n, ro) - avail = avail + ro - ! - ! -- calculate inflow - call this%lak_calculate_inflow(n, qinf) - avail = avail + qinf - ! - ! -- calculate external flow terms - call this%lak_calculate_external(n, ex) - avail = avail + ex - ! - ! -- calculate volume available in storage - call this%lak_calculate_vol(n, this%xoldpak(n), v0) - avail = avail + v0 / delt - ! - ! -- return - return - end subroutine lak_calculate_available - - - subroutine lak_calculate_residual(this, n, hlak, resid, headp) - ! ************************************************************************** - ! lak_calculate_residual -- Calculate the residual for a lake given a - ! passed stage - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - use TdisModule,only:delt - ! -- dummy - class(LakType), intent(inout) :: this - integer(I4B), intent(in) :: n - real(DP), intent(in) :: hlak - real(DP), intent(inout) :: resid - real(DP), intent(in), optional :: headp - ! -- local - integer(I4B) :: j - integer(I4B) :: idry - integer(I4B) :: igwfnode - real(DP) :: hp - real(DP) :: avail - real(DP) :: head - real(DP) :: ra - real(DP) :: ro - real(DP) :: qinf - real(DP) :: ex - real(DP) :: ev - real(DP) :: wr - real(DP) :: sout - real(DP) :: sin - real(DP) :: qlakgw - real(DP) :: clak - real(DP) :: seep - real(DP) :: hlak0 - real(DP) :: v0 - real(DP) :: v1 - ! - ! -- code - ! - ! -- set hp - if (present(headp)) then - hp = headp - else - hp = DZERO - end if - ! - ! -- initialize - resid = DZERO - avail = DZERO - seep = DZERO - ! - ! -- calculate the available water - call this%lak_calculate_available(n, hlak, avail, & - ra, ro, qinf, ex, hp) - ! - ! -- calculate groundwater seepage - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 - igwfnode = this%cellid(j) - if (this%ibound(igwfnode) == 0) cycle - head = this%xnew(igwfnode) + hp - call this%lak_estimate_conn_exchange(2, n, j, idry, hlak, head, qlakgw, clak, avail) - seep = seep + qlakgw - end do - ! - ! -- limit withdrawals to lake inflows and lake storage - call this%lak_calculate_withdrawal(n, avail, wr) - ! - ! -- limit evaporation to lake inflows and lake storage - call this%lak_calculate_evaporation(n, hlak, avail, ev) - ! - ! -- no outlet flow if evaporation consumes all water - call this%lak_calculate_outlet_outflow(n, hlak, avail, sout) - ! - ! -- update the surface inflow values - call this%lak_calculate_outlet_inflow(n, sin) - ! - ! -- calculate residual - resid = ra + ev + wr + ro + qinf + ex + sin + sout + seep - ! - ! -- include storage - if (this%gwfiss /= 1) then - hlak0 = this%xoldpak(n) - call this%lak_calculate_vol(n, hlak0, v0) - call this%lak_calculate_vol(n, hlak, v1) - resid = resid + (v0 - v1) / delt - end if - ! - ! -- return - return - end subroutine lak_calculate_residual - - subroutine lak_setup_budobj(this) -! ****************************************************************************** -! lak_setup_budobj -- Set up the budget object that stores all the lake flows -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LENBUDTXT - ! -- dummy - class(LakType) :: this - ! -- local - integer(I4B) :: nbudterm - integer(I4B) :: nlen - integer(I4B) :: j, n, n1, n2 - integer(I4B) :: maxlist, naux - integer(I4B) :: idx - real(DP) :: q - character(len=LENBUDTXT) :: text - character(len=LENBUDTXT), dimension(1) :: auxtxt -! ------------------------------------------------------------------------------ - ! - ! -- Determine the number of lake budget terms. These are fixed for - ! the simulation and cannot change - nbudterm = 9 - nlen = 0 - do n = 1, this%noutlets - if (this%lakein(n) > 0 .and. this%lakeout(n) > 0) then - nlen = nlen + 1 - end if - end do - if (nlen > 0) nbudterm = nbudterm + 1 - if (this%imover == 1) nbudterm = nbudterm + 2 - if (this%naux > 0) nbudterm = nbudterm + 1 - ! - ! -- set up budobj - call budgetobject_cr(this%budobj, this%name) - call this%budobj%budgetobject_df(this%nlakes, nbudterm, 0, 0) - idx = 0 - ! - ! -- Go through and set up each budget term - if (nlen > 0) then - text = ' FLOW-JA-FACE' - idx = idx + 1 - maxlist = 2 * this%noutlets - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- store connectivity - call this%budobj%budterm(idx)%reset(2 * nlen) - q = DZERO - do n = 1, this%noutlets - n1 = this%lakein(n) - n2 = this%lakeout(n) - if (n1 > 0 .and. n2 > 0) then - call this%budobj%budterm(idx)%update_term(n1, n2, q) - call this%budobj%budterm(idx)%update_term(n2, n1, -q) - end if - end do - end if - ! - ! -- - text = ' GWF' - idx = idx + 1 - maxlist = this%maxbound - naux = 1 - auxtxt(1) = ' FLOW-AREA' - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name_model, & - maxlist, .false., .true., & - naux, auxtxt) - call this%budobj%budterm(idx)%reset(this%maxbound) - q = DZERO - do n = 1, this%nlakes - do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1 - n2 = this%cellid(j) - call this%budobj%budterm(idx)%update_term(n, n2, q) - end do - end do - ! - ! -- - text = ' RAINFALL' - idx = idx + 1 - maxlist = this%nlakes - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- - text = ' EVAPORATION' - idx = idx + 1 - maxlist = this%nlakes - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- - text = ' RUNOFF' - idx = idx + 1 - maxlist = this%nlakes - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- - text = ' EXT-INFLOW' - idx = idx + 1 - maxlist = this%nlakes - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- - text = ' WITHDRAWAL' - idx = idx + 1 - maxlist = this%nlakes - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- - text = ' EXT-OUTFLOW' - idx = idx + 1 - maxlist = this%nlakes - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- - text = ' STORAGE' - idx = idx + 1 - maxlist = this%nlakes - naux = 1 - auxtxt(1) = ' VOLUME' - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux, auxtxt) - ! - ! -- - text = ' CONSTANT' - idx = idx + 1 - maxlist = this%nlakes - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- - if (this%imover == 1) then - ! - ! -- - text = ' FROM-MVR' - idx = idx + 1 - maxlist = this%nlakes - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- - text = ' TO-MVR' - idx = idx + 1 - maxlist = this%noutlets - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux, ordered_id1=.false.) - end if - ! - ! -- - naux = this%naux - if (naux > 0) then - ! - ! -- - text = ' AUXILIARY' - idx = idx + 1 - maxlist = this%nlakes - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux, this%auxname) - end if - ! - ! -- if lake flow for each reach are written to the listing file - if (this%iprflow /= 0) then - call this%budobj%flowtable_df(this%iout) - end if - ! - ! -- return - return - end subroutine lak_setup_budobj - - subroutine lak_fill_budobj(this) -! ****************************************************************************** -! lak_fill_budobj -- copy flow terms into this%budobj -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(LakType) :: this - ! -- local - integer(I4B) :: naux - real(DP), dimension(:), allocatable :: auxvartmp - integer(I4B) :: i, j, n, n1, n2 - integer(I4B) :: ii - integer(I4B) :: idx - integer(I4B) :: nlen - real(DP) :: hlak, hgwf - real(DP) :: v, v1 - real(DP) :: q - ! -- formats -! ----------------------------------------------------------------------------- - ! - ! -- initialize counter - idx = 0 - - - ! -- FLOW JA FACE - nlen = 0 - do n = 1, this%noutlets - if (this%lakein(n) > 0 .and. this%lakeout(n) > 0) then - nlen = nlen + 1 - end if - end do - if (nlen > 0) then - idx = idx + 1 - call this%budobj%budterm(idx)%reset(2 * nlen) - do n = 1, this%noutlets - n1 = this%lakein(n) - n2 = this%lakeout(n) - if (n1 > 0 .and. n2 > 0) then - q = this%simoutrate(n) - if (this%imover == 1) then - q = q + this%pakmvrobj%get_qtomvr(n) - end if - call this%budobj%budterm(idx)%update_term(n1, n2, q) - call this%budobj%budterm(idx)%update_term(n2, n1, -q) - end if - end do - end if - - - ! -- GWF (LEAKAGE) - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%maxbound) - do n = 1, this%nlakes - hlak = this%xnewpak(n) - do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1 - n2 = this%cellid(j) - hgwf = this%xnew(n2) - call this%lak_calculate_conn_warea(n, j, hlak, hgwf, this%qauxcbc(1)) - q = this%qleak(j) - call this%budobj%budterm(idx)%update_term(n, n2, q, this%qauxcbc) - end do - end do - - - ! -- RAIN - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nlakes) - do n = 1, this%nlakes - q = this%precip(n) - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - - - ! -- EVAPORATION - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nlakes) - do n = 1, this%nlakes - q = this%evap(n) - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - - - ! -- RUNOFF - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nlakes) - do n = 1, this%nlakes - q = this%runoff(n)%value - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - - - ! -- INFLOW - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nlakes) - do n = 1, this%nlakes - q = this%inflow(n)%value - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - - - ! -- WITHDRAWAL - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nlakes) - do n = 1, this%nlakes - q = this%withr(n) - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - - - ! -- EXTERNAL OUTFLOW - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nlakes) - do n = 1, this%nlakes - call this%lak_get_external_outlet(n, q) - ! subtract tomover from external outflow - call this%lak_get_external_mover(n, v) - q = q + v - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - - - ! -- STORAGE - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nlakes) - do n = 1, this%nlakes - call this%lak_calculate_vol(n, this%xnewpak(n), v1) - q = this%qsto(n) - this%qauxcbc(1) = v1 - call this%budobj%budterm(idx)%update_term(n, n, q, this%qauxcbc) - end do - - - ! -- CONSTANT FLOW - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nlakes) - do n = 1, this%nlakes - q = this%chterm(n) - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - - - ! -- MOVER - if (this%imover == 1) then - - ! -- FROM MOVER - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nlakes) - do n = 1, this%nlakes - q = this%pakmvrobj%get_qfrommvr(n) - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - - - ! -- TO MOVER - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%noutlets) - do n = 1, this%noutlets - n1 = this%lakein(n) - q = this%pakmvrobj%get_qtomvr(n) - if (q > DZERO) then - q = -q - end if - call this%budobj%budterm(idx)%update_term(n1, n1, q) - end do - - end if - - - ! -- AUXILIARY VARIABLES - naux = this%naux - if (naux > 0) then - idx = idx + 1 - allocate(auxvartmp(naux)) - call this%budobj%budterm(idx)%reset(this%nlakes) - do n = 1, this%nlakes - q = DZERO - do i = 1, naux - ii = (n - 1) * naux + i - auxvartmp(i) = this%lauxvar(ii)%value - end do - call this%budobj%budterm(idx)%update_term(n, n, q, auxvartmp) - end do - deallocate(auxvartmp) - end if - ! - ! --Terms are filled, now accumulate them for this time step - call this%budobj%accumulate_terms() - ! - ! -- return - return - end subroutine lak_fill_budobj - -end module LakModule +module LakModule + ! + use KindModule, only: DP, I4B + use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, LENTIMESERIESNAME, & + DZERO, DPREC, DEM30, DEM9, DEM6, DEM5, & + DEM4, DEM2, DEM1, DHALF, DP7, DONE, & + DTWO, DPI, DTHREE, DEIGHT, DTEN, DHUNDRED, DEP20, & + DONETHIRD, DTWOTHIRDS, DFIVETHIRDS, & + DGRAVITY, DCD, & + NAMEDBOUNDFLAG, LENFTYPE, LENPACKAGENAME, & + LENPAKLOC, DNODATA, & + TABLEFT, TABCENTER, TABRIGHT, & + TABSTRING, TABUCSTRING, TABINTEGER, TABREAL + use MemoryTypeModule, only: MemoryTSType + use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_setptr, & + mem_deallocate + use SmoothingModule, only: sQuadraticSaturation, sQSaturation, & + sQuadraticSaturationDerivative, & + sQSaturationDerivative + use BndModule, only: BndType + use BudgetObjectModule, only: BudgetObjectType, budgetobject_cr + use TableModule, only: TableType, table_cr + use ObserveModule, only: ObserveType + use ObsModule, only: ObsType + use InputOutputModule, only: get_node, URWORD, extract_idnum_or_bndname + use BaseDisModule, only: DisBaseType + use SimModule, only: count_errors, store_error, ustop + use GenericUtilitiesModule, only: sim_message + use ArrayHandlersModule, only: ExpandArray + use BlockParserModule, only: BlockParserType + use BaseDisModule, only: DisBaseType + ! + implicit none + ! + private + public :: LakType + public :: lak_create + ! + character(len=LENFTYPE) :: ftype = 'LAK' + character(len=LENPACKAGENAME) :: text = ' LAK' + ! + type LakTabType + real(DP), dimension(:), pointer, contiguous :: tabstage => null() + real(DP), dimension(:), pointer, contiguous :: tabvolume => null() + real(DP), dimension(:), pointer, contiguous :: tabsarea => null() + real(DP), dimension(:), pointer, contiguous :: tabwarea => null() + end type LakTabType + ! + type, extends(BndType) :: LakType + ! -- scalars + ! -- characters + character(len=16), dimension(:), pointer, contiguous :: clakbudget => NULL() + character(len=16), dimension(:), pointer, contiguous :: cauxcbc => NULL() + ! -- integers + integer(I4B), pointer :: iprhed => null() + integer(I4B), pointer :: istageout => null() + integer(I4B), pointer :: ibudgetout => null() + integer(I4B), pointer :: ipakcsv => null() + integer(I4B), pointer :: cbcauxitems => NULL() + integer(I4B), pointer :: nlakes => NULL() + integer(I4B), pointer :: noutlets => NULL() + integer(I4B), pointer :: ntables => NULL() + real(DP), pointer :: convlength => NULL() + real(DP), pointer :: convtime => NULL() + real(DP), pointer :: outdmax => NULL() + integer(I4B), pointer :: igwhcopt => NULL() + integer(I4B), pointer :: iconvchk => NULL() + integer(I4B), pointer :: iconvresidchk => NULL() + real(DP), pointer :: surfdep => NULL() + real(DP), pointer :: delh => NULL() + real(DP), pointer :: pdmax => NULL() + integer(I4B), pointer :: check_attr => NULL() + ! -- for budgets + integer(I4B), pointer :: bditems => NULL() + ! -- vectors + ! -- lake data + integer(I4B), dimension(:), pointer, contiguous :: nlakeconn => null() + integer(I4B), dimension(:), pointer, contiguous :: idxlakeconn => null() + integer(I4B), dimension(:), pointer, contiguous :: ntabrow => null() + real(DP), dimension(:), pointer, contiguous :: strt => null() + real(DP), dimension(:), pointer, contiguous :: laketop => null() + real(DP), dimension(:), pointer, contiguous :: lakebot => null() + real(DP), dimension(:), pointer, contiguous :: sareamax => null() + character(len=LENBOUNDNAME), dimension(:), pointer, & + contiguous :: lakename => null() + character (len=8), dimension(:), pointer, contiguous :: status => null() + real(DP), dimension(:), pointer, contiguous :: avail => null() + real(DP), dimension(:), pointer, contiguous :: lkgwsink => null() + ! -- time series aware data + type (MemoryTSType), dimension(:), pointer, contiguous :: stage => null() + type (MemoryTSType), dimension(:), pointer, contiguous :: rainfall => null() + type (MemoryTSType), dimension(:), pointer, & + contiguous :: evaporation => null() + type (MemoryTSType), dimension(:), pointer, contiguous :: runoff => null() + type (MemoryTSType), dimension(:), pointer, contiguous :: inflow => null() + type (MemoryTSType), dimension(:), pointer, & + contiguous :: withdrawal => null() + type (MemoryTSType), dimension(:), pointer, contiguous :: lauxvar => null() + ! + ! -- table data + type (LakTabType), dimension(:), pointer, contiguous :: laketables => null() + ! + ! -- lake solution data + integer(I4B), dimension(:), pointer, contiguous :: ncncvr => null() + real(DP), dimension(:), pointer, contiguous :: surfin => null() + real(DP), dimension(:), pointer, contiguous :: surfout => null() + real(DP), dimension(:), pointer, contiguous :: surfout1 => null() + real(DP), dimension(:), pointer, contiguous :: precip => null() + real(DP), dimension(:), pointer, contiguous :: precip1 => null() + real(DP), dimension(:), pointer, contiguous :: evap => null() + real(DP), dimension(:), pointer, contiguous :: evap1 => null() + real(DP), dimension(:), pointer, contiguous :: evapo => null() + real(DP), dimension(:), pointer, contiguous :: withr => null() + real(DP), dimension(:), pointer, contiguous :: withr1 => null() + real(DP), dimension(:), pointer, contiguous :: flwin => null() + real(DP), dimension(:), pointer, contiguous :: flwiter => null() + real(DP), dimension(:), pointer, contiguous :: flwiter1 => null() + real(DP), dimension(:), pointer, contiguous :: seep => null() + real(DP), dimension(:), pointer, contiguous :: seep1 => null() + real(DP), dimension(:), pointer, contiguous :: seep0 => null() + real(DP), dimension(:), pointer, contiguous :: stageiter => null() + real(DP), dimension(:), pointer, contiguous :: chterm => null() + ! + ! -- lake convergence + integer(I4B), dimension(:), pointer, contiguous :: iseepc => null() + integer(I4B), dimension(:), pointer, contiguous :: idhc => null() + real(DP), dimension(:), pointer, contiguous :: en1 => null() + real(DP), dimension(:), pointer, contiguous :: en2 => null() + real(DP), dimension(:), pointer, contiguous :: r1 => null() + real(DP), dimension(:), pointer, contiguous :: r2 => null() + real(DP), dimension(:), pointer, contiguous :: dh0 => null() + real(DP), dimension(:), pointer, contiguous :: s0 => null() + real(DP), dimension(:), pointer, contiguous :: qgwf0 => null() + ! + ! -- lake connection data + integer(I4B), dimension(:), pointer, contiguous :: imap => null() + integer(I4B), dimension(:), pointer, contiguous :: cellid => null() + integer(I4B), dimension(:), pointer, contiguous :: nodesontop => null() + integer(I4B), dimension(:), pointer, contiguous :: ictype => null() + real(DP), dimension(:), pointer, contiguous :: bedleak => null() + real(DP), dimension(:), pointer, contiguous :: belev => null() + real(DP), dimension(:), pointer, contiguous :: telev => null() + real(DP), dimension(:), pointer, contiguous :: connlength => null() + real(DP), dimension(:), pointer, contiguous :: connwidth => null() + real(DP), dimension(:), pointer, contiguous :: sarea => null() + real(DP), dimension(:), pointer, contiguous :: warea => null() + real(DP), dimension(:), pointer, contiguous :: satcond => null() + real(DP), dimension(:), pointer, contiguous :: simcond => null() + real(DP), dimension(:), pointer, contiguous :: simlakgw => null() + ! + ! -- lake outlet data + integer(I4B), dimension(:), pointer, contiguous :: lakein => null() + integer(I4B), dimension(:), pointer, contiguous :: lakeout => null() + integer(I4B), dimension(:), pointer, contiguous :: iouttype => null() + type (MemoryTSType), dimension(:), pointer, contiguous :: outrate => null() + type (MemoryTSType), dimension(:), pointer, & + contiguous :: outinvert => null() + type (MemoryTSType), dimension(:), pointer, contiguous :: outwidth => null() + type (MemoryTSType), dimension(:), pointer, contiguous :: outrough => null() + type (MemoryTSType), dimension(:), pointer, contiguous :: outslope => null() + real(DP), dimension(:), pointer, contiguous :: simoutrate => null() + ! + ! -- lake output data + real(DP), dimension(:), pointer, contiguous :: qauxcbc => null() + real(DP), dimension(:), pointer, contiguous :: dbuff => null() + real(DP), dimension(:), pointer, contiguous :: qleak => null() + real(DP), dimension(:), pointer, contiguous :: qsto => null() + ! + ! -- pointer to gwf iss and gwf hk + integer(I4B), pointer :: gwfiss => NULL() + real(DP), dimension(:), pointer, contiguous :: gwfk11 => NULL() + real(DP), dimension(:), pointer, contiguous :: gwfk33 => NULL() + real(DP), dimension(:), pointer, contiguous :: gwfsat => NULL() + integer(I4B), pointer :: gwfik33 => NULL() + ! + ! -- package x, xold, and ibound + integer(I4B), dimension(:), pointer, contiguous :: iboundpak => null() !package ibound + real(DP), dimension(:), pointer, contiguous :: xnewpak => null() !package x vector + real(DP), dimension(:), pointer, contiguous :: xoldpak => null() !package xold vector + ! + ! -- lake budget object + type(BudgetObjectType), pointer :: budobj => null() + ! + ! -- laketable objects + type(TableType), pointer :: pakcsvtab => null() + ! + ! -- type bound procedures + contains + procedure :: lak_allocate_scalars + procedure :: lak_allocate_arrays + procedure :: bnd_options => lak_options + procedure :: read_dimensions => lak_read_dimensions + procedure :: read_initial_attr => lak_read_initial_attr + procedure :: set_pointers => lak_set_pointers + procedure :: bnd_ar => lak_ar + procedure :: bnd_rp => lak_rp + procedure :: bnd_ad => lak_ad + procedure :: bnd_cf => lak_cf + procedure :: bnd_fc => lak_fc + procedure :: bnd_fn => lak_fn + procedure :: bnd_cc => lak_cc + procedure :: bnd_bd => lak_bd + procedure :: bnd_ot => lak_ot + procedure :: bnd_da => lak_da + procedure :: define_listlabel + ! -- methods for observations + procedure, public :: bnd_obs_supported => lak_obs_supported + procedure, public :: bnd_df_obs => lak_df_obs + procedure, public :: bnd_rp_obs => lak_rp_obs + ! -- private procedures + procedure, private :: lak_read_lakes + procedure, private :: lak_read_lake_connections + procedure, private :: lak_read_outlets + procedure, private :: lak_read_tables + procedure, private :: lak_read_table + !procedure, private :: lak_check_attributes + procedure, private :: lak_check_valid + procedure, private :: lak_set_stressperiod + procedure, private :: lak_set_attribute_error + procedure, private :: lak_cfupdate + procedure, private :: lak_bound_update + procedure, private :: lak_bd_obs + procedure, private :: lak_calculate_sarea + procedure, private :: lak_calculate_warea + procedure, private :: lak_calculate_conn_warea + procedure, public :: lak_calculate_vol + procedure, private :: lak_calculate_conductance + procedure, private :: lak_calculate_cond_head + procedure, private :: lak_calculate_conn_conductance + procedure, private :: lak_calculate_exchange + procedure, private :: lak_calculate_conn_exchange + procedure, private :: lak_estimate_conn_exchange + procedure, private :: lak_calculate_storagechange + procedure, private :: lak_calculate_rainfall + procedure, private :: lak_calculate_runoff + procedure, private :: lak_calculate_inflow + procedure, private :: lak_calculate_external + procedure, private :: lak_calculate_withdrawal + procedure, private :: lak_calculate_evaporation + procedure, private :: lak_calculate_outlet_inflow + procedure, private :: lak_calculate_outlet_outflow + procedure, private :: lak_get_internal_inlet + procedure, private :: lak_get_internal_outlet + procedure, private :: lak_get_external_outlet + procedure, private :: lak_get_internal_mover + procedure, private :: lak_get_external_mover + procedure, private :: lak_get_outlet_tomover + procedure, private :: lak_accumulate_chterm + procedure, private :: lak_vol2stage + procedure, private :: lak_solve + procedure, private :: lak_calculate_available + procedure, private :: lak_calculate_residual + procedure, private :: lak_linear_interpolation + procedure, private :: lak_setup_budobj + procedure, private :: lak_fill_budobj + end type LakType + +contains + + subroutine lak_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) +! ****************************************************************************** +! lak_create -- Create a New LAKE Package +! Subroutine: (1) create new-style package +! (2) point bndobj to the new package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(BndType), pointer :: packobj + integer(I4B),intent(in) :: id + integer(I4B),intent(in) :: ibcnum + integer(I4B),intent(in) :: inunit + integer(I4B),intent(in) :: iout + character(len=*), intent(in) :: namemodel + character(len=*), intent(in) :: pakname + type(LakType), pointer :: lakobj +! ------------------------------------------------------------------------------ + ! + ! -- allocate the object and assign values to object variables + allocate(lakobj) + packobj => lakobj + ! + ! -- create name and origin + call packobj%set_names(ibcnum, namemodel, pakname, ftype) + packobj%text = text + ! + ! -- allocate scalars + call lakobj%lak_allocate_scalars() + ! + ! -- initialize package + call packobj%pack_initialize() + + packobj%inunit = inunit + packobj%iout = iout + packobj%id = id + packobj%ibcnum = ibcnum + packobj%ncolbnd = 3 + packobj%iscloc = 0 ! not supported + packobj%ictorigin = 'NPF' + ! + ! -- return + return + end subroutine lak_create + + subroutine lak_allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars -- allocate scalar members +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType), intent(inout) :: this +! ------------------------------------------------------------------------------ + ! + ! -- call standard BndType allocate scalars + call this%BndType%allocate_scalars() + ! + ! -- allocate the object and assign values to object variables + call mem_allocate(this%iprhed, 'IPRHED', this%origin) + call mem_allocate(this%istageout, 'ISTAGEOUT', this%origin) + call mem_allocate(this%ibudgetout, 'IBUDGETOUT', this%origin) + call mem_allocate(this%ipakcsv, 'IPAKCSV', this%origin) + call mem_allocate(this%nlakes, 'NLAKES', this%origin) + call mem_allocate(this%noutlets, 'NOUTLETS', this%origin) + call mem_allocate(this%ntables, 'NTABLES', this%origin) + call mem_allocate(this%convlength, 'CONVLENGTH', this%origin) + call mem_allocate(this%convtime, 'CONVTIME', this%origin) + call mem_allocate(this%outdmax, 'OUTDMAX', this%origin) + call mem_allocate(this%igwhcopt, 'IGWHCOPT', this%origin) + call mem_allocate(this%iconvchk, 'ICONVCHK', this%origin) + call mem_allocate(this%iconvresidchk, 'ICONVRESIDCHK', this%origin) + call mem_allocate(this%surfdep, 'SURFDEP', this%origin) + call mem_allocate(this%delh, 'DELH', this%origin) + call mem_allocate(this%pdmax, 'PDMAX', this%origin) + call mem_allocate(this%check_attr, 'check_attr', this%origin) + call mem_allocate(this%bditems, 'BDITEMS', this%origin) + call mem_allocate(this%cbcauxitems, 'CBCAUXITEMS', this%origin) + ! + ! -- Set values + this%iprhed = 0 + this%istageout = 0 + this%ibudgetout = 0 + this%ipakcsv = 0 + this%nlakes = 0 + this%noutlets = 0 + this%ntables = 0 + this%convlength = DONE + this%convtime = DONE + this%outdmax = DZERO + this%igwhcopt = 0 + this%iconvchk = 1 + this%iconvresidchk = 1 + this%surfdep = DZERO + this%delh = DEM5 + this%pdmax = DEM1 + this%bditems = 11 + this%cbcauxitems = 1 + ! + ! -- return + return + end subroutine lak_allocate_scalars + + subroutine lak_allocate_arrays(this) +! ****************************************************************************** +! allocate_scalars -- allocate scalar members +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(LakType), intent(inout) :: this + ! -- local + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + ! -- call standard BndType allocate scalars + call this%BndType%allocate_arrays() + ! + ! -- allocate character array for budget text + allocate(this%clakbudget(this%bditems)) + ! + !-- fill clakbudget + this%clakbudget(1) = ' GWF' + this%clakbudget(2) = ' RAINFALL' + this%clakbudget(3) = ' EVAPORATION' + this%clakbudget(4) = ' RUNOFF' + this%clakbudget(5) = ' EXT-INFLOW' + this%clakbudget(6) = ' WITHDRAWAL' + this%clakbudget(7) = ' EXT-OUTFLOW' + this%clakbudget(8) = ' STORAGE' + this%clakbudget(9) = ' CONSTANT' + this%clakbudget(10) = ' FROM-MVR' + this%clakbudget(11) = ' TO-MVR' + ! + ! -- allocate and initialize dbuff + if (this%istageout > 0) then + call mem_allocate(this%dbuff, this%nlakes, 'DBUFF', this%origin) + do i = 1, this%nlakes + this%dbuff(i) = DZERO + end do + else + call mem_allocate(this%dbuff, 0, 'DBUFF', this%origin) + end if + ! + ! -- allocate character array for budget text + allocate(this%cauxcbc(this%cbcauxitems)) + ! + ! -- allocate and initialize qauxcbc + call mem_allocate(this%qauxcbc, this%cbcauxitems, 'QAUXCBC', this%origin) + do i = 1, this%cbcauxitems + this%qauxcbc(i) = DZERO + end do + ! + ! -- allocate qleak and qsto + call mem_allocate(this%qleak, this%maxbound, 'QLEAK', this%origin) + do i = 1, this%maxbound + this%qleak(i) = DZERO + end do + call mem_allocate(this%qsto, this%nlakes, 'QSTO', this%origin) + do i = 1, this%nlakes + this%qsto(i) = DZERO + end do + ! + ! -- return + return + end subroutine lak_allocate_arrays + + subroutine lak_read_lakes(this) +! ****************************************************************************** +! pak1read_dimensions -- Read the dimensions for this package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors, store_error_unit + use TimeSeriesManagerModule, only: read_single_value_or_time_series + ! -- dummy + class(LakType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + character(len=LINELENGTH) :: text + character(len=LENBOUNDNAME) :: bndName, bndNameTemp + character(len=9) :: cno + character(len=50), dimension(:), allocatable :: caux + integer(I4B) :: ierr, ival + logical :: isfound, endOfBlock + integer(I4B) :: n + integer(I4B) :: ii, jj + integer(I4B) :: iaux + integer(I4B) :: itmp + integer(I4B) :: nlak + integer(I4B) :: nconn + integer(I4B), dimension(:), pointer, contiguous :: nboundchk + ! -- format + ! + ! -- code + ! + ! -- initialize itmp + itmp = 0 + ! + ! -- allocate lake data + call mem_allocate(this%nlakeconn, this%nlakes, 'NLAKECONN', this%origin) + call mem_allocate(this%idxlakeconn, this%nlakes+1, 'IDXLAKECONN', this%origin) + call mem_allocate(this%ntabrow, this%nlakes, 'NTABROW', this%origin) + call mem_allocate(this%strt, this%nlakes, 'STRT', this%origin) + call mem_allocate(this%laketop, this%nlakes, 'LAKETOP', this%origin) + call mem_allocate(this%lakebot, this%nlakes, 'LAKEBOT', this%origin) + call mem_allocate(this%sareamax, this%nlakes, 'SAREAMAX', this%origin) + call mem_allocate(this%stage, this%nlakes, 'STAGE', this%origin) + call mem_allocate(this%rainfall, this%nlakes, 'RAINFALL', this%origin) + call mem_allocate(this%evaporation, this%nlakes, 'EVAPORATION', this%origin) + call mem_allocate(this%runoff, this%nlakes, 'RUNOFF', this%origin) + call mem_allocate(this%inflow, this%nlakes, 'INFLOW', this%origin) + call mem_allocate(this%withdrawal, this%nlakes, 'WITHDRAWAL', this%origin) + call mem_allocate(this%lauxvar, this%naux*this%nlakes, 'LAUXVAR', this%origin) + call mem_allocate(this%avail, this%nlakes, 'AVAIL', this%origin) + call mem_allocate(this%lkgwsink, this%nlakes, 'LKGWSINK', this%origin) + call mem_allocate(this%ncncvr, this%nlakes, 'NCNCVR', this%origin) + call mem_allocate(this%surfin, this%nlakes, 'SURFIN', this%origin) + call mem_allocate(this%surfout, this%nlakes, 'SURFOUT', this%origin) + call mem_allocate(this%surfout1, this%nlakes, 'SURFOUT1', this%origin) + call mem_allocate(this%precip, this%nlakes, 'PRECIP', this%origin) + call mem_allocate(this%precip1, this%nlakes, 'PRECIP1', this%origin) + call mem_allocate(this%evap, this%nlakes, 'EVAP', this%origin) + call mem_allocate(this%evap1, this%nlakes, 'EVAP1', this%origin) + call mem_allocate(this%evapo, this%nlakes, 'EVAPO', this%origin) + call mem_allocate(this%withr, this%nlakes, 'WITHR', this%origin) + call mem_allocate(this%withr1, this%nlakes, 'WITHR1', this%origin) + call mem_allocate(this%flwin, this%nlakes, 'FLWIN', this%origin) + call mem_allocate(this%flwiter, this%nlakes, 'FLWITER', this%origin) + call mem_allocate(this%flwiter1, this%nlakes, 'FLWITER1', this%origin) + call mem_allocate(this%seep, this%nlakes, 'SEEP', this%origin) + call mem_allocate(this%seep1, this%nlakes, 'SEEP1', this%origin) + call mem_allocate(this%seep0, this%nlakes, 'SEEP0', this%origin) + call mem_allocate(this%stageiter, this%nlakes, 'STAGEITER', this%origin) + call mem_allocate(this%chterm, this%nlakes, 'CHTERM', this%origin) + ! + ! -- lake boundary and stages + call mem_allocate(this%iboundpak, this%nlakes, 'IBOUND', this%origin) + call mem_allocate(this%xnewpak, this%nlakes, 'XNEWPAK', this%origin) + call mem_allocate(this%xoldpak, this%nlakes, 'XOLDPAK', this%origin) + ! + ! -- lake iteration variables + call mem_allocate(this%iseepc, this%nlakes, 'ISEEPC', this%origin) + call mem_allocate(this%idhc, this%nlakes, 'IDHC', this%origin) + call mem_allocate(this%en1, this%nlakes, 'EN1', this%origin) + call mem_allocate(this%en2, this%nlakes, 'EN2', this%origin) + call mem_allocate(this%r1, this%nlakes, 'R1', this%origin) + call mem_allocate(this%r2, this%nlakes, 'R2', this%origin) + call mem_allocate(this%dh0, this%nlakes, 'DH0', this%origin) + call mem_allocate(this%s0, this%nlakes, 'S0', this%origin) + call mem_allocate(this%qgwf0, this%nlakes, 'QGWF0', this%origin) + ! + ! -- allocate character storage not managed by the memory manager + allocate(this%lakename(this%nlakes)) ! ditch after boundnames allocated?? + allocate(this%status(this%nlakes)) + ! + do n = 1, this%nlakes + this%ntabrow(n) = 0 + this%status(n) = 'ACTIVE' + this%laketop(n) = -DEP20 + this%lakebot(n) = DEP20 + this%sareamax(n) = DZERO + this%iboundpak(n) = 1 + this%xnewpak(n) = DEP20 + this%xoldpak(n) = DEP20 + end do + ! + ! -- allocate local storage for aux variables + if (this%naux > 0) then + allocate(caux(this%naux)) + end if + ! + ! -- allocate and initialize temporary variables + allocate(nboundchk(this%nlakes)) + do n = 1, this%nlakes + nboundchk(n) = 0 + end do + ! + ! -- read lake well data + ! -- get lakes block + call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & + supportOpenClose=.true.) + ! + ! -- parse locations block if detected + if (isfound) then + write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & + ' PACKAGEDATA' + nlak = 0 + nconn = 0 + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + n = this%parser%GetInteger() + + if (n < 1 .or. n > this%nlakes) then + write(errmsg,'(4x,a,1x,i6)') & + '****ERROR. lakeno MUST BE > 0 and <= ', this%nlakes + call store_error(errmsg) + cycle + end if + + ! -- increment nboundchk + nboundchk(n) = nboundchk(n) + 1 + + ! -- strt + this%strt(n) = this%parser%GetDouble() + + ! nlakeconn + ival = this%parser%GetInteger() + + if (ival < 0) then + write(errmsg,'(4x,a,1x,i6)') & + '****ERROR. nlakeconn MUST BE >= 0 for lake ', n + call store_error(errmsg) + end if + + nconn = nconn + ival + this%nlakeconn(n) = ival + + ! -- get aux data + do iaux = 1, this%naux + call this%parser%GetString(caux(iaux)) + end do + + ! -- set default bndName + write(cno,'(i9.9)') n + bndName = 'Lake' // cno + + ! -- lakename + if (this%inamedbound /= 0) then + call this%parser%GetStringCaps(bndNameTemp) + if (bndNameTemp /= '') then + bndName = bndNameTemp(1:16) + endif + end if + this%lakename(n) = bndName + + ! -- fill time series aware data + ! -- fill aux data + do iaux = 1, this%naux + ! + ! -- Assign boundary name + if (this%inamedbound==1) then + bndName = this%lakename(n) + else + bndName = '' + end if + text = caux(iaux) + jj = 1 !iaux + ii = (n-1) * this%naux + iaux + call read_single_value_or_time_series(text, & + this%lauxvar(ii)%value, & + this%lauxvar(ii)%name, & + DZERO, & + this%Name, 'AUX', this%TsManager, & + this%iprpak, n, jj, & + this%auxname(iaux), & + bndName, this%parser%iuactive) + end do + + nlak = nlak + 1 + end do + ! + ! -- check for duplicate or missing lakes + do n = 1, this%nlakes + if (nboundchk(n) == 0) then + write(errmsg,'(a,1x,i0)') 'ERROR. NO DATA SPECIFIED FOR LAKE', n + call store_error(errmsg) + else if (nboundchk(n) > 1) then + write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & + 'ERROR. DATA FOR LAKE', n, 'SPECIFIED', nboundchk(n), 'TIMES' + call store_error(errmsg) + end if + end do + + write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' PACKAGEDATA' + else + call store_error('ERROR. REQUIRED PACKAGEDATA BLOCK NOT FOUND.') + end if + ! + ! -- terminate if any errors were detected + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- set MAXBOUND + this%MAXBOUND = nconn + write(this%iout,'(//4x,a,i7)') 'MAXBOUND = ', this%maxbound + + ! -- set idxlakeconn + this%idxlakeconn(1) = 1 + do n = 1, this%nlakes + this%idxlakeconn(n+1) = this%idxlakeconn(n) + this%nlakeconn(n) + end do + ! + ! -- deallocate local storage for aux variables + if (this%naux > 0) then + deallocate(caux) + end if + ! + ! -- deallocate local storage for nboundchk + deallocate(nboundchk) + ! + ! -- return + return + end subroutine lak_read_lakes + + subroutine lak_read_lake_connections(this) +! ****************************************************************************** +! lak_read_lake_connections -- Read the lake connections for this package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors + ! -- dummy + class(LakType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + character(len=LINELENGTH) :: keyword, cellid + integer(I4B) :: ierr, ival + logical :: isfound, endOfBlock + real(DP) :: rval + integer(I4B) :: j, n + integer(I4B) :: nn + integer(I4B) :: ipos, ipos0 + integer(I4B) :: icellid, icellid0 + real(DP) :: top, bot + integer(I4B), dimension(:), pointer, contiguous :: nboundchk + + ! -- format + ! + ! -- code + ! + ! -- allocate local storage + allocate(nboundchk(this%MAXBOUND)) + do n = 1, this%MAXBOUND + nboundchk(n) = 0 + end do + ! + ! -- get connectiondata block + call this%parser%GetBlock('CONNECTIONDATA', isfound, ierr, & + supportOpenClose=.true.) + ! + ! -- parse connectiondata block if detected + if (isfound) then + + ! -- allocate connection data using memory manager + call mem_allocate(this%imap, this%MAXBOUND, 'IMAP', this%origin) + call mem_allocate(this%cellid, this%MAXBOUND, 'CELLID', this%origin) + call mem_allocate(this%nodesontop, this%MAXBOUND, 'NODESONTOP', this%origin) + call mem_allocate(this%ictype, this%MAXBOUND, 'ICTYPE', this%origin) + call mem_allocate(this%bedleak, this%MAXBOUND, 'BEDLEAK', this%origin) ! don't need to save this - use a temporary vector + call mem_allocate(this%belev, this%MAXBOUND, 'BELEV', this%origin) + call mem_allocate(this%telev, this%MAXBOUND, 'TELEV', this%origin) + call mem_allocate(this%connlength, this%MAXBOUND, 'CONNLENGTH', this%origin) + call mem_allocate(this%connwidth, this%MAXBOUND, 'CONNWIDTH', this%origin) + call mem_allocate(this%sarea, this%MAXBOUND, 'SAREA', this%origin) + call mem_allocate(this%warea, this%MAXBOUND, 'WAREA', this%origin) + call mem_allocate(this%satcond, this%MAXBOUND, 'SATCOND', this%origin) + call mem_allocate(this%simcond, this%MAXBOUND, 'SIMCOND', this%origin) + call mem_allocate(this%simlakgw, this%MAXBOUND, 'SIMLAKGW', this%origin) + + + ! -- process the lake connection data + write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & + ' LAKE_CONNECTIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + n = this%parser%GetInteger() + + if (n < 1 .or. n > this%nlakes) then + write(errmsg,'(4x,a,1x,i6)') & + '****ERROR. lakeno MUST BE > 0 and <= ', this%nlakes + call store_error(errmsg) + cycle + end if + + ! -- read connection number + ival = this%parser%GetInteger() + if (ival <1 .or. ival > this%nlakeconn(n)) then + write(errmsg,'(4x,a,1x,i4,1x,a,1x,i6)') & + '****ERROR. iconn FOR LAKE ', n, 'MUST BE > 1 and <= ', this%nlakeconn(n) + call store_error(errmsg) + cycle + end if + + j = ival + ipos = this%idxlakeconn(n) + ival - 1 + + ! -- set imap + this%imap(ipos) = n + + ! + ! -- increment nboundchk + nboundchk(ipos) = nboundchk(ipos) + 1 + + ! -- read gwfnodes from the line + call this%parser%GetCellid(this%dis%ndim, cellid) + nn = this%dis%noder_from_cellid(cellid, & + this%parser%iuactive, this%iout) + ! + ! -- determine if a valid cell location was provided + if (nn < 1) then + write(errmsg,'(4x,a,1x,i4,1x,a,1x,i4)') & + '****ERROR. INVALID cellid FOR LAKE ', n, 'connection', j + call store_error(errmsg) + end if + + ! -- set gwf cellid for connection + this%cellid(ipos) = nn + this%nodesontop(ipos) = nn + + ! -- read ictype + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('VERTICAL') + this%ictype(ipos) = 0 + case ('HORIZONTAL') + this%ictype(ipos) = 1 + case ('EMBEDDEDH') + this%ictype(ipos) = 2 + case ('EMBEDDEDV') + this%ictype(ipos) = 3 + case default + write(errmsg,'(4x,a,1x,i4,1x,a,1x,i4,1x,a,a,a)') & + '****ERROR. UNKNOWN ctype FOR LAKE ', n, 'connection', j, & + '(', trim(keyword), ')' + call store_error(errmsg) + end select + + ! -- bed leakance + !this%bedleak(ipos) = this%parser%GetDouble() + call this%parser%GetStringCaps(keyword) + select case(keyword) + case ('NONE') + this%bedleak(ipos) = -DONE + case default + read(keyword, *) this%bedleak(ipos) + end select + + if (keyword /= 'NONE' .and. this%bedleak(ipos) < dzero) then + write(errmsg,'(4x,a,1x,i4,1x,a)') & + '****ERROR. bedleak FOR LAKE ', n, 'MUST BE >= 0' + call store_error(errmsg) + end if + + ! -- belev + this%belev(ipos) = this%parser%GetDouble() + + ! -- telev + this%telev(ipos) = this%parser%GetDouble() + + ! -- connection length + rval = this%parser%GetDouble() + if (rval < dzero) then + if (this%ictype(ipos) == 1 .or. this%ictype(ipos) == 2 .or. this%ictype(ipos) == 3) then + write(errmsg,'(4x,a,1x,i4,1x,a,1x,i4,1x,a)') & + '****ERROR. connection length (connlength) FOR LAKE ', n, ' HORIZONTAL CONNECTION ', j, & + 'MUST BE >= 0' + call store_error(errmsg) + else + rval = DZERO + end if + end if + this%connlength(ipos) = rval + + ! -- connection width + rval = this%parser%GetDouble() + if (rval < dzero) then + if (this%ictype(ipos) == 1) then + write(errmsg,'(4x,a,1x,i4,1x,a,1x,i4,1x,a)') & + '****ERROR. cell width (connwidth) FOR LAKE ', n, ' HORIZONTAL CONNECTION ', j, & + 'MUST BE >= 0' + call store_error(errmsg) + else + rval = DZERO + end if + end if + this%connwidth(ipos) = rval + end do + write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' CONNECTIONDATA' + else + call store_error('ERROR. REQUIRED CONNECTIONDATA BLOCK NOT FOUND.') + end if + ! + ! -- terminate if any errors were detected + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- check that embedded lakes have only one connection + do n = 1, this%nlakes + j = 0 + do ipos = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + if (this%ictype(ipos) /= 2 .and. this%ictype(ipos) /= 3) cycle + j = j + 1 + if (j > 1) then + write(errmsg,'(4x,a,1x,i4,1x,a,1x,i4,1x,a)') & + '****ERROR. nlakeconn FOR LAKE', n, 'EMBEDDED CONNECTION', j, & + ' EXCEEDS 1.' + call store_error(errmsg) + end if + end do + end do + ! -- check that an embedded lake is not in the same cell as a lake + ! with a vertical connection + do n = 1, this%nlakes + ipos0 = this%idxlakeconn(n) + icellid0 = this%cellid(ipos0) + if (this%ictype(ipos0) /= 2 .and. this%ictype(ipos0) /= 3) cycle + do nn = 1, this%nlakes + if (nn == n) cycle + j = 0 + do ipos = this%idxlakeconn(nn), this%idxlakeconn(nn+1)-1 + j = j + 1 + icellid = this%cellid(ipos) + if (icellid == icellid0) then + if (this%ictype(ipos) == 0) then + write(errmsg,'(4x,a,1x,i4,1x,a,1x,i4,1x,a,1x,i4,1x,a)') & + '****ERROR. EMBEDDED LAKE', n, & + 'CANNOT COINCIDE WITH VERTICAL CONNECTION', j, & + 'IN LAKE', nn, '.' + call store_error(errmsg) + end if + end if + end do + end do + end do + ! + ! -- process the data + do n = 1, this%nlakes + j = 0 + do ipos = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + j = j + 1 + nn = this%cellid(ipos) + top = this%dis%top(nn) + bot = this%dis%bot(nn) + ! vertical connection + if (this%ictype(ipos) == 0) then + this%telev(ipos) = top + this%surfdep + this%belev(ipos) = top + this%lakebot(n) = min(this%belev(ipos), this%lakebot(n)) + ! horizontal connection + else if (this%ictype(ipos) == 1) then + if (this%belev(ipos) == this%telev(ipos)) then + this%telev(ipos) = top + this%belev(ipos) = bot + else + if (this%belev(ipos) >= this%telev(ipos)) then + write(errmsg,'(4x,a,1x,i4,1x,a,1x,i4,1x,a)') & + '****ERROR. telev FOR LAKE ', n, ' HORIZONTAL CONNECTION ', j, & + 'MUST BE >= belev' + call store_error(errmsg) + else if (this%belev(ipos) < bot) then + write(errmsg,'(4x,a,1x,i4,1x,a,1x,i4,1x,a,1x,g15.7,1x,a)') & + '****ERROR. belev FOR LAKE ', n, ' HORIZONTAL CONNECTION ', j, & + 'MUST BE >= cell bottom (', bot, ')' + call store_error(errmsg) + else if (this%telev(ipos) > top) then + write(errmsg,'(4x,a,1x,i4,1x,a,1x,i4,1x,a,1x,g15.7,1x,a)') & + '****ERROR. telev FOR LAKE ', n, ' HORIZONTAL CONNECTION ', j, & + 'MUST BE <= cell top (', top, ')' + call store_error(errmsg) + end if + end if + this%laketop(n) = max(this%telev(ipos), this%laketop(n)) + this%lakebot(n) = min(this%belev(ipos), this%lakebot(n)) + ! embedded connections + else if (this%ictype(ipos) == 2 .or. this%ictype(ipos) == 3) then + this%telev(ipos) = top + this%belev(ipos) = bot + this%lakebot(n) = bot + end if + ! + ! -- check for missing or duplicate lake connections + if (nboundchk(ipos) == 0) then + write(errmsg,'(a,1x,i0,1x,a,1x,i0)') & + 'ERROR. NO DATA SPECIFIED FOR LAKE', n, 'CONNECTION', j + call store_error(errmsg) + else if (nboundchk(ipos) > 1) then + write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & + 'ERROR. DATA FOR LAKE', n, 'CONNECTION', j, & + 'SPECIFIED', nboundchk(ipos), 'TIMES' + call store_error(errmsg) + end if + ! + ! -- set laketop if it has not been assigned + end do + if (this%laketop(n) == -DEP20) then + this%laketop(n) = this%lakebot(n) + 100. + end if + end do + ! + ! -- deallocate local variable + deallocate(nboundchk) + ! + ! -- write summary of lake_connection error messages + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- return + return + end subroutine lak_read_lake_connections + + subroutine lak_read_tables(this) +! ****************************************************************************** +! lak_read_tables -- Read the lake tables for this package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors + ! -- dummy + class(LakType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: line, errmsg + character(len=LINELENGTH) :: keyword + integer(I4B) :: ierr + logical :: isfound, endOfBlock + integer(I4B) :: n + integer(I4B) :: ntabs + integer(I4B), dimension(:), pointer, contiguous :: nboundchk +! ------------------------------------------------------------------------------ + + ! -- format + ! + ! -- code + ! + ! -- skip of no outlets + if (this%ntables < 1) return + ! + ! -- allocate and initialize nboundchk + allocate(nboundchk(this%nlakes)) + do n = 1, this%nlakes + nboundchk(n) = 0 + end do + ! + ! -- allocate derived type for table data + allocate(this%laketables(this%nlakes)) + ! + ! -- get lake_tables block + call this%parser%GetBlock('TABLES', isfound, ierr, & + supportOpenClose=.true.) + ! + ! -- parse lake_tables block if detected + if (isfound) then + ntabs = 0 + ! -- process the lake connection data + write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & + ' LAKE_TABLES' + readtable: do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + n = this%parser%GetInteger() + + if (n < 1 .or. n > this%nlakes) then + write(errmsg,'(4x,a,1x,i6)') & + '****ERROR. lakeno MUST BE > 0 and <= ', this%nlakes + call store_error(errmsg) + cycle readtable + end if + + ! -- increment ntab and nboundchk + ntabs = ntabs + 1 + nboundchk(n) = nboundchk(n) + 1 + + ! -- read FILE keyword + call this%parser%GetStringCaps(keyword) + select case (keyword) + case('TAB6') + call this%parser%GetStringCaps(keyword) + if(trim(adjustl(keyword)) /= 'FILEIN') then + errmsg = 'TAB6 keyword must be followed by "FILEIN" ' // & + 'then by filename.' + call store_error(errmsg) + cycle readtable + end if + call this%parser%GetString(line) + call this%lak_read_table(n, line) + case default + write(errmsg,'(4x,a,1x,i4,1x,a)') & + '****ERROR. LAKE TABLE ENTRY for LAKE ', n, 'MUST INCLUDE TAB6 KEYWORD' + call store_error(errmsg) + cycle readtable + end select + end do readtable + + write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' LAKE_TABLES' + ! + ! -- check for missing or duplicate lake connections + if (ntabs < this%ntables) then + write(errmsg,'(a,1x,i0,1x,a,1x,i0)') & + 'ERROR. TABLE DATA ARE SPECIFIED', ntabs, & + 'TIMES BUT NTABLES IS SET TO', this%ntables + call store_error(errmsg) + end if + do n = 1, this%nlakes + if (this%ntabrow(n) > 0 .and. nboundchk(n) > 1) then + write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & + 'ERROR. TABLE DATA FOR LAKE', n, 'SPECIFIED', nboundchk(n), 'TIMES' + call store_error(errmsg) + end if + end do + else + call store_error('ERROR. REQUIRED TABLES BLOCK NOT FOUND.') + end if + ! + ! -- deallocate local storage + deallocate(nboundchk) + ! + ! -- write summary of lake_table error messages + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + + ! + ! -- return + return + end subroutine lak_read_tables + + subroutine lak_read_table(this, ilak, filename) +! ****************************************************************************** +! lak_read_table -- Read the lake table for this package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use InputOutputModule, only: openfile + use SimModule, only: ustop, store_error, count_errors + ! -- dummy + class(LakType), intent(inout) :: this + integer(I4B), intent(in) :: ilak + character (len=*), intent(in) :: filename + + ! -- local + character(len=LINELENGTH) :: errmsg + character(len=LINELENGTH) :: keyword + character(len=13) :: arrName + character(len=4) :: citem + integer(I4B) :: ierr + logical :: isfound, endOfBlock + integer(I4B) :: iu + integer(I4B) :: n + integer(I4B) :: ipos + integer(I4B) :: j + integer(I4B) :: jmin + integer(I4B) :: iconn + real(DP) :: vol + real(DP) :: sa + real(DP) :: wa + real(DP) :: v + type(BlockParserType) :: parser +! ------------------------------------------------------------------------------ + + ! -- format + ! + ! -- code + ! + ! -- initialize locals + n = 0 + j = 0 + ! + ! -- open the table file + iu = 0 + call openfile(iu, this%iout, filename, 'LAKE TABLE') + call parser%Initialize(iu, this%iout) + ! + ! -- get dimensions block + call parser%GetBlock('DIMENSIONS', isfound, ierr, supportOpenClose=.true.) + ! + ! -- parse well_connections block if detected + if (isfound) then + ! -- process the lake connection data + if (this%iprpak /= 0) then + write(this%iout,'(/1x,a)') & + 'PROCESSING '//trim(adjustl(this%text))//' DIMENSIONS' + end if + readdims: do + call parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call parser%GetStringCaps(keyword) + select case (keyword) + case ('NROW') + n = parser%GetInteger() + + if (n < 1) then + write(errmsg,'(4x,a)') & + '****ERROR. LAKE TABLE NROW MUST BE > 0' + call store_error(errmsg) + end if + case ('NCOL') + j = parser%GetInteger() + + if (this%ictype(ilak) == 2 .or. this%ictype(ilak) == 3) then + jmin = 4 + else + jmin = 3 + end if + if (j < jmin) then + write(errmsg,'(4x,a,1x,i0)') & + '****ERROR. LAKE TABLE NCOL MUST BE >= ', jmin + call store_error(errmsg) + end if + + case default + write(errmsg,'(4x,a,a)') & + '****ERROR. UNKNOWN '//trim(this%text)//' DIMENSIONS KEYWORD: ', & + trim(keyword) + call store_error(errmsg) + end select + end do readdims + if (this%iprpak /= 0) then + write(this%iout,'(1x,a)') & + 'END OF '//trim(adjustl(this%text))//' DIMENSIONS' + end if + else + call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') + end if + ! + ! -- check that ncol and nrow have been specified + if (n < 1) then + write(errmsg,'(4x,a)') & + '****ERROR. NROW NOT SPECIFIED IN THE LAKE TABLE DIMENSIONS BLOCK' + call store_error(errmsg) + end if + if (j < 1) then + write(errmsg,'(4x,a)') & + '****ERROR. NCOL NOT SPECIFIED IN THE LAKE TABLE DIMENSIONS BLOCK' + call store_error(errmsg) + end if + ! + ! -- only read the lake table data if n and j are specified to be greater + ! than zero + if (n * j > 0) then + ! + ! -- allocate space + this%ntabrow(ilak) = n + write(citem,'(i4.4)') ilak + ! -- build arrName for outlet + arrName = 'TABSTAGE' // citem + call mem_allocate(this%laketables(ilak)%tabstage, n, arrName, this%origin) + arrName = 'TABVOLUME' // citem + call mem_allocate(this%laketables(ilak)%tabvolume, n, arrName, this%origin) + arrName = 'TABSAREA' // citem + call mem_allocate(this%laketables(ilak)%tabsarea, n, arrName, this%origin) + ipos = this%idxlakeconn(ilak) + if (this%ictype(ipos) == 2 .or. this%ictype(ipos) == 3) then + arrName = 'tabwarea' // citem + call mem_allocate(this%laketables(ilak)%tabwarea, n, arrName, this%origin) + end if + + + ! -- get table block + call parser%GetBlock('TABLE', isfound, ierr, supportOpenClose=.true.) + ! + ! -- parse well_connections block if detected + if (isfound) then + + ! -- process the table data + if (this%iprpak /= 0) then + write(this%iout,'(/1x,a)') & + 'PROCESSING '//trim(adjustl(this%text))//' TABLE' + end if + iconn = this%idxlakeconn(ilak) + ipos = 0 + readtabledata: do + call parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + ipos = ipos + 1 + if (ipos > this%ntabrow(ilak)) then + cycle readtabledata + end if + this%laketables(ilak)%tabstage(ipos) = parser%GetDouble() + this%laketables(ilak)%tabvolume(ipos) = parser%GetDouble() + this%laketables(ilak)%tabsarea(ipos) = parser%GetDouble() + if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then + this%laketables(ilak)%tabwarea(ipos) = parser%GetDouble() + end if + end do readtabledata + + if (this%iprpak /= 0) then + write(this%iout,'(1x,a)') & + 'END OF '//trim(adjustl(this%text))//' TABLE' + end if + else + call store_error('ERROR. REQUIRED TABLE BLOCK NOT FOUND.') + end if + ! + ! -- error condition if number of rows read are not equal to nrow + if (ipos /= this%ntabrow(ilak)) then + write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & + 'ERROR. NROW SET TO',this%ntabrow(ilak), 'BUT', ipos, 'ROWS WERE READ' + call store_error(errmsg) + end if + ! + ! -- set lake bottom based on table if it is an embedded lake + iconn = this%idxlakeconn(ilak) + if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then + do n = 1, this%ntabrow(ilak) + vol = this%laketables(ilak)%tabvolume(n) + sa = this%laketables(ilak)%tabsarea(n) + wa = this%laketables(ilak)%tabwarea(n) + v = vol * sa * wa + ! -- check if all entries are zero + if (v > DZERO) exit + ! -- set lake bottom + this%lakebot(ilak) = this%laketables(ilak)%tabstage(n) + this%belev(ilak) = this%laketables(ilak)%tabstage(n) + end do + ! -- set maximum surface area for rainfall + n = this%ntabrow(ilak) + this%sareamax(ilak) = this%laketables(ilak)%tabsarea(n) + end if + ! + ! -- verify the table data + do n = 2, this%ntabrow(ilak) + if (this%laketables(ilak)%tabstage(n) <= this%laketables(ilak)%tabstage(n-1)) then + write(errmsg,'(4x,a,1x,i4,1x,a,1x,g15.6,1x,a,1x,i6,1x,a,1x,i4,1x,a,1x,g15.6,1x,a)') & + '****ERROR. TABLE STAGE ENTRY', n, '(', this%laketables(ilak)%tabstage(n), & + ') FOR LAKE ', ilak, 'MUST BE GREATER THAN THE PREVIOUS STAGE ENTRY', & + n-1, '(', this%laketables(ilak)%tabstage(n-1), ')' + call store_error(errmsg) + end if + if (this%laketables(ilak)%tabvolume(n) <= this%laketables(ilak)%tabvolume(n-1)) then + write(errmsg,'(4x,a,1x,i4,1x,a,1x,g15.6,1x,a,1x,i6,1x,a,1x,i4,1x,a,1x,g15.6,1x,a)') & + '****ERROR. TABLE VOLUME ENTRY', n, '(', this%laketables(ilak)%tabvolume(n), & + ') FOR LAKE ', ilak, 'MUST BE GREATER THAN THE PREVIOUS VOLUME ENTRY', & + n-1, '(', this%laketables(ilak)%tabvolume(n-1), ')' + call store_error(errmsg) + end if + if (this%laketables(ilak)%tabsarea(n) < this%laketables(ilak)%tabsarea(n-1)) then + write(errmsg,'(4x,a,1x,i4,1x,a,1x,g15.6,1x,a,1x,i6,1x,a,1x,i4,1x,a,1x,g15.6,1x,a)') & + '****ERROR. TABLE SURFACE AREA ENTRY', n, '(', this%laketables(ilak)%tabsarea(n), & + ') FOR LAKE ', ilak, 'MUST BE GREATER THAN OR EQUAL TO THE PREVIOUS SURFACE AREA ENTRY', & + n-1, '(', this%laketables(ilak)%tabsarea(n-1), ')' + call store_error(errmsg) + end if + iconn = this%idxlakeconn(ilak) + if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then + if (this%laketables(ilak)%tabwarea(n) < this%laketables(ilak)%tabwarea(n-1)) then + write(errmsg,'(4x,a,1x,i4,1x,a,1x,g15.6,1x,a,1x,i6,1x,a,1x,i4,1x,a,1x,g15.6,1x,a)') & + '****ERROR. TABLE EXCHANGE AREA ENTRY', n, '(', this%laketables(ilak)%tabwarea(n), & + ') FOR LAKE ', ilak, 'MUST BE GREATER THAN OR EQUAL TO THE PREVIOUS EXCHANGE AREA ENTRY', & + n-1, '(', this%laketables(ilak)%tabwarea(n-1), ')' + call store_error(errmsg) + end if + end if + end do + end if + ! + ! -- write summary of lake table error messages + if (count_errors() > 0) then + call parser%StoreErrorUnit() + call ustop() + end if + ! + ! Close the table file and clear other parser members + call parser%Clear() + ! + ! -- return + return + end subroutine lak_read_table + + subroutine lak_read_outlets(this) +! ****************************************************************************** +! lak_read_outlets -- Read the lake outlets for this package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors + use TimeSeriesManagerModule, only: read_single_value_or_time_series + ! -- dummy + class(LakType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + character(len=LINELENGTH) :: text, keyword + character(len=LENBOUNDNAME) :: bndName + character(len=9) :: citem + integer(I4B) :: ierr, ival + logical :: isfound, endOfBlock + integer(I4B) :: n + !integer(I4B) :: ii, jj, kk, nn + integer(I4B) :: jj + real(DP) :: endtim + integer(I4B), dimension(:), pointer, contiguous :: nboundchk + ! + ! -- format + ! + ! -- code +! ------------------------------------------------------------------------------ + ! + ! -- get well_connections block + call this%parser%GetBlock('OUTLETS', isfound, ierr, & + supportOpenClose=.true., blockRequired=.false.) + ! + ! -- parse outlets block if detected + if (isfound) then + if (this%noutlets > 0) then + ! + ! -- allocate and initialize local variables + allocate(nboundchk(this%noutlets)) + do n = 1, this%noutlets + nboundchk(n) = 0 + end do + ! + ! -- allocate outlet data using memory manager + call mem_allocate(this%lakein, this%NOUTLETS, 'LAKEIN', this%origin) + call mem_allocate(this%lakeout, this%NOUTLETS, 'LAKEOUT', this%origin) + call mem_allocate(this%iouttype, this%NOUTLETS, 'IOUTTYPE', this%origin) + call mem_allocate(this%outrate, this%NOUTLETS, 'OUTRATE', this%origin) + call mem_allocate(this%outinvert, this%NOUTLETS, 'OUTINVERT', & + this%origin) + call mem_allocate(this%outwidth, this%NOUTLETS, 'OUTWIDTH', this%origin) + call mem_allocate(this%outrough, this%NOUTLETS, 'OUTROUGH', this%origin) + call mem_allocate(this%outslope, this%NOUTLETS, 'OUTSLOPE', this%origin) + call mem_allocate(this%simoutrate, this%NOUTLETS, 'SIMOUTRATE', & + this%origin) + + ! -- process the lake connection data + write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & + ' OUTLETS' + readoutlet: do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + n = this%parser%GetInteger() + + if (n < 1 .or. n > this%noutlets) then + write(errmsg,'(4x,a,1x,i6)') & + '****ERROR. outletno MUST BE > 0 and <= ', this%noutlets + call store_error(errmsg) + cycle readoutlet + end if + ! + ! -- increment nboundchk + nboundchk(n) = nboundchk(n) + 1 + ! + ! -- read outlet lakein + ival = this%parser%GetInteger() + if (ival <1 .or. ival > this%nlakes) then + write(errmsg,'(4x,a,1x,i4,1x,a,1x,i6)') & + '****ERROR. lakein FOR OUTLET ', n, 'MUST BE > 0 and <= ', & + this%nlakes + call store_error(errmsg) + cycle readoutlet + end if + this%lakein(n) = ival + + ! -- read outlet lakeout + ival = this%parser%GetInteger() + if (ival <0 .or. ival > this%nlakes) then + write(errmsg,'(4x,a,1x,i4,1x,a,1x,i6)') & + '****ERROR. lakeout FOR OUTLET ', n, 'MUST BE >= 0 and <= ', & + this%nlakes + call store_error(errmsg) + cycle readoutlet + end if + this%lakeout(n) = ival + + ! -- read ictype + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('SPECIFIED') + this%iouttype(n) = 0 + case ('MANNING') + this%iouttype(n) = 1 + case ('WEIR') + this%iouttype(n) = 2 + case default + write(errmsg,'(4x,a,1x,i4,1x,a,a,a)') & + '****ERROR. UNKNOWN couttype FOR OUTLET ', n, & + '(', trim(keyword), ')' + call store_error(errmsg) + cycle readoutlet + end select + + ! -- build bndname for outlet + write(citem,'(i9.9)') n + bndName = 'OUTLET' // citem + + ! -- set a few variables for timeseries aware variables + endtim = DZERO + jj = 1 + + ! -- outlet invert + call this%parser%GetString(text) + call read_single_value_or_time_series(text, & + this%outinvert(n)%value, & + this%outinvert(n)%name, & + endtim, & + this%name, 'BND', & + this%TsManager, & + this%iprpak, n, jj, 'INVERT', & + bndName, this%parser%iuactive) + + ! -- outlet width + call this%parser%GetString(text) + call read_single_value_or_time_series(text, & + this%outwidth(n)%value, & + this%outwidth(n)%name, & + endtim, & + this%name, 'BND', & + this%TsManager, & + this%iprpak, n, jj, 'WIDTH', & + bndName, this%parser%iuactive) + + ! -- outlet roughness + call this%parser%GetString(text) + call read_single_value_or_time_series(text, & + this%outrough(n)%value, & + this%outrough(n)%name, & + endtim, & + this%name, 'BND', & + this%TsManager, & + this%iprpak, n, jj, 'ROUGH', & + bndName, this%parser%iuactive) + + ! -- outlet slope + call this%parser%GetString(text) + call read_single_value_or_time_series(text, & + this%outslope(n)%value, & + this%outslope(n)%name, & + endtim, & + this%name, 'BND', & + this%TsManager, & + this%iprpak, n, jj, 'SLOPE', & + bndName, this%parser%iuactive) + + + end do readoutlet + write(this%iout,'(1x,a)') 'END OF ' // trim(adjustl(this%text)) // & + ' OUTLETS' + ! + ! -- check for duplicate or missing outlets + do n = 1, this%noutlets + if (nboundchk(n) == 0) then + write(errmsg,'(a,1x,i0)') 'ERROR. NO DATA SPECIFIED FOR OUTLET', n + call store_error(errmsg) + else if (nboundchk(n) > 1) then + write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & + 'ERROR. DATA FOR OUTLET', n, 'SPECIFIED', nboundchk(n), 'TIMES' + call store_error(errmsg) + end if + end do + ! + ! -- deallocate local storage + deallocate(nboundchk) + else + write(errmsg,'(a,1x,a)') 'ERROR. AN OUTLETS BLOCK SHOULD NOT BE', & + 'SPECIFIED IF NOUTLETS IS NOT SPECIFIED OR IS SPECIFIED TO BE 0.' + call store_error(errmsg) + end if + + else + if (this%noutlets > 0) then + call store_error('ERROR. REQUIRED OUTLETS BLOCK NOT FOUND.') + end if + end if + ! + ! -- write summary of lake_connection error messages + ierr = count_errors() + if (ierr > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- return + return + end subroutine lak_read_outlets + + subroutine lak_read_dimensions(this) +! ****************************************************************************** +! pak1read_dimensions -- Read the dimensions for this package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors + ! -- dummy + class(LakType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + character(len=LINELENGTH) :: keyword + integer(I4B) :: ierr + logical :: isfound, endOfBlock + ! -- format +! ------------------------------------------------------------------------------ + ! + ! -- initialize dimensions to -1 + this%nlakes= -1 + this%maxbound = -1 + ! + ! -- 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 '//trim(adjustl(this%text))// & + ' DIMENSIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('NLAKES') + this%nlakes = this%parser%GetInteger() + write(this%iout,'(4x,a,i7)')'NLAKES = ', this%nlakes + case ('NOUTLETS') + this%noutlets = this%parser%GetInteger() + write(this%iout,'(4x,a,i7)')'NOUTLETS = ', this%noutlets + case ('NTABLES') + this%ntables = this%parser%GetInteger() + write(this%iout,'(4x,a,i7)')'NTABLES = ', this%ntables + case default + write(errmsg,'(4x,a,a)') & + '****ERROR. UNKNOWN '//trim(this%text)//' DIMENSION: ', & + trim(keyword) + call store_error(errmsg) + end select + end do + write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' DIMENSIONS' + else + call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') + end if + + if (this%nlakes < 0) then + write(errmsg, '(1x,a)') & + 'ERROR: NLAKES WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.' + call store_error(errmsg) + end if + ! + ! -- stop if errors were encountered in the DIMENSIONS block + ierr = count_errors() + if (ierr > 0) then + call ustop() + end if + ! + ! -- read lakes block + call this%lak_read_lakes() + ! + ! -- read lake_connections block + call this%lak_read_lake_connections() + ! + ! -- read tables block + call this%lak_read_tables() + ! + ! -- read outlets block + call this%lak_read_outlets() + ! + ! -- Call define_listlabel to construct the list label that is written + ! when PRINT_INPUT option is used. + call this%define_listlabel() + ! + ! -- setup the budget object + call this%lak_setup_budobj() + ! + ! -- return + return + end subroutine lak_read_dimensions + + + subroutine lak_read_initial_attr(this) +! ****************************************************************************** +! pak1read_dimensions -- Read the initial parameters for this package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors + use TimeSeriesManagerModule, only: read_single_value_or_time_series + ! -- dummy + class(LakType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: text + integer(I4B) :: j, jj, n + integer(I4B) :: nn + integer(I4B) :: idx + real(DP) :: endtim + real(DP) :: top + real(DP) :: bot + real(DP) :: k + real(DP) :: area + real(DP) :: length + real(DP) :: s + real(DP) :: dx + real(DP) :: c + real(DP) :: sa + real(DP) :: wa + real(DP) :: v + real(DP) :: fact + real(DP) :: c1 + real(DP) :: c2 + real(DP), allocatable, dimension(:) :: clb, caq + character (len=14) :: cbedleak + character (len=14) :: cbedcond + character (len=10), dimension(0:3) :: ctype + character (len=15) :: nodestr + !data + data ctype(0) /'VERTICAL '/ + data ctype(1) /'HORIZONTAL'/ + data ctype(2) /'EMBEDDEDH '/ + data ctype(3) /'EMBEDDEDV '/ + ! -- format +! ------------------------------------------------------------------------------ + ! + ! -- initialize xnewpak and set stage + do n = 1, this%nlakes + this%xnewpak(n) = this%strt(n) + write(text,'(g15.7)') this%strt(n) + endtim = DZERO + jj = 1 ! For STAGE + call read_single_value_or_time_series(text, & + this%stage(n)%value, & + this%stage(n)%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, n, jj, 'STAGE', & + this%lakename(n), this%inunit) + + end do + ! + ! -- initialize status (iboundpak) of lakes to active + do n = 1, this%nlakes + if (this%status(n) == 'CONSTANT') then + this%iboundpak(n) = -1 + else if (this%status(n) == 'INACTIVE') then + this%iboundpak(n) = 0 + else if (this%status(n) == 'ACTIVE ') then + this%iboundpak(n) = 1 + end if + end do + ! + ! -- set boundname for each connection + if (this%inamedbound /= 0) then + do n = 1, this%nlakes + do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + this%boundname(j) = this%lakename(n) + end do + end do + endif + ! + ! -- set pointer to gwf iss and gwf hk + call mem_setptr(this%gwfiss, 'ISS', trim(this%name_model)) + call mem_setptr(this%gwfk11, 'K11', trim(this%name_model)//' NPF') + call mem_setptr(this%gwfk33, 'K33', trim(this%name_model)//' NPF') + call mem_setptr(this%gwfik33, 'IK33', trim(this%name_model)//' NPF') + call mem_setptr(this%gwfsat, 'SAT', trim(this%name_model)//' NPF') + ! + ! -- allocate temporary storage + allocate(clb(this%MAXBOUND)) + allocate(caq(this%MAXBOUND)) + + ! -- calculate saturated conductance for each connection + do n = 1, this%nlakes + do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + nn = this%cellid(j) + top = this%dis%top(nn) + bot = this%dis%bot(nn) + ! vertical connection + if (this%ictype(j) == 0) then + area = this%dis%area(nn) + this%sarea(j) = area + this%warea(j) = area + this%sareamax(n) = this%sareamax(n) + area + if (this%gwfik33 == 0) then + k = this%gwfk11(nn) + else + k = this%gwfk33(nn) + endif + length = DHALF * (top - bot) + ! horizontal connection + else if (this%ictype(j) == 1) then + area = (this%telev(j) - this%belev(j)) * this%connwidth(j) + ! -- recalculate area if connected cell is confined and lake + ! connection top and bot are equal to the cell top and bot + if (top == this%telev(j) .and. bot == this%belev(j)) then + if (this%icelltype(nn) == 0) then + area = this%gwfsat(nn) * (top - bot) * this%connwidth(j) + end if + end if + this%sarea(j) = DZERO + this%warea(j) = area + this%sareamax(n) = this%sareamax(n) + DZERO + k = this%gwfk11(nn) + length = this%connlength(j) + ! embedded horizontal connection + else if (this%ictype(j) == 2) then + area = DONE + this%sarea(j) = DZERO + this%warea(j) = area + this%sareamax(n) = this%sareamax(n) + DZERO + k = this%gwfk11(nn) + length = this%connlength(j) + ! embedded vertical connection + else if (this%ictype(j) == 3) then + area = DONE + this%sarea(j) = DZERO + this%warea(j) = area + this%sareamax(n) = this%sareamax(n) + DZERO + if (this%gwfik33 == 0) then + k = this%gwfk11(nn) + else + k = this%gwfk33(nn) + endif + length = this%connlength(j) + end if + if (this%bedleak(j) < DZERO) then + clb(j) = -DONE + else if (this%bedleak(j) > DZERO) then + clb(j) = done / this%bedleak(j) + else + clb(j) = DZERO + end if + if (k > DZERO) then + caq(j) = length / k + else + caq(j) = DZERO + end if + if (this%bedleak(j) < DZERO) then + this%satcond(j) = area / caq(j) + else if (clb(j)*caq(j) > DZERO) then + this%satcond(j) = area / (clb(j) + caq(j)) + else + this%satcond(j) = DZERO + end if + end do + end do + ! + ! -- write a summary of the conductance + if (this%iprpak > 0) then + write(this%iout,'(//,29x,a,/)') 'INTERFACE CONDUCTANCE BETWEEN LAKE AND AQUIFER CELLS' + write(this%iout,'(1x,a)') & + & ' LAKE CONNECTION CONNECTION LAKEBED' // & + & ' C O N D U C T A N C E S ' + write(this%iout,'(1x,a)') & + & ' NUMBER NUMBER CELLID DIRECTION LEAKANCE' // & + & ' LAKEBED AQUIFER COMBINED' + write(this%iout,"(1x,108('-'))") + do n = 1, this%nlakes + idx = 0 + do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + idx = idx + 1 + fact = DONE + if (this%ictype(j) == 1) then + fact = this%telev(j) - this%belev(j) + if (ABS(fact) > DZERO) then + fact = DONE / fact + end if + end if + nn = this%cellid(j) + area = this%warea(j) + c1 = DZERO + if (clb(j) < DZERO) then + cbedleak = ' NONE ' + cbedcond = ' NONE ' + else if (clb(j) > DZERO) then + c1 = area * fact / clb(j) + write(cbedleak,'(g14.5)') this%bedleak(j) + write(cbedcond,'(g14.5)') c1 + else + write(cbedleak,'(g14.5)') c1 + write(cbedcond,'(g14.5)') c1 + end if + c2 = DZERO + if (caq(j) > DZERO) then + c2 = area * fact / caq(j) + end if + call this%dis%noder_to_string(nn, nodestr) + write(this%iout,'(1x,i10,1x,i10,1x,a15,1x,a10,2(1x,a14),2(1x,g14.5))') & + & n, idx, nodestr, ctype(this%ictype(j)), cbedleak, & + & cbedcond, c2, this%satcond(j) * fact + end do + end do + write(this%iout,"(1x,108('-'))") + write(this%iout,'(1x,a)') 'IF VERTICAL CONNECTION, CONDUCTANCE (L^2/T) IS BETWEEN AQUIFER CELL AND OVERLYING LAKE CELL.' + write(this%iout,'(1x,a)') 'IF HORIZONTAL CONNECTION, CONDUCTANCES ARE PER UNIT SATURATED THICKNESS (L/T).' + write(this%iout,'(1x,a)') 'IF EMBEDDED CONNECTION, CONDUCTANCES ARE PER UNIT EXCHANGE AREA (1/T).' + + ! write(this%iout,*) n, idx, nodestr, this%sarea(j), this%warea(j) + ! + ! -- calculate stage, surface area, wetted area, volume relation + do n = 1, this%nlakes + write(this%iout,'(//1x,a,1x,i10)') 'STAGE/VOLUME RELATION FOR LAKE ', n + write(this%iout,'(/1x,5(a14))') ' STAGE', ' SURFACE AREA', & + & ' WETTED AREA', ' CONDUCTANCE', & + & ' VOLUME' + write(this%iout,"(1x,70('-'))") + dx = (this%laketop(n) - this%lakebot(n)) / 150. + s = this%lakebot(n) + do j = 1, 151 + call this%lak_calculate_conductance(n, s, c) + call this%lak_calculate_sarea(n, s, sa) + call this%lak_calculate_warea(n, s, wa, s) + call this%lak_calculate_vol(n, s, v) + write(this%iout,'(1x,5(E14.5))') s, sa, wa, c, v + s = s + dx + end do + write(this%iout,"(1x,70('-'))") + + write(this%iout,'(//1x,a,1x,i10)') 'STAGE/VOLUME RELATION FOR LAKE ', n + write(this%iout,'(/1x,4(a14))') ' ', ' ', & + & ' CALCULATED', ' STAGE' + write(this%iout,'(1x,4(a14))') ' STAGE', ' VOLUME', & + & ' STAGE', ' DIFFERENCE' + write(this%iout,"(1x,56('-'))") + s = this%lakebot(n) - dx + do j = 1, 156 + call this%lak_calculate_vol(n, s, v) + call this%lak_vol2stage(n, v, c) + write(this%iout,'(1x,4(E14.5))') s, v, c, s-c + s = s + dx + end do + write(this%iout,"(1x,56('-'))") + end do + end if + ! + ! -- finished with pointer to gwf hydraulic conductivity + this%gwfk11 => null() + this%gwfk33 => null() + this%gwfsat => null() + this%gwfik33 => null() + ! + ! -- deallocate temporary storage + deallocate(clb) + deallocate(caq) + ! + ! -- return + return + end subroutine lak_read_initial_attr + +! -- simple subroutine for linear interpolation of two vectors +! function assumes x data is sorted in ascending order + subroutine lak_linear_interpolation(this, n, x, y, z, v) + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: n + real(DP), dimension(n), intent(in) :: x + real(DP), dimension(n), intent(in) :: y + real(DP), intent(in) :: z + real(DP), intent(inout) :: v + ! -- local + integer(I4B) :: i + real(DP) :: dx, dydx + ! code + v = DZERO + ! below bottom of range - set to lowest value + if (z <= x(1)) then + v = y(1) + ! above highest value + ! slope calculated from interval between n and n-1 + else if (z > x(n)) then + dx = x(n) - x(n-1) + dydx = DZERO + if (ABS(dx) > DZERO) then + dydx = ( y(n) - y(n-1) ) / dx + end if + dx = (z - x(n)) + v = y(n) + dydx * dx + ! between lowest and highest value in current interval + else + do i = 2, n + dx = x(i) - x(i-1) + dydx = DZERO + if (z >= x(i-1) .and. z <= x(i)) then + if (ABS(dx) > DZERO) then + dydx = ( y(i) - y(i-1) ) / dx + end if + dx = (z - x(i-1)) + v = y(i-1) + dydx * dx + exit + end if + end do + end if + ! return + return + end subroutine lak_linear_interpolation + + subroutine lak_calculate_sarea(this, ilak, stage, sarea) +! ****************************************************************************** +! lak_calculate_sarea -- Calculate the surface area of a lake at a given stage. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + real(DP), intent(in) :: stage + real(DP), intent(inout) :: sarea + ! -- local + integer(I4B) :: i + real(DP) :: topl + real(DP) :: botl + real(DP) :: sat + real(DP) :: sa + ! -- formats +! ------------------------------------------------------------------------------ + sarea = DZERO + if (this%ntabrow(ilak) > 0) then + i = this%ntabrow(ilak) + if (stage <= this%laketables(ilak)%tabstage(1)) then + sarea = this%laketables(ilak)%tabsarea(1) + else if (stage >= this%laketables(ilak)%tabstage(i)) then + sarea = this%laketables(ilak)%tabsarea(i) + else + call this%lak_linear_interpolation(i, this%laketables(ilak)%tabstage, & + this%laketables(ilak)%tabsarea, & + stage, sarea) + end if + else + do i = this%idxlakeconn(ilak), this%idxlakeconn(ilak+1)-1 + topl = this%telev(i) + botl = this%belev(i) + sat = sQuadraticSaturation(topl, botl, stage) + sa = sat * this%sarea(i) + sarea = sarea + sa + end do + end if + ! + ! -- return + return + end subroutine lak_calculate_sarea + + subroutine lak_calculate_warea(this, ilak, stage, warea, hin) +! ****************************************************************************** +! lak_calculate_warea -- Calculate the wetted area of a lake at a given stage. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + real(DP), intent(in) :: stage + real(DP), intent(inout) :: warea + real(DP), optional, intent(inout) :: hin + ! -- local + integer(I4B) :: i + integer(I4B) :: igwfnode + real(DP) :: head + real(DP) :: wa + ! -- formats +! ------------------------------------------------------------------------------ + warea = DZERO + do i = this%idxlakeconn(ilak), this%idxlakeconn(ilak+1)-1 + if (present(hin)) then + head = hin + else + igwfnode = this%cellid(i) + head = this%xnew(igwfnode) + end if + call this%lak_calculate_conn_warea(ilak, i, stage, head, wa) + warea = warea + wa + end do + ! + ! -- return + return + end subroutine lak_calculate_warea + + subroutine lak_calculate_conn_warea(this, ilak, iconn, stage, head, wa) +! ****************************************************************************** +! lak_calculate_conn_warea -- Calculate the wetted area of a lake connection +! at a given stage. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + integer(I4B), intent(in) :: iconn + real(DP), intent(in) :: stage + real(DP), intent(in) :: head + real(DP), intent(inout) :: wa + ! -- local + integer(I4B) :: i + integer(I4B) :: node + real(DP) :: topl + real(DP) :: botl + real(DP) :: vv + real(DP) :: sat + ! -- formats +! ------------------------------------------------------------------------------ + wa = DZERO + topl = this%telev(iconn) + botl = this%belev(iconn) + call this%lak_calculate_cond_head(iconn, stage, head, vv) + if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then + if (vv > topl) vv = topl + i = this%ntabrow(ilak) + if (vv <= this%laketables(ilak)%tabstage(1)) then + wa = this%laketables(ilak)%tabwarea(1) + else if (vv >= this%laketables(ilak)%tabstage(i)) then + wa = this%laketables(ilak)%tabwarea(i) + else + call this%lak_linear_interpolation(i, this%laketables(ilak)%tabstage, & + this%laketables(ilak)%tabwarea, & + vv, wa) + end if + else + node = this%cellid(iconn) + ! -- confined cell + if (this%icelltype(node) == 0) then + sat = DONE + ! -- convertible cell + else + sat = sQuadraticSaturation(topl, botl, vv) + end if + wa = sat * this%warea(iconn) + end if + ! + ! -- return + return + end subroutine lak_calculate_conn_warea + + + subroutine lak_calculate_vol(this, ilak, stage, volume) +! ****************************************************************************** +! lak_calculate_vol -- Calculate the volume of a lake at a given stage. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + real(DP), intent(in) :: stage + real(DP), intent(inout) :: volume + ! -- local + integer(I4B) :: i + real(DP) :: topl + real(DP) :: botl + real(DP) :: ds + real(DP) :: sa + real(DP) :: v + real(DP) :: sat + ! -- formats +! ------------------------------------------------------------------------------ + volume = DZERO + if (this%ntabrow(ilak) > 0) then + i = this%ntabrow(ilak) + if (stage <= this%laketables(ilak)%tabstage(1)) then + volume = this%laketables(ilak)%tabvolume(1) + else if (stage >= this%laketables(ilak)%tabstage(i)) then + ds = stage - this%laketables(ilak)%tabstage(i) + sa = this%laketables(ilak)%tabsarea(i) + volume = this%laketables(ilak)%tabvolume(i) + ds * sa + else + call this%lak_linear_interpolation(i, this%laketables(ilak)%tabstage, & + this%laketables(ilak)%tabvolume, & + stage, volume) + end if + else + do i = this%idxlakeconn(ilak), this%idxlakeconn(ilak+1)-1 + topl = this%telev(i) + botl = this%belev(i) + sat = sQuadraticSaturation(topl, botl, stage) + sa = sat * this%sarea(i) + if (stage < botl) then + v = DZERO + else if (stage > botl .and. stage < topl) then + v = sa * (stage - botl) + else + v = sa * (topl - botl) + sa * (stage - topl) + end if + volume = volume + v + end do + end if + ! + ! -- return + return + end subroutine lak_calculate_vol + + + subroutine lak_calculate_conductance(this, ilak, stage, conductance) +! ****************************************************************************** +! lak_calculate_conductance -- Calculate the total conductance for a lake at a +! provided stage. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + real(DP), intent(in) :: stage + real(DP), intent(inout) :: conductance + ! -- local + integer(I4B) :: i + real(DP) :: c + ! -- formats +! ------------------------------------------------------------------------------ + conductance = DZERO + do i = this%idxlakeconn(ilak), this%idxlakeconn(ilak+1)-1 + call this%lak_calculate_conn_conductance(ilak, i, stage, stage, c) + conductance = conductance + c + end do + ! + ! -- return + return + end subroutine lak_calculate_conductance + + subroutine lak_calculate_cond_head(this, iconn, stage, head, vv) +! ****************************************************************************** +! lak_calculate_conn_head -- Calculate the controlling lake stage or groundwater +! head used to calculate the conductance for a lake +! connection from a provided stage and groundwater +! head. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: iconn + real(DP), intent(in) :: stage + real(DP), intent(in) :: head + real(DP), intent(inout) :: vv + ! -- local + real(DP) :: ss + real(DP) :: hh + real(DP) :: topl + real(DP) :: botl + ! -- formats +! ------------------------------------------------------------------------------ + topl = this%telev(iconn) + botl = this%belev(iconn) + ss = min(stage, topl) + hh = min(head, topl) + if (this%igwhcopt > 0) then + vv = hh + else if (this%inewton > 0) then + vv = max(ss, hh) + else + vv = DHALF * (ss + hh) + end if + ! + ! -- return + return + end subroutine lak_calculate_cond_head + + + subroutine lak_calculate_conn_conductance(this, ilak, iconn, stage, head, cond) +! ****************************************************************************** +! lak_calculate_conn_conductance -- Calculate the conductance for a lake +! connection at a provided stage +! and groundwater head. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + integer(I4B), intent(in) :: iconn + real(DP), intent(in) :: stage + real(DP), intent(in) :: head + real(DP), intent(inout) :: cond + ! -- local + integer(I4B) :: node + !real(DP) :: ss + !real(DP) :: hh + real(DP) :: vv + real(DP) :: topl + real(DP) :: botl + real(DP) :: sat + real(DP) :: wa + ! -- formats +! ------------------------------------------------------------------------------ + cond = DZERO + topl = this%telev(iconn) + botl = this%belev(iconn) + call this%lak_calculate_cond_head(iconn, stage, head, vv) + sat = sQuadraticSaturation(topl, botl, vv) + ! vertical connection + ! use full saturated conductance if top and bottom of the lake connection + ! are equal + if (this%ictype(iconn) == 0) then + if (ABS(topl-botl) < DPREC) then + sat = DONE + end if + ! horizontal connection + ! use full saturated conductance if the connected cell is not convertible + else if (this%ictype(iconn) == 1) then + node = this%cellid(iconn) + if (this%icelltype(node) == 0) then + sat = DONE + end if + ! embedded connection + else if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then + node = this%cellid(iconn) + if (this%icelltype(node) == 0) then + vv = this%telev(iconn) + call this%lak_calculate_conn_warea(ilak, iconn, vv, vv, wa) + else + call this%lak_calculate_conn_warea(ilak, iconn, stage, head, wa) + end if + sat = wa + end if + cond = sat * this%satcond(iconn) + ! + ! -- return + return + end subroutine lak_calculate_conn_conductance + + + subroutine lak_calculate_exchange(this, ilak, stage, totflow) +! ****************************************************************************** +! lak_calculate_exchange -- Calculate the total groundwater-lake flow at a +! provided stage. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + real(DP), intent(in) :: stage + real(DP), intent(inout) :: totflow + ! -- local + integer(I4B) :: j + integer(I4B) :: igwfnode + real(DP) :: flow + real(DP) :: hgwf + real(DP) :: cond + ! -- formats +! ------------------------------------------------------------------------------ + totflow = DZERO + do j = this%idxlakeconn(ilak), this%idxlakeconn(ilak+1)-1 + igwfnode = this%cellid(j) + hgwf = this%xnew(igwfnode) + call this%lak_calculate_conn_exchange(ilak, j, stage, hgwf, flow, cond) + totflow = totflow + flow + end do + ! + ! -- return + return + end subroutine lak_calculate_exchange + + + subroutine lak_calculate_conn_exchange(this, ilak, iconn, stage, head, flow, cond) +! ****************************************************************************** +! lak_calculate_conn_exchange -- Calculate the groundwater-lake flow at a +! provided stage and groundwater head. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + integer(I4B), intent(in) :: iconn + real(DP), intent(in) :: stage + real(DP), intent(in) :: head + real(DP), intent(inout) :: flow + real(DP), intent(inout) :: cond + ! -- local + real(DP) :: botl + real(DP) :: ss + real(DP) :: hh + ! -- formats +! ------------------------------------------------------------------------------ + flow = DZERO + call this%lak_calculate_conn_conductance(ilak, iconn, stage, head, cond) + botl = this%belev(iconn) + ss = max(stage, botl) + hh = max(head, botl) + flow = cond * (hh - ss) + ! + ! -- return + return + end subroutine lak_calculate_conn_exchange + + + subroutine lak_estimate_conn_exchange(this, iflag, ilak, iconn, idry, stage, & + head, flow, cond, source) +! ****************************************************************************** +! lak_estimate_conn_exchange -- Calculate the groundwater-lake flow at a +! provided stage and groundwater head. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: iflag + integer(I4B), intent(in) :: ilak + integer(I4B), intent(in) :: iconn + integer(I4B), intent(inout) :: idry + real(DP), intent(in) :: stage + real(DP), intent(in) :: head + real(DP), intent(inout) :: flow + real(DP), intent(inout) :: cond + real(DP), intent(inout) :: source + ! -- local + ! -- formats +! ------------------------------------------------------------------------------ + flow = DZERO + idry = 0 + call this%lak_calculate_conn_exchange(ilak, iconn, stage, head, flow, cond) + if (iflag == 1) then + if (flow > DZERO) then + source = source + flow + end if + else if (iflag == 2) then + if (-flow > source) then + flow = -source + source = DZERO + idry = 1 + else if (flow < DZERO) then + source = source + flow + end if + end if + ! + ! -- return + return + end subroutine lak_estimate_conn_exchange + + subroutine lak_calculate_storagechange(this, ilak, stage, stage0, delt, dvr) +! ****************************************************************************** +! lak_calculate_storagechange -- Calculate the storage change in a lake based on +! provided stages and a passed delt. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + real(DP), intent(in) :: stage + real(DP), intent(in) :: stage0 + real(DP), intent(in) :: delt + real(DP), intent(inout) :: dvr + ! -- local + real(DP) :: v + real(DP) :: v0 + ! -- formats +! ------------------------------------------------------------------------------ + dvr = DZERO + if (this%gwfiss /= 1) then + call this%lak_calculate_vol(ilak, stage, v) + call this%lak_calculate_vol(ilak, stage0, v0) + dvr = (v0 - v) / delt + end if + ! + ! -- return + return + end subroutine lak_calculate_storagechange + + subroutine lak_calculate_rainfall(this, ilak, stage, ra) +! ****************************************************************************** +! lak_calculate_rainfall -- Calculate the rainfall for a lake . +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + real(DP), intent(in) :: stage + real(DP), intent(inout) :: ra + ! -- local + integer(I4B) :: iconn + real(DP) :: sa + ! -- formats +! ------------------------------------------------------------------------------ + ! -- rainfall + iconn = this%idxlakeconn(ilak) + if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then + sa = this%sareamax(ilak) + else + call this%lak_calculate_sarea(ilak, stage, sa) + end if + ra = this%rainfall(ilak)%value * sa !this%sareamax(ilak) + ! + ! -- return + return + end subroutine lak_calculate_rainfall + + subroutine lak_calculate_runoff(this, ilak, ro) +! ****************************************************************************** +! lak_calculate_runoff -- Calculate runoff to a lake. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + real(DP), intent(inout) :: ro + ! -- formats +! ------------------------------------------------------------------------------ + ! -- runoff + ro = this%runoff(ilak)%value + ! + ! -- return + return + end subroutine lak_calculate_runoff + + subroutine lak_calculate_inflow(this, ilak, qin) +! ****************************************************************************** +! lak_calculate_inflow -- Calculate specified inflow to a lake. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + real(DP), intent(inout) :: qin + ! -- formats +! ------------------------------------------------------------------------------ + ! -- inflow to lake + qin = this%inflow(ilak)%value + ! + ! -- return + return + end subroutine lak_calculate_inflow + + subroutine lak_calculate_external(this, ilak, ex) +! ****************************************************************************** +! lak_calculate_external -- Calculate the external flow terms to a lake. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + real(DP), intent(inout) :: ex + ! -- local + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- If mover is active, add receiver water to rhs and + ! store available water (as positive value) + ex = DZERO + if (this%imover == 1) then + ex = this%pakmvrobj%get_qfrommvr(ilak) + end if + ! + ! -- return + return + end subroutine lak_calculate_external + + subroutine lak_calculate_withdrawal(this, ilak, avail, wr) +! ****************************************************************************** +! lak_calculate_withdrawal -- Calculate the withdrawal from a lake subject to +! an available volume. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + real(DP), intent(inout) :: avail + real(DP), intent(inout) :: wr + ! -- local + ! -- formats +! ------------------------------------------------------------------------------ + ! -- withdrawals - limit to sum of inflows and available volume + wr = this%withdrawal(ilak)%value + if (wr > avail) then + wr = -avail + else + if (wr > DZERO) then + wr = -wr + end if + end if + avail = avail + wr + ! + ! -- return + return + end subroutine lak_calculate_withdrawal + + subroutine lak_calculate_evaporation(this, ilak, stage, avail, ev) +! ****************************************************************************** +! lak_calculate_evaporation -- Calculate the evaporation from a lake at a +! provided stage subject to an available volume. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + real(DP), intent(in) :: stage + real(DP), intent(inout) :: avail + real(DP), intent(inout) :: ev + ! -- local + real(DP) :: sa + ! -- formats +! ------------------------------------------------------------------------------ + ! -- evaporation - limit to sum of inflows and available volume + call this%lak_calculate_sarea(ilak, stage, sa) + ev = sa * this%evaporation(ilak)%value + if (ev > avail) then + ev = -avail + else + ev = -ev + end if + avail = avail + ev + ! + ! -- return + return + end subroutine lak_calculate_evaporation + + subroutine lak_calculate_outlet_inflow(this, ilak, outinf) +! ****************************************************************************** +! lak_calculate_outlet_inflow -- Calculate the outlet inflow to a lake. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + real(DP), intent(inout) :: outinf + ! -- local + integer(I4B) :: n + ! -- formats +! ------------------------------------------------------------------------------ + ! + outinf = DZERO + do n = 1, this%noutlets + if (this%lakeout(n) == ilak) then + outinf = outinf - this%simoutrate(n) + if (this%imover == 1) then + outinf = outinf - this%pakmvrobj%get_qtomvr(n) + end if + end if + end do + ! + ! -- return + return + end subroutine lak_calculate_outlet_inflow + + subroutine lak_calculate_outlet_outflow(this, ilak, stage, avail, outoutf) +! ****************************************************************************** +! lak_calculate_outlet_outflow -- Calculate the outlet outflow from a lake. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + real(DP), intent(in) :: stage + real(DP), intent(inout) :: avail + real(DP), intent(inout) :: outoutf + ! -- local + integer(I4B) :: n + real(DP) :: g + real(DP) :: d + real(DP) :: c + real(DP) :: gsm + real(DP) :: rate + ! -- formats +! ------------------------------------------------------------------------------ + ! + outoutf = DZERO + do n = 1, this%noutlets + if (this%lakein(n) == ilak) then + rate = DZERO + d = stage - this%outinvert(n)%value + if (this%outdmax > DZERO) then + if (d > this%outdmax) d = this%outdmax + end if + g = DGRAVITY * this%convlength * this%convtime * this%convtime + select case (this%iouttype(n)) + ! specified rate + case(0) + rate = this%outrate(n)%value + if (-rate > avail) then + rate = -avail + end if + ! manning + case (1) + if (d > DZERO) then + c = (this%convlength**DONETHIRD) * this%convtime + gsm = DZERO + if (this%outrough(n)%value > DZERO) then + gsm = DONE / this%outrough(n)%value + end if + rate = -c * gsm * this%outwidth(n)%value * ( d**DFIVETHIRDS ) * sqrt(this%outslope(n)%value) + end if + ! weir + case (2) + if (d > DZERO) then + rate = -DTWOTHIRDS * DCD * this%outwidth(n)%value * d * sqrt(DTWO * g * d) + end if + end select + !if (-rate > avail) then + ! rate = -avail + !end if + this%simoutrate(n) = rate + avail = avail + rate + outoutf = outoutf + rate + end if + end do + ! + ! -- return + return + end subroutine lak_calculate_outlet_outflow + + subroutine lak_get_internal_inlet(this, ilak, outinf) +! ****************************************************************************** +! lak_get_internal_inlet -- Get the outlet inflow to a lake from another lake. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + real(DP), intent(inout) :: outinf + ! -- local + integer(I4B) :: n + ! -- formats +! ------------------------------------------------------------------------------ + outinf = DZERO + do n = 1, this%noutlets + if (this%lakeout(n) == ilak) then + outinf = outinf - this%simoutrate(n) + if (this%imover == 1) then + outinf = outinf - this%pakmvrobj%get_qtomvr(n) + end if + end if + end do + ! + ! -- return + return + end subroutine lak_get_internal_inlet + + subroutine lak_get_internal_outlet(this, ilak, outoutf) +! ****************************************************************************** +! lak_get_internal_outlet -- Get the outlet from a lake to another lake. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + real(DP), intent(inout) :: outoutf + ! -- local + integer(I4B) :: n + ! -- formats +! ------------------------------------------------------------------------------ + outoutf = DZERO + do n = 1, this%noutlets + if (this%lakein(n) == ilak) then + if (this%lakeout(n) < 1) cycle + outoutf = outoutf + this%simoutrate(n) + end if + end do + ! + ! -- return + return + end subroutine lak_get_internal_outlet + + subroutine lak_get_external_outlet(this, ilak, outoutf) +! ****************************************************************************** +! lak_get_external_outlet -- Get the outlet outflow from a lake to an external +! boundary. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + real(DP), intent(inout) :: outoutf + ! -- local + integer(I4B) :: n + ! -- formats +! ------------------------------------------------------------------------------ + outoutf = DZERO + do n = 1, this%noutlets + if (this%lakein(n) == ilak) then + if (this%lakeout(n) > 0) cycle + outoutf = outoutf + this%simoutrate(n) + end if + end do + ! + ! -- return + return + end subroutine lak_get_external_outlet + + subroutine lak_get_external_mover(this, ilak, outoutf) +! ****************************************************************************** +! lak_get_external_mover -- Get the mover outflow from a lake to an external +! boundary. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + real(DP), intent(inout) :: outoutf + ! -- local + integer(I4B) :: n + ! -- formats +! ------------------------------------------------------------------------------ + outoutf = DZERO + if (this%imover == 1) then + do n = 1, this%noutlets + if (this%lakein(n) == ilak) then + if (this%lakeout(n) > 0) cycle + outoutf = outoutf + this%pakmvrobj%get_qtomvr(n) + end if + end do + end if + ! + ! -- return + return + end subroutine lak_get_external_mover + + subroutine lak_get_internal_mover(this, ilak, outoutf) +! ****************************************************************************** +! lak_get_internal_mover -- Get the mover outflow from a lake to another lake. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + real(DP), intent(inout) :: outoutf + ! -- local + integer(I4B) :: n + ! -- formats +! ------------------------------------------------------------------------------ + outoutf = DZERO + if (this%imover == 1) then + do n = 1, this%noutlets + if (this%lakein(n) == ilak) then + if (this%lakeout(n) < 1) cycle + outoutf = outoutf + this%pakmvrobj%get_qtomvr(n) + end if + end do + end if + ! + ! -- return + return + end subroutine lak_get_internal_mover + + subroutine lak_get_outlet_tomover(this, ilak, outoutf) +! ****************************************************************************** +! llak_get_outlet_tomover -- Get the outlet to mover from a lake. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + real(DP), intent(inout) :: outoutf + ! -- local + integer(I4B) :: n + ! -- formats +! ------------------------------------------------------------------------------ + outoutf = DZERO + if (this%imover == 1) then + do n = 1, this%noutlets + if (this%lakein(n) == ilak) then + outoutf = outoutf + this%pakmvrobj%get_qtomvr(n) + end if + end do + end if + ! + ! -- return + return + end subroutine lak_get_outlet_tomover + + subroutine lak_vol2stage(this, ilak, vol, stage) +! ****************************************************************************** +! lak_vol2stage-- Determine the stage from a provided volume. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + real(DP), intent(in) :: vol + real(DP), intent(inout) :: stage + ! -- local + integer(I4B) :: i + integer(I4B) :: ibs + real(DP) :: s0, s1, sm + real(DP) :: v0, v1, vm + real(DP) :: f0, f1, fm + real(DP) :: sa + real(DP) :: en0, en1 + real(DP) :: ds, ds0 + real(DP) :: denom + ! -- formats +! ------------------------------------------------------------------------------ + s0 = this%lakebot(ilak) + call this%lak_calculate_vol(ilak, s0, v0) + s1 = this%laketop(ilak) + call this%lak_calculate_vol(ilak, s1, v1) + ! -- zero volume + if (vol <= v0) then + stage = s0 + ! -- linear relation between stage and volume above top of lake + else if (vol >= v1) then + call this%lak_calculate_sarea(ilak, s1, sa) + stage = s1 + (vol - v1) / sa + ! -- use combination of secant and bisection + else + en0 = s0 + en1 = s1 + ! sm = s1 ! causes divide by zero in 1st line in secantbisection loop + ! sm = s0 ! causes divide by zero in 1st line in secantbisection loop + sm = DZERO + f0 = vol - v0 + f1 = vol - v1 + ibs = 0 + secantbisection: do i = 1, 150 + denom = f1 - f0 + if (denom /= DZERO) then + ds = f1 * (s1 - s0) / denom + else + ibs = 13 + end if + if (i == 1) then + ds0 = ds + end if + ! -- use bisection if end points are exceeded + if (sm < en0 .or. sm > en1) ibs = 13 + ! -- use bisection if secant method stagnates or if + ! ds exceeds previous ds - bisection would occur + ! after conditions exceeded in 13 iterations + if (ds*ds0 < DPREC .or. ABS(ds) > ABS(ds0)) ibs = ibs + 1 + if (ibs > 12) then + ds = DHALF * (s1 - s0) + ibs = 0 + end if + sm = s1 - ds + if (ABS(ds) < DEM6) then + exit secantbisection + end if + call this%lak_calculate_vol(ilak, sm, vm) + fm = vol - vm + s0 = s1 + f0 = f1 + s1 = sm + f1 = fm + ds0 = ds + end do secantbisection + stage = sm + if (ABS(ds) >= DEM6) then + write(this%iout, '(1x,a,1x,i5,4(1x,a,1x,g15.6))') & + & 'LAK_VOL2STAGE failed for lake', ilak, 'volume error =', fm, & + & 'finding stage (', stage, ') for volume =', vol, & + & 'final change in stage =', ds + end if + end if + ! + ! -- return + return + end subroutine lak_vol2stage + + + function lak_check_valid(this, itemno) result(ierr) +! ****************************************************************************** +! lak_check_valid -- Determine if a valid lake or outlet number has been +! specified. +! ****************************************************************************** + use SimModule, only: ustop, store_error + ! -- return + integer(I4B) :: ierr + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: itemno + ! -- local + character(len=LINELENGTH) :: errmsg + integer(I4B) :: ival + ! -- formats +! ------------------------------------------------------------------------------ + ierr = 0 + ival = abs(itemno) + if (itemno > 0) then + if (ival < 1 .or. ival > this%nlakes) then + write(errmsg,'(4x,a,1x,i6,1x,a,1x,i6)') & + '****ERROR. LAKENO ', itemno, 'MUST BE > 0 and <= ', this%nlakes + call store_error(errmsg) + ierr = 1 + end if + else + if (ival < 1 .or. ival > this%noutlets) then + write(errmsg,'(4x,a,1x,i6,1x,a,1x,i6)') & + '****ERROR. IOUTLET ', itemno, 'MUST BE > 0 and <= ', this%noutlets + call store_error(errmsg) + ierr = 1 + end if + end if + end function lak_check_valid + + subroutine lak_set_stressperiod(this, itemno, line) +! ****************************************************************************** +! lak_set_stressperiod -- Set a stress period attribute for lakweslls(itemno) +! using keywords. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + !use ConstantsModule, only: LINELENGTH, DTWO + use TdisModule, only: kper, perlen, totimsav + use TimeSeriesManagerModule, only: read_single_value_or_time_series + use InputOutputModule, only: urword + use SimModule, only: ustop, store_error + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: itemno + character (len=*), intent(in) :: line + ! -- local + character(len=LINELENGTH) :: text + character(len=LINELENGTH) :: caux + character(len=LINELENGTH) :: keyword + character(len=LINELENGTH) :: errmsg + character(len=LENBOUNDNAME) :: bndName + character(len=9) :: citem + integer(I4B) :: ierr + integer(I4B) :: itmp + integer(I4B) :: ival, istart, istop + integer(I4B) :: i0 + integer(I4B) :: lloc + integer(I4B) :: ii + integer(I4B) :: jj + integer(I4B) :: iaux + real(DP) :: rval + real(DP) :: endtim + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- Find time interval of current stress period. + endtim = totimsav + perlen(kper) + ! + ! -- write abs(itemno) to citem string + itmp = ABS(itemno) + write(citem,'(i9.9)') itmp + ! + ! -- Assign boundary name + if (this%inamedbound==1) then + bndName = this%boundname(itemno) + else + bndName = '' + end if + ! + ! -- read line + lloc = 1 + call urword(line, lloc, istart, istop, 1, ival, rval, this%iout, this%inunit) + i0 = istart + keyword = line(istart:istop) + select case (line(istart:istop)) + case ('STATUS') + ierr = this%lak_check_valid(itemno) + if (ierr /= 0) goto 999 + !bndName = this%boundname(itemno) + call urword(line, lloc, istart, istop, 1, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + this%status(itmp) = text(1:8) + if (text == 'CONSTANT') then + this%iboundpak(itmp) = -1 + else if (text == 'INACTIVE') then + this%iboundpak(itmp) = 0 + else if (text == 'ACTIVE') then + this%iboundpak(itmp) = 1 + else + write(errmsg,'(4x,a,a)') & + '****ERROR. UNKNOWN '//trim(this%text)//' LAK STATUS KEYWORD: ', & + text + call store_error(errmsg) + end if + case ('STAGE') + ierr = this%lak_check_valid(itemno) + if (ierr /= 0) goto 999 + !bndName = this%boundname(itemno) + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 1 ! For STAGE + call read_single_value_or_time_series(text, & + this%stage(itmp)%value, & + this%stage(itmp)%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, itmp, jj, 'STAGE', & + bndName, this%inunit) + case ('RAINFALL') + ierr = this%lak_check_valid(itemno) + if (ierr /= 0) goto 999 + !bndName = this%boundname(itemno) + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 1 ! For RAINFALL + call read_single_value_or_time_series(text, & + this%rainfall(itmp)%value, & + this%rainfall(itmp)%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, itmp, jj, 'RAINFALL', & + bndName, this%inunit) + if (this%rainfall(itmp)%value < DZERO) then + write(errmsg, '(4x, a, i0, a, G0, a)') & + '****ERROR. LAKE ', itmp, ' WAS ASSIGNED A RAINFALL VALUE OF ', & + this%rainfall(itmp)%value, '. RAINFALL MUST BE POSITIVE.' + call store_error(errmsg) + end if + case ('EVAPORATION') + ierr = this%lak_check_valid(itemno) + if (ierr /= 0) goto 999 + !bndName = this%boundname(itemno) + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 1 ! For EVAPORATION + call read_single_value_or_time_series(text, & + this%evaporation(itmp)%value, & + this%evaporation(itmp)%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, itmp, jj, 'EVAPORATION', & + bndName, this%inunit) + if (this%evaporation(itmp)%value < DZERO) then + write(errmsg, '(4x, a, i0, a, G0, a)') & + '****ERROR. LAKE ', itmp, ' WAS ASSIGNED AN EVAPORATION VALUE OF ', & + this%evaporation(itmp)%value, '. EVAPORATION MUST BE POSITIVE.' + call store_error(errmsg) + end if + case ('RUNOFF') + ierr = this%lak_check_valid(itemno) + if (ierr /= 0) goto 999 + !bndName = this%boundname(itemno) + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 1 ! For RUNOFF + call read_single_value_or_time_series(text, & + this%runoff(itmp)%value, & + this%runoff(itmp)%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, itmp, jj, 'RUNOFF', & + bndName, this%inunit) + if (this%runoff(itmp)%value < DZERO) then + write(errmsg, '(4x, a, i0, a, G0, a)') & + '****ERROR. LAKE ', itmp, ' WAS ASSIGNED A RUNOFF VALUE OF ', & + this%runoff(itmp)%value, '. RUNOFF MUST BE POSITIVE.' + call store_error(errmsg) + end if + case ('INFLOW') + ierr = this%lak_check_valid(itemno) + if (ierr /= 0) goto 999 + !bndName = this%boundname(itemno) + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 1 ! For specified INFLOW + call read_single_value_or_time_series(text, & + this%inflow(itmp)%value, & + this%inflow(itmp)%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, itmp, jj, 'INFLOW', & + bndName, this%inunit) + if (this%inflow(itmp)%value < DZERO) then + write(errmsg, '(4x, a, i0, a, G0, a)') & + '****ERROR. LAKE ', itmp, ' WAS ASSIGNED AN INFLOW VALUE OF ', & + this%inflow(itmp)%value, '. INFLOW MUST BE POSITIVE.' + call store_error(errmsg) + end if + case ('WITHDRAWAL') + ierr = this%lak_check_valid(itemno) + if (ierr /= 0) goto 999 + !bndName = this%boundname(itemno) + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 1 ! For specified WITHDRAWAL + call read_single_value_or_time_series(text, & + this%withdrawal(itmp)%value, & + this%withdrawal(itmp)%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, itmp, jj, 'WITHDRAWAL', & + bndName, this%inunit) + if (this%withdrawal(itmp)%value < DZERO) then + write(errmsg, '(4x, a, i0, a, G0, a)') & + '****ERROR. LAKE ', itmp, ' WAS ASSIGNED A WITHDRAWAL VALUE OF ', & + this%withdrawal(itmp)%value, '. WITHDRAWAL MUST BE POSITIVE.' + call store_error(errmsg) + end if + case ('RATE') + ierr = this%lak_check_valid(-itemno) + if (ierr /= 0) goto 999 + bndName = 'OUTLET' // citem + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 1 ! For specified OUTLET RATE + call read_single_value_or_time_series(text, & + this%outrate(itmp)%value, & + this%outrate(itmp)%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, itmp, jj, 'OUTRATE', & + bndName, this%inunit) + case ('INVERT') + ierr = this%lak_check_valid(-itemno) + if (ierr /= 0) goto 999 + bndName = 'OUTLET' // citem + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 1 ! For OUTLET INVERT + call read_single_value_or_time_series(text, & + this%outinvert(itmp)%value, & + this%outinvert(itmp)%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, itmp, jj, 'OUTINVERT', & + bndName,this%inunit) + case ('WIDTH') + ierr = this%lak_check_valid(-itemno) + if (ierr /= 0) goto 999 + bndName = 'OUTLET' // citem + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 1 ! For OUTLET WIDTH + call read_single_value_or_time_series(text, & + this%outwidth(itmp)%value, & + this%outwidth(itmp)%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, itmp, jj, 'OUTWIDTH', & + bndName, this%inunit) + case ('ROUGH') + ierr = this%lak_check_valid(-itemno) + if (ierr /= 0) goto 999 + bndName = 'OUTLET' // citem + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 1 ! For OUTLET ROUGHNESS + call read_single_value_or_time_series(text, & + this%outrough(itmp)%value, & + this%outrough(itmp)%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, itmp, jj, 'OUTROUGH', & + bndName, this%inunit) + case ('SLOPE') + ierr = this%lak_check_valid(-itemno) + if (ierr /= 0) goto 999 + bndName = 'OUTLET' // citem + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 1 ! For OUTLET SLOPE + call read_single_value_or_time_series(text, & + this%outslope(itmp)%value, & + this%outslope(itmp)%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, itmp, jj, 'OUTSLOPE', & + bndName, this%inunit) + case ('AUXILIARY') + ierr = this%lak_check_valid(itemno) + if (ierr /= 0) goto 999 + !bndName = this%boundname(itemno) + call urword(line, lloc, istart, istop, 1, ival, rval, this%iout, this%inunit) + caux = line(istart:istop) + do iaux = 1, this%naux + if (trim(adjustl(caux)) /= trim(adjustl(this%auxname(iaux)))) cycle + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 1 !iaux + ii = (itmp-1) * this%naux + iaux + call read_single_value_or_time_series(text, & + this%lauxvar(ii)%value, & + this%lauxvar(ii)%name, & + endtim, & + this%Name, 'AUX', this%TsManager, & + this%iprpak, itmp, jj, & + this%auxname(iaux), bndName, & + this%inunit) + exit + end do + case default + write(errmsg,'(4x,a,a)') & + '****ERROR. UNKNOWN '//trim(this%text)//' LAK DATA KEYWORD: ', & + line(istart:istop) + call store_error(errmsg) + call ustop() + end select + ! + ! -- terminate if any errors were detected +999 if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- write keyword data to output file + if (this%iprpak /= 0) then + write(this%iout, '(3x,i10,1x,a)') itmp, line(i0:istop) + end if + ! + ! -- return + return + end subroutine lak_set_stressperiod + + + subroutine lak_set_attribute_error(this, ilak, keyword, msg) +! ****************************************************************************** +! lak_set_attribute_error -- Issue a parameter error for lakweslls(ilak) +! Subroutine: (1) read itmp +! (2) read new boundaries if itmp>0 +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use SimModule, only: store_error + ! -- dummy + class(LakType),intent(inout) :: this + integer(I4B), intent(in) :: ilak + character (len=*), intent(in) :: keyword + character (len=*), intent(in) :: msg + ! -- local + character(len=LINELENGTH) :: errmsg + ! -- formats +! ------------------------------------------------------------------------------ + if (len(msg) == 0) then + write(errmsg,'(4x,a,1x,a,1x,a,1x,i6,1x,a)') & + '****ERROR.', keyword, ' for LAKE', ilak, 'has already been set.' + else + write(errmsg,'(4x,a,1x,a,1x,a,1x,i6,1x,a)') & + '****ERROR.', keyword, ' for LAKE', ilak, msg + end if + call store_error(errmsg) + ! -- return + return + end subroutine lak_set_attribute_error + + subroutine lak_options(this, option, found) +! ****************************************************************************** +! lak_options -- set options specific to LakType +! +! lak_options overrides BndType%bnd_options +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: MAXCHARLEN, DZERO + use OpenSpecModule, only: access, form + use SimModule, only: ustop, store_error + use InputOutputModule, only: urword, getunit, openfile + ! -- dummy + class(LakType), intent(inout) :: this + character(len=*), intent(inout) :: option + logical, intent(inout) :: found + ! -- local + character(len=MAXCHARLEN) :: fname, keyword + real(DP) :: r + ! -- formats + character(len=*),parameter :: fmtlengthconv = & + "(4x, 'LENGTH CONVERSION VALUE (',g15.7,') SPECIFIED.')" + character(len=*),parameter :: fmttimeconv = & + "(4x, 'TIME CONVERSION VALUE (',g15.7,') SPECIFIED.')" + character(len=*),parameter :: fmtoutdmax = & + "(4x, 'MAXIMUM OUTLET WATER DEPTH (',g15.7,') SPECIFIED.')" + character(len=*),parameter :: fmtlakeopt = & + "(4x, 'LAKE ', a, ' VALUE (',g15.7,') SPECIFIED.')" + character(len=*),parameter :: fmtlakbin = & + "(4x, 'LAK ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" +! ------------------------------------------------------------------------------ + ! + select case (option) + case ('PRINT_STAGE') + this%iprhed = 1 + write(this%iout,'(4x,a)') trim(adjustl(this%text))// & + ' STAGES WILL BE PRINTED TO LISTING FILE.' + found = .true. + case('STAGE') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%istageout = getunit() + call openfile(this%istageout, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE') + write(this%iout,fmtlakbin) 'STAGE', fname, this%istageout + found = .true. + else + call store_error('OPTIONAL STAGE KEYWORD MUST BE FOLLOWED BY FILEOUT') + end if + case('BUDGET') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ibudgetout = getunit() + call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE') + write(this%iout,fmtlakbin) 'BUDGET', fname, this%ibudgetout + found = .true. + else + call store_error('OPTIONAL BUDGET KEYWORD MUST BE FOLLOWED BY FILEOUT') + end if + case('PACKAGE_CONVERGENCE') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ipakcsv = getunit() + call openfile(this%ipakcsv, this%iout, fname, 'CSV', & + filstat_opt='REPLACE') + write(this%iout,fmtlakbin) 'PACKAGE_CONVERGENCE', fname, this%ipakcsv + found = .true. + else + call store_error('OPTIONAL PACKAGE_CONVERGENCE KEYWORD MUST BE ' // & + 'FOLLOWED BY FILEOUT') + end if + case('MOVER') + this%imover = 1 + write(this%iout, '(4x,A)') 'MOVER OPTION ENABLED' + found = .true. + case('LENGTH_CONVERSION') + this%convlength = this%parser%GetDouble() + write(this%iout, fmtlengthconv) this%convlength + found = .true. + case('TIME_CONVERSION') + this%convtime = this%parser%GetDouble() + write(this%iout, fmttimeconv) this%convtime + found = .true. + case('SURFDEP') + r = this%parser%GetDouble() + if (r < DZERO) then + r = DZERO + end if + this%surfdep = r + write(this%iout, fmtlakeopt) 'SURFDEP', this%surfdep + found = .true. + ! + ! -- right now these 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_GROUNDWATER_HEAD_CONDUCTANCE') + call this%parser%DevOpt() + this%igwhcopt = 1 + write(this%iout, '(4x,a)') & + & 'CONDUCTANCE FOR HORIZONTAL CONNECTIONS WILL BE CALCULATED ' // & + & 'USING THE GROUNDWATER HEAD' + found = .true. + case('DEV_MAXIMUM_OUTLET_DEPTH') + call this%parser%DevOpt() + this%outdmax = this%parser%GetDouble() + write(this%iout, fmtoutdmax) this%outdmax + found = .true. + case('DEV_NO_FINAL_CHECK') + call this%parser%DevOpt() + this%iconvchk = 0 + write(this%iout, '(4x,a)') & + & 'A FINAL CONVERGENCE CHECK OF THE CHANGE IN LAKE STAGES ' // & + & 'WILL NOT BE MADE' + found = .true. + case('DEV_NO_FINAL_RESIDUAL_CHECK') + call this%parser%DevOpt() + this%iconvresidchk = 0 + write(this%iout, '(4x,a)') & + & 'A FINAL CONVERGENCE CHECK OF THE CHANGE IN LAKE RESIDUALS ' // & + & 'WILL NOT BE MADE' + found = .true. + case('DEV_MAXIMUM_PERCENT_DIFFERENCE') + call this%parser%DevOpt() + r = this%parser%GetDouble() + if (r < DZERO) then + r = DEM1 + end if + this%pdmax = r + write(this%iout, fmtlakeopt) 'MAXIMUM_PERCENT_DIFFERENCE', this%pdmax + found = .true. + case default + ! + ! -- No options found + found = .false. + end select + ! + ! -- return + return + end subroutine lak_options + + subroutine lak_ar(this) + ! ****************************************************************************** + ! lak_ar -- Allocate and Read + ! Subroutine: (1) create new-style package + ! (2) point bndobj to the new package + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType),intent(inout) :: this + ! -- local + ! -- format + ! ------------------------------------------------------------------------------ + ! + call this%obs%obs_ar() + ! + ! -- Allocate arrays in LAK and in package superclass + call this%lak_allocate_arrays() + ! + ! -- read optional initial package parameters + call this%read_initial_attr() + ! + ! -- setup pakmvrobj + if (this%imover /= 0) then + allocate(this%pakmvrobj) + call this%pakmvrobj%ar(this%noutlets, this%nlakes, this%origin) + endif + ! + ! -- return + return + end subroutine lak_ar + + + subroutine lak_rp(this) +! ****************************************************************************** +! lak_rp -- Read and Prepare +! Subroutine: (1) read itmp +! (2) read new boundaries if itmp>0 +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use TdisModule, only: kper, nper + use SimModule, only: ustop, store_error, count_errors + ! -- dummy + class(LakType),intent(inout) :: this + ! -- local + integer(I4B) :: ierr + integer(I4B) :: node, n + logical :: isfound, endOfBlock + character(len=LINELENGTH) :: line + character(len=LINELENGTH) :: errmsg + integer(I4B) :: itemno + integer(I4B) :: j + integer(I4B) :: isfirst + ! -- formats + character(len=*),parameter :: fmtblkerr = & + "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + character(len=*),parameter :: fmtlsp = & + "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" +! ------------------------------------------------------------------------------ + ! + ! -- initialize flags + isfirst = 1 + ! + ! -- set nbound to maxbound + this%nbound = this%maxbound + ! + ! -- Set ionper to the stress period number for which a new block of data + ! will be read. + if(this%inunit == 0) return + ! + ! -- get stress period data + if (this%ionper < kper) then + ! + ! -- get period block + call this%parser%GetBlock('PERIOD', isfound, ierr, & + supportOpenClose=.true.) + if(isfound) then + ! + ! -- read ionper and check for increasing period numbers + call this%read_check_ionper() + else + ! + ! -- PERIOD block not found + if (ierr < 0) then + ! -- End of file found; data applies for remainder of simulation. + this%ionper = nper + 1 + else + ! -- Found invalid block + write(errmsg, fmtblkerr) adjustl(trim(line)) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end if + endif + end if + ! + ! -- Read data if ionper == kper + if(this%ionper == kper) then + + this%check_attr = 1 + stressperiod: do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + if (isfirst /= 0) then + isfirst = 0 + if (this%iprpak /= 0) then + write(this%iout,'(/1x,a,1x,i6,/)') & + 'READING '//trim(adjustl(this%text))//' DATA FOR PERIOD', kper + write(this%iout,'(3x,a)') ' LAKE KEYWORD AND DATA' + write(this%iout,'(3x,78("-"))') + end if + end if + itemno = this%parser%GetInteger() + call this%parser%GetRemainingLine(line) + call this%lak_set_stressperiod(itemno, line) + end do stressperiod + + if (this%iprpak /= 0) then + write(this%iout,'(/1x,a,1x,i6,/)') & + 'END OF '//trim(adjustl(this%text))//' DATA FOR PERIOD', kper + end if + ! + else + write(this%iout,fmtlsp) trim(this%filtyp) + endif + ! + !write summary of lake stress period error messages + ierr = count_errors() + if (ierr > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- fill arrays + do n = 1, this%nlakes + do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + node = this%cellid(j) + this%nodelist(j) = node + + this%bound(1,j) = this%xnewpak(n) + + this%bound(2,j) = this%satcond(j) + + this%bound(3,j) = this%belev(j) + + end do + end do + ! + ! -- return + return + end subroutine lak_rp + + subroutine lak_ad(this) +! ****************************************************************************** +! lak_ad -- Add package connection to matrix +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType) :: this + ! -- local + integer(I4B) :: n + integer(I4B) :: j, iaux, ii +! ------------------------------------------------------------------------------ + ! + ! -- Advance the time series + call this%TsManager%ad() + ! + ! -- update auxiliary variables by copying from the derived-type time + ! series variable into the bndpackage auxvar variable so that this + ! information is properly written to the GWF budget file + if (this%naux > 0) then + do n = 1, this%nlakes + do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1 + do iaux = 1, this%naux + ii = (n - 1) * this%naux + iaux + this%auxvar(iaux, j) = this%lauxvar(ii)%value + end do + end do + end do + end if + ! + ! -- copy xnew into xold and set xnewpak to stage%value for + ! constant stage lakes + do n = 1, this%nlakes + this%xoldpak(n) = this%xnewpak(n) + this%stageiter(n) = this%xnewpak(n) + if (this%iboundpak(n) < 0) then + this%xnewpak(n) = this%stage(n)%value + end if + this%seep0(n) = DZERO + end do + ! + ! -- pakmvrobj ad + if (this%imover == 1) then + call this%pakmvrobj%ad() + end if + ! + ! -- For each observation, push simulated value and corresponding + ! simulation time from "current" to "preceding" and reset + ! "current" value. + call this%obs%obs_ad() + ! + ! -- return + return + end subroutine lak_ad + + subroutine lak_cf(this, reset_mover) + ! ****************************************************************************** + ! lak_cf -- Formulate the HCOF and RHS terms + ! Subroutine: (1) skip if no lakes + ! (2) calculate hcof and rhs + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType) :: this + logical, intent(in), optional :: reset_mover + ! -- local + integer(I4B) :: j, n + integer(I4B) :: igwfnode + real(DP) :: hlak, blak + logical :: lrm + ! ------------------------------------------------------------------------------ + !! + !! -- Calculate lak conductance and update package RHS and HCOF + !call this%lak_cfupdate() + ! + ! -- save groundwater seepage for lake solution + do n = 1, this%nlakes + this%seep0(n) = this%seep(n) + end do + ! + ! -- save variables for convergence check + do n = 1, this%nlakes + this%s0(n) = this%xnewpak(n) + call this%lak_calculate_exchange(n, this%s0(n), this%qgwf0(n)) + end do + ! + ! -- pakmvrobj cf + lrm = .true. + if (present(reset_mover)) lrm = reset_mover + if(this%imover == 1 .and. lrm) then + call this%pakmvrobj%cf() + end if + ! + ! -- find highest active cell + do n = 1, this%nlakes + do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + ! -- skip horizontal connections + if (this%ictype(j) /= 0) then + cycle + end if + igwfnode = this%nodesontop(j) + if (this%ibound(igwfnode) == 0) then + call this%dis%highest_active(igwfnode, this%ibound) + end if + this%nodelist(j) = igwfnode + this%cellid(j) = igwfnode + end do + end do + ! + ! -- reset ibound for cells where lake stage is above the bottom + ! of the lake in the cell or the lake is inactive - only applied to + ! vertical connections + do n = 1, this%nlakes + ! + hlak = this%xnewpak(n) + ! + ! -- Go through lake connections + do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + ! + ! -- assign gwf node number + igwfnode = this%cellid(j) + ! + ! -- skip inactive or constant head GWF cells + if (this%ibound(igwfnode) < 1) then + cycle + end if + ! + ! -- skip horizontal connections + if (this%ictype(j) /= 0) then + cycle + end if + ! + ! -- skip embedded lakes + if (this%ictype(j) == 2 .or. this%ictype(j) == 3) then + cycle + end if + ! + ! -- Mark ibound for dry lakes; reset to 1 otherwise + blak = this%belev(j) + if (hlak > blak .or. this%iboundpak(n) == 0) then + this%ibound(igwfnode) = 10000 + else + this%ibound(igwfnode) = 1 + end if + end do + + end do + ! + ! -- Store the lake stage and cond in bound array for other + ! packages, such as the BUY package + call this%lak_bound_update() + ! + ! -- Return + return + end subroutine lak_cf + + subroutine lak_fc(this, rhs, ia, idxglo, amatsln) + ! ************************************************************************** + ! lak_fc -- Copy rhs and hcof into solution rhs and amat + ! ************************************************************************** + ! + ! SPECIFICATIONS: + ! -------------------------------------------------------------------------- + ! -- dummy + class(LakType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + real(DP), dimension(:), intent(inout) :: amatsln + ! -- local + integer(I4B) :: j, n + integer(I4B) :: igwfnode + integer(I4B) :: ipossymd +! -------------------------------------------------------------------------- + ! + ! -- pakmvrobj fc + if(this%imover == 1) then + call this%pakmvrobj%fc() + end if + ! + ! + ! -- make a stab at a solution + call this%lak_solve() + ! + ! -- add terms to the gwf matrix + do n = 1, this%nlakes + do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + igwfnode = this%cellid(j) + if (this%ibound(igwfnode) < 1) cycle + ipossymd = idxglo(ia(igwfnode)) + amatsln(ipossymd) = amatsln(ipossymd) + this%hcof(j) + rhs(igwfnode) = rhs(igwfnode) + this%rhs(j) + end do + end do + ! + ! -- return + return + end subroutine lak_fc + + subroutine lak_fn(this, rhs, ia, idxglo, amatsln) +! ************************************************************************** +! lak_fn -- Fill newton terms +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + ! -- dummy + class(LakType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + real(DP), dimension(:), intent(inout) :: amatsln + ! -- local + integer(I4B) :: j, n + integer(I4B) :: ipos + integer(I4B) :: igwfnode + integer(I4B) :: idry + real(DP) :: hlak + real(DP) :: avail + real(DP) :: ra + real(DP) :: ro + real(DP) :: qinf + real(DP) :: ex + real(DP) :: head + real(DP) :: clak1 + real(DP) :: q + real(DP) :: q1 + real(DP) :: rterm + real(DP) :: drterm +! -------------------------------------------------------------------------- + do n = 1, this%nlakes + if (this%iboundpak(n) == 0) cycle + hlak = this%xnewpak(n) + call this%lak_calculate_available(n, hlak, avail, & + ra, ro, qinf, ex, this%delh) + do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + igwfnode = this%cellid(j) + ipos = ia(igwfnode) + head = this%xnew(igwfnode) + if (-this%hcof(j) > DZERO) then + if (this%ibound(igwfnode) > 0) then + ! -- estimate lake-aquifer exchange with perturbed groundwater head + ! exchange is relative to the lake + !avail = DEP20 + call this%lak_estimate_conn_exchange(2, n, j, idry, hlak, head+this%delh, q1, clak1, avail) + q1 = -q1 + ! -- calculate unperturbed lake-aquifer exchange + q = this%hcof(j) * head - this%rhs(j) + ! -- calculate rterm + rterm = this%hcof(j) * head + ! -- calculate derivative + drterm = (q1 - q) / this%delh + ! -- add terms to convert conductance formulation into + ! newton-raphson formulation + amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + drterm - this%hcof(j) + rhs(igwfnode) = rhs(igwfnode) - rterm + drterm * head + end if + end if + end do + end do + + ! + ! -- return + return + end subroutine lak_fn + + subroutine lak_cc(this, kiter, iend, icnvgmod, cpak, dpak) +! ************************************************************************** +! lak_cc -- Final convergence check for package +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + use TdisModule, only: totim, kstp, kper, delt + ! -- dummy + class(LakType), intent(inout) :: this + integer(I4B), intent(in) :: kiter + integer(I4B), intent(in) :: iend + integer(I4B), intent(in) :: icnvgmod + character(len=LENPAKLOC), intent(inout) :: cpak + real(DP), intent(inout) :: dpak + ! -- local + character(len=LENPAKLOC) :: cloc + character(len=LINELENGTH) :: tag + integer(I4B) :: icheck + integer(I4B) :: ipakfail + integer(I4B) :: locdhmax + integer(I4B) :: locdgwfmax + integer(I4B) :: locdqoutmax + integer(I4B) :: ntabrows + integer(I4B) :: ntabcols + integer(I4B) :: n + real(DP) :: area + real(DP) :: gwf0 + real(DP) :: gwf + real(DP) :: dh + real(DP) :: dgwf + real(DP) :: hlak0 + real(DP) :: hlak + real(DP) :: qout0 + real(DP) :: qout + real(DP) :: dqout + real(DP) :: inf + real(DP) :: ra + real(DP) :: ro + real(DP) :: qinf + real(DP) :: ex + real(DP) :: dhmax + real(DP) :: dgwfmax + real(DP) :: dqoutmax + ! format +! -------------------------------------------------------------------------- + ! + ! -- initialize local variables + icheck = this%iconvchk + ipakfail = 0 + locdhmax = 0 + locdgwfmax = 0 + locdqoutmax = 0 + dhmax = DZERO + dgwfmax = DZERO + dqoutmax = DZERO + ! + ! -- if not saving package convergence data on check convergence if + ! the model is considered converged + if (this%ipakcsv == 0) then + if (icnvgmod == 0) then + icheck = 0 + end if + ! + ! -- saving package convergence data + else + ! + ! -- header for package csv + if (.not. associated(this%pakcsvtab)) then + ! + ! -- determine the number of columns and rows + ntabrows = 1 + ntabcols = 8 + if (this%noutlets > 0) then + ntabcols = ntabcols + 2 + end if + ! + ! -- setup table + call table_cr(this%pakcsvtab, this%name, '') + call this%pakcsvtab%table_df(ntabrows, ntabcols, this%ipakcsv, & + lineseparator=.FALSE., separator=',', & + finalize=.FALSE.) + ! + ! -- add columns to package csv + tag = 'totim' + call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'kper' + call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'kstp' + call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'nouter' + call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'dvmax' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + tag = 'dvmax_loc' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + tag = 'dgwfmax' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + tag = 'dgwfmax_loc' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + if (this%noutlets > 0) then + tag = 'dqoutmax' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + tag = 'dqoutmax_loc' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + end if + end if + end if + ! + ! -- perform package convergence check + if (icheck /= 0) then + final_check: do n = 1, this%nlakes + if (this%iboundpak(n) < 1) cycle + ! + ! -- set previous and current lake stage + hlak0 = this%s0(n) + hlak = this%xnewpak(n) + ! + ! -- stage difference + dh = hlak0 - hlak + ! + ! -- calculate surface area + call this%lak_calculate_sarea(n, hlak, area) + ! + ! -- change in gwf exchange + dgwf = DZERO + if (area > DZERO) then + gwf0 = this%qgwf0(n) + call this%lak_calculate_exchange(n, hlak, gwf) + dgwf = (gwf0 - gwf) * delt / area + end if + ! + ! -- change in outflows + dqout = DZERO + if (this%noutlets > 0) then + if (area > DZERO) then + call this%lak_calculate_available(n, hlak0, inf, ra, ro, qinf, ex) + call this%lak_calculate_outlet_outflow(n, hlak0, inf, qout0) + call this%lak_calculate_available(n, hlak, inf, ra, ro, qinf, ex) + call this%lak_calculate_outlet_outflow(n, hlak, inf, qout) + dqout = (qout0 - qout) * delt / area + end if + end if + ! + ! -- evaluate magnitude of differences + if (n == 1) then + locdhmax = n + dhmax = dh + locdgwfmax = n + dgwfmax = dgwf + locdqoutmax = n + dqoutmax = dqout + else + if (abs(dh) > abs(dhmax)) then + locdhmax = n + dhmax = dh + end if + if (abs(dgwf) > abs(dgwfmax)) then + locdgwfmax = n + dgwfmax = dgwf + end if + if (abs(dqout) > abs(dqoutmax)) then + locdqoutmax = n + dqoutmax = dqout + end if + end if + end do final_check + ! + ! -- set dpak and cpak + if (ABS(dhmax) > abs(dpak)) then + dpak = dhmax + write(cloc, "(a,'-(',i0,')-',a)") & + trim(this%name), locdhmax, 'stage' + cpak = trim(cloc) + end if + if (ABS(dgwfmax) > abs(dpak)) then + dpak = dgwfmax + write(cloc, "(a,'-(',i0,')-',a)") & + trim(this%name), locdhmax, 'gwf' + cpak = trim(cloc) + end if + if (this%noutlets > 0) then + if (ABS(dqoutmax) > abs(dpak)) then + dpak = dqoutmax + write(cloc, "(a,'-(',i0,')-',a)") & + trim(this%name), locdhmax, 'outlet' + cpak = trim(cloc) + end if + end if + ! + ! -- write convergence data to package csv + if (this%ipakcsv /= 0) then + ! + ! -- write the data + call this%pakcsvtab%add_term(totim) + call this%pakcsvtab%add_term(kper) + call this%pakcsvtab%add_term(kstp) + call this%pakcsvtab%add_term(kiter) + call this%pakcsvtab%add_term(dhmax) + call this%pakcsvtab%add_term(locdhmax) + call this%pakcsvtab%add_term(dgwfmax) + call this%pakcsvtab%add_term(locdgwfmax) + if (this%noutlets > 0) then + call this%pakcsvtab%add_term(dqoutmax) + call this%pakcsvtab%add_term(locdqoutmax) + end if + ! + ! -- finalize the package csv + if (iend == 1) then + call this%pakcsvtab%finalize_table() + end if + end if + end if + ! + ! -- return + return + end subroutine lak_cc + + subroutine lak_bd(this, x, idvfl, icbcfl, ibudfl, icbcun, iprobs, & + isuppress_output, model_budget, imap, iadv) +! ****************************************************************************** +! lak_bd -- Calculate Volumetric Budget for the lake +! Note that the compact budget will always be used. +! Subroutine: (1) Process each package entry +! (2) Write output +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: kstp, kper, delt, pertim, totim + use ConstantsModule, only: LENBOUNDNAME, DHNOFLO, DHDRY + use BudgetModule, only: BudgetType + use InputOutputModule, only: ulasav, ubdsv06 + ! -- dummy + class(LakType) :: this + real(DP),dimension(:),intent(in) :: x + integer(I4B), intent(in) :: idvfl + integer(I4B), intent(in) :: icbcfl + integer(I4B), intent(in) :: ibudfl + integer(I4B), intent(in) :: icbcun + integer(I4B), intent(in) :: iprobs + integer(I4B), intent(in) :: isuppress_output + type(BudgetType), intent(inout) :: model_budget + integer(I4B), dimension(:), optional, intent(in) :: imap + integer(I4B), optional, intent(in) :: iadv + ! -- local + integer(I4B) :: ibinun + real(DP) :: rrate + real(DP) :: chratin, chratout + ! -- for budget + integer(I4B) :: j, n + integer(I4B) :: igwfnode + real(DP) :: hlak, hgwf + real(DP) :: v0, v1 + real(DP) :: cond + !real(DP) :: blak + !real(DP) :: s + real(DP) :: d + real(DP) :: v + ! -- for observations + integer(I4B) :: iprobslocal + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- recalculate package HCOF and RHS terms with latest groundwater and + ! lak heads prior to calling base budget functionality + !call this%lak_cfupdate() + ! + ! -- update the lake hcof and rhs terms + call this%lak_solve(.false.) + ! + ! -- Suppress saving of simulated values; they + ! will be saved at end of this procedure. + iprobslocal = 0 + ! + ! -- call base functionality in bnd_bd + call this%BndType%bnd_bd(x, idvfl, icbcfl, ibudfl, icbcun, iprobslocal, & + isuppress_output, model_budget, this%imap, & + iadv=1) + ! + ! -- calculate several budget terms + chratin = DZERO + chratout = DZERO + do n = 1, this%nlakes + this%chterm(n) = DZERO + if (this%iboundpak(n) == 0) cycle + hlak = this%xnewpak(n) + call this%lak_calculate_vol(n, hlak, v1) + ! -- add budget terms for active lakes + if (this%iboundpak(n) /= 0) then + ! + ! -- rainfall + rrate = this%precip(n) + call this%lak_accumulate_chterm(n, rrate, chratin, chratout) + ! + ! -- evaporation + rrate = this%evap(n) + call this%lak_accumulate_chterm(n, rrate, chratin, chratout) + ! + ! -- runoff + rrate = this%runoff(n)%value + call this%lak_accumulate_chterm(n, rrate, chratin, chratout) + ! + ! -- inflow + rrate = this%inflow(n)%value + call this%lak_accumulate_chterm(n, rrate, chratin, chratout) + ! + ! -- withdrawals + rrate = this%withr(n) + call this%lak_accumulate_chterm(n, rrate, chratin, chratout) + ! + ! -- add lake storage changes + rrate = DZERO + if (this%iboundpak(n) > 0) then + if (this%gwfiss /= 1) then + call this%lak_calculate_vol(n, this%xoldpak(n), v0) + rrate = -(v1 - v0) / delt + call this%lak_accumulate_chterm(n, rrate, chratin, chratout) + end if + end if + this%qsto(n) = rrate + ! + ! -- add external outlets + call this%lak_get_external_outlet(n, rrate) + call this%lak_accumulate_chterm(n, rrate, chratin, chratout) + ! + ! -- add mover terms + if (this%imover == 1) then + if (this%iboundpak(n) /= 0) then + rrate = this%pakmvrobj%get_qfrommvr(n) + else + rrate = DZERO + end if + call this%lak_accumulate_chterm(n, rrate, chratin, chratout) + endif + end if + end do + ! + ! -- gwf flow and constant flow to lake + do n = 1, this%nlakes + if (this%iboundpak(n) == 0) cycle + rrate = DZERO + hlak = this%xnewpak(n) + do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + igwfnode = this%cellid(j) + hgwf = this%xnew(igwfnode) + call this%lak_calculate_conn_exchange(n, j, hlak, hgwf, rrate, cond) + !blak = this%belev(j) + !if (-this%hcof(j) > DZERO) then + ! if (hgwf >= blak) then + ! s = max(hlak, blak) + ! rrate = this%hcof(j) * (s - hgwf) + ! else + ! rrate = this%rhs(j) + ! end if + !else + ! rrate = this%rhs(j) + !end if + this%qleak(j) = rrate + call this%lak_accumulate_chterm(n, rrate, chratin, chratout) + end do + end do + ! + ! -- For continuous observations, save simulated values. + if (this%obs%npakobs > 0 .and. iprobs > 0) then + call this%lak_bd_obs() + endif + ! + ! -- set unit number for binary dependent variable output + ibinun = 0 + if(this%istageout /= 0) then + ibinun = this%istageout + end if + if(idvfl == 0) ibinun = 0 + if (isuppress_output /= 0) ibinun = 0 + ! + ! -- write lake binary output + if (ibinun > 0) then + do n = 1, this%nlakes + v = this%xnewpak(n) + d = v - this%lakebot(n) + if (this%iboundpak(n) == 0) then + v = DHNOFLO + else if (d <= DZERO) then + v = DHDRY + end if + this%dbuff(n) = v + end do + call ulasav(this%dbuff, ' STAGE', kstp, kper, pertim, totim, & + this%nlakes, 1, 1, ibinun) + end if + ! + ! -- fill the budget object + call this%lak_fill_budobj() + ! + ! -- write the flows from the budobj + ibinun = 0 + if(this%ibudgetout /= 0) then + ibinun = this%ibudgetout + end if + if(icbcfl == 0) ibinun = 0 + if (isuppress_output /= 0) ibinun = 0 + if (ibinun > 0) then + call this%budobj%save_flows(this%dis, ibinun, kstp, kper, delt, & + pertim, totim, this%iout) + end if + ! + ! -- return + return + end subroutine lak_bd + + subroutine lak_ot(this, kstp, kper, iout, ihedfl, ibudfl) + ! ************************************************************************** + ! lak_ot -- Output package budget + ! ************************************************************************** + ! + ! SPECIFICATIONS: + ! -------------------------------------------------------------------------- + use InputOutputModule, only: UWWORD + ! -- dummy + class(LakType) :: this + integer(I4B),intent(in) :: kstp + integer(I4B),intent(in) :: kper + integer(I4B),intent(in) :: iout + integer(I4B),intent(in) :: ihedfl + integer(I4B),intent(in) :: ibudfl + ! -- locals + character(len=LINELENGTH) :: line, linesep + character(len=16) :: text + integer(I4B) :: n + integer(I4B) :: iloc + real(DP) :: q + ! format + 2000 FORMAT ( 1X, ///1X, A, A, A, ' PERIOD ', I6, ' STEP ', I8) + ! -------------------------------------------------------------------------- + ! + ! -- write lake stage + if (ihedfl /= 0 .and. this%iprhed /= 0) then + write(iout, 2000) 'LAKE (', trim(this%name), ') STAGE', kper, kstp + iloc = 1 + line = '' + if (this%inamedbound==1) then + call UWWORD(line, iloc, 16, TABUCSTRING, & + 'lake', n, q, ALIGNMENT=TABLEFT) + end if + call UWWORD(line, iloc, 6, TABUCSTRING, & + 'lake', n, q, ALIGNMENT=TABCENTER, SEP=' ') + call UWWORD(line, iloc, 11, TABUCSTRING, & + 'lake', n, q, ALIGNMENT=TABCENTER) + ! -- create line separator + linesep = repeat('-', iloc) + ! -- write first line + write(iout,'(1X,A)') linesep(1:iloc) + write(iout,'(1X,A)') line(1:iloc) + ! -- create second header line + iloc = 1 + line = '' + if (this%inamedbound==1) then + call UWWORD(line, iloc, 16, TABUCSTRING, & + 'name', n, q, ALIGNMENT=TABLEFT) + end if + call UWWORD(line, iloc, 6, TABUCSTRING, & + 'no.', n, q, ALIGNMENT=TABCENTER, SEP=' ') + call UWWORD(line, iloc, 11, TABUCSTRING, & + 'stage', n, q, ALIGNMENT=TABCENTER) + ! -- write second line + write(iout,'(1X,A)') line(1:iloc) + write(iout,'(1X,A)') linesep(1:iloc) + ! -- write data + do n = 1, this%nlakes + iloc = 1 + line = '' + if (this%inamedbound==1) then + call UWWORD(line, iloc, 16, TABUCSTRING, & + this%lakename(n), n, q, ALIGNMENT=TABLEFT) + end if + call UWWORD(line, iloc, 6, TABINTEGER, text, n, q, SEP=' ') + call UWWORD(line, iloc, 11, TABREAL, text, n, this%xnewpak(n)) + write(iout, '(1X,A)') line(1:iloc) + end do + end if + ! + ! -- Output lake flow table + if (ibudfl /= 0 .and. this%iprflow /= 0) then + call this%budobj%write_flowtable(this%dis) + end if + ! + ! -- Output lake budget + call this%budobj%write_budtable(kstp, kper, iout) + ! + ! -- return + return + end subroutine lak_ot + + subroutine lak_da(this) + ! ************************************************************************** + ! lak_da -- Deallocate objects + ! ************************************************************************** + ! + ! SPECIFICATIONS: + ! -------------------------------------------------------------------------- + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(LakType) :: this + ! -- local + integer(I4B) :: n + integer(I4B) :: iconn + ! -- format + ! -------------------------------------------------------------------------- + ! + ! -- arrays + deallocate(this%lakename) + deallocate(this%status) + deallocate(this%clakbudget) + call mem_deallocate(this%dbuff) + deallocate(this%cauxcbc) + call mem_deallocate(this%qauxcbc) + call mem_deallocate(this%qleak) + call mem_deallocate(this%qsto) + ! + ! -- tables + do n = 1, this%nlakes + if (this%ntabrow(n) > 0) then + call mem_deallocate(this%laketables(n)%tabstage) + call mem_deallocate(this%laketables(n)%tabvolume) + call mem_deallocate(this%laketables(n)%tabsarea) + iconn = this%idxlakeconn(n) + if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then + call mem_deallocate(this%laketables(n)%tabwarea) + end if + end if + end do + if (this%ntables > 0) then + deallocate(this%laketables) + end if + ! + ! -- budobj + call this%budobj%budgetobject_da() + deallocate(this%budobj) + nullify(this%budobj) + ! + ! -- outlets + if (this%noutlets > 0) then + call mem_deallocate(this%lakein) + call mem_deallocate(this%lakeout) + call mem_deallocate(this%iouttype) + call mem_deallocate(this%outrate) + call mem_deallocate(this%outinvert) + call mem_deallocate(this%outwidth) + call mem_deallocate(this%outrough) + call mem_deallocate(this%outslope) + call mem_deallocate(this%simoutrate) + endif + ! + ! -- package csv table + if (this%ipakcsv > 0) then + call this%pakcsvtab%table_da() + deallocate(this%pakcsvtab) + nullify(this%pakcsvtab) + end if + ! + ! -- scalars + call mem_deallocate(this%iprhed) + call mem_deallocate(this%istageout) + call mem_deallocate(this%ibudgetout) + call mem_deallocate(this%ipakcsv) + call mem_deallocate(this%nlakes) + call mem_deallocate(this%noutlets) + call mem_deallocate(this%ntables) + call mem_deallocate(this%convlength) + call mem_deallocate(this%convtime) + call mem_deallocate(this%outdmax) + call mem_deallocate(this%igwhcopt) + call mem_deallocate(this%iconvchk) + call mem_deallocate(this%iconvresidchk) + call mem_deallocate(this%surfdep) + call mem_deallocate(this%delh) + call mem_deallocate(this%pdmax) + call mem_deallocate(this%check_attr) + call mem_deallocate(this%bditems) + call mem_deallocate(this%cbcauxitems) + ! + call mem_deallocate(this%nlakeconn) + call mem_deallocate(this%idxlakeconn) + call mem_deallocate(this%ntabrow) + call mem_deallocate(this%strt) + call mem_deallocate(this%laketop) + call mem_deallocate(this%lakebot) + call mem_deallocate(this%sareamax) + call mem_deallocate(this%stage) + call mem_deallocate(this%rainfall) + call mem_deallocate(this%evaporation) + call mem_deallocate(this%runoff) + call mem_deallocate(this%inflow) + call mem_deallocate(this%withdrawal) + call mem_deallocate(this%lauxvar) + call mem_deallocate(this%avail) + call mem_deallocate(this%lkgwsink) + call mem_deallocate(this%ncncvr) + call mem_deallocate(this%surfin) + call mem_deallocate(this%surfout) + call mem_deallocate(this%surfout1) + call mem_deallocate(this%precip) + call mem_deallocate(this%precip1) + call mem_deallocate(this%evap) + call mem_deallocate(this%evap1) + call mem_deallocate(this%evapo) + call mem_deallocate(this%withr) + call mem_deallocate(this%withr1) + call mem_deallocate(this%flwin) + call mem_deallocate(this%flwiter) + call mem_deallocate(this%flwiter1) + call mem_deallocate(this%seep) + call mem_deallocate(this%seep1) + call mem_deallocate(this%seep0) + call mem_deallocate(this%stageiter) + call mem_deallocate(this%chterm) + ! + ! -- lake boundary and stages + call mem_deallocate(this%iboundpak) + call mem_deallocate(this%xnewpak) + call mem_deallocate(this%xoldpak) + ! + ! -- lake iteration variables + call mem_deallocate(this%iseepc) + call mem_deallocate(this%idhc) + call mem_deallocate(this%en1) + call mem_deallocate(this%en2) + call mem_deallocate(this%r1) + call mem_deallocate(this%r2) + call mem_deallocate(this%dh0) + call mem_deallocate(this%s0) + call mem_deallocate(this%qgwf0) + ! + ! -- lake connection variables + call mem_deallocate(this%imap) + call mem_deallocate(this%cellid) + call mem_deallocate(this%nodesontop) + call mem_deallocate(this%ictype) + call mem_deallocate(this%bedleak) + call mem_deallocate(this%belev) + call mem_deallocate(this%telev) + call mem_deallocate(this%connlength) + call mem_deallocate(this%connwidth) + call mem_deallocate(this%sarea) + call mem_deallocate(this%warea) + call mem_deallocate(this%satcond) + call mem_deallocate(this%simcond) + call mem_deallocate(this%simlakgw) + ! + ! -- pointers to gwf variables + nullify(this%gwfiss) + ! + ! -- Parent object + call this%BndType%bnd_da() + ! + ! -- Return + return + end subroutine lak_da + + + subroutine define_listlabel(this) +! ****************************************************************************** +! define_listlabel -- Define the list heading that is written to iout when +! PRINT_INPUT option is used. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(LakType), intent(inout) :: this +! ------------------------------------------------------------------------------ + ! + ! -- create the header list label + this%listlabel = trim(this%filtyp) // ' NO.' + if(this%dis%ndim == 3) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif(this%dis%ndim == 2) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + else + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + endif + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' + if(this%inamedbound == 1) then + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + endif + ! + ! -- return + return + end subroutine define_listlabel + + + subroutine lak_set_pointers(this, neq, ibound, xnew, xold, flowja) +! ****************************************************************************** +! set_pointers -- Set pointers to model arrays and variables so that a package +! has access to these things. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(LakType) :: this + integer(I4B), pointer :: neq + integer(I4B), dimension(:), pointer, contiguous :: ibound + real(DP), dimension(:), pointer, contiguous :: xnew + real(DP), dimension(:), pointer, contiguous :: xold + real(DP), dimension(:), pointer, contiguous :: flowja + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- call base BndType set_pointers + call this%BndType%set_pointers(neq, ibound, xnew, xold, flowja) + ! + ! -- Set the LAK pointers + ! + ! -- set package pointers + !istart = this%dis%nodes + this%ioffset + 1 + !iend = istart + this%nlakes - 1 + !this%iboundpak => this%ibound(istart:iend) + !this%xnewpak => this%xnew(istart:iend) + ! + ! -- initialize xnewpak + !do n = 1, this%nlakes + ! this%xnewpak(n) = DEP20 + !end do + ! + ! -- return + end subroutine lak_set_pointers + + ! + ! -- Procedures related to observations (type-bound) + logical function lak_obs_supported(this) + ! ****************************************************************************** + ! lak_obs_supported + ! -- Return true because LAK package supports observations. + ! -- Overrides BndType%bnd_obs_supported() + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------ + class(LakType) :: this + lak_obs_supported = .true. + return + end function lak_obs_supported + + + subroutine lak_df_obs(this) + ! ****************************************************************************** + ! lak_df_obs (implements bnd_df_obs) + ! -- Store observation type supported by LAK package. + ! -- Overrides BndType%bnd_df_obs + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType) :: this + ! -- local + integer(I4B) :: indx + ! ------------------------------------------------------------------------------ + ! + ! -- Store obs type and assign procedure pointer + ! for stage observation type. + call this%obs%StoreObsType('stage', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for ext-inflow observation type. + call this%obs%StoreObsType('ext-inflow', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for outlet-inflow observation type. + call this%obs%StoreObsType('outlet-inflow', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for inflow observation type. + call this%obs%StoreObsType('inflow', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for from-mvr observation type. + call this%obs%StoreObsType('from-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for rainfall observation type. + call this%obs%StoreObsType('rainfall', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for runoff observation type. + call this%obs%StoreObsType('runoff', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for lak observation type. + call this%obs%StoreObsType('lak', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for evaporation observation type. + call this%obs%StoreObsType('evaporation', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for withdrawal observation type. + call this%obs%StoreObsType('withdrawal', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for ext-outflow observation type. + call this%obs%StoreObsType('ext-outflow', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for to-mvr observation type. + call this%obs%StoreObsType('to-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for storage observation type. + call this%obs%StoreObsType('storage', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for constant observation type. + call this%obs%StoreObsType('constant', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for outlet observation type. + call this%obs%StoreObsType('outlet', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for volume observation type. + call this%obs%StoreObsType('volume', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for surface-area observation type. + call this%obs%StoreObsType('surface-area', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for wetted-area observation type. + call this%obs%StoreObsType('wetted-area', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for conductance observation type. + call this%obs%StoreObsType('conductance', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsID + ! + return + end subroutine lak_df_obs + + + subroutine lak_bd_obs(this) + ! ************************************************************************** + ! lak_bd_obs + ! -- Calculate observations this time step and call + ! ObsType%SaveOneSimval for each LakType observation. + ! ************************************************************************** + ! + ! SPECIFICATIONS: + ! -------------------------------------------------------------------------- + ! -- dummy + class(LakType), intent(inout) :: this + ! -- local + integer(I4B) :: i, igwfnode, j, jj, n, nn + real(DP) :: hgwf, hlak, v, v2 + character(len=100) :: errmsg + type(ObserveType), pointer :: obsrv => null() + !--------------------------------------------------------------------------- + ! + ! Write simulated values for all LAK observations + if (this%obs%npakobs > 0) then + call this%obs%obs_bd_clear() + do i = 1, this%obs%npakobs + obsrv => this%obs%pakobs(i)%obsrv + nn = size(obsrv%indxbnds) + do j = 1, nn + v = DNODATA + jj = obsrv%indxbnds(j) + select case (obsrv%ObsTypeId) + case ('STAGE') + if (this%iboundpak(jj) /= 0) then + v = this%xnewpak(jj) + end if + case ('EXT-INFLOW') + if (this%iboundpak(jj) /= 0) then + call this%lak_calculate_inflow(jj, v) + end if + case ('OUTLET-INFLOW') + if (this%iboundpak(jj) /= 0) then + call this%lak_calculate_outlet_inflow(jj, v) + end if + case ('INFLOW') + if (this%iboundpak(jj) /= 0) then + call this%lak_calculate_inflow(jj, v) + call this%lak_calculate_outlet_inflow(jj, v2) + v = v + v2 + end if + case ('FROM-MVR') + if (this%iboundpak(jj) /= 0) then + if (this%imover == 1) then + v = this%pakmvrobj%get_qfrommvr(jj) + end if + end if + case ('RAINFALL') + if (this%iboundpak(jj) /= 0) then + v = this%precip(jj) + end if + case ('RUNOFF') + if (this%iboundpak(jj) /= 0) then + v = this%runoff(jj)%value + end if + case ('LAK') + n = this%imap(jj) + if (this%iboundpak(n) /= 0) then + igwfnode = this%cellid(jj) + hgwf = this%xnew(igwfnode) + if (this%hcof(jj) /= DZERO) then + v = -(this%hcof(jj) * (this%xnewpak(n) - hgwf)) + else + v = -this%rhs(jj) + end if + end if + case ('EVAPORATION') + if (this%iboundpak(jj) /= 0) then + v = this%evap(jj) + end if + case ('WITHDRAWAL') + if (this%iboundpak(jj) /= 0) then + v = this%withr(jj) + end if + case ('EXT-OUTFLOW') + n = this%lakein(jj) + if (this%iboundpak(n) /= 0) then + if (this%lakeout(jj) == 0) then + v = this%simoutrate(jj) + if (v < DZERO) then + if (this%imover == 1) then + v = v + this%pakmvrobj%get_qtomvr(jj) + end if + end if + end if + end if + case ('TO-MVR') + n = this%lakein(jj) + if (this%iboundpak(n) /= 0) then + if (this%imover == 1) then + v = this%pakmvrobj%get_qtomvr(jj) + if (v > DZERO) then + v = -v + end if + end if + end if + case ('STORAGE') + if (this%iboundpak(jj) /= 0) then + v = this%qsto(jj) + end if + case ('CONSTANT') + if (this%iboundpak(jj) /= 0) then + v = this%chterm(jj) + end if + case ('OUTLET') + n = this%lakein(jj) + if (this%iboundpak(jj) /= 0) then + v = this%simoutrate(jj) + !if (this%imover == 1) then + ! v = v + this%pakmvrobj%get_qtomvr(jj) + !end if + end if + case ('VOLUME') + if (this%iboundpak(jj) /= 0) then + call this%lak_calculate_vol(jj, this%xnewpak(jj), v) + end if + case ('SURFACE-AREA') + if (this%iboundpak(jj) /= 0) then + hlak = this%xnewpak(jj) + call this%lak_calculate_sarea(jj, hlak, v) + end if + case ('WETTED-AREA') + n = this%imap(jj) + if (this%iboundpak(n) /= 0) then + hlak = this%xnewpak(n) + nn = size(obsrv%indxbnds) + igwfnode = this%cellid(jj) + hgwf = this%xnew(igwfnode) + call this%lak_calculate_conn_warea(n, jj, hlak, hgwf, v) + end if + case ('CONDUCTANCE') + n = this%imap(jj) + if (this%iboundpak(n) /= 0) then + hlak = this%xnewpak(n) + nn = size(obsrv%indxbnds) + igwfnode = this%cellid(jj) + hgwf = this%xnew(igwfnode) + call this%lak_calculate_conn_conductance(n, jj, hlak, hgwf, v) + end if + case default + errmsg = 'Error: Unrecognized observation type: ' // & + trim(obsrv%ObsTypeId) + call store_error(errmsg) + call ustop() + end select + call this%obs%SaveOneSimval(obsrv, v) + end do + end do + end if + ! + return + end subroutine lak_bd_obs + + + subroutine lak_rp_obs(this) + ! -- dummy + class(LakType), intent(inout) :: this + ! -- local + integer(I4B) :: i, j, n, nn1, nn2 + integer(I4B) :: jj + character(len=200) :: ermsg + character(len=LENBOUNDNAME) :: bname + logical :: jfound + class(ObserveType), pointer :: obsrv => null() + ! -------------------------------------------------------------------------- + ! -- formats +10 format('Error: Boundary "',a,'" for observation "',a, & + '" is invalid in package "',a,'"') + ! + do i = 1, this%obs%npakobs + obsrv => this%obs%pakobs(i)%obsrv + ! + ! -- indxbnds needs to be deallocated and reallocated (using + ! ExpandArray) each stress period because list of boundaries + ! can change each stress period. + if (allocated(obsrv%indxbnds)) then + deallocate(obsrv%indxbnds) + end if + ! + ! -- get node number 1 + nn1 = obsrv%NodeNumber + if (nn1 == NAMEDBOUNDFLAG) then + bname = obsrv%FeatureName + if (bname /= '') then + ! -- Observation lake is based on a boundary name. + ! Iterate through all lakes to identify and store + ! corresponding index in bound array. + jfound = .false. + if (obsrv%ObsTypeId=='LAK' .or. & + obsrv%ObsTypeId=='CONDUCTANCE' .or. & + obsrv%ObsTypeId=='WETTED-AREA') then + do j = 1, this%nlakes + do jj = this%idxlakeconn(j), this%idxlakeconn(j+1) - 1 + if (this%boundname(jj) == bname) then + jfound = .true. + call ExpandArray(obsrv%indxbnds) + n = size(obsrv%indxbnds) + obsrv%indxbnds(n) = jj + end if + end do + end do + else if (obsrv%ObsTypeId=='EXT-OUTFLOW' .or. & + obsrv%ObsTypeId=='TO-MVR' .or. & + obsrv%ObsTypeId=='OUTLET') then + do j = 1, this%noutlets + jj = this%lakein(j) + if (this%lakename(jj) == bname) then + jfound = .true. + call ExpandArray(obsrv%indxbnds) + n = size(obsrv%indxbnds) + obsrv%indxbnds(n) = j + end if + end do + else + do j = 1, this%nlakes + if (this%lakename(j) == bname) then + jfound = .true. + call ExpandArray(obsrv%indxbnds) + n = size(obsrv%indxbnds) + obsrv%indxbnds(n) = j + end if + end do + end if + if (.not. jfound) then + write(ermsg,10)trim(bname), trim(obsrv%Name), trim(this%name) + call store_error(ermsg) + end if + end if + else + call ExpandArray(obsrv%indxbnds) + n = size(obsrv%indxbnds) + if (n == 1) then + if (obsrv%ObsTypeId=='LAK' .or. & + obsrv%ObsTypeId=='CONDUCTANCE' .or. & + obsrv%ObsTypeId=='WETTED-AREA') then + nn2 = obsrv%NodeNumber2 + j = this%idxlakeconn(nn1) + nn2 - 1 + obsrv%indxbnds(1) = j + else + obsrv%indxbnds(1) = nn1 + end if + else + ermsg = 'Programming error in lak_rp_obs' + call store_error(ermsg) + endif + end if + ! + ! -- catch non-cumulative observation assigned to observation defined + ! by a boundname that is assigned to more than one element + if (obsrv%ObsTypeId == 'STAGE') then + n = size(obsrv%indxbnds) + if (n > 1) then + write(ermsg, '(4x,a,4(1x,a))') & + 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & + 'for observation', trim(adjustl(obsrv%Name)), & + ' must be assigned to a lake with a unique boundname.' + call store_error(ermsg) + end if + end if + ! + ! -- check that index values are valid + if (obsrv%ObsTypeId=='TO-MVR' .or. & + obsrv%ObsTypeId=='EXT-OUTFLOW' .or. & + obsrv%ObsTypeId=='OUTLET') then + do j = 1, size(obsrv%indxbnds) + nn1 = obsrv%indxbnds(j) + if (nn1 < 1 .or. nn1 > this%noutlets) then + write(ermsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & + 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & + ' outlet must be > 0 and <=', this%noutlets, & + '(specified value is ', nn1, ')' + call store_error(ermsg) + end if + end do + else if (obsrv%ObsTypeId=='LAK' .or. & + obsrv%ObsTypeId=='CONDUCTANCE' .or. & + obsrv%ObsTypeId=='WETTED-AREA') then + do j = 1, size(obsrv%indxbnds) + nn1 = obsrv%indxbnds(j) + if (nn1 < 1 .or. nn1 > this%maxbound) then + write(ermsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & + 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & + ' lake connection number must be > 0 and <=', this%maxbound, & + '(specified value is ', nn1, ')' + call store_error(ermsg) + end if + end do + else + do j = 1, size(obsrv%indxbnds) + nn1 = obsrv%indxbnds(j) + if (nn1 < 1 .or. nn1 > this%nlakes) then + write(ermsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & + 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & + ' lake must be > 0 and <=', this%nlakes, & + '(specified value is ', nn1, ')' + call store_error(ermsg) + end if + end do + end if + end do + if (count_errors() > 0) call ustop() + ! + return + end subroutine lak_rp_obs + + + ! + ! -- Procedures related to observations (NOT type-bound) + subroutine lak_process_obsID(obsrv, dis, inunitobs, iout) + ! -- This procedure is pointed to by ObsDataType%ProcesssIdPtr. It processes + ! the ID string of an observation definition for LAK package observations. + ! -- dummy + type(ObserveType), intent(inout) :: obsrv + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: inunitobs + integer(I4B), intent(in) :: iout + ! -- local + integer(I4B) :: nn1, nn2 + integer(I4B) :: icol, istart, istop + character(len=LINELENGTH) :: strng + character(len=LENBOUNDNAME) :: bndname + ! formats + ! + strng = obsrv%IDstring + ! -- Extract lake number from strng and store it. + ! If 1st item is not an integer(I4B), it should be a + ! lake name--deal with it. + icol = 1 + ! -- get lake number or boundary name + call extract_idnum_or_bndname(strng, icol, istart, istop, nn1, bndname) + if (nn1 == NAMEDBOUNDFLAG) then + obsrv%FeatureName = bndname + else + if (obsrv%ObsTypeId=='LAK' .or. obsrv%ObsTypeId=='CONDUCTANCE' .or. & + obsrv%ObsTypeId=='WETTED-AREA') then + call extract_idnum_or_bndname(strng, icol, istart, istop, nn2, bndname) + if (nn2 == NAMEDBOUNDFLAG) then + obsrv%FeatureName = bndname + ! -- reset nn1 + nn1 = nn2 + else + obsrv%NodeNumber2 = nn2 + end if + !! -- store connection number (NodeNumber2) + !obsrv%NodeNumber2 = nn2 + endif + endif + ! -- store lake number (NodeNumber) + obsrv%NodeNumber = nn1 + ! + return + end subroutine lak_process_obsID + + ! + ! -- private LAK methods + ! + subroutine lak_accumulate_chterm(this, ilak, rrate, chratin, chratout) + ! ************************************************************************** + ! lak_accumulate_chterm -- Accumulate constant head terms for budget. + ! ************************************************************************** + ! + ! SPECIFICATIONS: + ! -------------------------------------------------------------------------- + ! -- dummy + class(LakType) :: this + integer(I4B), intent(in) :: ilak + real(DP), intent(in) :: rrate + real(DP), intent(inout) :: chratin + real(DP), intent(inout) :: chratout + ! -- locals + real(DP) :: q + ! format + ! code + if (this%iboundpak(ilak) < 0) then + q = -rrate + this%chterm(ilak) = this%chterm(ilak) + q + ! + ! -- See if flow is into lake or out of lake. + if (q < DZERO) then + ! + ! -- Flow is out of lake subtract rate from ratout. + chratout = chratout - q + else + ! + ! -- Flow is into lake; add rate to ratin. + chratin = chratin + q + end if + end if + ! -- return + return + end subroutine lak_accumulate_chterm + + + subroutine lak_cfupdate(this) + ! ****************************************************************************** + ! lak_cfupdate -- Update LAK satcond and package rhs and hcof + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + class(LakType), intent(inout) :: this + integer(I4B) :: j, n, node + real(DP) :: hlak, head, clak, blak + ! ------------------------------------------------------------------------------ + ! + ! -- Return if no lak lakes + if(this%nbound.eq.0) return + ! + ! -- Calculate hcof and rhs for each lak entry + do n = 1, this%nlakes + hlak = this%xnewpak(n) + do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + node = this%cellid(j) + head = this%xnew(node) + + this%hcof(j) = DZERO + this%rhs(j) = DZERO + ! + ! -- set bound, hcof, and rhs components + call this%lak_calculate_conn_conductance(n, j, hlak, head, clak) + this%simcond(j) = clak + + this%bound(2,j) = clak + + blak = this%bound(3,j) + + this%hcof(j) = -clak + ! + ! -- fill rhs + if (hlak < blak) then + this%rhs(j) = -clak * blak + else + this%rhs(j) = -clak * hlak + end if + end do + end do + ! + ! -- Return + return + end subroutine lak_cfupdate + + subroutine lak_bound_update(this) + ! ****************************************************************************** + ! lak_bound_update -- store the lake head and connection conductance in the + ! bound array + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + class(LakType), intent(inout) :: this + integer(I4B) :: j, n, node + real(DP) :: hlak, head, clak + ! ------------------------------------------------------------------------------ + ! + ! -- Return if no lak lakes + if (this%nbound == 0) return + ! + ! -- Calculate hcof and rhs for each lak entry + do n = 1, this%nlakes + hlak = this%xnewpak(n) + do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + node = this%cellid(j) + head = this%xnew(node) + call this%lak_calculate_conn_conductance(n, j, hlak, head, clak) + this%bound(1, j) = hlak + this%bound(2, j) = clak + end do + end do + ! + ! -- Return + return + end subroutine lak_bound_update + + subroutine lak_solve(this, update) + ! ************************************************************************** + ! lak_solve -- Solve for lake stage + ! ************************************************************************** + ! + ! SPECIFICATIONS: + ! -------------------------------------------------------------------------- + use TdisModule,only:delt + logical, intent(in), optional :: update + ! -- dummy + class(LakType), intent(inout) :: this + ! -- local + logical :: lupdate + integer(I4B) :: i + integer(I4B) :: j + integer(I4B) :: n + integer(I4B) :: iicnvg + integer(I4B) :: iter + integer(I4B) :: maxiter + integer(I4B) :: ncnv + integer(I4B) :: idry + integer(I4B) :: igwfnode + integer(I4B) :: ibflg + integer(I4B) :: idhp + real(DP) :: hlak + real(DP) :: hlak0 + real(DP) :: v0 + real(DP) :: v1 + real(DP) :: head + real(DP) :: ra + real(DP) :: ro + real(DP) :: qinf + real(DP) :: ex + real(DP) :: ev + real(DP) :: outinf + real(DP) :: s + real(DP) :: qlakgw + real(DP) :: qlakgw1 + real(DP) :: clak + real(DP) :: clak1 + real(DP) :: avail + real(DP) :: resid + real(DP) :: resid1 + real(DP) :: residb + real(DP) :: wr + real(DP) :: derv + real(DP) :: dh + real(DP) :: adh + real(DP) :: adh0 + real(DP) :: delh + real(DP) :: ts +! -------------------------------------------------------------------------- + ! + ! -- set lupdate + if (present(update)) then + lupdate = update + else + lupdate = .true. + end if + ! + ! -- initialize + avail = DZERO + delh = this%delh + ! + ! -- initialize + do n = 1, this%nlakes + this%ncncvr(n) = 0 + this%surfin(n) = DZERO + this%surfout(n) = DZERO + this%surfout1(n) = DZERO + if (this%xnewpak(n) < this%lakebot(n)) then + this%xnewpak(n) = this%lakebot(n) + end if + if (this%gwfiss /= 0) then + this%xoldpak(n) = this%xnewpak(n) + end if + ! -- lake iteration items + this%iseepc(n) = 0 + this%idhc(n) = 0 + this%en1(n) = this%lakebot(n) + call this%lak_calculate_residual(n, this%en1(n), this%r1(n)) + this%en2(n) = this%laketop(n) + call this%lak_calculate_residual(n, this%en2(n), this%r2(n)) + end do + do n = 1, this%noutlets + this%simoutrate(n) = DZERO + end do + ! + ! -- sum up inflows from mover inflows + do n = 1, this%nlakes + call this%lak_calculate_outlet_inflow(n, this%surfin(n)) + end do + ! + ! -- sum up overland runoff, inflows, and external flows into lake + ! (includes lake volume) + do n = 1, this%nlakes + hlak0 = this%xoldpak(n) + call this%lak_calculate_runoff(n, ro) + call this%lak_calculate_inflow(n, qinf) + call this%lak_calculate_external(n, ex) + ! -- + call this%lak_calculate_vol(n, hlak0, v0) + this%flwin(n) = this%surfin(n) + ro + qinf + ex + v0 / delt + end do + ! + ! -- sum up inflows from upstream outlets + do n = 1, this%nlakes + call this%lak_calculate_outlet_inflow(n, outinf) + this%flwin(n) = this%flwin(n) + outinf + end do + + iicnvg = 0 + maxiter = 150 + + ! -- outer loop + converge: do iter = 1, maxiter + ncnv = 0 + do n = 1, this%nlakes + if (this%ncncvr(n) == 0) ncnv = 1 + end do + if (iter == maxiter) ncnv = 0 + if (ncnv == 0) iicnvg = 1 + + ! -- initialize variables + do n = 1, this%nlakes + this%evap(n) = DZERO + this%precip(n) = DZERO + this%precip1(n) = DZERO + this%seep(n) = DZERO + this%seep1(n) = DZERO + this%evap(n) = DZERO + this%evap1(n) = DZERO + this%evapo(n) = DZERO + this%withr(n) = DZERO + this%withr1(n) = DZERO + this%flwiter(n) = this%flwin(n) + this%flwiter1(n) = this%flwin(n) + if (this%gwfiss /= 0) then + this%flwiter(n) = DEP20 !1.D+10 + this%flwiter1(n) = DEP20 !1.D+10 + end if + end do + + estseep: do i = 1, 2 + lakseep: do n = 1, this%nlakes + ! -- skip inactive lakes + if (this%iboundpak(n) == 0) then + cycle lakseep + end if + ! - set xoldpak to xnewpak if steady-state + if (this%gwfiss /= 0) then + this%xoldpak(n) = this%xnewpak(n) + end if + hlak = this%xnewpak(n) + calcconnseep: do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + igwfnode = this%cellid(j) + head = this%xnew(igwfnode) + if (this%ncncvr(n) /= 2) then + if (this%ibound(igwfnode) > 0) then + call this%lak_estimate_conn_exchange(i, n, j, idry, hlak, head, qlakgw, clak, this%flwiter(n)) + call this%lak_estimate_conn_exchange(i, n, j, idry, hlak+delh, head, qlakgw1, clak1, this%flwiter1(n)) + !write(1051,'(2(i10),4(g15.7))') j, idry, clak, hlak, head, qlakgw + ! + ! -- add to gwf matrix + if (ncnv == 0 .and. i == 2) then + if (j == this%maxbound) then + this%ncncvr(n) = 2 + end if + if (idry /= 1) then + if (head >= this%belev(j)) then + s = max(hlak, this%belev(j)) + this%hcof(j) = -clak + this%rhs(j) = -clak * s + else + this%hcof(j) = DZERO + this%rhs(j) = qlakgw + end if + else + this%hcof(j) = DZERO + this%rhs(j) = qlakgw + end if + end if + if (i == 2) then + this%seep(n) = this%seep(n) + qlakgw + this%seep1(n) = this%seep1(n) + qlakgw1 + end if + end if + end if + + end do calcconnseep + end do lakseep + end do estseep + + laklevel: do n = 1, this%nlakes + ibflg = 0 + hlak = this%xnewpak(n) + if (iter < maxiter) then + this%stageiter(n) = this%xnewpak(n) + end if + call this%lak_calculate_rainfall(n, hlak, ra) + this%precip(n) = ra + this%flwiter(n) = this%flwiter(n) + ra + call this%lak_calculate_rainfall(n, hlak+delh, ra) + this%precip1(n) = ra + this%flwiter1(n) = this%flwiter1(n) + ra + ! + ! -- limit withdrawals to lake inflows and lake storage + call this%lak_calculate_withdrawal(n, this%flwiter(n), wr) + this%withr = wr + call this%lak_calculate_withdrawal(n, this%flwiter1(n), wr) + this%withr1 = wr + ! + ! -- limit evaporation to lake inflows and lake storage + call this%lak_calculate_evaporation(n, hlak, this%flwiter(n), ev) + this%evap(n) = ev + call this%lak_calculate_evaporation(n, hlak+delh, this%flwiter1(n), ev) + this%evap1(n) = ev + ! + ! -- no outlet flow if evaporation consumes all water + call this%lak_calculate_outlet_outflow(n, hlak+delh, & + this%flwiter1(n), & + this%surfout1(n)) + call this%lak_calculate_outlet_outflow(n, hlak, this%flwiter(n), & + this%surfout(n)) + ! + ! -- update the surface inflow values + call this%lak_calculate_outlet_inflow(n, this%surfin(n)) + ! + ! + if (ncnv == 1) then + if (this%iboundpak(n) > 0 .and. lupdate .eqv. .true.) then + ! + ! -- recalculate flwin + hlak0 = this%xoldpak(n) + call this%lak_calculate_vol(n, hlak0, v0) + call this%lak_calculate_runoff(n, ro) + call this%lak_calculate_inflow(n, qinf) + call this%lak_calculate_external(n, ex) + this%flwin(n) = this%surfin(n) + ro + qinf + ex + v0 / delt + ! + ! -- compute new lake stage using Newton's method + resid = this%precip(n) + this%evap(n) + this%withr(n) + ro + & + qinf + ex + this%surfin(n) + & + this%surfout(n) + this%seep(n) + resid1 = this%precip1(n) + this%evap1(n) + this%withr1(n) + ro + & + qinf + ex + this%surfin(n) + & + this%surfout1(n) + this%seep1(n) + + !call this%lak_calculate_residual(n, this%xnewpak(n), residb) + ! + ! -- add storage changes for transient stress periods + hlak = this%xnewpak(n) + if (this%gwfiss /= 1) then + call this%lak_calculate_vol(n, hlak, v1) + resid = resid + (v0 - v1) / delt + call this%lak_calculate_vol(n, hlak+delh, v1) + resid1 = resid1 + (v0 - v1) / delt + !else + ! call this%lak_calculate_vol(n, hlak, v1) + ! resid = resid - v1 / delt + ! call this%lak_calculate_vol(n, hlak+delh, v1) + ! resid1 = resid1 - v1 / delt + end if + + ! + ! -- determine the derivative and the stage change + if (ABS(resid1-resid) > DZERO) then + derv = (resid1 - resid) / delh + dh = DZERO + if (ABS(derv) > DPREC) then + dh = resid / derv + end if + else + if (resid < DZERO) then + resid = DZERO + end if + call this%lak_vol2stage(n, resid, dh) + dh = hlak - dh + this%ncncvr(n) = 1 + end if + ! + ! -- determine if the updated stage is outside the endpoints + ts = hlak-dh + if (iter == 1) this%dh0(n) = dh + adh = ABS(dh) + adh0 = ABS(this%dh0(n)) + if ((ts >= this%en2(n)) .or. (ts <= this%en1(n))) then + ! -- use bisection if dh is increasing or updated stage is below the + ! bottom of the lake + if ((adh > adh0) .or. (ts-this%lakebot(n)) < DPREC) then + ibflg = 1 + ts = DHALF * (this%en1(n) + this%en2(n)) + call this%lak_calculate_residual(n, ts, residb) + dh = hlak - ts + end if + end if + ! + ! -- set seep0 on the first lake iteration + if (iter == 1) then + this%seep0(n) = this%seep(n) + end if + ! + ! -- check for slow convergence + if (this%seep(n)*this%seep0(n) < DPREC) then + this%iseepc(n) = this%iseepc(n) + 1 + else + this%iseepc(n) = 0 + end if + ! -- determine of convergence is slow and oscillating + idhp = 0 + if (dh*this%dh0(n) < DPREC) idhp = 1 + ! -- determine if stage change is increasing + adh = ABS(dh) + if (adh > adh0) idhp = 1 + ! -- increment idhc convergence flag + if (idhp == 1) then + this%idhc(n) = this%idhc(n) + 1 + end if + ! + ! -- switch to bisection when the Newton-Raphson method oscillates + ! or when convergence is slow + if (ibflg == 1) then + if (this%iseepc(n) > 7 .or. this%idhc(n) > 12) then + ibflg = 1 + ts = DHALF * (this%en1(n) + this%en2(n)) + call this%lak_calculate_residual(n, ts, residb) + dh = hlak - ts + end if + end if + if (ibflg == 1) then + ! -- change end points + ! -- root is between r1 and residb + if (this%r1(n)*residb < DZERO) then + this%en2(n) = ts + this%r2(n) = residb + ! -- root is between fp and f2 + else + this%en1(n) = ts + this%r1(n) = residb + end if + end if + else + dh = DZERO + end if + ! + ! -- update lake stage + hlak = hlak - dh + if (hlak < this%lakebot(n)) then + hlak = this%lakebot(n) + end if + if (ABS(dh) < delh) then + this%ncncvr(n) = 1 + end if + this%xnewpak(n) = hlak + ! + ! -- save iterates for lake + this%seep0(n) = this%seep(n) + this%dh0(n) = dh + end if + end do laklevel + + if (iicnvg == 1) exit converge + + end do converge + ! + ! -- Mover terms: store outflow after diversion loss + ! as qformvr and reduce outflow (qd) + ! by how much was actually sent to the mover + if (this%imover == 1) then + do n = 1, this%noutlets + call this%pakmvrobj%accumulate_qformvr(n, -this%simoutrate(n)) + end do + end if + ! + ! -- return + return + end subroutine lak_solve + + + subroutine lak_calculate_available(this, n, hlak, avail, & + ra, ro, qinf, ex, headp) + ! ************************************************************************** + ! lak_calculate_available -- Calculate the available volumetric rate for + ! a lake given a passed stage + ! ************************************************************************** + ! + ! SPECIFICATIONS: + ! -------------------------------------------------------------------------- + use TdisModule,only:delt + ! -- dummy + class(LakType), intent(inout) :: this + integer(I4B), intent(in) :: n + real(DP), intent(in) :: hlak + real(DP), intent(inout) :: avail + real(DP), intent(inout) :: ra + real(DP), intent(inout) :: ro + real(DP), intent(inout) :: qinf + real(DP), intent(inout) :: ex + real(DP), intent(in), optional :: headp + ! -- local + integer(I4B) :: j + integer(I4B) :: idry + integer(I4B) :: igwfnode + real(DP) :: hp + real(DP) :: head + real(DP) :: qlakgw + real(DP) :: clak + real(DP) :: v0 + ! code + ! + ! -- set hp + if (present(headp)) then + hp = headp + else + hp = DZERO + end if + ! + ! -- initialize + avail = DZERO + ! + ! -- calculate the aquifer sources to the lake + do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + igwfnode = this%cellid(j) + if (this%ibound(igwfnode) == 0) cycle + head = this%xnew(igwfnode) + hp + call this%lak_estimate_conn_exchange(1, n, j, idry, hlak, head, qlakgw, clak, avail) + end do + ! + ! -- add rainfall + call this%lak_calculate_rainfall(n, hlak, ra) + avail = avail + ra + ! + ! -- calculate runoff + call this%lak_calculate_runoff(n, ro) + avail = avail + ro + ! + ! -- calculate inflow + call this%lak_calculate_inflow(n, qinf) + avail = avail + qinf + ! + ! -- calculate external flow terms + call this%lak_calculate_external(n, ex) + avail = avail + ex + ! + ! -- calculate volume available in storage + call this%lak_calculate_vol(n, this%xoldpak(n), v0) + avail = avail + v0 / delt + ! + ! -- return + return + end subroutine lak_calculate_available + + + subroutine lak_calculate_residual(this, n, hlak, resid, headp) + ! ************************************************************************** + ! lak_calculate_residual -- Calculate the residual for a lake given a + ! passed stage + ! ************************************************************************** + ! + ! SPECIFICATIONS: + ! -------------------------------------------------------------------------- + use TdisModule,only:delt + ! -- dummy + class(LakType), intent(inout) :: this + integer(I4B), intent(in) :: n + real(DP), intent(in) :: hlak + real(DP), intent(inout) :: resid + real(DP), intent(in), optional :: headp + ! -- local + integer(I4B) :: j + integer(I4B) :: idry + integer(I4B) :: igwfnode + real(DP) :: hp + real(DP) :: avail + real(DP) :: head + real(DP) :: ra + real(DP) :: ro + real(DP) :: qinf + real(DP) :: ex + real(DP) :: ev + real(DP) :: wr + real(DP) :: sout + real(DP) :: sin + real(DP) :: qlakgw + real(DP) :: clak + real(DP) :: seep + real(DP) :: hlak0 + real(DP) :: v0 + real(DP) :: v1 + ! + ! -- code + ! + ! -- set hp + if (present(headp)) then + hp = headp + else + hp = DZERO + end if + ! + ! -- initialize + resid = DZERO + avail = DZERO + seep = DZERO + ! + ! -- calculate the available water + call this%lak_calculate_available(n, hlak, avail, & + ra, ro, qinf, ex, hp) + ! + ! -- calculate groundwater seepage + do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + igwfnode = this%cellid(j) + if (this%ibound(igwfnode) == 0) cycle + head = this%xnew(igwfnode) + hp + call this%lak_estimate_conn_exchange(2, n, j, idry, hlak, head, qlakgw, clak, avail) + seep = seep + qlakgw + end do + ! + ! -- limit withdrawals to lake inflows and lake storage + call this%lak_calculate_withdrawal(n, avail, wr) + ! + ! -- limit evaporation to lake inflows and lake storage + call this%lak_calculate_evaporation(n, hlak, avail, ev) + ! + ! -- no outlet flow if evaporation consumes all water + call this%lak_calculate_outlet_outflow(n, hlak, avail, sout) + ! + ! -- update the surface inflow values + call this%lak_calculate_outlet_inflow(n, sin) + ! + ! -- calculate residual + resid = ra + ev + wr + ro + qinf + ex + sin + sout + seep + ! + ! -- include storage + if (this%gwfiss /= 1) then + hlak0 = this%xoldpak(n) + call this%lak_calculate_vol(n, hlak0, v0) + call this%lak_calculate_vol(n, hlak, v1) + resid = resid + (v0 - v1) / delt + end if + ! + ! -- return + return + end subroutine lak_calculate_residual + + subroutine lak_setup_budobj(this) +! ****************************************************************************** +! lak_setup_budobj -- Set up the budget object that stores all the lake flows +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LENBUDTXT + ! -- dummy + class(LakType) :: this + ! -- local + integer(I4B) :: nbudterm + integer(I4B) :: nlen + integer(I4B) :: j, n, n1, n2 + integer(I4B) :: maxlist, naux + integer(I4B) :: idx + real(DP) :: q + character(len=LENBUDTXT) :: text + character(len=LENBUDTXT), dimension(1) :: auxtxt +! ------------------------------------------------------------------------------ + ! + ! -- Determine the number of lake budget terms. These are fixed for + ! the simulation and cannot change + nbudterm = 9 + nlen = 0 + do n = 1, this%noutlets + if (this%lakein(n) > 0 .and. this%lakeout(n) > 0) then + nlen = nlen + 1 + end if + end do + if (nlen > 0) nbudterm = nbudterm + 1 + if (this%imover == 1) nbudterm = nbudterm + 2 + if (this%naux > 0) nbudterm = nbudterm + 1 + ! + ! -- set up budobj + call budgetobject_cr(this%budobj, this%name) + call this%budobj%budgetobject_df(this%nlakes, nbudterm, 0, 0) + idx = 0 + ! + ! -- Go through and set up each budget term + if (nlen > 0) then + text = ' FLOW-JA-FACE' + idx = idx + 1 + maxlist = 2 * this%noutlets + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- store connectivity + call this%budobj%budterm(idx)%reset(2 * nlen) + q = DZERO + do n = 1, this%noutlets + n1 = this%lakein(n) + n2 = this%lakeout(n) + if (n1 > 0 .and. n2 > 0) then + call this%budobj%budterm(idx)%update_term(n1, n2, q) + call this%budobj%budterm(idx)%update_term(n2, n1, -q) + end if + end do + end if + ! + ! -- + text = ' GWF' + idx = idx + 1 + maxlist = this%maxbound + naux = 1 + auxtxt(1) = ' FLOW-AREA' + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name_model, & + maxlist, .false., .true., & + naux, auxtxt) + call this%budobj%budterm(idx)%reset(this%maxbound) + q = DZERO + do n = 1, this%nlakes + do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1 + n2 = this%cellid(j) + call this%budobj%budterm(idx)%update_term(n, n2, q) + end do + end do + ! + ! -- + text = ' RAINFALL' + idx = idx + 1 + maxlist = this%nlakes + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' EVAPORATION' + idx = idx + 1 + maxlist = this%nlakes + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' RUNOFF' + idx = idx + 1 + maxlist = this%nlakes + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' EXT-INFLOW' + idx = idx + 1 + maxlist = this%nlakes + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' WITHDRAWAL' + idx = idx + 1 + maxlist = this%nlakes + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' EXT-OUTFLOW' + idx = idx + 1 + maxlist = this%nlakes + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' STORAGE' + idx = idx + 1 + maxlist = this%nlakes + naux = 1 + auxtxt(1) = ' VOLUME' + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux, auxtxt) + ! + ! -- + text = ' CONSTANT' + idx = idx + 1 + maxlist = this%nlakes + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- + if (this%imover == 1) then + ! + ! -- + text = ' FROM-MVR' + idx = idx + 1 + maxlist = this%nlakes + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' TO-MVR' + idx = idx + 1 + maxlist = this%noutlets + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux, ordered_id1=.false.) + end if + ! + ! -- + naux = this%naux + if (naux > 0) then + ! + ! -- + text = ' AUXILIARY' + idx = idx + 1 + maxlist = this%nlakes + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux, this%auxname) + end if + ! + ! -- if lake flow for each reach are written to the listing file + if (this%iprflow /= 0) then + call this%budobj%flowtable_df(this%iout) + end if + ! + ! -- return + return + end subroutine lak_setup_budobj + + subroutine lak_fill_budobj(this) +! ****************************************************************************** +! lak_fill_budobj -- copy flow terms into this%budobj +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(LakType) :: this + ! -- local + integer(I4B) :: naux + real(DP), dimension(:), allocatable :: auxvartmp + integer(I4B) :: i, j, n, n1, n2 + integer(I4B) :: ii + integer(I4B) :: idx + integer(I4B) :: nlen + real(DP) :: hlak, hgwf + real(DP) :: v, v1 + real(DP) :: q + ! -- formats +! ----------------------------------------------------------------------------- + ! + ! -- initialize counter + idx = 0 + + + ! -- FLOW JA FACE + nlen = 0 + do n = 1, this%noutlets + if (this%lakein(n) > 0 .and. this%lakeout(n) > 0) then + nlen = nlen + 1 + end if + end do + if (nlen > 0) then + idx = idx + 1 + call this%budobj%budterm(idx)%reset(2 * nlen) + do n = 1, this%noutlets + n1 = this%lakein(n) + n2 = this%lakeout(n) + if (n1 > 0 .and. n2 > 0) then + q = this%simoutrate(n) + if (this%imover == 1) then + q = q + this%pakmvrobj%get_qtomvr(n) + end if + call this%budobj%budterm(idx)%update_term(n1, n2, q) + call this%budobj%budterm(idx)%update_term(n2, n1, -q) + end if + end do + end if + + + ! -- GWF (LEAKAGE) + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound) + do n = 1, this%nlakes + hlak = this%xnewpak(n) + do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1 + n2 = this%cellid(j) + hgwf = this%xnew(n2) + call this%lak_calculate_conn_warea(n, j, hlak, hgwf, this%qauxcbc(1)) + q = this%qleak(j) + call this%budobj%budterm(idx)%update_term(n, n2, q, this%qauxcbc) + end do + end do + + + ! -- RAIN + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nlakes) + do n = 1, this%nlakes + q = this%precip(n) + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + + + ! -- EVAPORATION + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nlakes) + do n = 1, this%nlakes + q = this%evap(n) + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + + + ! -- RUNOFF + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nlakes) + do n = 1, this%nlakes + q = this%runoff(n)%value + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + + + ! -- INFLOW + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nlakes) + do n = 1, this%nlakes + q = this%inflow(n)%value + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + + + ! -- WITHDRAWAL + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nlakes) + do n = 1, this%nlakes + q = this%withr(n) + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + + + ! -- EXTERNAL OUTFLOW + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nlakes) + do n = 1, this%nlakes + call this%lak_get_external_outlet(n, q) + ! subtract tomover from external outflow + call this%lak_get_external_mover(n, v) + q = q + v + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + + + ! -- STORAGE + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nlakes) + do n = 1, this%nlakes + call this%lak_calculate_vol(n, this%xnewpak(n), v1) + q = this%qsto(n) + this%qauxcbc(1) = v1 + call this%budobj%budterm(idx)%update_term(n, n, q, this%qauxcbc) + end do + + + ! -- CONSTANT FLOW + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nlakes) + do n = 1, this%nlakes + q = this%chterm(n) + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + + + ! -- MOVER + if (this%imover == 1) then + + ! -- FROM MOVER + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nlakes) + do n = 1, this%nlakes + q = this%pakmvrobj%get_qfrommvr(n) + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + + + ! -- TO MOVER + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%noutlets) + do n = 1, this%noutlets + n1 = this%lakein(n) + q = this%pakmvrobj%get_qtomvr(n) + if (q > DZERO) then + q = -q + end if + call this%budobj%budterm(idx)%update_term(n1, n1, q) + end do + + end if + + + ! -- AUXILIARY VARIABLES + naux = this%naux + if (naux > 0) then + idx = idx + 1 + allocate(auxvartmp(naux)) + call this%budobj%budterm(idx)%reset(this%nlakes) + do n = 1, this%nlakes + q = DZERO + do i = 1, naux + ii = (n - 1) * naux + i + auxvartmp(i) = this%lauxvar(ii)%value + end do + call this%budobj%budterm(idx)%update_term(n, n, q, auxvartmp) + end do + deallocate(auxvartmp) + end if + ! + ! --Terms are filled, now accumulate them for this time step + call this%budobj%accumulate_terms() + ! + ! -- return + return + end subroutine lak_fill_budobj + +end module LakModule diff --git a/src/Model/GroundWaterFlow/gwf3maw8.f90 b/src/Model/GroundWaterFlow/gwf3maw8.f90 index 684dbf42992..1530c8eb81f 100644 --- a/src/Model/GroundWaterFlow/gwf3maw8.f90 +++ b/src/Model/GroundWaterFlow/gwf3maw8.f90 @@ -1,4376 +1,4376 @@ -module MawModule - ! - use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, LENTIMESERIESNAME, & - DZERO, DEM6, DEM4, DEM2, DQUARTER, DHALF, DP7, & - DP9, DONE, DTWO, DPI, DTWOPI, DEIGHT, DHUNDRED, & - DEP20, NAMEDBOUNDFLAG, LENPACKAGENAME, LENAUXNAME, & - & LENFTYPE, DHNOFLO, DHDRY, DNODATA, MAXCHARLEN, & - TABLEFT, TABCENTER, TABRIGHT, & - TABSTRING, TABUCSTRING, TABINTEGER, TABREAL - use SmoothingModule, only: sQuadraticSaturation, sQSaturation, & - sQuadraticSaturationDerivative, & - sQSaturationDerivative - use BndModule, only: BndType - use BudgetObjectModule, only: BudgetObjectType, budgetobject_cr - use TableModule, only: TableType, table_cr - use ObserveModule, only: ObserveType - use ObsModule, only: ObsType - use InputOutputModule, only: get_node, URWORD, extract_idnum_or_bndname - use BaseDisModule, only: DisBaseType - use SimModule, only: count_errors, store_error, store_error_unit, ustop - use ArrayHandlersModule, only: ExpandArray - use BlockParserModule, only: BlockParserType - use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_setptr, & - mem_deallocate - ! - implicit none - - public :: MawType - - ! - character(len=LENFTYPE) :: ftype = 'MAW' - character(len=LENPACKAGENAME) :: text = ' MAW' - ! - type :: MawWellTSType - character (len=LENTIMESERIESNAME), pointer :: name => null() - real(DP), pointer :: value => null() - end type MawWellTSType - - type :: MawWellType - character (len=LENBOUNDNAME), pointer :: name => null() - character (len=8), pointer :: status => null() - integer(I4B), pointer :: ngwfnodes => null() - integer(I4B), pointer :: ieqn => null() - integer(I4B), pointer :: ishutoff => null() - integer(I4B), pointer :: ifwdischarge => null() - real(DP), pointer :: strt => null() - real(DP), pointer :: radius => null() - real(DP), pointer :: area => null() - real(DP), pointer :: pumpelev => null() - real(DP), pointer :: bot => null() - real(DP), pointer :: ratesim => null() - real(DP), pointer :: reduction_length => null() - real(DP), pointer :: fwelev => null() - real(DP), pointer :: fwcond => null() - real(DP), pointer :: fwrlen => null() - real(DP), pointer :: fwcondsim => null() - real(DP), pointer :: xsto => null() - real(DP), pointer :: xoldsto => null() - real(DP), pointer :: shutoffmin => null() - real(DP), pointer :: shutoffmax => null() - real(DP), pointer :: shutofflevel => null() - real(DP), pointer :: shutoffweight => null() - real(DP), pointer :: shutoffdq => null() - real(DP), pointer :: shutoffqold => null() - ! -- vectors - integer(I4B), dimension(:), pointer, contiguous :: gwfnodes => NULL() - real(DP), dimension(:), pointer, contiguous :: sradius => NULL() - real(DP), dimension(:), pointer, contiguous :: hk => NULL() - real(DP), dimension(:), pointer, contiguous :: satcond => NULL() - real(DP), dimension(:), pointer, contiguous :: simcond => NULL() - real(DP), dimension(:), pointer, contiguous :: topscrn => NULL() - real(DP), dimension(:), pointer, contiguous :: botscrn => NULL() - ! -- time-series aware data - ! -- aux data - type (MawWellTSType), dimension(:), pointer, contiguous :: auxvar => null() - ! -- pumping rate - type(MawWellTSType), pointer :: rate => null() - ! -- well head - type(MawWellTSType), pointer :: head => null() - end type MawWellType - ! - private - public :: maw_create - ! - type, extends(BndType) :: MawType - ! - ! -- scalars - ! -- characters - ! - character(len=16), dimension(:), pointer, contiguous :: cmawbudget => NULL() - character(len=LENAUXNAME), dimension(:), pointer, & - contiguous :: cauxcbc => NULL() - ! - ! -- integers - integer(I4B), pointer :: iprhed => null() - integer(I4B), pointer :: iheadout => null() - integer(I4B), pointer :: ibudgetout => null() - integer(I4B), pointer :: cbcauxitems => NULL() - integer(I4B), pointer :: iflowingwells => NULL() - integer(I4B), pointer :: imawiss => NULL() - integer(I4B), pointer :: imawissopt => NULL() - integer(I4B), pointer :: nmawwells => NULL() - integer(I4B), pointer :: check_attr => NULL() - integer(I4B), pointer :: ishutoffcnt => NULL() - integer(I4B), pointer :: ieffradopt => NULL() - real(DP), pointer :: satomega => null() - ! - ! -- for underrelaxation of estimated well q if using shutoff - real(DP), pointer :: theta => NULL() - real(DP), pointer :: kappa => NULL() - ! - ! -- derived types - type(MawWellType), dimension(:), pointer, contiguous :: mawwells => NULL() - ! - ! -- for budgets - integer(I4B), pointer :: bditems => NULL() - type(BudgetObjectType), pointer :: budobj => null() - ! - ! -- table objects - type(TableType), pointer :: headtab => null() - ! - ! -- pointer to gwf iss, k11, k22. - integer(I4B), pointer :: gwfiss => NULL() - real(DP), dimension(:), pointer, contiguous :: gwfk11 => NULL() - real(DP), dimension(:), pointer, contiguous :: gwfk22 => NULL() - integer(I4B), pointer :: gwfik22 => NULL() - real(DP), dimension(:), pointer, contiguous :: gwfsat => NULL() - ! - ! -- arrays for handling the rows added to the solution matrix - integer(I4B), dimension(:), pointer, contiguous :: idxlocnode => null() !map position in global rhs and x array of pack entry - integer(I4B), dimension(:), pointer, contiguous :: idxdglo => null() !map position in global array of package diagonal row entries - integer(I4B), dimension(:), pointer, contiguous :: idxoffdglo => null() !map position in global array of package off diagonal row entries - integer(I4B), dimension(:), pointer, contiguous :: idxsymdglo => null() !map position in global array of package diagonal entries to model rows - integer(I4B), dimension(:), pointer, contiguous :: idxsymoffdglo => null() !map position in global array of package off diagonal entries to model rows - integer(I4B), dimension(:), pointer, contiguous :: iboundpak => null() !package ibound - real(DP), dimension(:), pointer, contiguous :: xnewpak => null() !package x vector - real(DP), dimension(:), pointer, contiguous :: xoldpak => null() !package xold vector - real(DP), dimension(:), pointer, contiguous :: cterm => null() !package c vector - ! - ! -- vector data (start of flattening for future removal of MawWellType) - character (len=LENBOUNDNAME), dimension(:), pointer, & - contiguous :: cmawname => null() - integer(I4B), dimension(:), pointer, contiguous :: idxmawconn => null() - ! - ! -- imap vector - integer(I4B), dimension(:), pointer, contiguous :: imap => null() - ! - ! -- maw output data - real(DP), dimension(:), pointer, contiguous :: qauxcbc => null() - real(DP), dimension(:), pointer, contiguous :: dbuff => null() - real(DP), dimension(:), pointer, contiguous :: qleak => null() - real(DP), dimension(:), pointer, contiguous :: qout => null() - real(DP), dimension(:), pointer, contiguous :: qfw => null() - real(DP), dimension(:), pointer, contiguous :: qsto => null() - real(DP), dimension(:), pointer, contiguous :: qconst => null() - ! -- type bound procedures - contains - procedure :: maw_allocate_scalars - procedure :: maw_allocate_arrays - procedure :: bnd_options => maw_options - procedure :: read_dimensions => maw_read_dimensions - procedure :: read_initial_attr => maw_read_initial_attr - procedure :: set_pointers => maw_set_pointers - procedure :: bnd_ac => maw_ac - procedure :: bnd_mc => maw_mc - procedure :: bnd_ar => maw_ar - procedure :: bnd_rp => maw_rp - procedure :: bnd_ad => maw_ad - procedure :: bnd_cf => maw_cf - procedure :: bnd_fc => maw_fc - procedure :: bnd_fn => maw_fn - procedure :: bnd_nur => maw_nur - procedure :: bnd_bd => maw_bd - procedure :: bnd_ot => maw_ot - procedure :: bnd_da => maw_da - procedure :: define_listlabel - ! -- methods for observations - procedure, public :: bnd_obs_supported => maw_obs_supported - procedure, public :: bnd_df_obs => maw_df_obs - procedure, public :: bnd_rp_obs => maw_rp_obs - ! -- private procedures - procedure, private :: maw_read_wells - procedure, private :: maw_read_well_connections - procedure, private :: maw_allocate_well - procedure, private :: maw_deallocate_well - procedure, private :: maw_check_attributes - procedure, private :: maw_set_stressperiod - procedure, private :: maw_set_attribute_error - procedure, private :: maw_calculate_saturation - procedure, private :: maw_calculate_satcond - procedure, private :: maw_calculate_wellq - procedure, private :: maw_calculate_qpot - procedure, private :: maw_cfupdate - procedure, private :: maw_bd_obs - ! -- budget - procedure, private :: maw_setup_budobj - procedure, private :: maw_fill_budobj - ! -- table - procedure, private :: maw_setup_tableobj - end type MawType - -contains - - subroutine maw_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) -! ****************************************************************************** -! maw_create -- Create a New Multi-Aquifer Well Package -! Subroutine: (1) create new-style package -! (2) point bndobj to the new package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout - character(len=*), intent(in) :: namemodel - character(len=*), intent(in) :: pakname - type(MawType), pointer :: mawobj -! ------------------------------------------------------------------------------ - ! - ! -- allocate the object and assign values to object variables - allocate(mawobj) - packobj => mawobj - ! - ! -- create name and origin - call packobj%set_names(ibcnum, namemodel, pakname, ftype) - packobj%text = text - ! - ! -- allocate scalars - call mawobj%maw_allocate_scalars() - ! - ! -- initialize package - call packobj%pack_initialize() - - packobj%inunit = inunit - packobj%iout = iout - packobj%id = id - packobj%ibcnum = ibcnum - packobj%ncolbnd = 4 - packobj%iscloc = 0 ! not supported - packobj%ictorigin = 'NPF' - ! - ! -- return - return - end subroutine maw_create - - subroutine maw_allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -- allocate scalar members -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(MawType), intent(inout) :: this -! ------------------------------------------------------------------------------ - ! - ! -- call standard BndType allocate scalars - call this%BndType%allocate_scalars() - ! - ! -- allocate the object and assign values to object variables - call mem_allocate(this%iprhed, 'IPRHED', this%origin) - call mem_allocate(this%iheadout, 'IHEADOUT', this%origin) - call mem_allocate(this%ibudgetout, 'IBUDGETOUT', this%origin) - call mem_allocate(this%iflowingwells, 'IFLOWINGWELLS', this%origin) - call mem_allocate(this%imawiss, 'IMAWISS', this%origin) - call mem_allocate(this%imawissopt, 'IMAWISSOPT', this%origin) - call mem_allocate(this%nmawwells, 'NMAWWELLS', this%origin) - call mem_allocate(this%check_attr, 'check_attr', this%origin) - call mem_allocate(this%ishutoffcnt, 'ISHUTOFFCNT', this%origin) - call mem_allocate(this%ieffradopt, 'IEFFRADOPT', this%origin) - call mem_allocate(this%satomega, 'SATOMEGA', this%origin) - call mem_allocate(this%bditems, 'BDITEMS', this%origin) - call mem_allocate(this%theta, 'THETA', this%origin) - call mem_allocate(this%kappa, 'KAPPA', this%origin) - call mem_allocate(this%cbcauxitems, 'CBCAUXITEMS', this%origin) - ! - ! -- Set values - this%iprhed = 0 - this%iheadout = 0 - this%ibudgetout = 0 - this%iflowingwells = 0 - this%imawiss = 0 - this%imawissopt = 0 - this%ieffradopt = 0 - this%satomega = DZERO - this%bditems = 8 - this%theta = DP7 - this%kappa = DEM4 - this%cbcauxitems = 1 - !this%imover = 0 - ! - ! -- return - return - end subroutine maw_allocate_scalars - - subroutine maw_allocate_arrays(this) -! ****************************************************************************** -! allocate_scalars -- allocate scalar members -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(MawType), intent(inout) :: this - ! -- local - integer(I4B) :: i -! ------------------------------------------------------------------------------ - ! - ! -- call standard BndType allocate scalars - call this%BndType%allocate_arrays() - ! - ! -- allocate cmawname - allocate(this%cmawname(this%nmawwells)) - ! - ! -- allocate idxmawconn - call mem_allocate(this%idxmawconn, this%nmawwells+1, 'IDXMAWCONN', this%origin) - ! - ! -- allocate imap - call mem_allocate(this%imap, this%MAXBOUND, 'IMAP', this%origin) - ! - ! -- initialize idxmawconn and imap - do i = 1, this%nmawwells+1 - this%idxmawconn(i) = 0 - end do - do i = 1, this%maxbound - this%imap(i) = 0 - end do - ! - ! -- allocate character array for budget text - allocate(this%cmawbudget(this%bditems)) - ! - !-- fill cmawbudget - this%cmawbudget(1) = ' GWF' - this%cmawbudget(2) = ' RATE' - this%cmawbudget(3) = ' STORAGE' - this%cmawbudget(4) = ' CONSTANT' - this%cmawbudget(5) = ' FW-RATE' - this%cmawbudget(6) = ' FROM-MVR' - this%cmawbudget(7) = ' RATE-TO-MVR' - this%cmawbudget(8) = ' FW-RATE-TO-MVR' - ! - ! -- allocate and initialize dbuff - if (this%iheadout > 0) then - call mem_allocate(this%dbuff, this%nmawwells, 'DBUFF', this%origin) - do i = 1, this%nmawwells - this%dbuff(i) = DZERO - end do - else - call mem_allocate(this%dbuff, 0, 'DBUFF', this%origin) - end if - ! - ! -- allocate character array for budget text - allocate(this%cauxcbc(this%cbcauxitems)) - ! - ! -- allocate and initialize qauxcbc - call mem_allocate(this%qauxcbc, this%cbcauxitems, 'QAUXCBC', this%origin) - do i = 1, this%cbcauxitems - this%qauxcbc(i) = DZERO - end do - ! - ! -- allocate qleak and qsto - call mem_allocate(this%qleak, this%maxbound, 'QLEAK', this%origin) - do i = 1, this%maxbound - this%qleak(i) = DZERO - end do - if (this%iflowingwells /= 0) then - call mem_allocate(this%qfw, this%nmawwells, 'QFW', this%origin) - else - call mem_allocate(this%qfw, 1, 'QFW', this%origin) - end if - call mem_allocate(this%qout, this%nmawwells, 'QOUT', this%origin) - call mem_allocate(this%qsto, this%nmawwells, 'QSTO', this%origin) - call mem_allocate(this%qconst, this%nmawwells, 'QCONST', this%origin) - ! - ! -- initialize flowing well, storage, and constant flow terms - do i = 1, this%nmawwells - if (this%iflowingwells /= 0) this%qfw(i) = DZERO - this%qsto(i) = DZERO - this%qconst(i) = DZERO - end do - ! - ! -- return - return - end subroutine maw_allocate_arrays - - subroutine maw_read_wells(this) -! ****************************************************************************** -! pak1read_dimensions -- Read the dimensions for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use TimeSeriesManagerModule, only: read_single_value_or_time_series - ! -- dummy - class(MawType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: errmsg - character(len=LINELENGTH) :: text, keyword, cstr - character(len=LINELENGTH) :: strttext - character(len=LENBOUNDNAME) :: bndName, bndNameTemp - character(len=9) :: cno - character(len=50), dimension(:), allocatable :: caux - integer(I4B) :: ival - logical :: isfound, endOfBlock - real(DP) :: rval - integer(I4B) :: n - integer(I4B) :: jj - integer(I4B) :: iaux - integer(I4B) :: itmp - integer(I4B) :: ierr - real(DP) :: endtim - integer(I4B), dimension(:), pointer, contiguous :: nboundchk - ! -- format - character(len=*),parameter :: fmthdbot = & - "('well head (', G0, ') must be >= BOTTOM_ELEVATION (', G0, ').')" -! ------------------------------------------------------------------------------ - ! - ! -- code - ! - ! -- allocate and initialize temporary variables - allocate(nboundchk(this%nmawwells)) - do n = 1, this%nmawwells - nboundchk(n) = 0 - end do - ! - ! -- initialize itmp - itmp = 0 - ! - ! -- allocate space for mawwells data - allocate(this%mawwells(this%nmawwells)) - ! -- allocate pointers - do n = 1, this%nmawwells - call this%maw_allocate_well(n) - enddo - this%npakeq = this%nmawwells - ! - ! -- allocate local storage for aux variables - if (this%naux > 0) then - allocate(caux(this%naux)) - end if - ! - ! -- read maw well data - ! -- get wells block - call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & - supportopenclose=.true.) - ! - ! -- parse locations block if detected - if (isfound) then - write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & - ' PACKAGEDATA' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - ival = this%parser%GetInteger() - n = ival - - if (n < 1 .or. n > this%nmawwells) then - write(errmsg,'(4x,a,1x,i6)') & - '****ERROR. IMAW MUST BE > 0 and <= ', this%nmawwells - call store_error(errmsg) - cycle - end if - - ! -- increment nboundchk - nboundchk(n) = nboundchk(n) + 1 - - ! -- radius - rval = this%parser%GetDouble() - if (rval <= DZERO) then - write(errmsg,'(4x,a,1x,i6,1x,a)') & - '****ERROR. RADIUS FOR WELL', n, 'MUST BE GR5EATER THAN ZERO.' - call store_error(errmsg) - cycle - end if - this%mawwells(n)%radius = rval - this%mawwells(n)%area = DPI * rval**DTWO - ! -- well bottom - this%mawwells(n)%bot = this%parser%GetDouble() - ! -- strt - call this%parser%GetString(strttext) - ! -- ieqn - call this%parser%GetStringCaps(keyword) - if (keyword=='SPECIFIED') then - this%mawwells(n)%ieqn = 0 - else if (keyword=='THEIM' .or. keyword=='THIEM') then - this%mawwells(n)%ieqn = 1 - else if (keyword=='SKIN') then - this%mawwells(n)%ieqn = 2 - else if (keyword=='CUMULATIVE') then - this%mawwells(n)%ieqn = 3 - else if (keyword=='MEAN') then - this%mawwells(n)%ieqn = 4 - else - write(errmsg,'(4x,a,1x,i6,1x,a)') & - '****ERROR. CONDEQN FOR WELL', n, & - 'MUST BE "CONDUCTANCE", "THIEM" "MEAN", OR "SKIN".' - end if - ! -- ngwnodes - ival = this%parser%GetInteger() - if (ival < 1) then - write(errmsg,'(4x,a,1x,i6,1x,a)') & - '****ERROR. NGWFNODES FOR WELL', n, 'MUST BE GREATER THAN ZERO' - call store_error(errmsg) - end if - - if (ival > 0) then - this%mawwells(n)%ngwfnodes = ival - end if - - ! -- allocate storage for connection data needed for the MAW well - allocate(this%mawwells(n)%gwfnodes(this%mawwells(n)%ngwfnodes)) - allocate(this%mawwells(n)%satcond(this%mawwells(n)%ngwfnodes)) - allocate(this%mawwells(n)%simcond(this%mawwells(n)%ngwfnodes)) - allocate(this%mawwells(n)%topscrn(this%mawwells(n)%ngwfnodes)) - allocate(this%mawwells(n)%botscrn(this%mawwells(n)%ngwfnodes)) - if (this%mawwells(n)%ieqn==2 .OR. this%mawwells(n)%ieqn==3 .OR. & - this%mawwells(n)%ieqn==4) then - allocate(this%mawwells(n)%hk(this%mawwells(n)%ngwfnodes)) - end if - if (this%mawwells(n)%ieqn==2 .OR. this%mawwells(n)%ieqn==3 .OR. & - this%mawwells(n)%ieqn==4) then - allocate(this%mawwells(n)%sradius(this%mawwells(n)%ngwfnodes)) - end if - - ! -- increment maxbound - itmp = itmp + this%mawwells(n)%ngwfnodes - ! - ! -- set default bndName - write (cno,'(i9.9)') n - bndName = 'MAWWELL' // cno - - ! -- get aux data - do iaux = 1, this%naux - call this%parser%GetString(caux(iaux)) - end do - - ! -- read well name - this%mawwells(n)%name = bndName - if (this%inamedbound /= 0) then - call this%parser%GetStringCaps(bndNameTemp) - if (bndNameTemp /= '') then - this%mawwells(n)%name = bndNameTemp(1:16) - endif - else - bndName = '' - endif - ! fill timeseries aware data - jj = 1 ! For WELL_HEAD - endtim = DZERO - call read_single_value_or_time_series(strttext, & - this%mawwells(n)%head%value, & - this%mawwells(n)%head%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, n, jj, 'HEAD', & - bndName, this%parser%iuactive) - this%mawwells(n)%strt = this%mawwells(n)%head%value - if (this%mawwells(n)%strt < this%mawwells(n)%bot) then - write(cstr, fmthdbot) this%mawwells(n)%strt, this%mawwells(n)%bot - call this%maw_set_attribute_error(n, 'STRT', trim(cstr)) - end if - - ! -- fill aux data - do iaux = 1, this%naux - text = caux(iaux) - jj = 1 !iaux - call read_single_value_or_time_series(trim(adjustl(text)), & - this%mawwells(n)%auxvar(iaux)%value, & - this%mawwells(n)%auxvar(iaux)%name, & - endtim, & - this%Name, 'AUX', this%TsManager, & - this%iprpak, n, jj, & - this%auxname(iaux), & - bndName, this%parser%iuactive) - end do - end do - - write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' PACKAGEDATA' - ! - ! -- check for duplicate or missing wells - do n = 1, this%nmawwells - if (nboundchk(n) == 0) then - write(errmsg,'(a,1x,i0)') 'ERROR. NO DATA SPECIFIED FOR MAW WELL', n - call store_error(errmsg) - else if (nboundchk(n) > 1) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & - 'ERROR. DATA FOR MAW WELL', n, 'SPECIFIED', nboundchk(n), 'TIMES' - call store_error(errmsg) - end if - end do - else - call store_error('ERROR. REQUIRED PACKAGEDATA BLOCK NOT FOUND.') - end if - ! - ! -- terminate if any errors were detected - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- set MAXBOUND - this%maxbound = itmp - write(this%iout,'(//4x,a,i7)') 'MAXBOUND = ', this%maxbound - ! - ! -- deallocate local storage for aux variables - if (this%naux > 0) then - deallocate(caux) - end if - ! - ! -- deallocate local storage for nboundchk - deallocate(nboundchk) - ! - ! -- return - return - end subroutine maw_read_wells - - subroutine maw_read_well_connections(this) -! ****************************************************************************** -! pak1read_dimensions -- Read the dimensions for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - ! -- dummy - class(MawType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: errmsg - character(len=LINELENGTH) :: cellid - character(len=30) :: nodestr - integer(I4B) :: ierr, ival - integer(I4b) :: ipos - logical :: isfound, endOfBlock - real(DP) :: rval - real(DP) :: topnn - real(DP) :: botnn - real(DP) :: botw - integer(I4B) :: j - integer(I4B) :: jj - integer(I4B) :: n - integer(I4B) :: nn - integer(I4B) :: nn2 - integer(I4B), dimension(:), pointer, contiguous :: nboundchk - integer(I4B), dimension(:), pointer, contiguous :: iachk - -! ------------------------------------------------------------------------------ - ! -- format - ! - ! -- code - ! - ! -- allocate and initialize local storage - allocate(iachk(this%nmawwells+1)) - iachk(1) = 1 - do n = 1, this%nmawwells - iachk(n+1) = iachk(n) + this%mawwells(n)%ngwfnodes - end do - allocate(nboundchk(this%maxbound)) - do n = 1, this%maxbound - nboundchk(n) = 0 - end do - ! - ! -- get well_connections block - call this%parser%GetBlock('CONNECTIONDATA', isfound, ierr, & - supportOpenClose=.true.) - ! - ! -- parse well_connections block if detected - if (isfound) then - write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & - ' CONNECTIONDATA' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - ival = this%parser%GetInteger() - n = ival - - if (n < 1 .or. n > this%nmawwells) then - write(errmsg,'(4x,a,1x,i6)') & - '****ERROR. IMAW MUST BE > 0 and <= ', this%nmawwells - call store_error(errmsg) - cycle - end if - - ! -- read connection number - ival = this%parser%GetInteger() - if (ival < 1 .or. ival > this%mawwells(n)%ngwfnodes) then - write(errmsg,'(4x,a,1x,i4,1x,a,1x,i6)') & - '****ERROR. JCONN FOR WELL ', n, 'MUST BE > 1 and <= ', this%mawwells(n)%ngwfnodes - call store_error(errmsg) - cycle - end if - - ipos = iachk(n) + ival - 1 - nboundchk(ipos) = nboundchk(ipos) + 1 - - j = ival - ! -- read gwfnodes from the line - call this%parser%GetCellid(this%dis%ndim, cellid) - nn = this%dis%noder_from_cellid(cellid, this%inunit, this%iout) - topnn = this%dis%top(nn) - botnn = this%dis%bot(nn) - botw = this%mawwells(n)%bot - ! -- set gwf node number for connection - this%mawwells(n)%gwfnodes(j) = nn - ! -- top of screen - rval = this%parser%GetDouble() - if (this%mawwells(n)%ieqn /= 4) then - rval = topnn - else - if (rval > topnn) then - rval = topnn - end if - end if - this%mawwells(n)%topscrn(j) = rval - ! -- bottom of screen - rval = this%parser%GetDouble() - if (this%mawwells(n)%ieqn /= 4) then - rval = botnn - else - if (rval < botnn) then - rval = botnn - end if - end if - this%mawwells(n)%botscrn(j) = rval - ! adjust the bottom of the well for all conductance approaches - ! except for "mean" - if (this%mawwells(n)%ieqn /= 4) then - if (rval < botw) then - botw = rval - this%mawwells(n)%bot = rval - end if - end if - ! -- hydraulic conductivity or conductance - rval = this%parser%GetDouble() - if (this%mawwells(n)%ieqn==0) then - this%mawwells(n)%satcond(j) = rval - else if (this%mawwells(n)%ieqn==2 .OR. this%mawwells(n)%ieqn==3 .OR. & - this%mawwells(n)%ieqn==4) then - this%mawwells(n)%hk(j) = rval - end if - ! -- skin radius - rval = this%parser%GetDouble() - if (this%mawwells(n)%ieqn==2 .OR. this%mawwells(n)%ieqn==3 .OR. & - this%mawwells(n)%ieqn==4) then - this%mawwells(n)%sradius(j) = rval - end if - end do - write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' CONNECTIONDATA' - - ipos = 0 - do n = 1, this%nmawwells - do j = 1, this%mawwells(n)%ngwfnodes - ipos = ipos + 1 - ! - ! -- check for missing or duplicate maw well connections - if (nboundchk(ipos) == 0) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0)') & - 'ERROR. NO DATA SPECIFIED FOR MAW WELL', n, 'CONNECTION', j - call store_error(errmsg) - else if (nboundchk(ipos) > 1) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & - 'ERROR. DATA FOR MAW WELL', n, 'CONNECTION', j, & - 'SPECIFIED', nboundchk(n), 'TIMES' - call store_error(errmsg) - end if - end do - end do - ! - ! -- make sure that more than one connection per cell is only specified - ! wells using the mean conducance type - do n = 1, this%nmawwells - if (this%mawwells(n)%ieqn /= 4) then - do j = 1, this%mawwells(n)%ngwfnodes - nn = this%mawwells(n)%gwfnodes(j) - do jj = 1, this%mawwells(n)%ngwfnodes - ! skip current maw node - if (jj == j) then - cycle - end if - nn2 = this%mawwells(n)%gwfnodes(jj) - if (nn2 == nn) then - call this%dis%noder_to_string(nn, nodestr) - write(errmsg,'(a,1x,i0,1x,a,1x,i0,3(1x,a))') & - 'ERROR. ONLY ONE CONNECTION CAN BE SPECIFIED FOR MAW WELL', & - n, 'CONNECTION', j, 'TO GWF CELL', trim(adjustl(nodestr)), & - 'UNLESS THE MEAN CONDEQN IS SPECIFIED' - call store_error(errmsg) - end if - end do - end do - end if - end do - else - call store_error('ERROR. REQUIRED CONNECTIONDATA BLOCK NOT FOUND.') - end if - ! - ! -- deallocate local variable - deallocate(iachk) - deallocate(nboundchk) - ! - ! -- write summary of maw well_connection error messages - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- return - return - end subroutine maw_read_well_connections - - - subroutine maw_read_dimensions(this) -! ****************************************************************************** -! pak1read_dimensions -- Read the dimensions for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - ! -- dummy - class(MawType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: errmsg - character(len=LENBOUNDNAME) :: keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock - ! -- format -! ------------------------------------------------------------------------------ - ! - ! -- initialize dimensions to -1 - this%nmawwells= -1 - this%maxbound = -1 - ! - ! -- 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 '//trim(adjustl(this%text))// & - ' DIMENSIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('NMAWWELLS') - this%nmawwells = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)')'NMAWWELLS = ', this%nmawwells - case default - write(errmsg,'(4x,a,a)') & - '****ERROR. UNKNOWN '//trim(this%text)//' DIMENSION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - end do - write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' DIMENSIONS' - else - call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') - call ustop() - end if - ! - ! -- verify dimensions were set correctly - if (this%nmawwells < 0) then - write(errmsg, '(1x,a)') & - 'ERROR: NMAWWELLS WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.' - call store_error(errmsg) - end if - ! - ! -- stop if errors were encountered in the DIMENSIONS block - ierr = count_errors() - if (ierr > 0) then - call ustop() - end if - ! - ! -- read wells block - call this%maw_read_wells() - ! - ! -- read well_connections block - call this%maw_read_well_connections() - ! - ! -- Call define_listlabel to construct the list label that is written - ! when PRINT_INPUT option is used. - call this%define_listlabel() - ! - ! -- setup the budget object - call this%maw_setup_budobj() - ! - ! -- setup the head table object - call this%maw_setup_tableobj() - ! - ! -- return - return - end subroutine maw_read_dimensions - - - subroutine maw_read_initial_attr(this) -! ****************************************************************************** -! maw_read_initial_attr -- Read the initial parameters for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use MemoryManagerModule, only: mem_setptr - ! -- dummy - class(MawType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: title - character(len=LINELENGTH) :: text - integer(I4B) :: ntabcols - integer(I4B) :: j, n - integer(I4B) :: nn - integer(I4B) :: inode - integer(I4B) :: idx - real(DP) :: k11, k22 - character (len=10), dimension(0:4) :: ccond - character (len=30) :: nodestr - ! -- data - data ccond(0) /'SPECIFIED '/ - data ccond(1) /'THIEM '/ - data ccond(2) /'SKIN '/ - data ccond(3) /'CUMULATIVE'/ - data ccond(4) /'MEAN '/ - ! -- format - character(len=*), parameter :: fmtwelln = & - "(1X,//43X,'MULTI-AQUIFER WELL DATA'" // & - "/1X,109('-')," // & - "/1X,7(A10,1X),A16)" - character(len=*), parameter :: fmtwelld = & - "(1X,I10,1X,4(G10.3,1X),I10,1X,A10,1X,A16)" - character(len=*), parameter :: fmtline = & - "(1X,119('-'),//)" - character(len=*), parameter :: fmtwellcn = & - "(1X,//37X,'MULTI-AQUIFER WELL CONNECTION DATA'" // & - "/1X,119('-')," // & - "/1X,2(A10,1X),A20,7(A10,1X))" - character(len=*), parameter :: fmtwellcd = & - "(1X,2(I10,1X),A20,1X,2(G10.3,1X),2(A10,1X),3(G10.3,1X))" -! ------------------------------------------------------------------------------ - ! - ! -- initialize xnewpak - do n = 1, this%nmawwells - this%xnewpak(n) = this%mawwells(n)%strt - end do - ! - ! -- initialize status (iboundpak) of maw wells to active - do n = 1, this%nmawwells - if (this%mawwells(n)%status == 'CONSTANT') then - this%iboundpak(n) = -1 - else if (this%mawwells(n)%status == 'INACTIVE') then - this%iboundpak(n) = 0 - else if (this%mawwells(n)%status == 'ACTIVE ') then - this%iboundpak(n) = 1 - end if - end do - ! - ! -- set idxmawconn and imap for each connection - idx = 0 - this%idxmawconn(1) = 1 - do n = 1, this%nmawwells - do j = 1, this%mawwells(n)%ngwfnodes - idx = idx + 1 - this%imap(idx) = n - end do - this%idxmawconn(n+1) = idx + 1 - end do - ! - ! -- set boundname for each connection - if (this%inamedbound /= 0) then - idx = 0 - do n = 1, this%nmawwells - this%cmawname(n) = this%mawwells(n)%name - do j = 1, this%mawwells(n)%ngwfnodes - idx = idx + 1 - this%boundname(idx) = this%mawwells(n)%name - end do - end do - else - do n = 1, this%nmawwells - this%cmawname(n) = '' - end do - end if - ! - ! -- set imap and boundname for each connection - if (this%inamedbound /= 0) then - idx = 0 - do n = 1, this%nmawwells - do j = 1, this%mawwells(n)%ngwfnodes - idx = idx + 1 - this%boundname(idx) = this%mawwells(n)%name - this%imap(idx) = n - end do - end do - end if - ! - ! -- set pointer to gwf iss and gwf hk - call mem_setptr(this%gwfiss, 'ISS', trim(this%name_model)) - call mem_setptr(this%gwfk11, 'K11', trim(this%name_model)//' NPF') - call mem_setptr(this%gwfk22, 'K22', trim(this%name_model)//' NPF') - call mem_setptr(this%gwfik22, 'IK22', trim(this%name_model)//' NPF') - call mem_setptr(this%gwfsat, 'SAT', trim(this%name_model)//' NPF') - ! - ! -- qa data - call this%maw_check_attributes() - ! - ! -- Calculate the saturated conductance - do n = 1, this%nmawwells - ! - ! -- calculate saturated conductance only if CONDUCTANCE was not - ! specified for each maw-gwf connection (CONDUCTANCE keyword). - do j = 1, this%mawwells(n)%ngwfnodes - if (this%mawwells(n)%ieqn /= 0) then - inode = this%mawwells(n)%gwfnodes(j) - call this%maw_calculate_satcond(n, j, inode) - end if - end do - end do - ! - ! -- write summary of static well data - ! -- write well data - if (this%iprpak /= 0) then - ntabcols = 7 - if (this%inamedbound /= 0) then - ntabcols = ntabcols + 1 - end if - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%name)) //') STATIC WELL DATA' - call table_cr(this%inputtab, this%name, title) - call this%inputtab%table_df(this%nmawwells, ntabcols, this%iout) - text = 'NUMBER' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'RADIUS' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'AREA' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'WELL BOTTOM' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'STARTING HEAD' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'NUMBER OF GWF NODES' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'CONDUCT. EQUATION' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - if (this%inamedbound /= 0) then - text = 'NAME' - call this%inputtab%initialize_column(text, 20, alignment=TABLEFT) - end if - do n = 1, this%nmawwells - call this%inputtab%add_term(n) - call this%inputtab%add_term(this%mawwells(n)%radius) - call this%inputtab%add_term(this%mawwells(n)%area) - call this%inputtab%add_term(this%mawwells(n)%bot) - call this%inputtab%add_term(this%mawwells(n)%strt) - call this%inputtab%add_term(this%mawwells(n)%ngwfnodes) - call this%inputtab%add_term(ccond(this%mawwells(n)%ieqn)) - if (this%inamedbound /= 0) then - call this%inputtab%add_term(this%mawwells(n)%name) - end if - end do - end if - ! - ! -- write well connection data - if (this%iprpak /= 0) then - ntabcols = 10 - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%name)) //') STATIC WELL CONNECTION DATA' - call table_cr(this%inputtab, this%name, title) - call this%inputtab%table_df(this%maxbound, ntabcols, this%iout) - text = 'NUMBER' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'WELL CONNECTION' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'CELLID' - call this%inputtab%initialize_column(text, 20, alignment=TABLEFT) - text = 'TOP OF SCREEN' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'BOTTOM OF SCREEN' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'SKIN RADIUS' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'SKIN K' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'K11' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'K22' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'SATURATED WELL CONDUCT.' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - ! - ! -- write the data to the table - do n = 1, this%nmawwells - do j = 1, this%mawwells(n)%ngwfnodes - call this%inputtab%add_term(n) - call this%inputtab%add_term(j) - nn = this%mawwells(n)%gwfnodes(j) - call this%dis%noder_to_string(nn, nodestr) - call this%inputtab%add_term(nodestr) - call this%inputtab%add_term(this%mawwells(n)%topscrn(j)) - call this%inputtab%add_term(this%mawwells(n)%botscrn(j)) - if (this%mawwells(n)%ieqn == 2 .or. & - this%mawwells(n)%ieqn == 3 .or. & - this%mawwells(n)%ieqn == 4) then - call this%inputtab%add_term(this%mawwells(n)%sradius(j)) - call this%inputtab%add_term(this%mawwells(n)%hk(j)) - else - call this%inputtab%add_term(' ') - call this%inputtab%add_term(' ') - end if - if (this%mawwells(n)%ieqn == 1 .or. & - this%mawwells(n)%ieqn == 2 .or. & - this%mawwells(n)%ieqn == 3) then - k11 = this%gwfk11(nn) - if (this%gwfik22 == 0) then - k22 = this%gwfk11(nn) - else - k22 = this%gwfk22(nn) - end if - call this%inputtab%add_term(k11) - call this%inputtab%add_term(k22) - else - call this%inputtab%add_term(' ') - call this%inputtab%add_term(' ') - end if - call this%inputtab%add_term(this%mawwells(n)%satcond(j)) - end do - end do - end if - ! - ! -- finished with pointer to gwf hydraulic conductivity - this%gwfk11 => null() - this%gwfk22 => null() - this%gwfik22 => null() - this%gwfsat => null() - ! - ! -- check for any error conditions - if (count_errors() > 0) then - call ustop() - end if - ! - ! -- return - return - end subroutine maw_read_initial_attr - - - subroutine maw_set_stressperiod(this, imaw, line) -! ****************************************************************************** -! maw_set_stressperiod -- Set a stress period attribute for mawweslls(imaw) -! using keywords. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: kper, perlen, totimsav - use TimeSeriesManagerModule, only: read_single_value_or_time_series - ! -- dummy - class(MawType),intent(inout) :: this - integer(I4B), intent(in) :: imaw - character (len=*), intent(in) :: line - ! -- local - character(len=LINELENGTH) :: text, cstr - character(len=LINELENGTH) :: caux - character(len=LINELENGTH) :: keyword - character(len=LINELENGTH) :: errmsg - character(len=LENBOUNDNAME) :: bndName - character(len=9) :: cmaw - integer(I4B) :: ival, istart, istop - integer(I4B) :: i0 - integer(I4B) :: lloc - integer(I4B) :: ii - integer(I4B) :: jj - integer(I4B) :: idx - integer(I4B) :: iaux - real(DP) :: rval - real(DP) :: endtim - integer(I4B) :: istat - character(len=MAXCHARLEN) :: ermsg, ermsgr - ! -- formats - character(len=*),parameter :: fmthdbot = & - "('well head (',G0,') must be >= BOTTOM_ELEVATION (',G0, ').')" -! ------------------------------------------------------------------------------ - ! - ! -- Find time interval of current stress period. - endtim = totimsav + perlen(kper) - ! - ! -- Assign boundary name, if available - ! - ! -- set default bndName - write (cmaw,'(i9.9)') imaw - !bndName = 'MAWWELL' // cmaw - if (this%inamedbound==1) then - idx = 0 - do ii = 1, imaw - do jj = 1, this%mawwells(ii)%ngwfnodes - idx = idx + 1 - end do - end do - bndName = this%boundname(idx) - else - bndName = '' - endif - ! - ! -- read line - lloc = 1 - call urword(line, lloc, istart, istop, 1, ival, rval, this%iout, this%inunit) - i0 = istart - keyword = line(istart:istop) - select case (line(istart:istop)) - case ('STATUS') - call urword(line, lloc, istart, istop, 1, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - this%mawwells(imaw)%status = text(1:8) - if (text == 'CONSTANT') then - this%iboundpak(imaw) = -1 - else if (text == 'INACTIVE') then - this%iboundpak(imaw) = 0 - else if (text == 'ACTIVE') then - this%iboundpak(imaw) = 1 - else - write(errmsg,'(4x,a,a)') & - '****ERROR. UNKNOWN '//trim(this%text)//' MAW STATUS KEYWORD: ', & - text - call store_error(errmsg) - end if - case ('RATE') - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 1 ! For RATE - call read_single_value_or_time_series(text, & - this%mawwells(imaw)%rate%value, & - this%mawwells(imaw)%rate%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, imaw, jj, 'RATE', & - bndName, this%inunit) - case ('WELL_HEAD') - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 1 ! For WELL_HEAD - call read_single_value_or_time_series(text, & - this%mawwells(imaw)%head%value, & - this%mawwells(imaw)%head%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, imaw, jj, 'HEAD', & - bndName, this%inunit) - this%xnewpak(imaw) = this%mawwells(imaw)%head%value - if (this%mawwells(imaw)%head%value < this%mawwells(imaw)%bot) then - write(cstr, fmthdbot) this%mawwells(imaw)%head%value, this%mawwells(imaw)%bot - call this%maw_set_attribute_error(imaw, 'WELL HEAD', trim(cstr)) - end if - case ('FLOWING_WELL') - call urword(line, lloc, istart, istop, 3, ival, rval, this%iout, this%inunit) - this%mawwells(imaw)%fwelev = rval - call urword(line, lloc, istart, istop, 3, ival, rval, this%iout, this%inunit) - this%mawwells(imaw)%fwcond = rval - call urword(line, lloc, istart, istop, 3, ival, rval, -this%iout, this%inunit) - this%mawwells(imaw)%fwrlen = rval - case ('RATE_SCALING') - call urword(line, lloc, istart, istop, 3, ival, rval, this%iout, this%inunit) - this%mawwells(imaw)%pumpelev = rval - call urword(line, lloc, istart, istop, 3, ival, rval, this%iout, this%inunit) - this%mawwells(imaw)%reduction_length = rval - if (rval < DZERO) then - call this%maw_set_attribute_error(imaw, trim(keyword), 'must be >= 0.') - end if - case ('HEAD_LIMIT') - call urword(line, lloc, istart, istop, 1, ival, rval, this%iout, this%inunit) - if (line(istart:istop) == 'OFF') then - this%mawwells(imaw)%shutofflevel = DEP20 - else - read (line(istart:istop), *,iostat=istat,iomsg=ermsgr) this%mawwells(imaw)%shutofflevel - if (istat /= 0) then - ermsg = 'Error reading HEAD_LIMIT value.' - call store_error(ermsg) - call store_error(ermsgr) - call ustop() - endif - end if - case ('SHUT_OFF') - call urword(line, lloc, istart, istop, 3, ival, rval, this%iout, this%inunit) - this%mawwells(imaw)%shutoffmin = rval - call urword(line, lloc, istart, istop, 3, ival, rval, this%iout, this%inunit) - this%mawwells(imaw)%shutoffmax = rval - case ('AUXILIARY') - call urword(line, lloc, istart, istop, 1, ival, rval, this%iout, this%inunit) - caux = line(istart:istop) - do iaux = 1, this%naux - if (trim(adjustl(caux)) /= trim(adjustl(this%auxname(iaux)))) cycle - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 1 !iaux - call read_single_value_or_time_series(text, & - this%mawwells(imaw)%auxvar(iaux)%value, & - this%mawwells(imaw)%auxvar(iaux)%name, & - endtim, & - this%Name, 'AUX', this%TsManager, & - this%iprpak, imaw, jj, & - this%auxname(iaux), bndName, & - this%inunit) - exit - end do - case default - write(errmsg,'(4x,a,a)') & - '****ERROR. UNKNOWN '//trim(this%text)//' MAW DATA KEYWORD: ', & - line(istart:istop) - call store_error(errmsg) - call ustop() - end select - - ! - ! -- return - return - end subroutine maw_set_stressperiod - - - subroutine maw_set_attribute_error(this, imaw, keyword, msg) -! ****************************************************************************** -! maw_set_attribute_error -- Issue a parameter error for mawweslls(imaw) -! Subroutine: (1) read itmp -! (2) read new boundaries if itmp>0 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use SimModule, only: store_error - ! -- dummy - class(MawType),intent(inout) :: this - integer(I4B), intent(in) :: imaw - character (len=*), intent(in) :: keyword - character (len=*), intent(in) :: msg - ! -- local - character(len=LINELENGTH) :: errmsg - ! -- formats -! ------------------------------------------------------------------------------ - if (len(msg) == 0) then - write(errmsg,'(4x,a,1x,a,1x,a,1x,i0,1x,a)') & - '****ERROR.', keyword, ' for MAW well', imaw, 'has already been set.' - else - write(errmsg,'(4x,a,1x,a,1x,a,1x,i0,1x,a)') & - '****ERROR.', keyword, ' for MAW well', imaw, msg - end if - call store_error(errmsg) - ! -- return - return - end subroutine maw_set_attribute_error - - - subroutine maw_check_attributes(this) -! ****************************************************************************** -! maw_check_attributes -- Issue parameter errors for mawwells(imaw) -! Subroutine: (1) read itmp -! (2) read new boundaries if itmp>0 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use SimModule, only: store_error - ! -- dummy - class(MawType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: cgwfnode - integer(I4B) :: idx - integer(I4B) :: n - integer(I4B) :: j - ! -- formats -! ------------------------------------------------------------------------------ - idx = 1 - do n = 1, this%nmawwells - if (this%mawwells(n)%ngwfnodes < 1) then - call this%maw_set_attribute_error(n, 'NGWFNODES', 'must be greater ' // & - 'than 0.') - end if - ! -- CDL 2/5/2018 Moved to maw_set_stressperiod so it is only done if a - ! new head is read in. - !if (this%xnewpak(n) < this%mawwells(n)%bot) then - !write(cstr, fmthdbot) this%xnewpak(n), this%mawwells(n)%bot - !call this%maw_set_attribute_error(n, 'WELL HEAD', trim(cstr)) - !end if - if (this%mawwells(n)%radius == DEP20) then - call this%maw_set_attribute_error(n, 'RADIUS', 'has not been specified.') - end if - if (this%mawwells(n)%shutoffmin > DZERO) then - if (this%mawwells(n)%shutoffmin >= this%mawwells(n)%shutoffmax) then - call this%maw_set_attribute_error(n, 'SHUT_OFF', 'shutoffmax must ' // & - 'be > shutoffmin.') - end if - end if - do j = 1, this%mawwells(n)%ngwfnodes - ! -- write gwfnode number - write(cgwfnode,'(a,i0,a)') 'gwfnode(', j,')' - if (this%mawwells(n)%botscrn(j) >= this%mawwells(n)%topscrn(j)) then - call this%maw_set_attribute_error(n, 'SCREEN_TOP', 'screen bottom ' // & - 'must be < screen top. ' // & - trim(cgwfnode)) - end if - if (this%mawwells(n)%ieqn==2 .OR. this%mawwells(n)%ieqn==3 .OR. & - this%mawwells(n)%ieqn==4) then - if (this%mawwells(n)%sradius(j) > DZERO) then - if (this%mawwells(n)%sradius(j) <= this%mawwells(n)%radius) then - call this%maw_set_attribute_error(n, 'RADIUS_SKIN', 'skin ' // & - 'radius must be >= well ' // & - 'radius. ' // trim(cgwfnode)) - end if - end if - if (this%mawwells(n)%hk(j) <= DZERO) then - call this%maw_set_attribute_error(n, 'HK_SKIN', 'skin hyraulic ' // & - 'conductivity must be > zero. ' // & - trim(cgwfnode)) - end if - else if (this%mawwells(n)%ieqn == 0) then - if (this%mawwells(n)%satcond(j) < DZERO) then - call this%maw_set_attribute_error(n, 'HK_SKIN', & - 'skin hyraulic conductivity ' // & - 'must be >= zero when using ' // & - 'SPECIFIED condeqn. ' // & - trim(cgwfnode)) - end if - end if - idx = idx + 1 - end do - end do - ! -- reset check_attr - this%check_attr = 0 - ! -- return - return - end subroutine maw_check_attributes - - subroutine maw_ac(this, moffset, sparse) -! ****************************************************************************** -! bnd_ac -- Add package connection to matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use SparseModule, only: sparsematrix - ! -- dummy - class(MawType),intent(inout) :: this - integer(I4B), intent(in) :: moffset - type(sparsematrix), intent(inout) :: sparse - ! -- local - integer(I4B) :: j, n - integer(I4B) :: jj, jglo - integer(I4B) :: nglo - ! -- format -! ------------------------------------------------------------------------------ - ! - ! - ! -- Add package rows to sparse - do n = 1, this%nmawwells - nglo = moffset + this%dis%nodes + this%ioffset + n - call sparse%addconnection(nglo, nglo, 1) - do j = 1, this%mawwells(n)%ngwfnodes - jj = this%mawwells(n)%gwfnodes(j) - jglo = jj + moffset - call sparse%addconnection(nglo, jglo, 1) - call sparse%addconnection(jglo, nglo, 1) - end do - - end do - ! - ! -- return - return - end subroutine maw_ac - - subroutine maw_mc(this, moffset, iasln, jasln) -! ****************************************************************************** -! bnd_ac -- map package connection to matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use SparseModule, only: sparsematrix - ! -- dummy - class(MawType),intent(inout) :: this - integer(I4B), intent(in) :: moffset - integer(I4B), dimension(:), intent(in) :: iasln - integer(I4B), dimension(:), intent(in) :: jasln - ! -- local - integer(I4B) :: n, j, ii, jj, iglo, jglo - integer(I4B) :: ipos - ! -- format -! ------------------------------------------------------------------------------ - ! - ! - allocate(this%idxlocnode(this%nmawwells)) - allocate(this%idxdglo(this%maxbound)) - allocate(this%idxoffdglo(this%maxbound)) - allocate(this%idxsymdglo(this%maxbound)) - allocate(this%idxsymoffdglo(this%maxbound)) - ! - ! -- Find the position of each connection in the global ia, ja structure - ! and store them in idxglo. idxglo allows this model to insert or - ! retrieve values into or from the global A matrix - ! -- maw rows - ipos = 1 - do n = 1, this%nmawwells - iglo = moffset + this%dis%nodes + this%ioffset + n - this%idxlocnode(n) = this%dis%nodes + this%ioffset + n - do ii = 1, this%mawwells(n)%ngwfnodes - j = this%mawwells(n)%gwfnodes(ii) - jglo = j + moffset - searchloop: do jj = iasln(iglo), iasln(iglo + 1) - 1 - if(jglo == jasln(jj)) then - this%idxdglo(ipos) = iasln(iglo) - this%idxoffdglo(ipos) = jj - exit searchloop - endif - enddo searchloop - ipos = ipos + 1 - end do - end do - ! -- maw contributions gwf portion of global matrix - ipos = 1 - do n = 1, this%nmawwells - do ii = 1, this%mawwells(n)%ngwfnodes - iglo = this%mawwells(n)%gwfnodes(ii) + moffset - jglo = moffset + this%dis%nodes + this%ioffset + n - symsearchloop: do jj = iasln(iglo), iasln(iglo + 1) - 1 - if(jglo == jasln(jj)) then - this%idxsymdglo(ipos) = iasln(iglo) - this%idxsymoffdglo(ipos) = jj - exit symsearchloop - endif - enddo symsearchloop - ipos = ipos + 1 - end do - end do - ! - ! -- return - return - end subroutine maw_mc - - subroutine maw_options(this, option, found) -! ****************************************************************************** -! maw_options -- set options specific to MawType -! -! maw_options overrides BndType%bnd_options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: MAXCHARLEN, DZERO - use OpenSpecModule, only: access, form - use InputOutputModule, only: urword, getunit, openfile - ! -- dummy - class(MawType), intent(inout) :: this - character(len=*), intent(inout) :: option - logical, intent(inout) :: found - ! -- local - character(len=MAXCHARLEN) :: fname, keyword - ! -- formats - character(len=*),parameter :: fmtflowingwells = & - "(4x, 'FLOWING WELLS WILL BE SIMULATED.')" - character(len=*),parameter :: fmtshutdown = & - "(4x, 'SHUTDOWN ', a, ' VALUE (',g15.7,') SPECIFIED.')" - character(len=*),parameter :: fmtnostoragewells = & - "(4x, 'WELL STORAGE WILL NOT BE SIMULATED.')" - character(len=*),parameter :: fmtmawbin = & - "(4x, 'MAW ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" -! ------------------------------------------------------------------------------ - ! - ! -- Check for 'FLOWING_WELLS' and set this%iflowingwells - select case (option) - case ('PRINT_HEAD') - this%iprhed = 1 - write(this%iout,'(4x,a)') trim(adjustl(this%text))// & - ' HEADS WILL BE PRINTED TO LISTING FILE.' - found = .true. - case('HEAD') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%iheadout = getunit() - call openfile(this%iheadout, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE') - write(this%iout,fmtmawbin) 'HEAD', fname, this%iheadout - found = .true. - else - call store_error('OPTIONAL STAGE KEYWORD MUST BE FOLLOWED BY FILEOUT') - end if - case('BUDGET') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ibudgetout = getunit() - call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE') - write(this%iout,fmtmawbin) 'BUDGET', fname, this%ibudgetout - found = .true. - else - call store_error('OPTIONAL BUDGET KEYWORD MUST BE FOLLOWED BY FILEOUT') - end if - case('FLOWING_WELLS') - this%iflowingwells = 1 - ! - ! -- Write option and return with found set to true - if(this%iflowingwells > 0) & - write(this%iout, fmtflowingwells) - found = .true. - case('SHUTDOWN_THETA') - this%theta = this%parser%GetDouble() - write(this%iout, fmtshutdown) 'THETA', this%theta - found = .true. - case('SHUTDOWN_KAPPA') - this%kappa = this%parser%GetDouble() - write(this%iout, fmtshutdown) 'KAPPA', this%kappa - found = .true. - case('MOVER') - this%imover = 1 - write(this%iout, '(4x,A)') 'MOVER OPTION ENABLED' - found = .true. - case('NO_WELL_STORAGE') - this%imawissopt = 1 - write(this%iout, fmtnostoragewells) - found = .true. - ! - ! -- right now these 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_PEACEMAN_EFFECTIVE_RADIUS') - call this%parser%DevOpt() - this%ieffradopt = 1 - write(this%iout, '(4x,a)') & - & 'EFFECTIVE RADIUS FOR STRUCTURED GRIDS WILL BE CALCULATED ' // & - & 'USING PEACEMAN 1983' - found = .true. - case default - ! - ! -- No options found - found = .false. - end select - ! - ! -- return - return - end subroutine maw_options - - subroutine maw_ar(this) - ! ****************************************************************************** - ! maw_ar -- Allocate and Read - ! Subroutine: (1) create new-style package - ! (2) point bndobj to the new package - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - ! -- dummy - class(MawType),intent(inout) :: this - ! -- local - ! -- format - ! ------------------------------------------------------------------------------ - ! - call this%obs%obs_ar() - ! - ! -- set omega value used for saturation calculations - if (this%inewton > 0) then - this%satomega = DEM6 - end if - ! - ! -- Allocate arrays in MAW and in package superclass - call this%maw_allocate_arrays() - ! - ! -- read optional initial package parameters - call this%read_initial_attr() - ! - ! -- setup pakmvrobj - if (this%imover /= 0) then - allocate(this%pakmvrobj) - call this%pakmvrobj%ar(this%nmawwells, this%nmawwells, this%origin) - endif - ! - ! -- return - return - end subroutine maw_ar - - - subroutine maw_rp(this) -! ****************************************************************************** -! maw_rp -- Read and Prepare -! Subroutine: (1) read itmp -! (2) read new boundaries if itmp>0 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use TdisModule, only: kper, nper - ! -- dummy - class(MawType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: title - character(len=LINELENGTH) :: line - character(len=LINELENGTH) :: text - character(len=LINELENGTH) :: errmsg - character (len=16) :: csteady - integer(I4B) :: ierr - integer(I4B) :: node, n - logical :: isfound, endOfBlock - integer(I4B) :: ntabcols - integer(I4B) :: ntabrows - integer(I4B) :: imaw - integer(I4B) :: ibnd - integer(I4B) :: j - !integer(I4B) :: isfirst - ! -- formats - character(len=*),parameter :: fmtblkerr = & - "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - character(len=*),parameter :: fmtlsp = & - "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" -! ------------------------------------------------------------------------------ - ! - ! -- set steady-state flag based on gwfiss - this%imawiss = this%gwfiss - ! -- reset maw steady flag if 'STEADY-STATE' specified in the OPTIONS block - if (this%imawissopt == 1) then - this%imawiss = 1 - end if - ! - ! -- set nbound to maxbound - this%nbound = this%maxbound - ! - ! -- Set ionper to the stress period number for which a new block of data - ! will be read. - if(this%inunit == 0) return - ! - ! -- get stress period data - if (this%ionper < kper) then - ! - ! -- get period block - call this%parser%GetBlock('PERIOD', isfound, ierr, & - supportOpenClose=.true.) - if(isfound) then - ! - ! -- read ionper and check for increasing period numbers - call this%read_check_ionper() - else - ! - ! -- PERIOD block not found - if (ierr < 0) then - ! -- End of file found; data applies for remainder of simulation. - this%ionper = nper + 1 - else - ! -- Found invalid block - write(errmsg, fmtblkerr) adjustl(trim(line)) - call store_error(errmsg) - call ustop() - end if - endif - end if - ! - ! -- Read data if ionper == kper - if(this%ionper == kper) then - ! - ! -- setup table for period data - if (this%iprpak /= 0) then - ! - ! -- reset the input table object - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%name)) //') DATA FOR PERIOD' - write(title, '(a,1x,i6)') trim(adjustl(title)), kper - call table_cr(this%inputtab, this%name, title) - call this%inputtab%table_df(1, 5, this%iout, finalize=.FALSE.) - text = 'NUMBER' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'KEYWORD' - call this%inputtab%initialize_column(text, 20, alignment=TABLEFT) - do n = 1, 3 - write(text, '(a,1x,i6)') 'VALUE', n - call this%inputtab%initialize_column(text, 15, alignment=TABCENTER) - end do - end if - ! - ! -- set flag to check attributes - this%check_attr = 1 - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - - imaw = this%parser%GetInteger() - if (imaw < 1 .or. imaw > this%nmawwells) then - write(errmsg,'(4x,a,1x,i6)') & - '****ERROR. IMAW MUST BE > 0 and <= ', this%nmawwells - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - - call this%parser%GetRemainingLine(line) - call this%maw_set_stressperiod(imaw, line) - ! - ! -- write line to table - if (this%iprpak /= 0) then - call this%inputtab%add_term(imaw) - call this%inputtab%line_to_columns(line) - end if - end do - if (this%iprpak /= 0) then - call this%inputtab%finalize_table() - write(this%iout,'(/1x,a,1x,i6,/)') & - 'END OF '//trim(adjustl(this%text))//' DATA FOR PERIOD', kper - end if - ! - else - write(this%iout,fmtlsp) trim(this%filtyp) - endif - ! - !write summary of maw well stress period error messages - ierr = count_errors() - if (ierr > 0) then - call ustop() - end if - ! - ! -- qa data if necessary - if (this%check_attr /= 0) then - call this%maw_check_attributes() - - ! -- write summary of stress period data for MAW - if (this%iprpak == 1) then - if (this%imawiss /= 0) then - csteady = 'STEADY-STATE ' - else - csteady = 'TRANSIENT ' - end if - ! - ! -- reset the input table object for rate data - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%name)) //') ' // trim(adjustl(csteady)) // & - ' RATE DATA FOR PERIOD' - write(title, '(a,1x,i6)') trim(adjustl(title)), kper - ntabcols = 6 - call table_cr(this%inputtab, this%name, title) - call this%inputtab%table_df(this%nmawwells, ntabcols, this%iout) - text = 'NUMBER' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'STATUS' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'RATE' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'SPECIFIED HEAD' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'PUMP ELEVATION' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'REDUCTION LENGTH' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - do n = 1, this%nmawwells - call this%inputtab%add_term(n) - call this%inputtab%add_term(this%mawwells(n)%status) - call this%inputtab%add_term(this%mawwells(n)%rate%value) - if (this%iboundpak(n) < 0) then - call this%inputtab%add_term(this%mawwells(n)%head%value) - else - call this%inputtab%add_term(' ') - end if - call this%inputtab%add_term(this%mawwells(n)%pumpelev) - if (this%mawwells(n)%reduction_length /= DEP20) then - call this%inputtab%add_term(this%mawwells(n)%reduction_length) - else - call this%inputtab%add_term(' ') - end if - end do - ! - ! -- flowing wells - if (this%iflowingwells /= 0) then - ! - ! -- reset the input table object for flowing well data - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%name)) //') ' // trim(adjustl(csteady)) // & - ' FLOWING WELL DATA FOR PERIOD' - write(title, '(a,1x,i6)') trim(adjustl(title)), kper - ntabcols = 4 - ntabrows = 0 - do n = 1, this%nmawwells - if (this%mawwells(n)%fwcond > DZERO) then - ntabrows = ntabrows + 1 - end if - end do - if (ntabrows > 0) then - call table_cr(this%inputtab, this%name, title) - call this%inputtab%table_df(ntabrows, ntabcols, this%iout) - text = 'NUMBER' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'ELEVATION' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'CONDUCT.' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'REDUCTION LENGTH' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - do n = 1, this%nmawwells - if (this%mawwells(n)%fwcond > DZERO) then - call this%inputtab%add_term(n) - call this%inputtab%add_term(this%mawwells(n)%fwelev) - call this%inputtab%add_term(this%mawwells(n)%fwcond) - call this%inputtab%add_term(this%mawwells(n)%fwrlen) - end if - end do - end if - end if - ! - ! -- reset the input table object for shutoff data - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%name)) //') '// trim(adjustl(csteady)) // & - ' WELL SHUTOFF DATA FOR PERIOD' - write(title, '(a,1x,i6)') trim(adjustl(title)), kper - ntabcols = 4 - ntabrows = 0 - do n = 1, this%nmawwells - if (this%mawwells(n)%shutofflevel /= DEP20) then - ntabrows = ntabrows + 1 - end if - end do - if (ntabrows > 0) then - call table_cr(this%inputtab, this%name, title) - call this%inputtab%table_df(ntabrows, ntabcols, this%iout) - text = 'NUMBER' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'ELEVATION' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'MINIMUM. Q' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'MAXIMUM Q' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - do n = 1, this%nmawwells - if (this%mawwells(n)%shutofflevel /= DEP20) then - call this%inputtab%add_term(n) - call this%inputtab%add_term(this%mawwells(n)%shutofflevel) - call this%inputtab%add_term(this%mawwells(n)%shutoffmin) - call this%inputtab%add_term(this%mawwells(n)%shutoffmax) - end if - end do - end if - end if - end if - ! - ! -- fill arrays - ibnd = 1 - do n = 1, this%nmawwells - do j = 1, this%mawwells(n)%ngwfnodes - node = this%mawwells(n)%gwfnodes(j) - this%nodelist(ibnd) = node - - this%bound(1,ibnd) = this%xnewpak(n) - - this%bound(2,ibnd) = this%mawwells(n)%satcond(j) - - this%bound(3,ibnd) = this%mawwells(n)%botscrn(j) - - if (this%iboundpak(n) > 0) then - this%bound(4,ibnd) = this%mawwells(n)%rate%value - else - this%bound(4,ibnd) = DZERO - end if - ibnd = ibnd + 1 - end do - end do - ! - ! -- return - return - end subroutine maw_rp - - subroutine maw_ad(this) -! ****************************************************************************** -! maw_ad -- Add package connection to matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use TdisModule, only : kper, kstp - ! -- dummy - class(MawType) :: this - ! -- local - integer(I4B) :: n - integer(I4B) :: j, iaux, ibnd -! ------------------------------------------------------------------------------ - ! - ! -- Advance the time series - call this%TsManager%ad() - ! - ! -- update auxiliary variables by copying from the derived-type time - ! series variable into the bndpackage auxvar variable so that this - ! information is properly written to the GWF budget file - if (this%naux > 0) then - ibnd = 1 - do n = 1, this%nmawwells - do j = 1, this%mawwells(n)%ngwfnodes - do iaux = 1, this%naux - this%auxvar(iaux, ibnd) = this%mawwells(n)%auxvar(iaux)%value - end do - ibnd = ibnd + 1 - end do - end do - end if - ! - ! -- copy xnew into xold - do n = 1, this%nmawwells - this%xoldpak(n) = this%xnewpak(n) - this%mawwells(n)%xoldsto = this%mawwells(n)%xsto - if (this%iboundpak(n) < 0) then - this%xnewpak(n) = this%mawwells(n)%head%value - end if - end do - ! - !--use the appropriate xoldsto if intial heads are above the - ! specified flowing well discharge elevation - if (kper==1 .and. kstp==1) then - do n = 1, this%nmawwells - if (this%mawwells(n)%fwcond > DZERO) then - if (this%mawwells(n)%xoldsto > this%mawwells(n)%fwelev) then - this%mawwells(n)%xoldsto = this%mawwells(n)%fwelev - end if - end if - end do - end if - ! - ! -- reset ishutoffcnt (equivalent to kiter) to zero - this%ishutoffcnt = 0 - ! - ! -- pakmvrobj ad - if(this%imover == 1) then - call this%pakmvrobj%ad() - endif - ! - ! -- For each observation, push simulated value and corresponding - ! simulation time from "current" to "preceding" and reset - ! "current" value. - call this%obs%obs_ad() - ! - ! -- return - return - end subroutine maw_ad - - subroutine maw_cf(this, reset_mover) - ! ****************************************************************************** - ! maw_cf -- Formulate the HCOF and RHS terms - ! Subroutine: (1) skip if no multi-aquifer wells - ! (2) calculate hcof and rhs - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - ! -- dummy - class(MawType) :: this - logical, intent(in), optional :: reset_mover - ! -- local - logical :: lrm - ! ------------------------------------------------------------------------------ - ! - ! -- Calculate maw conductance and update package RHS and HCOF - call this%maw_cfupdate() - ! - ! -- pakmvrobj cf - lrm = .true. - if (present(reset_mover)) lrm = reset_mover - if(this%imover == 1 .and. lrm) then - call this%pakmvrobj%cf() - endif - ! - ! -- Return - return - end subroutine maw_cf - - subroutine maw_fc(this, rhs, ia, idxglo, amatsln) -! ****************************************************************************** -! maw_fc -- Copy rhs and hcof into solution rhs and amat -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule,only: delt - ! -- dummy - class(MawType) :: this - real(DP), dimension(:), intent(inout) :: rhs - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln - ! -- local - integer(I4B) :: j, n - integer(I4B) :: idx - integer(I4B) :: iloc, isymloc - integer(I4B) :: igwfnode - integer(I4B) :: iposd, iposoffd - integer(I4B) :: isymnode - integer(I4B) :: ipossymd, ipossymoffd - real(DP) :: hmaw - real(DP) :: bmaw - real(DP) :: bnode - real(DP) :: sat - real(DP) :: cfw - real(DP) :: cmaw - real(DP) :: cterm - real(DP) :: scale - real(DP) :: tp - real(DP) :: bt - real(DP) :: rate - real(DP) :: ratefw -! -------------------------------------------------------------------------- - ! - ! -- pakmvrobj fc - if(this%imover == 1) then - call this%pakmvrobj%fc() - endif - ! - ! -- Copy package rhs and hcof into solution rhs and amat - idx = 1 - do n = 1, this%nmawwells - iloc = this%idxlocnode(n) - ! -- update head value for constant head maw wells - if (this%iboundpak(n) < 0) then - this%xnewpak(n) = this%mawwells(n)%head%value - end if - hmaw = this%xnewpak(n) - ! -- add pumping rate to active or constant maw well - if (this%iboundpak(n) == 0) then - this%mawwells(n)%ratesim = DZERO - else - call this%maw_calculate_wellq(n, hmaw, rate) - this%mawwells(n)%ratesim = rate - !write (1999,'(i5,5(g15.7))') this%ishutoffcnt, hmaw, rate, this%mawwells(n)%shutoffqold, & - ! this%mawwells(n)%shutoffdq, this%mawwells(n)%shutoffweight - rhs(iloc) = rhs(iloc) - rate - ! -- location of diagonal for maw row - iposd = this%idxdglo(idx) - ! -- add flowing well - this%mawwells(n)%xsto = hmaw - ratefw = DZERO - if (this%iflowingwells > 0) then - if (this%mawwells(n)%fwcond > DZERO) then - bt = this%mawwells(n)%fwelev - tp = bt + this%mawwells(n)%fwrlen - scale = sQSaturation(tp, bt, hmaw) - cfw = scale * this%mawwells(n)%fwcond - this%mawwells(n)%ifwdischarge = 0 - if (cfw > DZERO) then - this%mawwells(n)%ifwdischarge = 1 - this%mawwells(n)%xsto = bt - end if - this%mawwells(n)%fwcondsim = cfw - amatsln(iposd) = amatsln(iposd) - cfw - rhs(iloc) = rhs(iloc) - cfw * bt - ratefw = cfw * (bt - hmaw) - end if - end if - ! -- add maw storage changes - if (this%imawiss /= 1) then - if (this%mawwells(n)%ifwdischarge /= 1) then - amatsln(iposd) = amatsln(iposd) - (this%mawwells(n)%area / delt) - rhs(iloc) = rhs(iloc) - (this%mawwells(n)%area * this%mawwells(n)%xoldsto / delt) - else - cterm = this%mawwells(n)%xoldsto - this%mawwells(n)%fwelev - rhs(iloc) = rhs(iloc) - (this%mawwells(n)%area * cterm / delt) - end if - end if - ! - ! -- If mover is active, add receiver water to rhs and - ! store available water (as positive value) - if(this%imover == 1) then - rhs(iloc) = rhs(iloc) - this%pakmvrobj%get_qfrommvr(n) - call this%pakmvrobj%accumulate_qformvr(n, -rate) !pumped water - call this%pakmvrobj%accumulate_qformvr(n, -ratefw) !flowing water - endif - ! - endif - do j = 1, this%mawwells(n)%ngwfnodes - if (this%iboundpak(n) /= 0) then - igwfnode = this%mawwells(n)%gwfnodes(j) - call this%maw_calculate_saturation(n, j, igwfnode, sat) - cmaw = this%mawwells(n)%satcond(j) * sat - this%mawwells(n)%simcond(j) = cmaw - - bnode = this%dis%bot(igwfnode) - bmaw = this%mawwells(n)%botscrn(j) - ! -- calculate cterm - relative to gwf - cterm = DZERO - if (hmaw < bmaw) then - cterm = cmaw * (bmaw - hmaw) - end if - ! -- add to maw row - iposd = this%idxdglo(idx) - iposoffd = this%idxoffdglo(idx) - amatsln(iposd) = amatsln(iposd) - cmaw - amatsln(iposoffd) = cmaw - ! -- add correction term - rhs(iloc) = rhs(iloc) + cterm - ! -- add to gwf row for maw connection - isymnode = this%mawwells(n)%gwfnodes(j) - isymloc = ia(isymnode) - ipossymd = this%idxsymdglo(idx) - ipossymoffd = this%idxsymoffdglo(idx) - amatsln(ipossymd) = amatsln(ipossymd) - cmaw - amatsln(ipossymoffd) = cmaw - ! -- add correction term - rhs(isymnode) = rhs(isymnode) - cterm - endif - ! -- increment maw connection counter - idx = idx + 1 - end do - end do - ! - ! -- return - return - end subroutine maw_fc - - subroutine maw_fn(this, rhs, ia, idxglo, amatsln) -! ************************************************************************** -! maw_fn -- Fill newton terms -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - use TdisModule,only:delt - ! -- dummy - class(MawType) :: this - real(DP), dimension(:), intent(inout) :: rhs - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln - ! -- local - integer(I4B) :: j, n - integer(I4B) :: idx - integer(I4B) :: iloc, isymloc - integer(I4B) :: igwfnode - integer(I4B) :: iposd, iposoffd - integer(I4B) :: isymnode - integer(I4B) :: ipossymd, ipossymoffd - real(DP) :: hmaw - real(DP) :: tmaw - real(DP) :: bmaw - real(DP) :: sat - real(DP) :: cmaw - real(DP) :: scale - real(DP) :: tp - real(DP) :: bt - real(DP) :: cfw - real(DP) :: rate - real(DP) :: rate2 - real(DP) :: rterm - real(DP) :: derv - real(DP) :: drterm - real(DP) :: hgwf - real(DP) :: hups - real(DP) :: term -! -------------------------------------------------------------------------- - ! - ! -- Copy package rhs and hcof into solution rhs and amat - idx = 1 - do n = 1, this%nmawwells - iloc = this%idxlocnode(n) - hmaw = this%xnewpak(n) - ! -- add pumping rate to active or constant maw well - if (this%iboundpak(n) /= 0) then - iposd = this%idxdglo(idx) - scale = DONE - drterm = DZERO - rate = this%mawwells(n)%ratesim - !--calculate final derivative for pumping rate - call this%maw_calculate_wellq(n, hmaw+DEM4, rate2) - drterm = (rate2 - rate) / DEM4 - !--fill amat and rhs with newton-raphson terms - amatsln(iposd) = amatsln(iposd) + drterm - rhs(iloc) = rhs(iloc) + drterm * hmaw - ! -- add flowing well - if (this%iflowingwells > 0) then - if (this%mawwells(n)%fwcond > DZERO) then - bt = this%mawwells(n)%fwelev - tp = bt + this%mawwells(n)%fwrlen - scale = sQSaturation(tp, bt, hmaw) - cfw = scale * this%mawwells(n)%fwcond - this%mawwells(n)%ifwdischarge = 0 - if (cfw > DZERO) this%mawwells(n)%ifwdischarge = 1 - this%mawwells(n)%fwcondsim = cfw - rate = cfw * (bt - hmaw) - rterm = -cfw * hmaw - !--calculate derivative for flowing well - if (hmaw < tp) then - derv = sQSaturationDerivative(tp, bt, hmaw) - drterm = -(cfw + this%mawwells(n)%fwcond * derv * (hmaw - bt)) - !--fill amat and rhs with newton-raphson terms - amatsln(iposd) = amatsln(iposd) - & - this%mawwells(n)%fwcond * derv * (hmaw - bt) - rhs(iloc) = rhs(iloc) - rterm + drterm * hmaw - end if - end if - end if - ! -- add maw storage changes - if (this%imawiss /= 1) then - if (this%mawwells(n)%ifwdischarge /= 1) then - rate = this%mawwells(n)%area * hmaw / delt - rterm = -rate - !--calculate storage derivative - drterm = -this%mawwells(n)%area / delt - !--fill amat and rhs with storage components - rhs(iloc) = rhs(iloc) - rterm + drterm * hmaw - end if - end if - end if - do j = 1, this%mawwells(n)%ngwfnodes - if (this%iboundpak(n) /= 0) then - igwfnode = this%mawwells(n)%gwfnodes(j) - hgwf = this%xnew(igwfnode) - ! -- calculate upstream weighted conductance - call this%maw_calculate_saturation(n, j, igwfnode, sat) - cmaw = this%mawwells(n)%satcond(j) * sat - this%mawwells(n)%simcond(j) = cmaw - ! -- set top and bottom of the screen - tmaw = this%mawwells(n)%topscrn(j) - bmaw = this%mawwells(n)%botscrn(j) - ! -- add to maw row - iposd = this%idxdglo(idx) - iposoffd = this%idxoffdglo(idx) - ! -- add to gwf row for maw connection - isymnode = this%mawwells(n)%gwfnodes(j) - isymloc = ia(isymnode) - ipossymd = this%idxsymdglo(idx) - ipossymoffd = this%idxsymoffdglo(idx) - ! -- calculate newton corrections - hups = hmaw - if (hgwf > hups) hups = hgwf - drterm = sQuadraticSaturationDerivative(tmaw, bmaw, hups, this%satomega) - ! -- maw is upstream - if (hmaw > hgwf) then - term = drterm * this%mawwells(n)%satcond(j) * (hmaw - hgwf) - rhs(iloc) = rhs(iloc) + term * hmaw - rhs(isymnode) = rhs(isymnode) - term * hmaw - amatsln(iposd) = amatsln(iposd) + term - if (this%ibound(igwfnode) > 0) then - amatsln(ipossymoffd) = amatsln(ipossymoffd) - term - end if - ! -- gwf is upstream - else - term = -drterm * this%mawwells(n)%satcond(j) * (hgwf - hmaw) - rhs(iloc) = rhs(iloc) + term * hgwf - rhs(isymnode) = rhs(isymnode) - term * hgwf - if (this%iboundpak(n) > 0) then - amatsln(iposoffd) = amatsln(iposoffd) + term - end if - amatsln(ipossymd) = amatsln(ipossymd) - term - end if - endif - ! - ! -- increment maw connection counter - idx = idx + 1 - end do - end do - ! - ! -- return - return - end subroutine maw_fn - - - subroutine maw_nur(this, neqpak, x, xtemp, dx, inewtonur, dxmax, locmax) -! ****************************************************************************** -! maw_nur -- under-relaxation -! Subroutine: (1) Under-relaxation of Groundwater Flow Model MAW Package Heads -! for current outer iteration using the well bottom -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(MawType), intent(inout) :: this - integer(I4B), intent(in) :: neqpak - real(DP), dimension(neqpak), intent(inout) :: x - real(DP), dimension(neqpak), intent(in) :: xtemp - real(DP), dimension(neqpak), intent(inout) :: dx - integer(I4B), intent(inout) :: inewtonur - real(DP), intent(inout) :: dxmax - integer(I4B), intent(inout) :: locmax - ! -- local - integer(I4B) :: n - real(DP) :: botw - real(DP) :: xx - real(DP) :: dxx -! ------------------------------------------------------------------------------ - - ! - ! -- Newton-Raphson under-relaxation - do n = 1, this%nmawwells - if (this%iboundpak(n) < 1) cycle - botw = this%mawwells(n)%bot - ! -- only apply Newton-Raphson under-relaxation if - ! solution head is below the bottom of the well - if (x(n) < botw) then - inewtonur = 1 - xx = xtemp(n)*(DONE-DP9) + botw*DP9 - dxx = x(n) - xx - if (abs(dxx) > abs(dxmax)) then - locmax = n - dxmax = dxx - end if - x(n) = xx - dx(n) = DZERO - end if - end do - ! - ! -- return - return - end subroutine maw_nur - - - subroutine maw_bd(this, x, idvfl, icbcfl, ibudfl, icbcun, iprobs, & - isuppress_output, model_budget, imap, iadv) -! ****************************************************************************** -! bnd_bd -- Calculate Volumetric Budget -! Note that the compact budget will always be used. -! Subroutine: (1) Process each package entry -! (2) Write output -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: kstp, kper, delt, pertim, totim - use ConstantsModule, only: LENBOUNDNAME - use InputOutputModule, only: ulasav, ubdsv06 - use BudgetModule, only: BudgetType - ! -- dummy - class(MawType) :: this - real(DP),dimension(:),intent(in) :: x - integer(I4B), intent(in) :: idvfl - integer(I4B), intent(in) :: icbcfl - integer(I4B), intent(in) :: ibudfl - integer(I4B), intent(in) :: icbcun - integer(I4B), intent(in) :: iprobs - integer(I4B), intent(in) :: isuppress_output - type(BudgetType), intent(inout) :: model_budget - integer(I4B), dimension(:), optional, intent(in) :: imap - integer(I4B), optional, intent(in) :: iadv - ! -- local - integer(I4B) :: ibinun - real(DP) :: rrate - ! -- for budget - integer(I4B) :: j, n - integer(I4B) :: igwfnode - integer(I4B) :: ibnd - real(DP) :: hmaw, hgwf - real(DP) :: cfw - real(DP) :: bmaw, cmaw - real(DP) :: cterm - real(DP) :: v - real(DP) :: d - ! -- for observations - integer(I4B) :: iprobslocal - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- recalculate package HCOF and RHS terms with latest groundwater and - ! maw heads prior to calling base budget functionality - call this%maw_cfupdate() - ! - ! -- Suppress saving of simulated values; they - ! will be saved at end of this procedure. - iprobslocal = 0 - ! - ! -- call base functionality in bnd_bd - call this%BndType%bnd_bd(x, idvfl, icbcfl, ibudfl, icbcun, iprobslocal, & - isuppress_output, model_budget, this%imap, & - iadv=1) - ! - ! -- calculate maw budget flow and storage terms - do n = 1, this%nmawwells - this%qout(n) = DZERO - this%qsto(n) = DZERO - if (this%iflowingwells > 0) this%qfw(n) = DZERO - if (this%iboundpak(n) == 0) cycle - ! - ! -- set hmaw and xsto - hmaw = this%xnewpak(n) - this%mawwells(n)%xsto = hmaw - ! - ! -- add pumping rate to active maw well - rrate = this%mawwells(n)%ratesim - ! - ! -- If flow is out of maw set qout to rrate. - if (rrate < DZERO) then - this%qout(n) = rrate - end if - ! - ! -- add flowing well - if (this%iflowingwells > 0) then - if (this%mawwells(n)%fwcond > DZERO) then - cfw = this%mawwells(n)%fwcondsim - this%mawwells(n)%xsto = this%mawwells(n)%fwelev - rrate = cfw * (this%mawwells(n)%fwelev - hmaw) - this%qfw(n) = rrate - ! - ! -- Subtract flowing well rrate from qout. - this%qout(n) = this%qout(n) + rrate - end if - end if - ! - ! -- Calculate qsto - if (this%imawiss /= 1) then - rrate = -this%mawwells(n)%area * (this%mawwells(n)%xsto - this%mawwells(n)%xoldsto) / delt - this%qsto(n) = rrate - end if - end do - ! - ! -- gwf and constant flow - ibnd = 1 - do n = 1, this%nmawwells - rrate = DZERO - hmaw = this%xnewpak(n) - this%qconst(n) = DZERO - do j = 1, this%mawwells(n)%ngwfnodes - this%qleak(ibnd) = DZERO - if (this%iboundpak(n) == 0) cycle - igwfnode = this%mawwells(n)%gwfnodes(j) - hgwf = this%xnew(igwfnode) - cmaw = this%mawwells(n)%simcond(j) - - bmaw = this%mawwells(n)%botscrn(j) - ! -- calculate cterm - relative to gwf - cterm = DZERO - if (hmaw < bmaw) then - cterm = cmaw * (bmaw - hmaw) - end if - rrate = -(cmaw * (hmaw - hgwf) + cterm) - this%qleak(ibnd) = rrate - if (this%iboundpak(n) < 0) then - this%qconst(n) = this%qconst(n) - rrate - ! - ! -- If flow is out increment qout by -rrate. - if (-rrate < DZERO) then - this%qout(n) = this%qout(n) - rrate - end if - end if - ibnd = ibnd + 1 - end do - !! - !! -- Update . - !if (this%qconst(n) < DZERO) then - ! this%qout(n) = this%qout(n) + this%qconst(n) - !end if - ! - ! -- add additional flow terms to constant head term - if (this%iboundpak(n) < 0) then - ! - ! -- add well pumping rate - this%qconst(n) = this%qconst(n) - this%mawwells(n)%ratesim - ! - ! -- add flowing well rate - if (this%iflowingwells > 0) then - this%qconst(n) = this%qconst(n) - this%qfw(n) - end if - ! - ! -- add storage term - if (this%imawiss /= 1) then - this%qconst(n) = this%qconst(n) - this%qsto(n) - end if - end if - end do - ! - ! -- For continuous observations, save simulated values. - if (this%obs%npakobs > 0 .and. iprobs > 0) then - call this%maw_bd_obs() - endif - ! - ! -- set unit number for binary dependent variable output - ibinun = 0 - if(this%iheadout /= 0) then - ibinun = this%iheadout - end if - if(idvfl == 0) ibinun = 0 - if (isuppress_output /= 0) ibinun = 0 - ! - ! -- write maw binary output - if (ibinun > 0) then - do n = 1, this%nmawwells - v = this%xnewpak(n) - d = v - this%mawwells(n)%bot - if (this%iboundpak(n) == 0) then - v = DHNOFLO - else if (d <= DZERO) then - v = DHDRY - end if - this%dbuff(n) = v - end do - call ulasav(this%dbuff, ' HEAD', & - kstp, kper, pertim, totim, & - this%nmawwells, 1, 1, ibinun) - end if - ! - ! -- fill the budget object - call this%maw_fill_budobj() - ! - ! -- write the flows from the budobj - ibinun = 0 - if(this%ibudgetout /= 0) then - ibinun = this%ibudgetout - end if - if(icbcfl == 0) ibinun = 0 - if (isuppress_output /= 0) ibinun = 0 - if (ibinun > 0) then - call this%budobj%save_flows(this%dis, ibinun, kstp, kper, delt, & - pertim, totim, this%iout) - end if - ! - ! -- return - return - end subroutine maw_bd - - - subroutine maw_ot(this, kstp, kper, iout, ihedfl, ibudfl) - ! ************************************************************************** - ! maw_ot -- Output package budget - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - ! - ! -- dummy - class(MawType) :: this - integer(I4B),intent(in) :: kstp - integer(I4B),intent(in) :: kper - integer(I4B),intent(in) :: iout - integer(I4B),intent(in) :: ihedfl - integer(I4B),intent(in) :: ibudfl - ! -- locals - integer(I4B) :: n - ! format - ! -------------------------------------------------------------------------- - ! - ! -- write maw head table - if (ihedfl /= 0 .and. this%iprhed /= 0) then - ! - ! -- fill stage data - do n = 1, this%nmawwells - if(this%inamedbound==1) then - call this%headtab%add_term(this%cmawname(n)) - end if - call this%headtab%add_term(n) - call this%headtab%add_term(this%xnewpak(n)) - end do - end if - ! - ! -- Output maw flow table - if (ibudfl /= 0 .and. this%iprflow /= 0) then - call this%budobj%write_flowtable(this%dis) - end if - ! - ! -- Output maw budget - call this%budobj%write_budtable(kstp, kper, iout) - ! - ! -- return - return - end subroutine maw_ot - - subroutine maw_da(this) -! ****************************************************************************** -! maw_da -- deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(MawType) :: this - ! -- local - integer(I4B) :: n -! ------------------------------------------------------------------------------ - ! - ! -- mawwells derived type array - do n = 1, this%nmawwells - call this%maw_deallocate_well(n) - enddo - deallocate(this%mawwells) - ! - ! -- budobj - call this%budobj%budgetobject_da() - deallocate(this%budobj) - nullify(this%budobj) - ! - ! -- head table - if (this%iprhed > 0) then - call this%headtab%table_da() - deallocate(this%headtab) - nullify(this%headtab) - end if - ! - ! -- arrays - deallocate(this%cmawname) - deallocate(this%cmawbudget) - call mem_deallocate(this%idxmawconn) - call mem_deallocate(this%imap) - call mem_deallocate(this%dbuff) - deallocate(this%cauxcbc) - call mem_deallocate(this%qauxcbc) - call mem_deallocate(this%qleak) - call mem_deallocate(this%qfw) - call mem_deallocate(this%qout) - call mem_deallocate(this%qsto) - call mem_deallocate(this%qconst) - deallocate(this%idxlocnode) - deallocate(this%idxdglo) - deallocate(this%idxoffdglo) - deallocate(this%idxsymdglo) - deallocate(this%idxsymoffdglo) - deallocate(this%xoldpak) - deallocate(this%cterm) - ! - ! -- scalars - call mem_deallocate(this%iprhed) - call mem_deallocate(this%iheadout) - call mem_deallocate(this%ibudgetout) - call mem_deallocate(this%iflowingwells) - call mem_deallocate(this%imawiss) - call mem_deallocate(this%imawissopt) - call mem_deallocate(this%nmawwells) - call mem_deallocate(this%check_attr) - call mem_deallocate(this%ishutoffcnt) - call mem_deallocate(this%ieffradopt) - call mem_deallocate(this%satomega) - call mem_deallocate(this%bditems) - call mem_deallocate(this%theta) - call mem_deallocate(this%kappa) - call mem_deallocate(this%cbcauxitems) - ! - ! -- pointers to gwf variables - nullify(this%gwfiss) - ! - ! -- call standard BndType deallocate - call this%BndType%bnd_da() - ! - ! -- return - return - end subroutine maw_da - - subroutine define_listlabel(this) -! ****************************************************************************** -! define_listlabel -- Define the list heading that is written to iout when -! PRINT_INPUT option is used. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(MawType), intent(inout) :: this -! ------------------------------------------------------------------------------ - ! - ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' - else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif - ! - ! -- return - return - end subroutine define_listlabel - - - subroutine maw_set_pointers(this, neq, ibound, xnew, xold, flowja) -! ****************************************************************************** -! set_pointers -- Set pointers to model arrays and variables so that a package -! has access to these things. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(MawType) :: this - integer(I4B), pointer :: neq - integer(I4B), dimension(:), pointer, contiguous :: ibound - real(DP), dimension(:), pointer, contiguous :: xnew - real(DP), dimension(:), pointer, contiguous :: xold - real(DP), dimension(:), pointer, contiguous :: flowja - ! -- local - integer(I4B) :: n - integer(I4B) :: istart, iend -! ------------------------------------------------------------------------------ - ! - ! -- call base BndType set_pointers - call this%BndType%set_pointers(neq, ibound, xnew, xold, flowja) - ! - ! -- Set the MAW pointers - ! - ! -- set package pointers - istart = this%dis%nodes + this%ioffset + 1 - iend = istart + this%nmawwells - 1 - this%iboundpak => this%ibound(istart:iend) - this%xnewpak => this%xnew(istart:iend) - allocate(this%xoldpak(this%nmawwells)) - allocate(this%cterm(this%maxbound)) - ! - ! -- initialize xnewpak - do n = 1, this%nmawwells - this%xnewpak(n) = DEP20 - end do - ! - ! -- return - end subroutine maw_set_pointers - - ! - ! -- Procedures related to observations (type-bound) - logical function maw_obs_supported(this) - ! ****************************************************************************** - ! maw_obs_supported - ! -- Return true because MAW package supports observations. - ! -- Overrides BndType%bnd_obs_supported() - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - class(MawType) :: this - ! ------------------------------------------------------------------------------ - maw_obs_supported = .true. - return - end function maw_obs_supported - - - subroutine maw_df_obs(this) - ! ****************************************************************************** - ! maw_df_obs (implements bnd_df_obs) - ! -- Store observation type supported by MAW package. - ! -- Overrides BndType%bnd_df_obs - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - ! -- dummy - class(MawType) :: this - ! -- local - integer(I4B) :: indx - ! ------------------------------------------------------------------------------ - ! - ! -- Store obs type and assign procedure pointer - ! for head observation type. - call this%obs%StoreObsType('head', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => maw_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for frommvr observation type. - call this%obs%StoreObsType('from-mvr', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => maw_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for conn-rate observation type. - call this%obs%StoreObsType('maw', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => maw_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for rate observation type. - call this%obs%StoreObsType('rate', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => maw_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for rate-to-mvr observation type. - call this%obs%StoreObsType('rate-to-mvr', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => maw_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for fw-rate observation type. - call this%obs%StoreObsType('fw-rate', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => maw_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for rate-to-mvr observation type. - call this%obs%StoreObsType('fw-to-mvr', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => maw_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for storage observation type. - call this%obs%StoreObsType('storage', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => maw_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for constant observation type. - call this%obs%StoreObsType('constant', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => maw_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for cond observation type. - call this%obs%StoreObsType('conductance', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => maw_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for fw-conductance observation type. - call this%obs%StoreObsType('fw-conductance', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => maw_process_obsID - ! - return - end subroutine maw_df_obs - - - subroutine maw_bd_obs(this) - ! ************************************************************************** - ! maw_bd_obs - ! -- Calculate observations this time step and call - ! ObsType%SaveOneSimval for each MawType observation. - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - ! -- dummy - class(MawType), intent(inout) :: this - ! -- local - integer(I4B) :: i, igwfnode, j, jj, n, nn - real(DP) :: cmaw, hmaw, v - real(DP) :: qfact - character(len=200) :: errmsg - type(ObserveType), pointer :: obsrv => null() - !--------------------------------------------------------------------------- - ! - ! Calculate, save, and write simulated values for all MAW observations - if (this%obs%npakobs > 0) then - call this%obs%obs_bd_clear() - do i = 1, this%obs%npakobs - obsrv => this%obs%pakobs(i)%obsrv - nn = size(obsrv%indxbnds) - do j = 1, nn - v = DNODATA - jj = obsrv%indxbnds(j) - select case (obsrv%ObsTypeId) - case ('HEAD') - if (this%iboundpak(jj) /= 0) then - v = this%xnewpak(jj) - end if - case ('FROM-MVR') - if (this%iboundpak(jj) /= 0) then - if (this%imover == 1) then - v = this%pakmvrobj%get_qfrommvr(jj) - end if - end if - case ('MAW') - n = this%imap(jj) - if (this%iboundpak(n) /= 0) then - v = this%qleak(jj) - end if - case ('RATE') - if (this%iboundpak(jj) /= 0) then - v = this%mawwells(jj)%ratesim - if (v < DZERO .and. this%qout(jj) < DZERO) then - qfact = v / this%qout(jj) - if (this%imover == 1) then - v = v + this%pakmvrobj%get_qtomvr(jj) * qfact - end if - end if - end if - case ('RATE-TO-MVR') - if (this%iboundpak(jj) /= 0) then - if (this%imover == 1) then - v = this%mawwells(jj)%ratesim - qfact = DZERO - if (v < DZERO .and. this%qout(jj) < DZERO) then - qfact = v / this%qout(jj) - end if - v = this%pakmvrobj%get_qtomvr(jj) * qfact - if (v > DZERO) then - v = -v - end if - end if - end if - case ('FW-RATE') - if (this%iboundpak(jj) /= 0 .and. this%iflowingwells /= 0) then - hmaw = this%xnewpak(jj) - cmaw = this%mawwells(jj)%fwcondsim - v = cmaw * (this%mawwells(jj)%fwelev - hmaw) - if (v < DZERO .and. this%qout(jj) < DZERO) then - qfact = v / this%qout(jj) - if (this%imover == 1) then - v = v + this%pakmvrobj%get_qtomvr(jj) * qfact - end if - end if - end if - case ('FW-TO-MVR') - if (this%iboundpak(jj) /= 0 .and. this%iflowingwells /= 0) then - if (this%imover == 1) then - hmaw = this%xnewpak(jj) - cmaw = this%mawwells(jj)%fwcondsim - v = cmaw * (this%mawwells(jj)%fwelev - hmaw) - qfact = DZERO - if (v < DZERO .and. this%qout(jj) < DZERO) then - qfact = v / this%qout(jj) - end if - v = this%pakmvrobj%get_qtomvr(jj) * qfact - if (v > DZERO) then - v = -v - end if - end if - end if - case ('STORAGE') - if (this%iboundpak(jj) /= 0 .and. this%imawissopt /= 1) then - v = this%qsto(jj) - end if - case ('CONSTANT') - if (this%iboundpak(jj) /= 0) then - v = this%qconst(jj) - end if - case ('CONDUCTANCE') - n = this%imap(jj) - if (this%iboundpak(n) /= 0) then - nn = jj - this%idxmawconn(n) + 1 - igwfnode = this%mawwells(n)%gwfnodes(nn) - v = this%mawwells(n)%simcond(nn) - end if - case ('FW-CONDUCTANCE') - if (this%iboundpak(jj) /= 0) then - v = this%mawwells(jj)%fwcondsim - end if - case default - errmsg = 'Error: Unrecognized observation type: ' // & - trim(obsrv%ObsTypeId) - call store_error(errmsg) - call ustop() - end select - call this%obs%SaveOneSimval(obsrv, v) - end do - end do - end if - ! - ! -- return - return - end subroutine maw_bd_obs - - - subroutine maw_rp_obs(this) - ! -- dummy - class(MawType), intent(inout) :: this - ! -- local - integer(I4B) :: i, j, n, nn1, nn2 - integer(I4B) :: jj - character(len=200) :: ermsg - character(len=LENBOUNDNAME) :: bname - logical :: jfound - class(ObserveType), pointer :: obsrv => null() - ! -------------------------------------------------------------------------- - ! -- formats -10 format('Error: Boundary "',a,'" for observation "',a, & - '" is invalid in package "',a,'"') - ! - ! - do i = 1, this%obs%npakobs - obsrv => this%obs%pakobs(i)%obsrv - ! - ! -- indxbnds needs to be deallocated and reallocated (using - ! ExpandArray) each stress period because list of boundaries - ! can change each stress period. - if (allocated(obsrv%indxbnds)) then - deallocate(obsrv%indxbnds) - end if - ! - ! -- get node number 1 - nn1 = obsrv%NodeNumber - if (nn1 == NAMEDBOUNDFLAG) then - bname = obsrv%FeatureName - if (bname /= '') then - ! -- Observation maw is based on a boundary name. - ! Iterate through all multi-aquifer wells to identify and store - ! corresponding index in bound array. - jfound = .false. - if (obsrv%ObsTypeId=='MAW' .or. & - obsrv%ObsTypeId=='CONDUCTANCE') then - do j = 1, this%nmawwells - do jj = this%idxmawconn(j), this%idxmawconn(j+1) - 1 - if (this%boundname(jj) == bname) then - jfound = .true. - call ExpandArray(obsrv%indxbnds) - n = size(obsrv%indxbnds) - obsrv%indxbnds(n) = jj - end if - end do - end do - else - do j = 1, this%nmawwells - if (this%cmawname(j) == bname) then - jfound = .true. - call ExpandArray(obsrv%indxbnds) - n = size(obsrv%indxbnds) - obsrv%indxbnds(n) = j - end if - end do - end if - if (.not. jfound) then - write(ermsg,10)trim(bname), trim(obsrv%Name), trim(this%name) - call store_error(ermsg) - end if - end if - else - call ExpandArray(obsrv%indxbnds) - n = size(obsrv%indxbnds) - if (n == 1) then - if (obsrv%ObsTypeId=='MAW' .or. & - obsrv%ObsTypeId=='CONDUCTANCE') then - nn2 = obsrv%NodeNumber2 - j = this%idxmawconn(nn1) + nn2 - 1 - obsrv%indxbnds(1) = j - else - obsrv%indxbnds(1) = nn1 - end if - else - ermsg = 'Programming error in maw_rp_obs' - call store_error(ermsg) - endif - end if - ! - ! -- catch non-cumulative observation assigned to observation defined - ! by a boundname that is assigned to more than one element - if (obsrv%ObsTypeId == 'HEAD') then - n = size(obsrv%indxbnds) - if (n > 1) then - write (ermsg, '(4x,a,4(1x,a))') & - 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & - 'for observation', trim(adjustl(obsrv%Name)), & - ' must be assigned to a multi-aquifer well with a unique boundname.' - call store_error(ermsg) - end if - end if - ! - ! -- check that index values are valid - if (obsrv%ObsTypeId=='MAW' .or. & - obsrv%ObsTypeId=='CONDUCTANCE') then - do j = 1, size(obsrv%indxbnds) - nn1 = obsrv%indxbnds(j) - n = this%imap(nn1) - nn2 = nn1 - this%idxmawconn(n) + 1 - jj = this%idxmawconn(n+1) - this%idxmawconn(n) - if (nn1 < 1 .or. nn1 > this%maxbound) then - write (ermsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & - 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & - ' multi-aquifer well connection number must be > 0 and <=', & - jj, '(specified value is ', nn2, ')' - call store_error(ermsg) - end if - end do - else - do j = 1, size(obsrv%indxbnds) - nn1 = obsrv%indxbnds(j) - if (nn1 < 1 .or. nn1 > this%nmawwells) then - write (ermsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & - 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & - ' multi-aquifer well must be > 0 and <=', this%nmawwells, & - '(specified value is ', nn1, ')' - call store_error(ermsg) - end if - end do - end if - end do - ! - ! -- check if any error were encountered - if (count_errors() > 0) call ustop() - ! - ! -- return - return - end subroutine maw_rp_obs - - - ! - ! -- Procedures related to observations (NOT type-bound) - subroutine maw_process_obsID(obsrv, dis, inunitobs, iout) - ! -- This procedure is pointed to by ObsDataType%ProcesssIdPtr. It processes - ! the ID string of an observation definition for MAW package observations. - ! -- dummy - type(ObserveType), intent(inout) :: obsrv - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: inunitobs - integer(I4B), intent(in) :: iout - ! -- local - integer(I4B) :: nn1, nn2 - integer(I4B) :: icol, istart, istop - character(len=LINELENGTH) :: strng - character(len=LENBOUNDNAME) :: bndname - ! formats - ! - strng = obsrv%IDstring - ! -- Extract multi-aquifer well number from strng and store it. - ! If 1st item is not an integer(I4B), it should be a - ! maw name--deal with it. - icol = 1 - ! -- get multi-aquifer well number or boundary name - call extract_idnum_or_bndname(strng, icol, istart, istop, nn1, bndname) - if (nn1 == NAMEDBOUNDFLAG) then - obsrv%FeatureName = bndname - else - if (obsrv%ObsTypeId=='MAW' .or. & - obsrv%ObsTypeId=='CONDUCTANCE') then - call extract_idnum_or_bndname(strng, icol, istart, istop, nn2, bndname) - if (nn2 == NAMEDBOUNDFLAG) then - obsrv%FeatureName = bndname - ! -- reset nn1 - nn1 = nn2 - else - obsrv%NodeNumber2 = nn2 - end if - end if - end if - ! -- store multi-aquifer well number (NodeNumber) - obsrv%NodeNumber = nn1 - ! - ! -- return - return - end subroutine maw_process_obsID - - ! - ! -- private MAW methods - ! - subroutine maw_calculate_satcond(this, i, j, node) - ! -- dummy - class(MawType),intent(inout) :: this - integer(I4B), intent(in) :: i - integer(I4B), intent(in) :: j - integer(I4B), intent(in) :: node - ! -- local - character(len=LINELENGTH) :: errmsg - integer(I4B) :: iTcontrastErr - real(DP) :: c - real(DP) :: k11 - real(DP) :: k22 - real(DP) :: sqrtk11k22 - real(DP) :: hks - real(DP) :: area - real(DP) :: eradius - real(DP) :: topw - real(DP) :: botw - real(DP) :: tthkw - real(DP) :: tthka - real(DP) :: Tcontrast - real(DP) :: skin - real(DP) :: ravg - real(DP) :: slen - real(DP) :: pavg - real(DP) :: gwfsat - real(DP) :: gwftop - real(DP) :: gwfbot - real(DP) :: lc1 - real(DP) :: lc2 - real(DP) :: dx - real(DP) :: dy - real(DP) :: Txx - real(DP) :: Tyy - real(DP) :: T2pi - real(DP) :: yx4 - real(DP) :: xy4 - ! -- formats - ! ------------------------------------------------------------------------------ - ! - ! -- initialize conductance variables - iTcontrastErr = 0 - lc1 = DZERO - lc2 = DZERO - ! - ! -- set K11 and K22 - k11 = this%gwfk11(node) - if (this%gwfik22 == 0) then - k22 = this%gwfk11(node) - else - k22 = this%gwfk22(node) - endif - sqrtk11k22 = sqrt(k11 * k22) - ! - ! -- set gwftop, gwfbot, and gwfsat - gwftop = this%dis%top(node) - gwfbot = this%dis%bot(node) - tthka = gwftop - gwfbot - gwfsat = this%gwfsat(node) - ! - ! -- set top and bottom of well screen - c = DZERO - topw = this%mawwells(i)%topscrn(j) - botw = this%mawwells(i)%botscrn(j) - tthkw = topw - botw - ! - ! -- scale screen thickness using gwfsat (for NPF Package THICKSTRT) - if (gwftop == topw .and. gwfbot == botw) then - if (this%icelltype(node) == 0) then - tthkw = tthkw * gwfsat - tthka = tthka * gwfsat - end if - end if - ! - ! -- calculate the aquifer transmissivity (T2pi) - T2pi = DTWOPI * tthka * sqrtk11k22 - ! - ! -- calculate effective radius - if (this%dis%ndim == 3 .and. this%ieffradopt /= 0) then - Txx = k11 * tthka - Tyy = k22 * tthka - dx = sqrt(this%dis%area(node)) - dy = dx - yx4 = (Tyy/Txx)**DQUARTER - xy4 = (Txx/Tyy)**DQUARTER - eradius = 0.28_DP * ((yx4*dx)**DTWO + (xy4*dy)**DTWO)**DHALF / (yx4+xy4) - else - area = this%dis%area(node) - eradius = sqrt(area / (DEIGHT * DPI)) - end if - ! - ! -- conductance calculations - ! -- Thiem equation (1) and cumulative Thiem and skin equations (3) - if (this%mawwells(i)%ieqn == 1 .or. this%mawwells(i)%ieqn == 3) then - lc1 = log(eradius / this%mawwells(i)%radius) / T2pi - end if - ! -- skin equation (2) and cumulative Thiem and skin equations (3) - if (this%mawwells(i)%ieqn == 2 .or. this%mawwells(i)%ieqn == 3) then - hks = this%mawwells(i)%hk(j) - if (tthkw * hks > DZERO) then - Tcontrast = (sqrtk11k22 * tthka) / (hks * tthkw) - skin = (Tcontrast - DONE) * & - log(this%mawwells(i)%sradius(j) / this%mawwells(i)%radius) - ! -- trap invalid transmissvity contrast if using skin equation (2). - ! Not trapped for cumulative Thiem and skin equations (3) - ! because the MNW2 package allowed this condition (for - ! backward compatibility with the MNW2 package for - ! MODFLOW-2005, MODFLOW-NWT, and MODFLOW-USG). - if (Tcontrast <= 1 .and. this%mawwells(i)%ieqn == 2) then - iTcontrastErr = 1 - write(errmsg, '(4x,a,g0,a,1x,i0,1x,a,1x,i0,a,4(1x,a))') & - '****ERROR. INVALID CALCULATED TRANSMISSIVITY CONTRAST (', Tcontrast,& - ') for MAW WELL', i, 'CONNECTION', j, '.', 'THIS HAPPENS WHEN THE', & - 'SKIN TRANSMISSIVITY EQUALS OR EXCEEDS THE AQUIFER TRANSMISSIVITY.', & - 'CONSIDER DECREASING HK_SKIN FOR THE CONNECTION OR USING THE', & - 'CUMULATIVE OR MEAN CONDUCTANCE EQUATIONS.' - call store_error(errmsg) - else - lc2 = skin / T2pi - end if - end if - end if - ! -- conductance using screen elevations, hk, well radius, - ! and screen radius - if (this%mawwells(i)%ieqn == 4) then - hks = this%mawwells(i)%hk(j) - ravg = DHALF * (this%mawwells(i)%radius + this%mawwells(i)%sradius(j)) - slen = this%mawwells(i)%sradius(j) - this%mawwells(i)%radius - pavg = DTWOPI * ravg - c = hks * pavg * tthkw / slen - end if - ! - ! -- calculate final conductance for Theim (1), Skin (2), and - ! and cumulative Thiem and skin equations (3) - if (this%mawwells(i)%ieqn < 4) then - if (lc1 + lc2 /= DZERO) then - c = DONE / (lc1 + lc2) - else - c = -DNODATA - end if - end if - ! - ! -- ensure that the conductance is not negative. Only write error message - ! if error condition has not occured for skin calculations (LC2) - if (c < DZERO .and. iTcontrastErr == 0) then - write(errmsg, '(4x,a,g0,a,1x,i0,1x,a,1x,i0,a,4(1x,a))') & - '****ERROR. INVALID CALCULATED NEGATIVE CONDUCTANCE (', c, & - ') for MAW WELL', i, 'CONNECTION', j, '.', 'THIS HAPPENS WHEN THE', & - 'SKIN TRANSMISSIVITY EQUALS OR EXCEEDS THE AQUIFER TRANSMISSIVITY.', & - 'CONSIDER DECREASING HK_SKIN FOR THE CONNECTION OR USING THE', & - 'MEAN CONDUCTANCE EQUATION.' - call store_error(errmsg) - end if - ! - ! -- set saturated conductance - this%mawwells(i)%satcond(j) = c - ! - ! -- return - return - end subroutine maw_calculate_satcond - - - subroutine maw_calculate_saturation(this, i, j, node, sat) - ! -- dummy - class(MawType),intent(inout) :: this - integer(I4B), intent(in) :: i - integer(I4B), intent(in) :: j - integer(I4B), intent(in) :: node - real(DP), intent(inout) :: sat - ! -- local - real(DP) :: htmp - real(DP) :: hwell - real(DP) :: topw - real(DP) :: botw - ! -- formats - ! ------------------------------------------------------------------------------ - ! - ! -- initialize saturation - sat = DZERO - ! - ! -- calculate current saturation for convertible cells - if (this%icelltype(node) /= 0) then - ! - ! -- set hwell - hwell = this%xnewpak(i) - ! -- set top and bottom of the well connection - topw = this%mawwells(i)%topscrn(j) - botw = this%mawwells(i)%botscrn(j) - ! - ! -- calculate appropriate saturation - if (this%inewton /= 1) then - htmp = this%xnew(node) - if (htmp < botw) htmp = botw - if (hwell < botw) hwell = botw - htmp = DHALF * (htmp + hwell) - else - htmp = this%xnew(node) - if (hwell > htmp) htmp = hwell - if (htmp < botw) htmp = botw - end if - ! -- calculate saturation - sat = sQuadraticSaturation(topw, botw, htmp, this%satomega) - else - sat = DONE - end if - ! - ! -- return - return - end subroutine maw_calculate_saturation - - subroutine maw_calculate_wellq(this, n, hmaw, q) -! ************************************************************************** -! maw_calculate_wellq-- Calculate well pumping rate based on constraints -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - ! -- dummy - class(MawType) :: this - integer(I4B), intent(in) :: n - real(DP), intent(in) :: hmaw - real(DP), intent(inout) :: q - ! -- local - real(DP) :: scale - real(DP) :: tp - real(DP) :: bt - real(DP) :: rate - real(DP) :: weight - real(DP) :: dq -! -------------------------------------------------------------------------- - ! - ! -- Initialize q - q = DZERO - ! - ! -- Assign rate as the user-provided base pumping rate - rate = this%mawwells(n)%rate%value - ! - ! -- Assign q differently depending on whether this is an extraction well - ! (rate < 0) or an injection well (rate > 0). - if (rate < DZERO) then - ! - ! -- If well shut off is activated, then turn off well if necessary, - ! or if shut off is not activated then check to see if rate scaling - ! is on. - if (this%mawwells(n)%shutofflevel /= DEP20) then - call this%maw_calculate_qpot(n, q) - if (q < DZERO) q = DZERO - if (q > -rate) q = -rate - - if (this%ishutoffcnt == 1) then - this%mawwells(n)%shutoffweight = DONE - this%mawwells(n)%shutoffdq = DZERO - this%mawwells(n)%shutoffqold = q - end if - - dq = q - this%mawwells(n)%shutoffqold - weight = this%mawwells(n)%shutoffweight - - ! -- for flip-flop condition, decrease factor - if ( this%mawwells(n)%shutoffdq*dq < DZERO ) then - weight = this%theta * this%mawwells(n)%shutoffweight - ! -- when change is of same sign, increase factor - else - weight = this%mawwells(n)%shutoffweight + this%kappa - end if - if ( weight > DONE ) weight = DONE - - q = this%mawwells(n)%shutoffqold + weight * dq - - this%mawwells(n)%shutoffqold = q - this%mawwells(n)%shutoffdq = dq - this%mawwells(n)%shutoffweight = weight - - ! - ! -- If shutoffmin and shutoffmax are specified then apply - ! additional checks for when to shut off the well. - if (this%mawwells(n)%shutoffmin > DZERO) then - if (hmaw < this%mawwells(n)%shutofflevel) then - ! - ! -- calculate adjusted well rate subject to constraints - ! -- well is shutoff - if (this%mawwells(n)%ishutoff /= 0) then - q = DZERO - ! --- well is not shut off - else - ! -- turn off well if q is less than the minimum rate and - ! reset the ishutoff flag if at least on iteration 3 - if (q < this%mawwells(n)%shutoffmin) then - if (this%ishutoffcnt > 2) then - this%mawwells(n)%ishutoff = 1 - end if - q = DZERO - ! -- leave well on and use the specified rate - ! or the potential rate - end if - end if - ! -- try to use the specified rate or the potential rate - else - if (q > this%mawwells(n)%shutoffmax) then - if (this%ishutoffcnt <= 2) then - this%mawwells(n)%ishutoff = 0 - end if - end if - if (this%mawwells(n)%ishutoff /= 0) then - q = DZERO - end if - end if - end if - - if (q /= DZERO) q = -q - - else - scale = DONE - ! -- Apply rate scaling by reducing pumpage when hmaw is less than the - ! sum of maw pump elevation (pumpelev) and the specified reduction - ! length. The rate will go to zero as hmaw drops to the pump - ! elevation. - if (this%mawwells(n)%reduction_length /= DEP20) then - bt = this%mawwells(n)%pumpelev - tp = bt + this%mawwells(n)%reduction_length - scale = sQSaturation(tp, bt, hmaw) - end if - q = scale * rate - end if - ! - else - ! - ! -- Handle the injection case (rate > 0) differently than extraction. - q = rate - if (this%mawwells(n)%shutofflevel /= DEP20) then - call this%maw_calculate_qpot(n, q) - q = -q - if (q < DZERO) q = DZERO - if (q > rate) q = rate - - if (this%ishutoffcnt == 1) then - this%mawwells(n)%shutoffweight = DONE - this%mawwells(n)%shutoffdq = DZERO - this%mawwells(n)%shutoffqold = q - end if - - dq = q - this%mawwells(n)%shutoffqold - weight = this%mawwells(n)%shutoffweight - - ! -- for flip-flop condition, decrease factor - if ( this%mawwells(n)%shutoffdq*dq < DZERO ) then - weight = this%theta * this%mawwells(n)%shutoffweight - ! -- when change is of same sign, increase factor - else - weight = this%mawwells(n)%shutoffweight + this%kappa - end if - if ( weight > DONE ) weight = DONE - - q = this%mawwells(n)%shutoffqold + weight * dq - - this%mawwells(n)%shutoffqold = q - this%mawwells(n)%shutoffdq = dq - this%mawwells(n)%shutoffweight = weight - - else - scale = DONE - ! -- Apply rate scaling for an injection well by reducting the - ! injection rate as hmaw rises above the pump elevation. The rate - ! will approach zero as hmaw approaches pumpelev + reduction_length. - if (this%mawwells(n)%reduction_length /= DEP20) then - bt = this%mawwells(n)%pumpelev - tp = bt + this%mawwells(n)%reduction_length - scale = DONE - sQSaturation(tp, bt, hmaw) - endif - q = scale * rate - endif - end if - ! - ! -- return - return - end subroutine maw_calculate_wellq - - subroutine maw_calculate_qpot(this, n, qnet) -! ****************************************************************************** -! maw_calculate_qpot -- Calculate groundwater inflow to a maw well -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use TdisModule,only:delt - ! -- dummy - class(MawType),intent(inout) :: this - integer(I4B), intent(in) :: n - real(DP), intent(inout) :: qnet - ! -- local - integer(I4B) :: j - integer(I4B) :: igwfnode - real(DP) :: bt - real(DP) :: tp - real(DP) :: scale - real(DP) :: cfw - real(DP) :: hdterm - real(DP) :: sat - real(DP) :: cmaw - real(DP) :: hgwf - real(DP) :: bmaw - real(DP) :: htmp - real(DP) :: hv - ! -- format -! ------------------------------------------------------------------------------ - !--initialize qnet - qnet = DZERO - ! -- - htmp = this%mawwells(n)%shutofflevel - ! -- calculate discharge to flowing wells - if (this%iflowingwells > 0) then - if (this%mawwells(n)%fwcond > DZERO) then - bt = this%mawwells(n)%fwelev - tp = bt + this%mawwells(n)%fwrlen - scale = sQSaturation(tp, bt, htmp) - cfw = scale * this%mawwells(n)%fwcond - this%mawwells(n)%ifwdischarge = 0 - if (cfw > DZERO) then - this%mawwells(n)%ifwdischarge = 1 - this%mawwells(n)%xsto = bt - end if - qnet = qnet + cfw * (bt - htmp) - end if - end if - ! -- calculate maw storage changes - if (this%imawiss /= 1) then - if (this%mawwells(n)%ifwdischarge /= 1) then - hdterm = this%mawwells(n)%xoldsto - htmp - else - hdterm = this%mawwells(n)%xoldsto - this%mawwells(n)%fwelev - end if - qnet = qnet - (this%mawwells(n)%area * hdterm / delt) - end if - ! -- calculate inflow from aquifer - do j = 1, this%mawwells(n)%ngwfnodes - igwfnode = this%mawwells(n)%gwfnodes(j) - call this%maw_calculate_saturation(n, j, igwfnode, sat) !, hv) - cmaw = this%mawwells(n)%satcond(j) * sat - hgwf = this%xnew(igwfnode) - bmaw = this%mawwells(n)%botscrn(j) - hv = htmp - if (hv < bmaw) then - hv = bmaw - end if - if (hgwf < bmaw) then - hgwf = bmaw - end if - qnet = qnet + cmaw * (hgwf - hv) - end do - ! - ! -- return - return - end subroutine maw_calculate_qpot - - subroutine maw_cfupdate(this) - ! ****************************************************************************** - ! maw_cfupdate -- Update MAW satcond and package rhs and hcof - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - class(MawType) :: this - integer(I4B) :: j, n, node - integer(I4B) :: ibnd - real(DP) :: sat, cmaw, hmaw, bmaw - ! ------------------------------------------------------------------------------ - ! - ! -- Return if no maw wells - if(this%nbound.eq.0) return - ! - ! -- Update shutoff count - this%ishutoffcnt = this%ishutoffcnt + 1 - ! - ! -- Calculate hcof and rhs for each maw entry - ibnd = 1 - do n = 1, this%nmawwells - hmaw = this%xnewpak(n) - do j = 1, this%mawwells(n)%ngwfnodes - node = this%nodelist(ibnd) - this%hcof(ibnd) = DZERO - this%rhs(ibnd) = DZERO - ! - ! -- set bound, hcof, and rhs components - call this%maw_calculate_saturation(n, j, node, sat) - if (this%iboundpak(n) == 0) then - cmaw = DZERO - else - cmaw = this%mawwells(n)%satcond(j) * sat - endif - this%mawwells(n)%simcond(j) = cmaw - - this%bound(2,ibnd) = cmaw - - bmaw = this%bound(3,ibnd) - - this%hcof(ibnd) = -cmaw - ! - ! -- fill rhs - if (hmaw < bmaw) then - this%rhs(ibnd) = -cmaw * bmaw - else - this%rhs(ibnd) = -cmaw * hmaw - end if - ! - ! -- increment boundary number - ibnd = ibnd + 1 - end do - end do - ! - ! -- Return - return - end subroutine maw_cfupdate - - - subroutine maw_allocate_well(this, n) -! ****************************************************************************** -! allocate_reach -- Allocate pointers for multi-aquifer well mawwells(n). -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(MawType) :: this - integer(I4B), intent(in) :: n - ! -- local - character(len=LINELENGTH) :: ermsg - character(len=10) :: cwel - integer(I4B) :: iaux -! ------------------------------------------------------------------------------ - ! - ! -- make sure maw well has not been allocated - if (associated(this%mawwells(n)%ieqn)) then - write (cwel, '(i10)') n - ermsg = 'multi-aquifer well ' // trim(cwel) // ' is already allocated' - call store_error(ermsg) - call ustop() - end if - ! -- allocate pointers - !allocate(character (len=LENBOUNDNAME) :: this%mawwells(n)%name) - allocate(this%mawwells(n)%name) - allocate(this%mawwells(n)%status) - allocate(this%mawwells(n)%ngwfnodes) - allocate(this%mawwells(n)%ieqn) - allocate(this%mawwells(n)%ishutoff) - allocate(this%mawwells(n)%ifwdischarge) - allocate(this%mawwells(n)%strt) - allocate(this%mawwells(n)%radius) - allocate(this%mawwells(n)%area) - allocate(this%mawwells(n)%pumpelev) - allocate(this%mawwells(n)%bot) - allocate(this%mawwells(n)%ratesim) - allocate(this%mawwells(n)%reduction_length) - allocate(this%mawwells(n)%fwelev) - allocate(this%mawwells(n)%fwcond) - allocate(this%mawwells(n)%fwrlen) - allocate(this%mawwells(n)%fwcondsim) - allocate(this%mawwells(n)%xsto) - allocate(this%mawwells(n)%xoldsto) - allocate(this%mawwells(n)%shutoffmin) - allocate(this%mawwells(n)%shutoffmax) - allocate(this%mawwells(n)%shutofflevel) - allocate(this%mawwells(n)%shutoffweight) - allocate(this%mawwells(n)%shutoffdq) - allocate(this%mawwells(n)%shutoffqold) - ! -- timeseries aware data - if (this%naux > 0) then - allocate(this%mawwells(n)%auxvar(this%naux)) - do iaux = 1, this%naux - allocate(this%mawwells(n)%auxvar(iaux)%name) - allocate(this%mawwells(n)%auxvar(iaux)%value) - end do - end if - allocate(this%mawwells(n)%rate) - allocate(this%mawwells(n)%rate%name) - allocate(this%mawwells(n)%rate%value) - allocate(this%mawwells(n)%head) - allocate(this%mawwells(n)%head%name) - allocate(this%mawwells(n)%head%value) - ! - ! -- initialize a few well variables - this%mawwells(n)%name = '' - this%mawwells(n)%status = 'ACTIVE' - this%mawwells(n)%ngwfnodes = 0 - this%mawwells(n)%ieqn = 0 - this%mawwells(n)%ishutoff = 0 - this%mawwells(n)%ifwdischarge = 0 - this%mawwells(n)%strt = DEP20 - this%mawwells(n)%radius = DEP20 - this%mawwells(n)%area = DZERO - this%mawwells(n)%pumpelev = DEP20 - this%mawwells(n)%bot = DEP20 - this%mawwells(n)%ratesim = DZERO - this%mawwells(n)%reduction_length = DEP20 - this%mawwells(n)%fwelev = DZERO - this%mawwells(n)%fwcond = DZERO - this%mawwells(n)%fwrlen = DZERO - this%mawwells(n)%fwcondsim = DZERO - this%mawwells(n)%xsto = DZERO - this%mawwells(n)%xoldsto = DZERO - this%mawwells(n)%shutoffmin = DZERO - this%mawwells(n)%shutoffmax = DZERO - this%mawwells(n)%shutofflevel = DEP20 - this%mawwells(n)%shutoffweight = DONE - this%mawwells(n)%shutoffdq = DONE - this%mawwells(n)%shutoffqold = DONE - ! -- timeseries aware data - do iaux = 1, this%naux - this%mawwells(n)%auxvar(iaux)%name = '' - this%mawwells(n)%auxvar(iaux)%value = DZERO - end do - this%mawwells(n)%rate%name = '' - this%mawwells(n)%rate%value = DZERO - this%mawwells(n)%head%name = '' - this%mawwells(n)%head%value = DZERO - ! - ! -- return - return - end subroutine maw_allocate_well - - subroutine maw_deallocate_well(this, n) -! ****************************************************************************** -! maw_deallocate_well -- deallocate pointers for multi-aquifer well mawwells(n). -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(MawType) :: this - integer(I4B), intent(in) :: n - ! -- local - integer(I4B) :: iaux -! ------------------------------------------------------------------------------ - ! - deallocate(this%mawwells(n)%gwfnodes) - deallocate(this%mawwells(n)%satcond) - deallocate(this%mawwells(n)%simcond) - deallocate(this%mawwells(n)%topscrn) - deallocate(this%mawwells(n)%botscrn) - if (this%mawwells(n)%ieqn==2 .OR. this%mawwells(n)%ieqn==3 .OR. & - this%mawwells(n)%ieqn==4) then - deallocate(this%mawwells(n)%hk) - end if - if (this%mawwells(n)%ieqn==2 .OR. this%mawwells(n)%ieqn==3 .OR. & - this%mawwells(n)%ieqn==4) then - deallocate(this%mawwells(n)%sradius) - end if - deallocate(this%mawwells(n)%name) - deallocate(this%mawwells(n)%status) - deallocate(this%mawwells(n)%ngwfnodes) - deallocate(this%mawwells(n)%ieqn) - deallocate(this%mawwells(n)%ishutoff) - deallocate(this%mawwells(n)%ifwdischarge) - deallocate(this%mawwells(n)%strt) - deallocate(this%mawwells(n)%radius) - deallocate(this%mawwells(n)%area) - deallocate(this%mawwells(n)%pumpelev) - deallocate(this%mawwells(n)%bot) - deallocate(this%mawwells(n)%ratesim) - deallocate(this%mawwells(n)%reduction_length) - deallocate(this%mawwells(n)%fwelev) - deallocate(this%mawwells(n)%fwcond) - deallocate(this%mawwells(n)%fwrlen) - deallocate(this%mawwells(n)%fwcondsim) - deallocate(this%mawwells(n)%xsto) - deallocate(this%mawwells(n)%xoldsto) - deallocate(this%mawwells(n)%shutoffmin) - deallocate(this%mawwells(n)%shutoffmax) - deallocate(this%mawwells(n)%shutofflevel) - deallocate(this%mawwells(n)%shutoffweight) - deallocate(this%mawwells(n)%shutoffdq) - deallocate(this%mawwells(n)%shutoffqold) - ! -- timeseries aware data - if (this%naux > 0) then - do iaux = 1, this%naux - deallocate(this%mawwells(n)%auxvar(iaux)%name) - deallocate(this%mawwells(n)%auxvar(iaux)%value) - end do - deallocate(this%mawwells(n)%auxvar) - end if - deallocate(this%mawwells(n)%rate%name) - deallocate(this%mawwells(n)%rate%value) - deallocate(this%mawwells(n)%rate) - deallocate(this%mawwells(n)%head%name) - deallocate(this%mawwells(n)%head%value) - deallocate(this%mawwells(n)%head) - ! - ! -- return - return - end subroutine maw_deallocate_well - - subroutine maw_setup_budobj(this) -! ****************************************************************************** -! maw_setup_budobj -- Set up the budget object that stores all the maw flows -! The terms listed here must correspond in number and order to the ones -! listed in the maw_fill_budobj routine. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LENBUDTXT - ! -- dummy - class(MawType) :: this - ! -- local - integer(I4B) :: nbudterm - integer(I4B) :: n, j, n2 - real(DP) :: q - integer(I4B) :: maxlist, naux - integer(I4B) :: idx - character(len=LENBUDTXT) :: text - character(len=LENBUDTXT), dimension(1) :: auxtxt -! ------------------------------------------------------------------------------ - ! - ! -- Determine the number of maw budget terms. These are fixed for - ! the simulation and cannot change. - ! gwf rate [flowing_well] storage constant_flow [frommvr tomvr tomvrcf [tomvrfw]] [aux] - nbudterm = 4 - if (this%iflowingwells > 0) nbudterm = nbudterm + 1 - if (this%imover == 1) then - nbudterm = nbudterm + 3 - if (this%iflowingwells > 0) nbudterm = nbudterm + 1 - end if - if (this%naux > 0) nbudterm = nbudterm + 1 - ! - ! -- set up budobj - call budgetobject_cr(this%budobj, this%name) - call this%budobj%budgetobject_df(this%nmawwells, nbudterm, 0, 0) - idx = 0 - ! - ! -- Go through and set up each budget term - ! - ! -- - text = ' GWF' - idx = idx + 1 - maxlist = this%maxbound - naux = 1 - auxtxt(1) = ' FLOW-AREA' - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name_model, & - maxlist, .false., .true., & - naux, auxtxt) - call this%budobj%budterm(idx)%reset(this%maxbound) - q = DZERO - do n = 1, this%nmawwells - do j = 1, this%mawwells(n)%ngwfnodes - n2 = this%mawwells(n)%gwfnodes(j) - call this%budobj%budterm(idx)%update_term(n, n2, q) - end do - end do - ! - ! -- - text = ' RATE' - idx = idx + 1 - maxlist = this%nmawwells - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- - if (this%iflowingwells > 0) then - text = ' FW-RATE' - idx = idx + 1 - maxlist = this%nmawwells - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - end if - ! - ! -- - text = ' STORAGE' - idx = idx + 1 - maxlist = this%nmawwells - naux = 1 - auxtxt(1) = ' VOLUME' - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name_model, & - maxlist, .false., .true., & - naux, auxtxt) - ! - ! -- - text = ' CONSTANT' - idx = idx + 1 - maxlist = this%nmawwells - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- - if (this%imover == 1) then - ! - ! -- - text = ' FROM-MVR' - idx = idx + 1 - maxlist = this%nmawwells - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- - text = ' RATE-TO-MVR' - idx = idx + 1 - maxlist = this%nmawwells - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- constant-head flow to mover - text = ' CONSTANT-TO-MVR' - idx = idx + 1 - maxlist = this%nmawwells - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- - if (this%iflowingwells > 0) then - ! - ! -- - text = ' FW-RATE-TO-MVR' - idx = idx + 1 - maxlist = this%nmawwells - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - end if - end if - ! - ! -- - naux = this%naux - if (naux > 0) then - ! - ! -- - text = ' AUXILIARY' - idx = idx + 1 - maxlist = this%maxbound - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux, this%auxname) - end if - ! - ! -- if maw flow for each reach are written to the listing file - if (this%iprflow /= 0) then - call this%budobj%flowtable_df(this%iout) - end if - ! - ! -- return - return - end subroutine maw_setup_budobj - - subroutine maw_fill_budobj(this) -! ****************************************************************************** -! maw_fill_budobj -- copy flow terms into this%budobj -! -! gwf rate [flowing_well] [storage] constant_flow [frommvr tomvr tomvrcf [tomvrfw]] [aux] -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(MawType) :: this - ! -- local - integer(I4B) :: naux - integer(I4B) :: j, n, n2 - integer(I4B) :: idx - integer(I4B) :: ibnd - real(DP) :: q - real(DP) :: tmaw - real(DP) :: bmaw - real(DP) :: sat - real(DP) :: qfact - real(DP) :: q2 - real(DP) :: b - real(DP) :: v - ! -- formats -! ----------------------------------------------------------------------------- - ! - ! -- initialize counter - idx = 0 - ! - ! -- GWF (LEAKAGE) and connection surface area (aux) - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%maxbound) - ibnd = 1 - do n = 1, this%nmawwells - do j = 1, this%mawwells(n)%ngwfnodes - n2 = this%mawwells(n)%gwfnodes(j) - tmaw = this%mawwells(n)%topscrn(j) - bmaw = this%mawwells(n)%botscrn(j) - call this%maw_calculate_saturation(n, j, n2, sat) - this%qauxcbc(1) = DTWO * DPI * this%mawwells(n)%radius * sat * (tmaw - bmaw) - q = this%qleak(ibnd) - call this%budobj%budterm(idx)%update_term(n, n2, q, this%qauxcbc) - ibnd = ibnd + 1 - end do - end do - ! - ! -- RATE (WITHDRAWAL RATE) - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nmawwells) - do n = 1, this%nmawwells - q = this%mawwells(n)%ratesim - ! -- adjust if well rate is an outflow - if (this%imover == 1 .and. q < DZERO) then - qfact = DONE - if (this%qout(n) < DZERO) then - qfact = q / this%qout(n) - end if - q = q + qfact * this%pakmvrobj%get_qtomvr(n) - end if - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - ! - ! -- FLOWING WELL - if (this%iflowingwells > 0) then - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nmawwells) - do n = 1, this%nmawwells - q = this%qfw(n) - if (this%imover == 1) then - qfact = DONE - ! -- adjust if well rate is an outflow - if (this%qout(n) < DZERO) then - qfact = q / this%qout(n) - end if - q = q + qfact * this%pakmvrobj%get_qtomvr(n) - end if - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - end if - ! - ! -- STORAGE (AND VOLUME AS AUX) - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nmawwells) - do n = 1, this%nmawwells - b = this%mawwells(n)%xsto - this%mawwells(n)%bot - if (b < DZERO) then - b = DZERO - end if - v = this%mawwells(n)%area * b - if (this%imawissopt /= 1) then - q = this%qsto(n) - else - q = DZERO - end if - this%qauxcbc(1) = v - call this%budobj%budterm(idx)%update_term(n, n, q, this%qauxcbc) - end do - ! - ! -- CONSTANT FLOW - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nmawwells) - do n = 1, this%nmawwells - q = this%qconst(n) - ! - ! -- adjust if constant-flow rate is an outflow - if (this%imover == 1 .and. q < DZERO) then - qfact = DONE - if (this%qout(n) < DZERO) then - qfact = q / this%qout(n) - end if - q = q + qfact * this%pakmvrobj%get_qtomvr(n) - end if - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - ! - ! -- MOVER - if (this%imover == 1) then - ! - ! -- FROM MOVER - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nmawwells) - do n = 1, this%nmawwells - if (this%iboundpak(n) == 0) then - q = DZERO - else - q = this%pakmvrobj%get_qfrommvr(n) - end if - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - ! - ! -- RATE TO MOVER - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nmawwells) - do n = 1, this%nmawwells - q = this%pakmvrobj%get_qtomvr(n) - if (q > DZERO) then - q = -q - q2 = this%mawwells(n)%ratesim - ! -- adjust TO MOVER if well rate is outflow - if (q2 < DZERO) then - qfact = q2 / this%qout(n) - q = q * qfact - else - q = DZERO - end if - end if - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - ! - ! -- CONSTANT TO MOVER - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nmawwells) - do n = 1, this%nmawwells - q = this%pakmvrobj%get_qtomvr(n) - if (q > DZERO) then - q = -q - q2 = this%qconst(n) - ! -- adjust TO MOVER if well rate is outflow - if (q2 < DZERO) then - qfact = q2 / this%qout(n) - q = q * qfact - else - q = DZERO - end if - end if - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - ! - ! -- FLOWING WELL TO MOVER - if (this%iflowingwells > 0) then - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nmawwells) - do n = 1, this%nmawwells - q = this%pakmvrobj%get_qtomvr(n) - if (q > DZERO) then - q = -q - q2 = this%mawwells(n)%ratesim - ! -- adjust TO MOVER if well rate is outflow - qfact = DONE - if (this%qout(n) < DZERO) then - qfact = this%qfw(n) / this%qout(n) - end if - q = q * qfact - end if - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - end if - - end if - ! - ! -- AUXILIARY VARIABLES - naux = this%naux - if (naux > 0) then - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nmawwells) - do n = 1, this%nmawwells - q = DZERO - call this%budobj%budterm(idx)%update_term(n, n, q, this%auxvar(:, n)) - end do - end if - ! - ! --Terms are filled, now accumulate them for this time step - call this%budobj%accumulate_terms() - ! - ! -- return - return - end subroutine maw_fill_budobj - - subroutine maw_setup_tableobj(this) -! ****************************************************************************** -! maw_setup_tableobj -- Set up the table object that is used to write the maw -! head data. The terms listed here must correspond in -! number and order to the ones written to the head table -! in the maw_ot method. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH, LENBUDTXT - ! -- dummy - class(MawType) :: this - ! -- local - integer(I4B) :: nterms - character(len=LINELENGTH) :: title - character(len=LINELENGTH) :: text -! ------------------------------------------------------------------------------ - ! - ! -- setup well head table - if (this%iprhed > 0) then - ! - ! -- Determine the number of head table columns - nterms = 2 - if (this%inamedbound == 1) nterms = nterms + 1 - ! - ! -- set up table title - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%name)) //') HEADS FOR EACH CONTROL VOLUME' - ! - ! -- set up head tableobj - call table_cr(this%headtab, this%name, title) - call this%headtab%table_df(this%nmawwells, nterms, this%iout, & - transient=.TRUE.) - ! - ! -- Go through and set up table budget term - if (this%inamedbound == 1) then - text = 'NAME' - call this%headtab%initialize_column(text, 20, alignment=TABLEFT) - end if - ! - ! -- reach number - text = 'NUMBER' - call this%headtab%initialize_column(text, 10, alignment=TABCENTER) - ! - ! -- reach stage - text = 'HEAD' - call this%headtab%initialize_column(text, 12, alignment=TABCENTER) - end if - ! - ! -- return - return - end subroutine maw_setup_tableobj - -end module MawModule +module MawModule + ! + use KindModule, only: DP, I4B + use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, LENTIMESERIESNAME, & + DZERO, DEM6, DEM4, DEM2, DQUARTER, DHALF, DP7, & + DP9, DONE, DTWO, DPI, DTWOPI, DEIGHT, DHUNDRED, & + DEP20, NAMEDBOUNDFLAG, LENPACKAGENAME, LENAUXNAME, & + & LENFTYPE, DHNOFLO, DHDRY, DNODATA, MAXCHARLEN, & + TABLEFT, TABCENTER, TABRIGHT, & + TABSTRING, TABUCSTRING, TABINTEGER, TABREAL + use SmoothingModule, only: sQuadraticSaturation, sQSaturation, & + sQuadraticSaturationDerivative, & + sQSaturationDerivative + use BndModule, only: BndType + use BudgetObjectModule, only: BudgetObjectType, budgetobject_cr + use TableModule, only: TableType, table_cr + use ObserveModule, only: ObserveType + use ObsModule, only: ObsType + use InputOutputModule, only: get_node, URWORD, extract_idnum_or_bndname + use BaseDisModule, only: DisBaseType + use SimModule, only: count_errors, store_error, store_error_unit, ustop + use ArrayHandlersModule, only: ExpandArray + use BlockParserModule, only: BlockParserType + use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_setptr, & + mem_deallocate + ! + implicit none + + public :: MawType + + ! + character(len=LENFTYPE) :: ftype = 'MAW' + character(len=LENPACKAGENAME) :: text = ' MAW' + ! + type :: MawWellTSType + character (len=LENTIMESERIESNAME), pointer :: name => null() + real(DP), pointer :: value => null() + end type MawWellTSType + + type :: MawWellType + character (len=LENBOUNDNAME), pointer :: name => null() + character (len=8), pointer :: status => null() + integer(I4B), pointer :: ngwfnodes => null() + integer(I4B), pointer :: ieqn => null() + integer(I4B), pointer :: ishutoff => null() + integer(I4B), pointer :: ifwdischarge => null() + real(DP), pointer :: strt => null() + real(DP), pointer :: radius => null() + real(DP), pointer :: area => null() + real(DP), pointer :: pumpelev => null() + real(DP), pointer :: bot => null() + real(DP), pointer :: ratesim => null() + real(DP), pointer :: reduction_length => null() + real(DP), pointer :: fwelev => null() + real(DP), pointer :: fwcond => null() + real(DP), pointer :: fwrlen => null() + real(DP), pointer :: fwcondsim => null() + real(DP), pointer :: xsto => null() + real(DP), pointer :: xoldsto => null() + real(DP), pointer :: shutoffmin => null() + real(DP), pointer :: shutoffmax => null() + real(DP), pointer :: shutofflevel => null() + real(DP), pointer :: shutoffweight => null() + real(DP), pointer :: shutoffdq => null() + real(DP), pointer :: shutoffqold => null() + ! -- vectors + integer(I4B), dimension(:), pointer, contiguous :: gwfnodes => NULL() + real(DP), dimension(:), pointer, contiguous :: sradius => NULL() + real(DP), dimension(:), pointer, contiguous :: hk => NULL() + real(DP), dimension(:), pointer, contiguous :: satcond => NULL() + real(DP), dimension(:), pointer, contiguous :: simcond => NULL() + real(DP), dimension(:), pointer, contiguous :: topscrn => NULL() + real(DP), dimension(:), pointer, contiguous :: botscrn => NULL() + ! -- time-series aware data + ! -- aux data + type (MawWellTSType), dimension(:), pointer, contiguous :: auxvar => null() + ! -- pumping rate + type(MawWellTSType), pointer :: rate => null() + ! -- well head + type(MawWellTSType), pointer :: head => null() + end type MawWellType + ! + private + public :: maw_create + ! + type, extends(BndType) :: MawType + ! + ! -- scalars + ! -- characters + ! + character(len=16), dimension(:), pointer, contiguous :: cmawbudget => NULL() + character(len=LENAUXNAME), dimension(:), pointer, & + contiguous :: cauxcbc => NULL() + ! + ! -- integers + integer(I4B), pointer :: iprhed => null() + integer(I4B), pointer :: iheadout => null() + integer(I4B), pointer :: ibudgetout => null() + integer(I4B), pointer :: cbcauxitems => NULL() + integer(I4B), pointer :: iflowingwells => NULL() + integer(I4B), pointer :: imawiss => NULL() + integer(I4B), pointer :: imawissopt => NULL() + integer(I4B), pointer :: nmawwells => NULL() + integer(I4B), pointer :: check_attr => NULL() + integer(I4B), pointer :: ishutoffcnt => NULL() + integer(I4B), pointer :: ieffradopt => NULL() + real(DP), pointer :: satomega => null() + ! + ! -- for underrelaxation of estimated well q if using shutoff + real(DP), pointer :: theta => NULL() + real(DP), pointer :: kappa => NULL() + ! + ! -- derived types + type(MawWellType), dimension(:), pointer, contiguous :: mawwells => NULL() + ! + ! -- for budgets + integer(I4B), pointer :: bditems => NULL() + type(BudgetObjectType), pointer :: budobj => null() + ! + ! -- table objects + type(TableType), pointer :: headtab => null() + ! + ! -- pointer to gwf iss, k11, k22. + integer(I4B), pointer :: gwfiss => NULL() + real(DP), dimension(:), pointer, contiguous :: gwfk11 => NULL() + real(DP), dimension(:), pointer, contiguous :: gwfk22 => NULL() + integer(I4B), pointer :: gwfik22 => NULL() + real(DP), dimension(:), pointer, contiguous :: gwfsat => NULL() + ! + ! -- arrays for handling the rows added to the solution matrix + integer(I4B), dimension(:), pointer, contiguous :: idxlocnode => null() !map position in global rhs and x array of pack entry + integer(I4B), dimension(:), pointer, contiguous :: idxdglo => null() !map position in global array of package diagonal row entries + integer(I4B), dimension(:), pointer, contiguous :: idxoffdglo => null() !map position in global array of package off diagonal row entries + integer(I4B), dimension(:), pointer, contiguous :: idxsymdglo => null() !map position in global array of package diagonal entries to model rows + integer(I4B), dimension(:), pointer, contiguous :: idxsymoffdglo => null() !map position in global array of package off diagonal entries to model rows + integer(I4B), dimension(:), pointer, contiguous :: iboundpak => null() !package ibound + real(DP), dimension(:), pointer, contiguous :: xnewpak => null() !package x vector + real(DP), dimension(:), pointer, contiguous :: xoldpak => null() !package xold vector + real(DP), dimension(:), pointer, contiguous :: cterm => null() !package c vector + ! + ! -- vector data (start of flattening for future removal of MawWellType) + character (len=LENBOUNDNAME), dimension(:), pointer, & + contiguous :: cmawname => null() + integer(I4B), dimension(:), pointer, contiguous :: idxmawconn => null() + ! + ! -- imap vector + integer(I4B), dimension(:), pointer, contiguous :: imap => null() + ! + ! -- maw output data + real(DP), dimension(:), pointer, contiguous :: qauxcbc => null() + real(DP), dimension(:), pointer, contiguous :: dbuff => null() + real(DP), dimension(:), pointer, contiguous :: qleak => null() + real(DP), dimension(:), pointer, contiguous :: qout => null() + real(DP), dimension(:), pointer, contiguous :: qfw => null() + real(DP), dimension(:), pointer, contiguous :: qsto => null() + real(DP), dimension(:), pointer, contiguous :: qconst => null() + ! -- type bound procedures + contains + procedure :: maw_allocate_scalars + procedure :: maw_allocate_arrays + procedure :: bnd_options => maw_options + procedure :: read_dimensions => maw_read_dimensions + procedure :: read_initial_attr => maw_read_initial_attr + procedure :: set_pointers => maw_set_pointers + procedure :: bnd_ac => maw_ac + procedure :: bnd_mc => maw_mc + procedure :: bnd_ar => maw_ar + procedure :: bnd_rp => maw_rp + procedure :: bnd_ad => maw_ad + procedure :: bnd_cf => maw_cf + procedure :: bnd_fc => maw_fc + procedure :: bnd_fn => maw_fn + procedure :: bnd_nur => maw_nur + procedure :: bnd_bd => maw_bd + procedure :: bnd_ot => maw_ot + procedure :: bnd_da => maw_da + procedure :: define_listlabel + ! -- methods for observations + procedure, public :: bnd_obs_supported => maw_obs_supported + procedure, public :: bnd_df_obs => maw_df_obs + procedure, public :: bnd_rp_obs => maw_rp_obs + ! -- private procedures + procedure, private :: maw_read_wells + procedure, private :: maw_read_well_connections + procedure, private :: maw_allocate_well + procedure, private :: maw_deallocate_well + procedure, private :: maw_check_attributes + procedure, private :: maw_set_stressperiod + procedure, private :: maw_set_attribute_error + procedure, private :: maw_calculate_saturation + procedure, private :: maw_calculate_satcond + procedure, private :: maw_calculate_wellq + procedure, private :: maw_calculate_qpot + procedure, private :: maw_cfupdate + procedure, private :: maw_bd_obs + ! -- budget + procedure, private :: maw_setup_budobj + procedure, private :: maw_fill_budobj + ! -- table + procedure, private :: maw_setup_tableobj + end type MawType + +contains + + subroutine maw_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) +! ****************************************************************************** +! maw_create -- Create a New Multi-Aquifer Well Package +! Subroutine: (1) create new-style package +! (2) point bndobj to the new package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(BndType), pointer :: packobj + integer(I4B),intent(in) :: id + integer(I4B),intent(in) :: ibcnum + integer(I4B),intent(in) :: inunit + integer(I4B),intent(in) :: iout + character(len=*), intent(in) :: namemodel + character(len=*), intent(in) :: pakname + type(MawType), pointer :: mawobj +! ------------------------------------------------------------------------------ + ! + ! -- allocate the object and assign values to object variables + allocate(mawobj) + packobj => mawobj + ! + ! -- create name and origin + call packobj%set_names(ibcnum, namemodel, pakname, ftype) + packobj%text = text + ! + ! -- allocate scalars + call mawobj%maw_allocate_scalars() + ! + ! -- initialize package + call packobj%pack_initialize() + + packobj%inunit = inunit + packobj%iout = iout + packobj%id = id + packobj%ibcnum = ibcnum + packobj%ncolbnd = 4 + packobj%iscloc = 0 ! not supported + packobj%ictorigin = 'NPF' + ! + ! -- return + return + end subroutine maw_create + + subroutine maw_allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars -- allocate scalar members +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(MawType), intent(inout) :: this +! ------------------------------------------------------------------------------ + ! + ! -- call standard BndType allocate scalars + call this%BndType%allocate_scalars() + ! + ! -- allocate the object and assign values to object variables + call mem_allocate(this%iprhed, 'IPRHED', this%origin) + call mem_allocate(this%iheadout, 'IHEADOUT', this%origin) + call mem_allocate(this%ibudgetout, 'IBUDGETOUT', this%origin) + call mem_allocate(this%iflowingwells, 'IFLOWINGWELLS', this%origin) + call mem_allocate(this%imawiss, 'IMAWISS', this%origin) + call mem_allocate(this%imawissopt, 'IMAWISSOPT', this%origin) + call mem_allocate(this%nmawwells, 'NMAWWELLS', this%origin) + call mem_allocate(this%check_attr, 'check_attr', this%origin) + call mem_allocate(this%ishutoffcnt, 'ISHUTOFFCNT', this%origin) + call mem_allocate(this%ieffradopt, 'IEFFRADOPT', this%origin) + call mem_allocate(this%satomega, 'SATOMEGA', this%origin) + call mem_allocate(this%bditems, 'BDITEMS', this%origin) + call mem_allocate(this%theta, 'THETA', this%origin) + call mem_allocate(this%kappa, 'KAPPA', this%origin) + call mem_allocate(this%cbcauxitems, 'CBCAUXITEMS', this%origin) + ! + ! -- Set values + this%iprhed = 0 + this%iheadout = 0 + this%ibudgetout = 0 + this%iflowingwells = 0 + this%imawiss = 0 + this%imawissopt = 0 + this%ieffradopt = 0 + this%satomega = DZERO + this%bditems = 8 + this%theta = DP7 + this%kappa = DEM4 + this%cbcauxitems = 1 + !this%imover = 0 + ! + ! -- return + return + end subroutine maw_allocate_scalars + + subroutine maw_allocate_arrays(this) +! ****************************************************************************** +! allocate_scalars -- allocate scalar members +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(MawType), intent(inout) :: this + ! -- local + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + ! -- call standard BndType allocate scalars + call this%BndType%allocate_arrays() + ! + ! -- allocate cmawname + allocate(this%cmawname(this%nmawwells)) + ! + ! -- allocate idxmawconn + call mem_allocate(this%idxmawconn, this%nmawwells+1, 'IDXMAWCONN', this%origin) + ! + ! -- allocate imap + call mem_allocate(this%imap, this%MAXBOUND, 'IMAP', this%origin) + ! + ! -- initialize idxmawconn and imap + do i = 1, this%nmawwells+1 + this%idxmawconn(i) = 0 + end do + do i = 1, this%maxbound + this%imap(i) = 0 + end do + ! + ! -- allocate character array for budget text + allocate(this%cmawbudget(this%bditems)) + ! + !-- fill cmawbudget + this%cmawbudget(1) = ' GWF' + this%cmawbudget(2) = ' RATE' + this%cmawbudget(3) = ' STORAGE' + this%cmawbudget(4) = ' CONSTANT' + this%cmawbudget(5) = ' FW-RATE' + this%cmawbudget(6) = ' FROM-MVR' + this%cmawbudget(7) = ' RATE-TO-MVR' + this%cmawbudget(8) = ' FW-RATE-TO-MVR' + ! + ! -- allocate and initialize dbuff + if (this%iheadout > 0) then + call mem_allocate(this%dbuff, this%nmawwells, 'DBUFF', this%origin) + do i = 1, this%nmawwells + this%dbuff(i) = DZERO + end do + else + call mem_allocate(this%dbuff, 0, 'DBUFF', this%origin) + end if + ! + ! -- allocate character array for budget text + allocate(this%cauxcbc(this%cbcauxitems)) + ! + ! -- allocate and initialize qauxcbc + call mem_allocate(this%qauxcbc, this%cbcauxitems, 'QAUXCBC', this%origin) + do i = 1, this%cbcauxitems + this%qauxcbc(i) = DZERO + end do + ! + ! -- allocate qleak and qsto + call mem_allocate(this%qleak, this%maxbound, 'QLEAK', this%origin) + do i = 1, this%maxbound + this%qleak(i) = DZERO + end do + if (this%iflowingwells /= 0) then + call mem_allocate(this%qfw, this%nmawwells, 'QFW', this%origin) + else + call mem_allocate(this%qfw, 1, 'QFW', this%origin) + end if + call mem_allocate(this%qout, this%nmawwells, 'QOUT', this%origin) + call mem_allocate(this%qsto, this%nmawwells, 'QSTO', this%origin) + call mem_allocate(this%qconst, this%nmawwells, 'QCONST', this%origin) + ! + ! -- initialize flowing well, storage, and constant flow terms + do i = 1, this%nmawwells + if (this%iflowingwells /= 0) this%qfw(i) = DZERO + this%qsto(i) = DZERO + this%qconst(i) = DZERO + end do + ! + ! -- return + return + end subroutine maw_allocate_arrays + + subroutine maw_read_wells(this) +! ****************************************************************************** +! pak1read_dimensions -- Read the dimensions for this package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use TimeSeriesManagerModule, only: read_single_value_or_time_series + ! -- dummy + class(MawType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + character(len=LINELENGTH) :: text, keyword, cstr + character(len=LINELENGTH) :: strttext + character(len=LENBOUNDNAME) :: bndName, bndNameTemp + character(len=9) :: cno + character(len=50), dimension(:), allocatable :: caux + integer(I4B) :: ival + logical :: isfound, endOfBlock + real(DP) :: rval + integer(I4B) :: n + integer(I4B) :: jj + integer(I4B) :: iaux + integer(I4B) :: itmp + integer(I4B) :: ierr + real(DP) :: endtim + integer(I4B), dimension(:), pointer, contiguous :: nboundchk + ! -- format + character(len=*),parameter :: fmthdbot = & + "('well head (', G0, ') must be >= BOTTOM_ELEVATION (', G0, ').')" +! ------------------------------------------------------------------------------ + ! + ! -- code + ! + ! -- allocate and initialize temporary variables + allocate(nboundchk(this%nmawwells)) + do n = 1, this%nmawwells + nboundchk(n) = 0 + end do + ! + ! -- initialize itmp + itmp = 0 + ! + ! -- allocate space for mawwells data + allocate(this%mawwells(this%nmawwells)) + ! -- allocate pointers + do n = 1, this%nmawwells + call this%maw_allocate_well(n) + enddo + this%npakeq = this%nmawwells + ! + ! -- allocate local storage for aux variables + if (this%naux > 0) then + allocate(caux(this%naux)) + end if + ! + ! -- read maw well data + ! -- get wells block + call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & + supportopenclose=.true.) + ! + ! -- parse locations block if detected + if (isfound) then + write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & + ' PACKAGEDATA' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + ival = this%parser%GetInteger() + n = ival + + if (n < 1 .or. n > this%nmawwells) then + write(errmsg,'(4x,a,1x,i6)') & + '****ERROR. IMAW MUST BE > 0 and <= ', this%nmawwells + call store_error(errmsg) + cycle + end if + + ! -- increment nboundchk + nboundchk(n) = nboundchk(n) + 1 + + ! -- radius + rval = this%parser%GetDouble() + if (rval <= DZERO) then + write(errmsg,'(4x,a,1x,i6,1x,a)') & + '****ERROR. RADIUS FOR WELL', n, 'MUST BE GR5EATER THAN ZERO.' + call store_error(errmsg) + cycle + end if + this%mawwells(n)%radius = rval + this%mawwells(n)%area = DPI * rval**DTWO + ! -- well bottom + this%mawwells(n)%bot = this%parser%GetDouble() + ! -- strt + call this%parser%GetString(strttext) + ! -- ieqn + call this%parser%GetStringCaps(keyword) + if (keyword=='SPECIFIED') then + this%mawwells(n)%ieqn = 0 + else if (keyword=='THEIM' .or. keyword=='THIEM') then + this%mawwells(n)%ieqn = 1 + else if (keyword=='SKIN') then + this%mawwells(n)%ieqn = 2 + else if (keyword=='CUMULATIVE') then + this%mawwells(n)%ieqn = 3 + else if (keyword=='MEAN') then + this%mawwells(n)%ieqn = 4 + else + write(errmsg,'(4x,a,1x,i6,1x,a)') & + '****ERROR. CONDEQN FOR WELL', n, & + 'MUST BE "CONDUCTANCE", "THIEM" "MEAN", OR "SKIN".' + end if + ! -- ngwnodes + ival = this%parser%GetInteger() + if (ival < 1) then + write(errmsg,'(4x,a,1x,i6,1x,a)') & + '****ERROR. NGWFNODES FOR WELL', n, 'MUST BE GREATER THAN ZERO' + call store_error(errmsg) + end if + + if (ival > 0) then + this%mawwells(n)%ngwfnodes = ival + end if + + ! -- allocate storage for connection data needed for the MAW well + allocate(this%mawwells(n)%gwfnodes(this%mawwells(n)%ngwfnodes)) + allocate(this%mawwells(n)%satcond(this%mawwells(n)%ngwfnodes)) + allocate(this%mawwells(n)%simcond(this%mawwells(n)%ngwfnodes)) + allocate(this%mawwells(n)%topscrn(this%mawwells(n)%ngwfnodes)) + allocate(this%mawwells(n)%botscrn(this%mawwells(n)%ngwfnodes)) + if (this%mawwells(n)%ieqn==2 .OR. this%mawwells(n)%ieqn==3 .OR. & + this%mawwells(n)%ieqn==4) then + allocate(this%mawwells(n)%hk(this%mawwells(n)%ngwfnodes)) + end if + if (this%mawwells(n)%ieqn==2 .OR. this%mawwells(n)%ieqn==3 .OR. & + this%mawwells(n)%ieqn==4) then + allocate(this%mawwells(n)%sradius(this%mawwells(n)%ngwfnodes)) + end if + + ! -- increment maxbound + itmp = itmp + this%mawwells(n)%ngwfnodes + ! + ! -- set default bndName + write (cno,'(i9.9)') n + bndName = 'MAWWELL' // cno + + ! -- get aux data + do iaux = 1, this%naux + call this%parser%GetString(caux(iaux)) + end do + + ! -- read well name + this%mawwells(n)%name = bndName + if (this%inamedbound /= 0) then + call this%parser%GetStringCaps(bndNameTemp) + if (bndNameTemp /= '') then + this%mawwells(n)%name = bndNameTemp(1:16) + endif + else + bndName = '' + endif + ! fill timeseries aware data + jj = 1 ! For WELL_HEAD + endtim = DZERO + call read_single_value_or_time_series(strttext, & + this%mawwells(n)%head%value, & + this%mawwells(n)%head%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, n, jj, 'HEAD', & + bndName, this%parser%iuactive) + this%mawwells(n)%strt = this%mawwells(n)%head%value + if (this%mawwells(n)%strt < this%mawwells(n)%bot) then + write(cstr, fmthdbot) this%mawwells(n)%strt, this%mawwells(n)%bot + call this%maw_set_attribute_error(n, 'STRT', trim(cstr)) + end if + + ! -- fill aux data + do iaux = 1, this%naux + text = caux(iaux) + jj = 1 !iaux + call read_single_value_or_time_series(trim(adjustl(text)), & + this%mawwells(n)%auxvar(iaux)%value, & + this%mawwells(n)%auxvar(iaux)%name, & + endtim, & + this%Name, 'AUX', this%TsManager, & + this%iprpak, n, jj, & + this%auxname(iaux), & + bndName, this%parser%iuactive) + end do + end do + + write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' PACKAGEDATA' + ! + ! -- check for duplicate or missing wells + do n = 1, this%nmawwells + if (nboundchk(n) == 0) then + write(errmsg,'(a,1x,i0)') 'ERROR. NO DATA SPECIFIED FOR MAW WELL', n + call store_error(errmsg) + else if (nboundchk(n) > 1) then + write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & + 'ERROR. DATA FOR MAW WELL', n, 'SPECIFIED', nboundchk(n), 'TIMES' + call store_error(errmsg) + end if + end do + else + call store_error('ERROR. REQUIRED PACKAGEDATA BLOCK NOT FOUND.') + end if + ! + ! -- terminate if any errors were detected + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- set MAXBOUND + this%maxbound = itmp + write(this%iout,'(//4x,a,i7)') 'MAXBOUND = ', this%maxbound + ! + ! -- deallocate local storage for aux variables + if (this%naux > 0) then + deallocate(caux) + end if + ! + ! -- deallocate local storage for nboundchk + deallocate(nboundchk) + ! + ! -- return + return + end subroutine maw_read_wells + + subroutine maw_read_well_connections(this) +! ****************************************************************************** +! pak1read_dimensions -- Read the dimensions for this package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + ! -- dummy + class(MawType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + character(len=LINELENGTH) :: cellid + character(len=30) :: nodestr + integer(I4B) :: ierr, ival + integer(I4b) :: ipos + logical :: isfound, endOfBlock + real(DP) :: rval + real(DP) :: topnn + real(DP) :: botnn + real(DP) :: botw + integer(I4B) :: j + integer(I4B) :: jj + integer(I4B) :: n + integer(I4B) :: nn + integer(I4B) :: nn2 + integer(I4B), dimension(:), pointer, contiguous :: nboundchk + integer(I4B), dimension(:), pointer, contiguous :: iachk + +! ------------------------------------------------------------------------------ + ! -- format + ! + ! -- code + ! + ! -- allocate and initialize local storage + allocate(iachk(this%nmawwells+1)) + iachk(1) = 1 + do n = 1, this%nmawwells + iachk(n+1) = iachk(n) + this%mawwells(n)%ngwfnodes + end do + allocate(nboundchk(this%maxbound)) + do n = 1, this%maxbound + nboundchk(n) = 0 + end do + ! + ! -- get well_connections block + call this%parser%GetBlock('CONNECTIONDATA', isfound, ierr, & + supportOpenClose=.true.) + ! + ! -- parse well_connections block if detected + if (isfound) then + write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & + ' CONNECTIONDATA' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + ival = this%parser%GetInteger() + n = ival + + if (n < 1 .or. n > this%nmawwells) then + write(errmsg,'(4x,a,1x,i6)') & + '****ERROR. IMAW MUST BE > 0 and <= ', this%nmawwells + call store_error(errmsg) + cycle + end if + + ! -- read connection number + ival = this%parser%GetInteger() + if (ival < 1 .or. ival > this%mawwells(n)%ngwfnodes) then + write(errmsg,'(4x,a,1x,i4,1x,a,1x,i6)') & + '****ERROR. JCONN FOR WELL ', n, 'MUST BE > 1 and <= ', this%mawwells(n)%ngwfnodes + call store_error(errmsg) + cycle + end if + + ipos = iachk(n) + ival - 1 + nboundchk(ipos) = nboundchk(ipos) + 1 + + j = ival + ! -- read gwfnodes from the line + call this%parser%GetCellid(this%dis%ndim, cellid) + nn = this%dis%noder_from_cellid(cellid, this%inunit, this%iout) + topnn = this%dis%top(nn) + botnn = this%dis%bot(nn) + botw = this%mawwells(n)%bot + ! -- set gwf node number for connection + this%mawwells(n)%gwfnodes(j) = nn + ! -- top of screen + rval = this%parser%GetDouble() + if (this%mawwells(n)%ieqn /= 4) then + rval = topnn + else + if (rval > topnn) then + rval = topnn + end if + end if + this%mawwells(n)%topscrn(j) = rval + ! -- bottom of screen + rval = this%parser%GetDouble() + if (this%mawwells(n)%ieqn /= 4) then + rval = botnn + else + if (rval < botnn) then + rval = botnn + end if + end if + this%mawwells(n)%botscrn(j) = rval + ! adjust the bottom of the well for all conductance approaches + ! except for "mean" + if (this%mawwells(n)%ieqn /= 4) then + if (rval < botw) then + botw = rval + this%mawwells(n)%bot = rval + end if + end if + ! -- hydraulic conductivity or conductance + rval = this%parser%GetDouble() + if (this%mawwells(n)%ieqn==0) then + this%mawwells(n)%satcond(j) = rval + else if (this%mawwells(n)%ieqn==2 .OR. this%mawwells(n)%ieqn==3 .OR. & + this%mawwells(n)%ieqn==4) then + this%mawwells(n)%hk(j) = rval + end if + ! -- skin radius + rval = this%parser%GetDouble() + if (this%mawwells(n)%ieqn==2 .OR. this%mawwells(n)%ieqn==3 .OR. & + this%mawwells(n)%ieqn==4) then + this%mawwells(n)%sradius(j) = rval + end if + end do + write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' CONNECTIONDATA' + + ipos = 0 + do n = 1, this%nmawwells + do j = 1, this%mawwells(n)%ngwfnodes + ipos = ipos + 1 + ! + ! -- check for missing or duplicate maw well connections + if (nboundchk(ipos) == 0) then + write(errmsg,'(a,1x,i0,1x,a,1x,i0)') & + 'ERROR. NO DATA SPECIFIED FOR MAW WELL', n, 'CONNECTION', j + call store_error(errmsg) + else if (nboundchk(ipos) > 1) then + write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & + 'ERROR. DATA FOR MAW WELL', n, 'CONNECTION', j, & + 'SPECIFIED', nboundchk(n), 'TIMES' + call store_error(errmsg) + end if + end do + end do + ! + ! -- make sure that more than one connection per cell is only specified + ! wells using the mean conducance type + do n = 1, this%nmawwells + if (this%mawwells(n)%ieqn /= 4) then + do j = 1, this%mawwells(n)%ngwfnodes + nn = this%mawwells(n)%gwfnodes(j) + do jj = 1, this%mawwells(n)%ngwfnodes + ! skip current maw node + if (jj == j) then + cycle + end if + nn2 = this%mawwells(n)%gwfnodes(jj) + if (nn2 == nn) then + call this%dis%noder_to_string(nn, nodestr) + write(errmsg,'(a,1x,i0,1x,a,1x,i0,3(1x,a))') & + 'ERROR. ONLY ONE CONNECTION CAN BE SPECIFIED FOR MAW WELL', & + n, 'CONNECTION', j, 'TO GWF CELL', trim(adjustl(nodestr)), & + 'UNLESS THE MEAN CONDEQN IS SPECIFIED' + call store_error(errmsg) + end if + end do + end do + end if + end do + else + call store_error('ERROR. REQUIRED CONNECTIONDATA BLOCK NOT FOUND.') + end if + ! + ! -- deallocate local variable + deallocate(iachk) + deallocate(nboundchk) + ! + ! -- write summary of maw well_connection error messages + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- return + return + end subroutine maw_read_well_connections + + + subroutine maw_read_dimensions(this) +! ****************************************************************************** +! pak1read_dimensions -- Read the dimensions for this package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + ! -- dummy + class(MawType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + character(len=LENBOUNDNAME) :: keyword + integer(I4B) :: ierr + logical :: isfound, endOfBlock + ! -- format +! ------------------------------------------------------------------------------ + ! + ! -- initialize dimensions to -1 + this%nmawwells= -1 + this%maxbound = -1 + ! + ! -- 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 '//trim(adjustl(this%text))// & + ' DIMENSIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('NMAWWELLS') + this%nmawwells = this%parser%GetInteger() + write(this%iout,'(4x,a,i7)')'NMAWWELLS = ', this%nmawwells + case default + write(errmsg,'(4x,a,a)') & + '****ERROR. UNKNOWN '//trim(this%text)//' DIMENSION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + end do + write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' DIMENSIONS' + else + call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') + call ustop() + end if + ! + ! -- verify dimensions were set correctly + if (this%nmawwells < 0) then + write(errmsg, '(1x,a)') & + 'ERROR: NMAWWELLS WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.' + call store_error(errmsg) + end if + ! + ! -- stop if errors were encountered in the DIMENSIONS block + ierr = count_errors() + if (ierr > 0) then + call ustop() + end if + ! + ! -- read wells block + call this%maw_read_wells() + ! + ! -- read well_connections block + call this%maw_read_well_connections() + ! + ! -- Call define_listlabel to construct the list label that is written + ! when PRINT_INPUT option is used. + call this%define_listlabel() + ! + ! -- setup the budget object + call this%maw_setup_budobj() + ! + ! -- setup the head table object + call this%maw_setup_tableobj() + ! + ! -- return + return + end subroutine maw_read_dimensions + + + subroutine maw_read_initial_attr(this) +! ****************************************************************************** +! maw_read_initial_attr -- Read the initial parameters for this package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use MemoryManagerModule, only: mem_setptr + ! -- dummy + class(MawType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: text + integer(I4B) :: ntabcols + integer(I4B) :: j, n + integer(I4B) :: nn + integer(I4B) :: inode + integer(I4B) :: idx + real(DP) :: k11, k22 + character (len=10), dimension(0:4) :: ccond + character (len=30) :: nodestr + ! -- data + data ccond(0) /'SPECIFIED '/ + data ccond(1) /'THIEM '/ + data ccond(2) /'SKIN '/ + data ccond(3) /'CUMULATIVE'/ + data ccond(4) /'MEAN '/ + ! -- format + character(len=*), parameter :: fmtwelln = & + "(1X,//43X,'MULTI-AQUIFER WELL DATA'" // & + "/1X,109('-')," // & + "/1X,7(A10,1X),A16)" + character(len=*), parameter :: fmtwelld = & + "(1X,I10,1X,4(G10.3,1X),I10,1X,A10,1X,A16)" + character(len=*), parameter :: fmtline = & + "(1X,119('-'),//)" + character(len=*), parameter :: fmtwellcn = & + "(1X,//37X,'MULTI-AQUIFER WELL CONNECTION DATA'" // & + "/1X,119('-')," // & + "/1X,2(A10,1X),A20,7(A10,1X))" + character(len=*), parameter :: fmtwellcd = & + "(1X,2(I10,1X),A20,1X,2(G10.3,1X),2(A10,1X),3(G10.3,1X))" +! ------------------------------------------------------------------------------ + ! + ! -- initialize xnewpak + do n = 1, this%nmawwells + this%xnewpak(n) = this%mawwells(n)%strt + end do + ! + ! -- initialize status (iboundpak) of maw wells to active + do n = 1, this%nmawwells + if (this%mawwells(n)%status == 'CONSTANT') then + this%iboundpak(n) = -1 + else if (this%mawwells(n)%status == 'INACTIVE') then + this%iboundpak(n) = 0 + else if (this%mawwells(n)%status == 'ACTIVE ') then + this%iboundpak(n) = 1 + end if + end do + ! + ! -- set idxmawconn and imap for each connection + idx = 0 + this%idxmawconn(1) = 1 + do n = 1, this%nmawwells + do j = 1, this%mawwells(n)%ngwfnodes + idx = idx + 1 + this%imap(idx) = n + end do + this%idxmawconn(n+1) = idx + 1 + end do + ! + ! -- set boundname for each connection + if (this%inamedbound /= 0) then + idx = 0 + do n = 1, this%nmawwells + this%cmawname(n) = this%mawwells(n)%name + do j = 1, this%mawwells(n)%ngwfnodes + idx = idx + 1 + this%boundname(idx) = this%mawwells(n)%name + end do + end do + else + do n = 1, this%nmawwells + this%cmawname(n) = '' + end do + end if + ! + ! -- set imap and boundname for each connection + if (this%inamedbound /= 0) then + idx = 0 + do n = 1, this%nmawwells + do j = 1, this%mawwells(n)%ngwfnodes + idx = idx + 1 + this%boundname(idx) = this%mawwells(n)%name + this%imap(idx) = n + end do + end do + end if + ! + ! -- set pointer to gwf iss and gwf hk + call mem_setptr(this%gwfiss, 'ISS', trim(this%name_model)) + call mem_setptr(this%gwfk11, 'K11', trim(this%name_model)//' NPF') + call mem_setptr(this%gwfk22, 'K22', trim(this%name_model)//' NPF') + call mem_setptr(this%gwfik22, 'IK22', trim(this%name_model)//' NPF') + call mem_setptr(this%gwfsat, 'SAT', trim(this%name_model)//' NPF') + ! + ! -- qa data + call this%maw_check_attributes() + ! + ! -- Calculate the saturated conductance + do n = 1, this%nmawwells + ! + ! -- calculate saturated conductance only if CONDUCTANCE was not + ! specified for each maw-gwf connection (CONDUCTANCE keyword). + do j = 1, this%mawwells(n)%ngwfnodes + if (this%mawwells(n)%ieqn /= 0) then + inode = this%mawwells(n)%gwfnodes(j) + call this%maw_calculate_satcond(n, j, inode) + end if + end do + end do + ! + ! -- write summary of static well data + ! -- write well data + if (this%iprpak /= 0) then + ntabcols = 7 + if (this%inamedbound /= 0) then + ntabcols = ntabcols + 1 + end if + title = trim(adjustl(this%text)) // ' PACKAGE (' // & + trim(adjustl(this%name)) //') STATIC WELL DATA' + call table_cr(this%inputtab, this%name, title) + call this%inputtab%table_df(this%nmawwells, ntabcols, this%iout) + text = 'NUMBER' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'RADIUS' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'AREA' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'WELL BOTTOM' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'STARTING HEAD' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'NUMBER OF GWF NODES' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'CONDUCT. EQUATION' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + if (this%inamedbound /= 0) then + text = 'NAME' + call this%inputtab%initialize_column(text, 20, alignment=TABLEFT) + end if + do n = 1, this%nmawwells + call this%inputtab%add_term(n) + call this%inputtab%add_term(this%mawwells(n)%radius) + call this%inputtab%add_term(this%mawwells(n)%area) + call this%inputtab%add_term(this%mawwells(n)%bot) + call this%inputtab%add_term(this%mawwells(n)%strt) + call this%inputtab%add_term(this%mawwells(n)%ngwfnodes) + call this%inputtab%add_term(ccond(this%mawwells(n)%ieqn)) + if (this%inamedbound /= 0) then + call this%inputtab%add_term(this%mawwells(n)%name) + end if + end do + end if + ! + ! -- write well connection data + if (this%iprpak /= 0) then + ntabcols = 10 + title = trim(adjustl(this%text)) // ' PACKAGE (' // & + trim(adjustl(this%name)) //') STATIC WELL CONNECTION DATA' + call table_cr(this%inputtab, this%name, title) + call this%inputtab%table_df(this%maxbound, ntabcols, this%iout) + text = 'NUMBER' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'WELL CONNECTION' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'CELLID' + call this%inputtab%initialize_column(text, 20, alignment=TABLEFT) + text = 'TOP OF SCREEN' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'BOTTOM OF SCREEN' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'SKIN RADIUS' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'SKIN K' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'K11' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'K22' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'SATURATED WELL CONDUCT.' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + ! + ! -- write the data to the table + do n = 1, this%nmawwells + do j = 1, this%mawwells(n)%ngwfnodes + call this%inputtab%add_term(n) + call this%inputtab%add_term(j) + nn = this%mawwells(n)%gwfnodes(j) + call this%dis%noder_to_string(nn, nodestr) + call this%inputtab%add_term(nodestr) + call this%inputtab%add_term(this%mawwells(n)%topscrn(j)) + call this%inputtab%add_term(this%mawwells(n)%botscrn(j)) + if (this%mawwells(n)%ieqn == 2 .or. & + this%mawwells(n)%ieqn == 3 .or. & + this%mawwells(n)%ieqn == 4) then + call this%inputtab%add_term(this%mawwells(n)%sradius(j)) + call this%inputtab%add_term(this%mawwells(n)%hk(j)) + else + call this%inputtab%add_term(' ') + call this%inputtab%add_term(' ') + end if + if (this%mawwells(n)%ieqn == 1 .or. & + this%mawwells(n)%ieqn == 2 .or. & + this%mawwells(n)%ieqn == 3) then + k11 = this%gwfk11(nn) + if (this%gwfik22 == 0) then + k22 = this%gwfk11(nn) + else + k22 = this%gwfk22(nn) + end if + call this%inputtab%add_term(k11) + call this%inputtab%add_term(k22) + else + call this%inputtab%add_term(' ') + call this%inputtab%add_term(' ') + end if + call this%inputtab%add_term(this%mawwells(n)%satcond(j)) + end do + end do + end if + ! + ! -- finished with pointer to gwf hydraulic conductivity + this%gwfk11 => null() + this%gwfk22 => null() + this%gwfik22 => null() + this%gwfsat => null() + ! + ! -- check for any error conditions + if (count_errors() > 0) then + call ustop() + end if + ! + ! -- return + return + end subroutine maw_read_initial_attr + + + subroutine maw_set_stressperiod(this, imaw, line) +! ****************************************************************************** +! maw_set_stressperiod -- Set a stress period attribute for mawweslls(imaw) +! using keywords. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: kper, perlen, totimsav + use TimeSeriesManagerModule, only: read_single_value_or_time_series + ! -- dummy + class(MawType),intent(inout) :: this + integer(I4B), intent(in) :: imaw + character (len=*), intent(in) :: line + ! -- local + character(len=LINELENGTH) :: text, cstr + character(len=LINELENGTH) :: caux + character(len=LINELENGTH) :: keyword + character(len=LINELENGTH) :: errmsg + character(len=LENBOUNDNAME) :: bndName + character(len=9) :: cmaw + integer(I4B) :: ival, istart, istop + integer(I4B) :: i0 + integer(I4B) :: lloc + integer(I4B) :: ii + integer(I4B) :: jj + integer(I4B) :: idx + integer(I4B) :: iaux + real(DP) :: rval + real(DP) :: endtim + integer(I4B) :: istat + character(len=MAXCHARLEN) :: ermsg, ermsgr + ! -- formats + character(len=*),parameter :: fmthdbot = & + "('well head (',G0,') must be >= BOTTOM_ELEVATION (',G0, ').')" +! ------------------------------------------------------------------------------ + ! + ! -- Find time interval of current stress period. + endtim = totimsav + perlen(kper) + ! + ! -- Assign boundary name, if available + ! + ! -- set default bndName + write (cmaw,'(i9.9)') imaw + !bndName = 'MAWWELL' // cmaw + if (this%inamedbound==1) then + idx = 0 + do ii = 1, imaw + do jj = 1, this%mawwells(ii)%ngwfnodes + idx = idx + 1 + end do + end do + bndName = this%boundname(idx) + else + bndName = '' + endif + ! + ! -- read line + lloc = 1 + call urword(line, lloc, istart, istop, 1, ival, rval, this%iout, this%inunit) + i0 = istart + keyword = line(istart:istop) + select case (line(istart:istop)) + case ('STATUS') + call urword(line, lloc, istart, istop, 1, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + this%mawwells(imaw)%status = text(1:8) + if (text == 'CONSTANT') then + this%iboundpak(imaw) = -1 + else if (text == 'INACTIVE') then + this%iboundpak(imaw) = 0 + else if (text == 'ACTIVE') then + this%iboundpak(imaw) = 1 + else + write(errmsg,'(4x,a,a)') & + '****ERROR. UNKNOWN '//trim(this%text)//' MAW STATUS KEYWORD: ', & + text + call store_error(errmsg) + end if + case ('RATE') + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 1 ! For RATE + call read_single_value_or_time_series(text, & + this%mawwells(imaw)%rate%value, & + this%mawwells(imaw)%rate%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, imaw, jj, 'RATE', & + bndName, this%inunit) + case ('WELL_HEAD') + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 1 ! For WELL_HEAD + call read_single_value_or_time_series(text, & + this%mawwells(imaw)%head%value, & + this%mawwells(imaw)%head%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, imaw, jj, 'HEAD', & + bndName, this%inunit) + this%xnewpak(imaw) = this%mawwells(imaw)%head%value + if (this%mawwells(imaw)%head%value < this%mawwells(imaw)%bot) then + write(cstr, fmthdbot) this%mawwells(imaw)%head%value, this%mawwells(imaw)%bot + call this%maw_set_attribute_error(imaw, 'WELL HEAD', trim(cstr)) + end if + case ('FLOWING_WELL') + call urword(line, lloc, istart, istop, 3, ival, rval, this%iout, this%inunit) + this%mawwells(imaw)%fwelev = rval + call urword(line, lloc, istart, istop, 3, ival, rval, this%iout, this%inunit) + this%mawwells(imaw)%fwcond = rval + call urword(line, lloc, istart, istop, 3, ival, rval, -this%iout, this%inunit) + this%mawwells(imaw)%fwrlen = rval + case ('RATE_SCALING') + call urword(line, lloc, istart, istop, 3, ival, rval, this%iout, this%inunit) + this%mawwells(imaw)%pumpelev = rval + call urword(line, lloc, istart, istop, 3, ival, rval, this%iout, this%inunit) + this%mawwells(imaw)%reduction_length = rval + if (rval < DZERO) then + call this%maw_set_attribute_error(imaw, trim(keyword), 'must be >= 0.') + end if + case ('HEAD_LIMIT') + call urword(line, lloc, istart, istop, 1, ival, rval, this%iout, this%inunit) + if (line(istart:istop) == 'OFF') then + this%mawwells(imaw)%shutofflevel = DEP20 + else + read (line(istart:istop), *,iostat=istat,iomsg=ermsgr) this%mawwells(imaw)%shutofflevel + if (istat /= 0) then + ermsg = 'Error reading HEAD_LIMIT value.' + call store_error(ermsg) + call store_error(ermsgr) + call ustop() + endif + end if + case ('SHUT_OFF') + call urword(line, lloc, istart, istop, 3, ival, rval, this%iout, this%inunit) + this%mawwells(imaw)%shutoffmin = rval + call urword(line, lloc, istart, istop, 3, ival, rval, this%iout, this%inunit) + this%mawwells(imaw)%shutoffmax = rval + case ('AUXILIARY') + call urword(line, lloc, istart, istop, 1, ival, rval, this%iout, this%inunit) + caux = line(istart:istop) + do iaux = 1, this%naux + if (trim(adjustl(caux)) /= trim(adjustl(this%auxname(iaux)))) cycle + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 1 !iaux + call read_single_value_or_time_series(text, & + this%mawwells(imaw)%auxvar(iaux)%value, & + this%mawwells(imaw)%auxvar(iaux)%name, & + endtim, & + this%Name, 'AUX', this%TsManager, & + this%iprpak, imaw, jj, & + this%auxname(iaux), bndName, & + this%inunit) + exit + end do + case default + write(errmsg,'(4x,a,a)') & + '****ERROR. UNKNOWN '//trim(this%text)//' MAW DATA KEYWORD: ', & + line(istart:istop) + call store_error(errmsg) + call ustop() + end select + + ! + ! -- return + return + end subroutine maw_set_stressperiod + + + subroutine maw_set_attribute_error(this, imaw, keyword, msg) +! ****************************************************************************** +! maw_set_attribute_error -- Issue a parameter error for mawweslls(imaw) +! Subroutine: (1) read itmp +! (2) read new boundaries if itmp>0 +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use SimModule, only: store_error + ! -- dummy + class(MawType),intent(inout) :: this + integer(I4B), intent(in) :: imaw + character (len=*), intent(in) :: keyword + character (len=*), intent(in) :: msg + ! -- local + character(len=LINELENGTH) :: errmsg + ! -- formats +! ------------------------------------------------------------------------------ + if (len(msg) == 0) then + write(errmsg,'(4x,a,1x,a,1x,a,1x,i0,1x,a)') & + '****ERROR.', keyword, ' for MAW well', imaw, 'has already been set.' + else + write(errmsg,'(4x,a,1x,a,1x,a,1x,i0,1x,a)') & + '****ERROR.', keyword, ' for MAW well', imaw, msg + end if + call store_error(errmsg) + ! -- return + return + end subroutine maw_set_attribute_error + + + subroutine maw_check_attributes(this) +! ****************************************************************************** +! maw_check_attributes -- Issue parameter errors for mawwells(imaw) +! Subroutine: (1) read itmp +! (2) read new boundaries if itmp>0 +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use SimModule, only: store_error + ! -- dummy + class(MawType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: cgwfnode + integer(I4B) :: idx + integer(I4B) :: n + integer(I4B) :: j + ! -- formats +! ------------------------------------------------------------------------------ + idx = 1 + do n = 1, this%nmawwells + if (this%mawwells(n)%ngwfnodes < 1) then + call this%maw_set_attribute_error(n, 'NGWFNODES', 'must be greater ' // & + 'than 0.') + end if + ! -- CDL 2/5/2018 Moved to maw_set_stressperiod so it is only done if a + ! new head is read in. + !if (this%xnewpak(n) < this%mawwells(n)%bot) then + !write(cstr, fmthdbot) this%xnewpak(n), this%mawwells(n)%bot + !call this%maw_set_attribute_error(n, 'WELL HEAD', trim(cstr)) + !end if + if (this%mawwells(n)%radius == DEP20) then + call this%maw_set_attribute_error(n, 'RADIUS', 'has not been specified.') + end if + if (this%mawwells(n)%shutoffmin > DZERO) then + if (this%mawwells(n)%shutoffmin >= this%mawwells(n)%shutoffmax) then + call this%maw_set_attribute_error(n, 'SHUT_OFF', 'shutoffmax must ' // & + 'be > shutoffmin.') + end if + end if + do j = 1, this%mawwells(n)%ngwfnodes + ! -- write gwfnode number + write(cgwfnode,'(a,i0,a)') 'gwfnode(', j,')' + if (this%mawwells(n)%botscrn(j) >= this%mawwells(n)%topscrn(j)) then + call this%maw_set_attribute_error(n, 'SCREEN_TOP', 'screen bottom ' // & + 'must be < screen top. ' // & + trim(cgwfnode)) + end if + if (this%mawwells(n)%ieqn==2 .OR. this%mawwells(n)%ieqn==3 .OR. & + this%mawwells(n)%ieqn==4) then + if (this%mawwells(n)%sradius(j) > DZERO) then + if (this%mawwells(n)%sradius(j) <= this%mawwells(n)%radius) then + call this%maw_set_attribute_error(n, 'RADIUS_SKIN', 'skin ' // & + 'radius must be >= well ' // & + 'radius. ' // trim(cgwfnode)) + end if + end if + if (this%mawwells(n)%hk(j) <= DZERO) then + call this%maw_set_attribute_error(n, 'HK_SKIN', 'skin hyraulic ' // & + 'conductivity must be > zero. ' // & + trim(cgwfnode)) + end if + else if (this%mawwells(n)%ieqn == 0) then + if (this%mawwells(n)%satcond(j) < DZERO) then + call this%maw_set_attribute_error(n, 'HK_SKIN', & + 'skin hyraulic conductivity ' // & + 'must be >= zero when using ' // & + 'SPECIFIED condeqn. ' // & + trim(cgwfnode)) + end if + end if + idx = idx + 1 + end do + end do + ! -- reset check_attr + this%check_attr = 0 + ! -- return + return + end subroutine maw_check_attributes + + subroutine maw_ac(this, moffset, sparse) +! ****************************************************************************** +! bnd_ac -- Add package connection to matrix +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use SparseModule, only: sparsematrix + ! -- dummy + class(MawType),intent(inout) :: this + integer(I4B), intent(in) :: moffset + type(sparsematrix), intent(inout) :: sparse + ! -- local + integer(I4B) :: j, n + integer(I4B) :: jj, jglo + integer(I4B) :: nglo + ! -- format +! ------------------------------------------------------------------------------ + ! + ! + ! -- Add package rows to sparse + do n = 1, this%nmawwells + nglo = moffset + this%dis%nodes + this%ioffset + n + call sparse%addconnection(nglo, nglo, 1) + do j = 1, this%mawwells(n)%ngwfnodes + jj = this%mawwells(n)%gwfnodes(j) + jglo = jj + moffset + call sparse%addconnection(nglo, jglo, 1) + call sparse%addconnection(jglo, nglo, 1) + end do + + end do + ! + ! -- return + return + end subroutine maw_ac + + subroutine maw_mc(this, moffset, iasln, jasln) +! ****************************************************************************** +! bnd_ac -- map package connection to matrix +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use SparseModule, only: sparsematrix + ! -- dummy + class(MawType),intent(inout) :: this + integer(I4B), intent(in) :: moffset + integer(I4B), dimension(:), intent(in) :: iasln + integer(I4B), dimension(:), intent(in) :: jasln + ! -- local + integer(I4B) :: n, j, ii, jj, iglo, jglo + integer(I4B) :: ipos + ! -- format +! ------------------------------------------------------------------------------ + ! + ! + allocate(this%idxlocnode(this%nmawwells)) + allocate(this%idxdglo(this%maxbound)) + allocate(this%idxoffdglo(this%maxbound)) + allocate(this%idxsymdglo(this%maxbound)) + allocate(this%idxsymoffdglo(this%maxbound)) + ! + ! -- Find the position of each connection in the global ia, ja structure + ! and store them in idxglo. idxglo allows this model to insert or + ! retrieve values into or from the global A matrix + ! -- maw rows + ipos = 1 + do n = 1, this%nmawwells + iglo = moffset + this%dis%nodes + this%ioffset + n + this%idxlocnode(n) = this%dis%nodes + this%ioffset + n + do ii = 1, this%mawwells(n)%ngwfnodes + j = this%mawwells(n)%gwfnodes(ii) + jglo = j + moffset + searchloop: do jj = iasln(iglo), iasln(iglo + 1) - 1 + if(jglo == jasln(jj)) then + this%idxdglo(ipos) = iasln(iglo) + this%idxoffdglo(ipos) = jj + exit searchloop + endif + enddo searchloop + ipos = ipos + 1 + end do + end do + ! -- maw contributions gwf portion of global matrix + ipos = 1 + do n = 1, this%nmawwells + do ii = 1, this%mawwells(n)%ngwfnodes + iglo = this%mawwells(n)%gwfnodes(ii) + moffset + jglo = moffset + this%dis%nodes + this%ioffset + n + symsearchloop: do jj = iasln(iglo), iasln(iglo + 1) - 1 + if(jglo == jasln(jj)) then + this%idxsymdglo(ipos) = iasln(iglo) + this%idxsymoffdglo(ipos) = jj + exit symsearchloop + endif + enddo symsearchloop + ipos = ipos + 1 + end do + end do + ! + ! -- return + return + end subroutine maw_mc + + subroutine maw_options(this, option, found) +! ****************************************************************************** +! maw_options -- set options specific to MawType +! +! maw_options overrides BndType%bnd_options +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: MAXCHARLEN, DZERO + use OpenSpecModule, only: access, form + use InputOutputModule, only: urword, getunit, openfile + ! -- dummy + class(MawType), intent(inout) :: this + character(len=*), intent(inout) :: option + logical, intent(inout) :: found + ! -- local + character(len=MAXCHARLEN) :: fname, keyword + ! -- formats + character(len=*),parameter :: fmtflowingwells = & + "(4x, 'FLOWING WELLS WILL BE SIMULATED.')" + character(len=*),parameter :: fmtshutdown = & + "(4x, 'SHUTDOWN ', a, ' VALUE (',g15.7,') SPECIFIED.')" + character(len=*),parameter :: fmtnostoragewells = & + "(4x, 'WELL STORAGE WILL NOT BE SIMULATED.')" + character(len=*),parameter :: fmtmawbin = & + "(4x, 'MAW ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" +! ------------------------------------------------------------------------------ + ! + ! -- Check for 'FLOWING_WELLS' and set this%iflowingwells + select case (option) + case ('PRINT_HEAD') + this%iprhed = 1 + write(this%iout,'(4x,a)') trim(adjustl(this%text))// & + ' HEADS WILL BE PRINTED TO LISTING FILE.' + found = .true. + case('HEAD') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%iheadout = getunit() + call openfile(this%iheadout, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE') + write(this%iout,fmtmawbin) 'HEAD', fname, this%iheadout + found = .true. + else + call store_error('OPTIONAL STAGE KEYWORD MUST BE FOLLOWED BY FILEOUT') + end if + case('BUDGET') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ibudgetout = getunit() + call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE') + write(this%iout,fmtmawbin) 'BUDGET', fname, this%ibudgetout + found = .true. + else + call store_error('OPTIONAL BUDGET KEYWORD MUST BE FOLLOWED BY FILEOUT') + end if + case('FLOWING_WELLS') + this%iflowingwells = 1 + ! + ! -- Write option and return with found set to true + if(this%iflowingwells > 0) & + write(this%iout, fmtflowingwells) + found = .true. + case('SHUTDOWN_THETA') + this%theta = this%parser%GetDouble() + write(this%iout, fmtshutdown) 'THETA', this%theta + found = .true. + case('SHUTDOWN_KAPPA') + this%kappa = this%parser%GetDouble() + write(this%iout, fmtshutdown) 'KAPPA', this%kappa + found = .true. + case('MOVER') + this%imover = 1 + write(this%iout, '(4x,A)') 'MOVER OPTION ENABLED' + found = .true. + case('NO_WELL_STORAGE') + this%imawissopt = 1 + write(this%iout, fmtnostoragewells) + found = .true. + ! + ! -- right now these 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_PEACEMAN_EFFECTIVE_RADIUS') + call this%parser%DevOpt() + this%ieffradopt = 1 + write(this%iout, '(4x,a)') & + & 'EFFECTIVE RADIUS FOR STRUCTURED GRIDS WILL BE CALCULATED ' // & + & 'USING PEACEMAN 1983' + found = .true. + case default + ! + ! -- No options found + found = .false. + end select + ! + ! -- return + return + end subroutine maw_options + + subroutine maw_ar(this) + ! ****************************************************************************** + ! maw_ar -- Allocate and Read + ! Subroutine: (1) create new-style package + ! (2) point bndobj to the new package + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + ! -- dummy + class(MawType),intent(inout) :: this + ! -- local + ! -- format + ! ------------------------------------------------------------------------------ + ! + call this%obs%obs_ar() + ! + ! -- set omega value used for saturation calculations + if (this%inewton > 0) then + this%satomega = DEM6 + end if + ! + ! -- Allocate arrays in MAW and in package superclass + call this%maw_allocate_arrays() + ! + ! -- read optional initial package parameters + call this%read_initial_attr() + ! + ! -- setup pakmvrobj + if (this%imover /= 0) then + allocate(this%pakmvrobj) + call this%pakmvrobj%ar(this%nmawwells, this%nmawwells, this%origin) + endif + ! + ! -- return + return + end subroutine maw_ar + + + subroutine maw_rp(this) +! ****************************************************************************** +! maw_rp -- Read and Prepare +! Subroutine: (1) read itmp +! (2) read new boundaries if itmp>0 +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use TdisModule, only: kper, nper + ! -- dummy + class(MawType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: line + character(len=LINELENGTH) :: text + character(len=LINELENGTH) :: errmsg + character (len=16) :: csteady + integer(I4B) :: ierr + integer(I4B) :: node, n + logical :: isfound, endOfBlock + integer(I4B) :: ntabcols + integer(I4B) :: ntabrows + integer(I4B) :: imaw + integer(I4B) :: ibnd + integer(I4B) :: j + !integer(I4B) :: isfirst + ! -- formats + character(len=*),parameter :: fmtblkerr = & + "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + character(len=*),parameter :: fmtlsp = & + "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" +! ------------------------------------------------------------------------------ + ! + ! -- set steady-state flag based on gwfiss + this%imawiss = this%gwfiss + ! -- reset maw steady flag if 'STEADY-STATE' specified in the OPTIONS block + if (this%imawissopt == 1) then + this%imawiss = 1 + end if + ! + ! -- set nbound to maxbound + this%nbound = this%maxbound + ! + ! -- Set ionper to the stress period number for which a new block of data + ! will be read. + if(this%inunit == 0) return + ! + ! -- get stress period data + if (this%ionper < kper) then + ! + ! -- get period block + call this%parser%GetBlock('PERIOD', isfound, ierr, & + supportOpenClose=.true.) + if(isfound) then + ! + ! -- read ionper and check for increasing period numbers + call this%read_check_ionper() + else + ! + ! -- PERIOD block not found + if (ierr < 0) then + ! -- End of file found; data applies for remainder of simulation. + this%ionper = nper + 1 + else + ! -- Found invalid block + write(errmsg, fmtblkerr) adjustl(trim(line)) + call store_error(errmsg) + call ustop() + end if + endif + end if + ! + ! -- Read data if ionper == kper + if(this%ionper == kper) then + ! + ! -- setup table for period data + if (this%iprpak /= 0) then + ! + ! -- reset the input table object + title = trim(adjustl(this%text)) // ' PACKAGE (' // & + trim(adjustl(this%name)) //') DATA FOR PERIOD' + write(title, '(a,1x,i6)') trim(adjustl(title)), kper + call table_cr(this%inputtab, this%name, title) + call this%inputtab%table_df(1, 5, this%iout, finalize=.FALSE.) + text = 'NUMBER' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'KEYWORD' + call this%inputtab%initialize_column(text, 20, alignment=TABLEFT) + do n = 1, 3 + write(text, '(a,1x,i6)') 'VALUE', n + call this%inputtab%initialize_column(text, 15, alignment=TABCENTER) + end do + end if + ! + ! -- set flag to check attributes + this%check_attr = 1 + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + + imaw = this%parser%GetInteger() + if (imaw < 1 .or. imaw > this%nmawwells) then + write(errmsg,'(4x,a,1x,i6)') & + '****ERROR. IMAW MUST BE > 0 and <= ', this%nmawwells + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end if + + call this%parser%GetRemainingLine(line) + call this%maw_set_stressperiod(imaw, line) + ! + ! -- write line to table + if (this%iprpak /= 0) then + call this%inputtab%add_term(imaw) + call this%inputtab%line_to_columns(line) + end if + end do + if (this%iprpak /= 0) then + call this%inputtab%finalize_table() + write(this%iout,'(/1x,a,1x,i6,/)') & + 'END OF '//trim(adjustl(this%text))//' DATA FOR PERIOD', kper + end if + ! + else + write(this%iout,fmtlsp) trim(this%filtyp) + endif + ! + !write summary of maw well stress period error messages + ierr = count_errors() + if (ierr > 0) then + call ustop() + end if + ! + ! -- qa data if necessary + if (this%check_attr /= 0) then + call this%maw_check_attributes() + + ! -- write summary of stress period data for MAW + if (this%iprpak == 1) then + if (this%imawiss /= 0) then + csteady = 'STEADY-STATE ' + else + csteady = 'TRANSIENT ' + end if + ! + ! -- reset the input table object for rate data + title = trim(adjustl(this%text)) // ' PACKAGE (' // & + trim(adjustl(this%name)) //') ' // trim(adjustl(csteady)) // & + ' RATE DATA FOR PERIOD' + write(title, '(a,1x,i6)') trim(adjustl(title)), kper + ntabcols = 6 + call table_cr(this%inputtab, this%name, title) + call this%inputtab%table_df(this%nmawwells, ntabcols, this%iout) + text = 'NUMBER' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'STATUS' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'RATE' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'SPECIFIED HEAD' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'PUMP ELEVATION' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'REDUCTION LENGTH' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + do n = 1, this%nmawwells + call this%inputtab%add_term(n) + call this%inputtab%add_term(this%mawwells(n)%status) + call this%inputtab%add_term(this%mawwells(n)%rate%value) + if (this%iboundpak(n) < 0) then + call this%inputtab%add_term(this%mawwells(n)%head%value) + else + call this%inputtab%add_term(' ') + end if + call this%inputtab%add_term(this%mawwells(n)%pumpelev) + if (this%mawwells(n)%reduction_length /= DEP20) then + call this%inputtab%add_term(this%mawwells(n)%reduction_length) + else + call this%inputtab%add_term(' ') + end if + end do + ! + ! -- flowing wells + if (this%iflowingwells /= 0) then + ! + ! -- reset the input table object for flowing well data + title = trim(adjustl(this%text)) // ' PACKAGE (' // & + trim(adjustl(this%name)) //') ' // trim(adjustl(csteady)) // & + ' FLOWING WELL DATA FOR PERIOD' + write(title, '(a,1x,i6)') trim(adjustl(title)), kper + ntabcols = 4 + ntabrows = 0 + do n = 1, this%nmawwells + if (this%mawwells(n)%fwcond > DZERO) then + ntabrows = ntabrows + 1 + end if + end do + if (ntabrows > 0) then + call table_cr(this%inputtab, this%name, title) + call this%inputtab%table_df(ntabrows, ntabcols, this%iout) + text = 'NUMBER' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'ELEVATION' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'CONDUCT.' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'REDUCTION LENGTH' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + do n = 1, this%nmawwells + if (this%mawwells(n)%fwcond > DZERO) then + call this%inputtab%add_term(n) + call this%inputtab%add_term(this%mawwells(n)%fwelev) + call this%inputtab%add_term(this%mawwells(n)%fwcond) + call this%inputtab%add_term(this%mawwells(n)%fwrlen) + end if + end do + end if + end if + ! + ! -- reset the input table object for shutoff data + title = trim(adjustl(this%text)) // ' PACKAGE (' // & + trim(adjustl(this%name)) //') '// trim(adjustl(csteady)) // & + ' WELL SHUTOFF DATA FOR PERIOD' + write(title, '(a,1x,i6)') trim(adjustl(title)), kper + ntabcols = 4 + ntabrows = 0 + do n = 1, this%nmawwells + if (this%mawwells(n)%shutofflevel /= DEP20) then + ntabrows = ntabrows + 1 + end if + end do + if (ntabrows > 0) then + call table_cr(this%inputtab, this%name, title) + call this%inputtab%table_df(ntabrows, ntabcols, this%iout) + text = 'NUMBER' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'ELEVATION' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'MINIMUM. Q' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'MAXIMUM Q' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + do n = 1, this%nmawwells + if (this%mawwells(n)%shutofflevel /= DEP20) then + call this%inputtab%add_term(n) + call this%inputtab%add_term(this%mawwells(n)%shutofflevel) + call this%inputtab%add_term(this%mawwells(n)%shutoffmin) + call this%inputtab%add_term(this%mawwells(n)%shutoffmax) + end if + end do + end if + end if + end if + ! + ! -- fill arrays + ibnd = 1 + do n = 1, this%nmawwells + do j = 1, this%mawwells(n)%ngwfnodes + node = this%mawwells(n)%gwfnodes(j) + this%nodelist(ibnd) = node + + this%bound(1,ibnd) = this%xnewpak(n) + + this%bound(2,ibnd) = this%mawwells(n)%satcond(j) + + this%bound(3,ibnd) = this%mawwells(n)%botscrn(j) + + if (this%iboundpak(n) > 0) then + this%bound(4,ibnd) = this%mawwells(n)%rate%value + else + this%bound(4,ibnd) = DZERO + end if + ibnd = ibnd + 1 + end do + end do + ! + ! -- return + return + end subroutine maw_rp + + subroutine maw_ad(this) +! ****************************************************************************** +! maw_ad -- Add package connection to matrix +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use TdisModule, only : kper, kstp + ! -- dummy + class(MawType) :: this + ! -- local + integer(I4B) :: n + integer(I4B) :: j, iaux, ibnd +! ------------------------------------------------------------------------------ + ! + ! -- Advance the time series + call this%TsManager%ad() + ! + ! -- update auxiliary variables by copying from the derived-type time + ! series variable into the bndpackage auxvar variable so that this + ! information is properly written to the GWF budget file + if (this%naux > 0) then + ibnd = 1 + do n = 1, this%nmawwells + do j = 1, this%mawwells(n)%ngwfnodes + do iaux = 1, this%naux + this%auxvar(iaux, ibnd) = this%mawwells(n)%auxvar(iaux)%value + end do + ibnd = ibnd + 1 + end do + end do + end if + ! + ! -- copy xnew into xold + do n = 1, this%nmawwells + this%xoldpak(n) = this%xnewpak(n) + this%mawwells(n)%xoldsto = this%mawwells(n)%xsto + if (this%iboundpak(n) < 0) then + this%xnewpak(n) = this%mawwells(n)%head%value + end if + end do + ! + !--use the appropriate xoldsto if intial heads are above the + ! specified flowing well discharge elevation + if (kper==1 .and. kstp==1) then + do n = 1, this%nmawwells + if (this%mawwells(n)%fwcond > DZERO) then + if (this%mawwells(n)%xoldsto > this%mawwells(n)%fwelev) then + this%mawwells(n)%xoldsto = this%mawwells(n)%fwelev + end if + end if + end do + end if + ! + ! -- reset ishutoffcnt (equivalent to kiter) to zero + this%ishutoffcnt = 0 + ! + ! -- pakmvrobj ad + if(this%imover == 1) then + call this%pakmvrobj%ad() + endif + ! + ! -- For each observation, push simulated value and corresponding + ! simulation time from "current" to "preceding" and reset + ! "current" value. + call this%obs%obs_ad() + ! + ! -- return + return + end subroutine maw_ad + + subroutine maw_cf(this, reset_mover) + ! ****************************************************************************** + ! maw_cf -- Formulate the HCOF and RHS terms + ! Subroutine: (1) skip if no multi-aquifer wells + ! (2) calculate hcof and rhs + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + ! -- dummy + class(MawType) :: this + logical, intent(in), optional :: reset_mover + ! -- local + logical :: lrm + ! ------------------------------------------------------------------------------ + ! + ! -- Calculate maw conductance and update package RHS and HCOF + call this%maw_cfupdate() + ! + ! -- pakmvrobj cf + lrm = .true. + if (present(reset_mover)) lrm = reset_mover + if(this%imover == 1 .and. lrm) then + call this%pakmvrobj%cf() + endif + ! + ! -- Return + return + end subroutine maw_cf + + subroutine maw_fc(this, rhs, ia, idxglo, amatsln) +! ****************************************************************************** +! maw_fc -- Copy rhs and hcof into solution rhs and amat +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule,only: delt + ! -- dummy + class(MawType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + real(DP), dimension(:), intent(inout) :: amatsln + ! -- local + integer(I4B) :: j, n + integer(I4B) :: idx + integer(I4B) :: iloc, isymloc + integer(I4B) :: igwfnode + integer(I4B) :: iposd, iposoffd + integer(I4B) :: isymnode + integer(I4B) :: ipossymd, ipossymoffd + real(DP) :: hmaw + real(DP) :: bmaw + real(DP) :: bnode + real(DP) :: sat + real(DP) :: cfw + real(DP) :: cmaw + real(DP) :: cterm + real(DP) :: scale + real(DP) :: tp + real(DP) :: bt + real(DP) :: rate + real(DP) :: ratefw +! -------------------------------------------------------------------------- + ! + ! -- pakmvrobj fc + if(this%imover == 1) then + call this%pakmvrobj%fc() + endif + ! + ! -- Copy package rhs and hcof into solution rhs and amat + idx = 1 + do n = 1, this%nmawwells + iloc = this%idxlocnode(n) + ! -- update head value for constant head maw wells + if (this%iboundpak(n) < 0) then + this%xnewpak(n) = this%mawwells(n)%head%value + end if + hmaw = this%xnewpak(n) + ! -- add pumping rate to active or constant maw well + if (this%iboundpak(n) == 0) then + this%mawwells(n)%ratesim = DZERO + else + call this%maw_calculate_wellq(n, hmaw, rate) + this%mawwells(n)%ratesim = rate + !write (1999,'(i5,5(g15.7))') this%ishutoffcnt, hmaw, rate, this%mawwells(n)%shutoffqold, & + ! this%mawwells(n)%shutoffdq, this%mawwells(n)%shutoffweight + rhs(iloc) = rhs(iloc) - rate + ! -- location of diagonal for maw row + iposd = this%idxdglo(idx) + ! -- add flowing well + this%mawwells(n)%xsto = hmaw + ratefw = DZERO + if (this%iflowingwells > 0) then + if (this%mawwells(n)%fwcond > DZERO) then + bt = this%mawwells(n)%fwelev + tp = bt + this%mawwells(n)%fwrlen + scale = sQSaturation(tp, bt, hmaw) + cfw = scale * this%mawwells(n)%fwcond + this%mawwells(n)%ifwdischarge = 0 + if (cfw > DZERO) then + this%mawwells(n)%ifwdischarge = 1 + this%mawwells(n)%xsto = bt + end if + this%mawwells(n)%fwcondsim = cfw + amatsln(iposd) = amatsln(iposd) - cfw + rhs(iloc) = rhs(iloc) - cfw * bt + ratefw = cfw * (bt - hmaw) + end if + end if + ! -- add maw storage changes + if (this%imawiss /= 1) then + if (this%mawwells(n)%ifwdischarge /= 1) then + amatsln(iposd) = amatsln(iposd) - (this%mawwells(n)%area / delt) + rhs(iloc) = rhs(iloc) - (this%mawwells(n)%area * this%mawwells(n)%xoldsto / delt) + else + cterm = this%mawwells(n)%xoldsto - this%mawwells(n)%fwelev + rhs(iloc) = rhs(iloc) - (this%mawwells(n)%area * cterm / delt) + end if + end if + ! + ! -- If mover is active, add receiver water to rhs and + ! store available water (as positive value) + if(this%imover == 1) then + rhs(iloc) = rhs(iloc) - this%pakmvrobj%get_qfrommvr(n) + call this%pakmvrobj%accumulate_qformvr(n, -rate) !pumped water + call this%pakmvrobj%accumulate_qformvr(n, -ratefw) !flowing water + endif + ! + endif + do j = 1, this%mawwells(n)%ngwfnodes + if (this%iboundpak(n) /= 0) then + igwfnode = this%mawwells(n)%gwfnodes(j) + call this%maw_calculate_saturation(n, j, igwfnode, sat) + cmaw = this%mawwells(n)%satcond(j) * sat + this%mawwells(n)%simcond(j) = cmaw + + bnode = this%dis%bot(igwfnode) + bmaw = this%mawwells(n)%botscrn(j) + ! -- calculate cterm - relative to gwf + cterm = DZERO + if (hmaw < bmaw) then + cterm = cmaw * (bmaw - hmaw) + end if + ! -- add to maw row + iposd = this%idxdglo(idx) + iposoffd = this%idxoffdglo(idx) + amatsln(iposd) = amatsln(iposd) - cmaw + amatsln(iposoffd) = cmaw + ! -- add correction term + rhs(iloc) = rhs(iloc) + cterm + ! -- add to gwf row for maw connection + isymnode = this%mawwells(n)%gwfnodes(j) + isymloc = ia(isymnode) + ipossymd = this%idxsymdglo(idx) + ipossymoffd = this%idxsymoffdglo(idx) + amatsln(ipossymd) = amatsln(ipossymd) - cmaw + amatsln(ipossymoffd) = cmaw + ! -- add correction term + rhs(isymnode) = rhs(isymnode) - cterm + endif + ! -- increment maw connection counter + idx = idx + 1 + end do + end do + ! + ! -- return + return + end subroutine maw_fc + + subroutine maw_fn(this, rhs, ia, idxglo, amatsln) +! ************************************************************************** +! maw_fn -- Fill newton terms +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + use TdisModule,only:delt + ! -- dummy + class(MawType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + real(DP), dimension(:), intent(inout) :: amatsln + ! -- local + integer(I4B) :: j, n + integer(I4B) :: idx + integer(I4B) :: iloc, isymloc + integer(I4B) :: igwfnode + integer(I4B) :: iposd, iposoffd + integer(I4B) :: isymnode + integer(I4B) :: ipossymd, ipossymoffd + real(DP) :: hmaw + real(DP) :: tmaw + real(DP) :: bmaw + real(DP) :: sat + real(DP) :: cmaw + real(DP) :: scale + real(DP) :: tp + real(DP) :: bt + real(DP) :: cfw + real(DP) :: rate + real(DP) :: rate2 + real(DP) :: rterm + real(DP) :: derv + real(DP) :: drterm + real(DP) :: hgwf + real(DP) :: hups + real(DP) :: term +! -------------------------------------------------------------------------- + ! + ! -- Copy package rhs and hcof into solution rhs and amat + idx = 1 + do n = 1, this%nmawwells + iloc = this%idxlocnode(n) + hmaw = this%xnewpak(n) + ! -- add pumping rate to active or constant maw well + if (this%iboundpak(n) /= 0) then + iposd = this%idxdglo(idx) + scale = DONE + drterm = DZERO + rate = this%mawwells(n)%ratesim + !--calculate final derivative for pumping rate + call this%maw_calculate_wellq(n, hmaw+DEM4, rate2) + drterm = (rate2 - rate) / DEM4 + !--fill amat and rhs with newton-raphson terms + amatsln(iposd) = amatsln(iposd) + drterm + rhs(iloc) = rhs(iloc) + drterm * hmaw + ! -- add flowing well + if (this%iflowingwells > 0) then + if (this%mawwells(n)%fwcond > DZERO) then + bt = this%mawwells(n)%fwelev + tp = bt + this%mawwells(n)%fwrlen + scale = sQSaturation(tp, bt, hmaw) + cfw = scale * this%mawwells(n)%fwcond + this%mawwells(n)%ifwdischarge = 0 + if (cfw > DZERO) this%mawwells(n)%ifwdischarge = 1 + this%mawwells(n)%fwcondsim = cfw + rate = cfw * (bt - hmaw) + rterm = -cfw * hmaw + !--calculate derivative for flowing well + if (hmaw < tp) then + derv = sQSaturationDerivative(tp, bt, hmaw) + drterm = -(cfw + this%mawwells(n)%fwcond * derv * (hmaw - bt)) + !--fill amat and rhs with newton-raphson terms + amatsln(iposd) = amatsln(iposd) - & + this%mawwells(n)%fwcond * derv * (hmaw - bt) + rhs(iloc) = rhs(iloc) - rterm + drterm * hmaw + end if + end if + end if + ! -- add maw storage changes + if (this%imawiss /= 1) then + if (this%mawwells(n)%ifwdischarge /= 1) then + rate = this%mawwells(n)%area * hmaw / delt + rterm = -rate + !--calculate storage derivative + drterm = -this%mawwells(n)%area / delt + !--fill amat and rhs with storage components + rhs(iloc) = rhs(iloc) - rterm + drterm * hmaw + end if + end if + end if + do j = 1, this%mawwells(n)%ngwfnodes + if (this%iboundpak(n) /= 0) then + igwfnode = this%mawwells(n)%gwfnodes(j) + hgwf = this%xnew(igwfnode) + ! -- calculate upstream weighted conductance + call this%maw_calculate_saturation(n, j, igwfnode, sat) + cmaw = this%mawwells(n)%satcond(j) * sat + this%mawwells(n)%simcond(j) = cmaw + ! -- set top and bottom of the screen + tmaw = this%mawwells(n)%topscrn(j) + bmaw = this%mawwells(n)%botscrn(j) + ! -- add to maw row + iposd = this%idxdglo(idx) + iposoffd = this%idxoffdglo(idx) + ! -- add to gwf row for maw connection + isymnode = this%mawwells(n)%gwfnodes(j) + isymloc = ia(isymnode) + ipossymd = this%idxsymdglo(idx) + ipossymoffd = this%idxsymoffdglo(idx) + ! -- calculate newton corrections + hups = hmaw + if (hgwf > hups) hups = hgwf + drterm = sQuadraticSaturationDerivative(tmaw, bmaw, hups, this%satomega) + ! -- maw is upstream + if (hmaw > hgwf) then + term = drterm * this%mawwells(n)%satcond(j) * (hmaw - hgwf) + rhs(iloc) = rhs(iloc) + term * hmaw + rhs(isymnode) = rhs(isymnode) - term * hmaw + amatsln(iposd) = amatsln(iposd) + term + if (this%ibound(igwfnode) > 0) then + amatsln(ipossymoffd) = amatsln(ipossymoffd) - term + end if + ! -- gwf is upstream + else + term = -drterm * this%mawwells(n)%satcond(j) * (hgwf - hmaw) + rhs(iloc) = rhs(iloc) + term * hgwf + rhs(isymnode) = rhs(isymnode) - term * hgwf + if (this%iboundpak(n) > 0) then + amatsln(iposoffd) = amatsln(iposoffd) + term + end if + amatsln(ipossymd) = amatsln(ipossymd) - term + end if + endif + ! + ! -- increment maw connection counter + idx = idx + 1 + end do + end do + ! + ! -- return + return + end subroutine maw_fn + + + subroutine maw_nur(this, neqpak, x, xtemp, dx, inewtonur, dxmax, locmax) +! ****************************************************************************** +! maw_nur -- under-relaxation +! Subroutine: (1) Under-relaxation of Groundwater Flow Model MAW Package Heads +! for current outer iteration using the well bottom +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(MawType), intent(inout) :: this + integer(I4B), intent(in) :: neqpak + real(DP), dimension(neqpak), intent(inout) :: x + real(DP), dimension(neqpak), intent(in) :: xtemp + real(DP), dimension(neqpak), intent(inout) :: dx + integer(I4B), intent(inout) :: inewtonur + real(DP), intent(inout) :: dxmax + integer(I4B), intent(inout) :: locmax + ! -- local + integer(I4B) :: n + real(DP) :: botw + real(DP) :: xx + real(DP) :: dxx +! ------------------------------------------------------------------------------ + + ! + ! -- Newton-Raphson under-relaxation + do n = 1, this%nmawwells + if (this%iboundpak(n) < 1) cycle + botw = this%mawwells(n)%bot + ! -- only apply Newton-Raphson under-relaxation if + ! solution head is below the bottom of the well + if (x(n) < botw) then + inewtonur = 1 + xx = xtemp(n)*(DONE-DP9) + botw*DP9 + dxx = x(n) - xx + if (abs(dxx) > abs(dxmax)) then + locmax = n + dxmax = dxx + end if + x(n) = xx + dx(n) = DZERO + end if + end do + ! + ! -- return + return + end subroutine maw_nur + + + subroutine maw_bd(this, x, idvfl, icbcfl, ibudfl, icbcun, iprobs, & + isuppress_output, model_budget, imap, iadv) +! ****************************************************************************** +! bnd_bd -- Calculate Volumetric Budget +! Note that the compact budget will always be used. +! Subroutine: (1) Process each package entry +! (2) Write output +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: kstp, kper, delt, pertim, totim + use ConstantsModule, only: LENBOUNDNAME + use InputOutputModule, only: ulasav, ubdsv06 + use BudgetModule, only: BudgetType + ! -- dummy + class(MawType) :: this + real(DP),dimension(:),intent(in) :: x + integer(I4B), intent(in) :: idvfl + integer(I4B), intent(in) :: icbcfl + integer(I4B), intent(in) :: ibudfl + integer(I4B), intent(in) :: icbcun + integer(I4B), intent(in) :: iprobs + integer(I4B), intent(in) :: isuppress_output + type(BudgetType), intent(inout) :: model_budget + integer(I4B), dimension(:), optional, intent(in) :: imap + integer(I4B), optional, intent(in) :: iadv + ! -- local + integer(I4B) :: ibinun + real(DP) :: rrate + ! -- for budget + integer(I4B) :: j, n + integer(I4B) :: igwfnode + integer(I4B) :: ibnd + real(DP) :: hmaw, hgwf + real(DP) :: cfw + real(DP) :: bmaw, cmaw + real(DP) :: cterm + real(DP) :: v + real(DP) :: d + ! -- for observations + integer(I4B) :: iprobslocal + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- recalculate package HCOF and RHS terms with latest groundwater and + ! maw heads prior to calling base budget functionality + call this%maw_cfupdate() + ! + ! -- Suppress saving of simulated values; they + ! will be saved at end of this procedure. + iprobslocal = 0 + ! + ! -- call base functionality in bnd_bd + call this%BndType%bnd_bd(x, idvfl, icbcfl, ibudfl, icbcun, iprobslocal, & + isuppress_output, model_budget, this%imap, & + iadv=1) + ! + ! -- calculate maw budget flow and storage terms + do n = 1, this%nmawwells + this%qout(n) = DZERO + this%qsto(n) = DZERO + if (this%iflowingwells > 0) this%qfw(n) = DZERO + if (this%iboundpak(n) == 0) cycle + ! + ! -- set hmaw and xsto + hmaw = this%xnewpak(n) + this%mawwells(n)%xsto = hmaw + ! + ! -- add pumping rate to active maw well + rrate = this%mawwells(n)%ratesim + ! + ! -- If flow is out of maw set qout to rrate. + if (rrate < DZERO) then + this%qout(n) = rrate + end if + ! + ! -- add flowing well + if (this%iflowingwells > 0) then + if (this%mawwells(n)%fwcond > DZERO) then + cfw = this%mawwells(n)%fwcondsim + this%mawwells(n)%xsto = this%mawwells(n)%fwelev + rrate = cfw * (this%mawwells(n)%fwelev - hmaw) + this%qfw(n) = rrate + ! + ! -- Subtract flowing well rrate from qout. + this%qout(n) = this%qout(n) + rrate + end if + end if + ! + ! -- Calculate qsto + if (this%imawiss /= 1) then + rrate = -this%mawwells(n)%area * (this%mawwells(n)%xsto - this%mawwells(n)%xoldsto) / delt + this%qsto(n) = rrate + end if + end do + ! + ! -- gwf and constant flow + ibnd = 1 + do n = 1, this%nmawwells + rrate = DZERO + hmaw = this%xnewpak(n) + this%qconst(n) = DZERO + do j = 1, this%mawwells(n)%ngwfnodes + this%qleak(ibnd) = DZERO + if (this%iboundpak(n) == 0) cycle + igwfnode = this%mawwells(n)%gwfnodes(j) + hgwf = this%xnew(igwfnode) + cmaw = this%mawwells(n)%simcond(j) + + bmaw = this%mawwells(n)%botscrn(j) + ! -- calculate cterm - relative to gwf + cterm = DZERO + if (hmaw < bmaw) then + cterm = cmaw * (bmaw - hmaw) + end if + rrate = -(cmaw * (hmaw - hgwf) + cterm) + this%qleak(ibnd) = rrate + if (this%iboundpak(n) < 0) then + this%qconst(n) = this%qconst(n) - rrate + ! + ! -- If flow is out increment qout by -rrate. + if (-rrate < DZERO) then + this%qout(n) = this%qout(n) - rrate + end if + end if + ibnd = ibnd + 1 + end do + !! + !! -- Update . + !if (this%qconst(n) < DZERO) then + ! this%qout(n) = this%qout(n) + this%qconst(n) + !end if + ! + ! -- add additional flow terms to constant head term + if (this%iboundpak(n) < 0) then + ! + ! -- add well pumping rate + this%qconst(n) = this%qconst(n) - this%mawwells(n)%ratesim + ! + ! -- add flowing well rate + if (this%iflowingwells > 0) then + this%qconst(n) = this%qconst(n) - this%qfw(n) + end if + ! + ! -- add storage term + if (this%imawiss /= 1) then + this%qconst(n) = this%qconst(n) - this%qsto(n) + end if + end if + end do + ! + ! -- For continuous observations, save simulated values. + if (this%obs%npakobs > 0 .and. iprobs > 0) then + call this%maw_bd_obs() + endif + ! + ! -- set unit number for binary dependent variable output + ibinun = 0 + if(this%iheadout /= 0) then + ibinun = this%iheadout + end if + if(idvfl == 0) ibinun = 0 + if (isuppress_output /= 0) ibinun = 0 + ! + ! -- write maw binary output + if (ibinun > 0) then + do n = 1, this%nmawwells + v = this%xnewpak(n) + d = v - this%mawwells(n)%bot + if (this%iboundpak(n) == 0) then + v = DHNOFLO + else if (d <= DZERO) then + v = DHDRY + end if + this%dbuff(n) = v + end do + call ulasav(this%dbuff, ' HEAD', & + kstp, kper, pertim, totim, & + this%nmawwells, 1, 1, ibinun) + end if + ! + ! -- fill the budget object + call this%maw_fill_budobj() + ! + ! -- write the flows from the budobj + ibinun = 0 + if(this%ibudgetout /= 0) then + ibinun = this%ibudgetout + end if + if(icbcfl == 0) ibinun = 0 + if (isuppress_output /= 0) ibinun = 0 + if (ibinun > 0) then + call this%budobj%save_flows(this%dis, ibinun, kstp, kper, delt, & + pertim, totim, this%iout) + end if + ! + ! -- return + return + end subroutine maw_bd + + + subroutine maw_ot(this, kstp, kper, iout, ihedfl, ibudfl) + ! ************************************************************************** + ! maw_ot -- Output package budget + ! ************************************************************************** + ! + ! SPECIFICATIONS: + ! -------------------------------------------------------------------------- + ! + ! -- dummy + class(MawType) :: this + integer(I4B),intent(in) :: kstp + integer(I4B),intent(in) :: kper + integer(I4B),intent(in) :: iout + integer(I4B),intent(in) :: ihedfl + integer(I4B),intent(in) :: ibudfl + ! -- locals + integer(I4B) :: n + ! format + ! -------------------------------------------------------------------------- + ! + ! -- write maw head table + if (ihedfl /= 0 .and. this%iprhed /= 0) then + ! + ! -- fill stage data + do n = 1, this%nmawwells + if(this%inamedbound==1) then + call this%headtab%add_term(this%cmawname(n)) + end if + call this%headtab%add_term(n) + call this%headtab%add_term(this%xnewpak(n)) + end do + end if + ! + ! -- Output maw flow table + if (ibudfl /= 0 .and. this%iprflow /= 0) then + call this%budobj%write_flowtable(this%dis) + end if + ! + ! -- Output maw budget + call this%budobj%write_budtable(kstp, kper, iout) + ! + ! -- return + return + end subroutine maw_ot + + subroutine maw_da(this) +! ****************************************************************************** +! maw_da -- deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(MawType) :: this + ! -- local + integer(I4B) :: n +! ------------------------------------------------------------------------------ + ! + ! -- mawwells derived type array + do n = 1, this%nmawwells + call this%maw_deallocate_well(n) + enddo + deallocate(this%mawwells) + ! + ! -- budobj + call this%budobj%budgetobject_da() + deallocate(this%budobj) + nullify(this%budobj) + ! + ! -- head table + if (this%iprhed > 0) then + call this%headtab%table_da() + deallocate(this%headtab) + nullify(this%headtab) + end if + ! + ! -- arrays + deallocate(this%cmawname) + deallocate(this%cmawbudget) + call mem_deallocate(this%idxmawconn) + call mem_deallocate(this%imap) + call mem_deallocate(this%dbuff) + deallocate(this%cauxcbc) + call mem_deallocate(this%qauxcbc) + call mem_deallocate(this%qleak) + call mem_deallocate(this%qfw) + call mem_deallocate(this%qout) + call mem_deallocate(this%qsto) + call mem_deallocate(this%qconst) + deallocate(this%idxlocnode) + deallocate(this%idxdglo) + deallocate(this%idxoffdglo) + deallocate(this%idxsymdglo) + deallocate(this%idxsymoffdglo) + deallocate(this%xoldpak) + deallocate(this%cterm) + ! + ! -- scalars + call mem_deallocate(this%iprhed) + call mem_deallocate(this%iheadout) + call mem_deallocate(this%ibudgetout) + call mem_deallocate(this%iflowingwells) + call mem_deallocate(this%imawiss) + call mem_deallocate(this%imawissopt) + call mem_deallocate(this%nmawwells) + call mem_deallocate(this%check_attr) + call mem_deallocate(this%ishutoffcnt) + call mem_deallocate(this%ieffradopt) + call mem_deallocate(this%satomega) + call mem_deallocate(this%bditems) + call mem_deallocate(this%theta) + call mem_deallocate(this%kappa) + call mem_deallocate(this%cbcauxitems) + ! + ! -- pointers to gwf variables + nullify(this%gwfiss) + ! + ! -- call standard BndType deallocate + call this%BndType%bnd_da() + ! + ! -- return + return + end subroutine maw_da + + subroutine define_listlabel(this) +! ****************************************************************************** +! define_listlabel -- Define the list heading that is written to iout when +! PRINT_INPUT option is used. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(MawType), intent(inout) :: this +! ------------------------------------------------------------------------------ + ! + ! -- create the header list label + this%listlabel = trim(this%filtyp) // ' NO.' + if(this%dis%ndim == 3) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif(this%dis%ndim == 2) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + else + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + endif + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' + if(this%inamedbound == 1) then + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + endif + ! + ! -- return + return + end subroutine define_listlabel + + + subroutine maw_set_pointers(this, neq, ibound, xnew, xold, flowja) +! ****************************************************************************** +! set_pointers -- Set pointers to model arrays and variables so that a package +! has access to these things. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(MawType) :: this + integer(I4B), pointer :: neq + integer(I4B), dimension(:), pointer, contiguous :: ibound + real(DP), dimension(:), pointer, contiguous :: xnew + real(DP), dimension(:), pointer, contiguous :: xold + real(DP), dimension(:), pointer, contiguous :: flowja + ! -- local + integer(I4B) :: n + integer(I4B) :: istart, iend +! ------------------------------------------------------------------------------ + ! + ! -- call base BndType set_pointers + call this%BndType%set_pointers(neq, ibound, xnew, xold, flowja) + ! + ! -- Set the MAW pointers + ! + ! -- set package pointers + istart = this%dis%nodes + this%ioffset + 1 + iend = istart + this%nmawwells - 1 + this%iboundpak => this%ibound(istart:iend) + this%xnewpak => this%xnew(istart:iend) + allocate(this%xoldpak(this%nmawwells)) + allocate(this%cterm(this%maxbound)) + ! + ! -- initialize xnewpak + do n = 1, this%nmawwells + this%xnewpak(n) = DEP20 + end do + ! + ! -- return + end subroutine maw_set_pointers + + ! + ! -- Procedures related to observations (type-bound) + logical function maw_obs_supported(this) + ! ****************************************************************************** + ! maw_obs_supported + ! -- Return true because MAW package supports observations. + ! -- Overrides BndType%bnd_obs_supported() + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + class(MawType) :: this + ! ------------------------------------------------------------------------------ + maw_obs_supported = .true. + return + end function maw_obs_supported + + + subroutine maw_df_obs(this) + ! ****************************************************************************** + ! maw_df_obs (implements bnd_df_obs) + ! -- Store observation type supported by MAW package. + ! -- Overrides BndType%bnd_df_obs + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + ! -- dummy + class(MawType) :: this + ! -- local + integer(I4B) :: indx + ! ------------------------------------------------------------------------------ + ! + ! -- Store obs type and assign procedure pointer + ! for head observation type. + call this%obs%StoreObsType('head', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => maw_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for frommvr observation type. + call this%obs%StoreObsType('from-mvr', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => maw_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for conn-rate observation type. + call this%obs%StoreObsType('maw', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => maw_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for rate observation type. + call this%obs%StoreObsType('rate', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => maw_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for rate-to-mvr observation type. + call this%obs%StoreObsType('rate-to-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => maw_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for fw-rate observation type. + call this%obs%StoreObsType('fw-rate', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => maw_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for rate-to-mvr observation type. + call this%obs%StoreObsType('fw-to-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => maw_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for storage observation type. + call this%obs%StoreObsType('storage', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => maw_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for constant observation type. + call this%obs%StoreObsType('constant', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => maw_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for cond observation type. + call this%obs%StoreObsType('conductance', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => maw_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for fw-conductance observation type. + call this%obs%StoreObsType('fw-conductance', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => maw_process_obsID + ! + return + end subroutine maw_df_obs + + + subroutine maw_bd_obs(this) + ! ************************************************************************** + ! maw_bd_obs + ! -- Calculate observations this time step and call + ! ObsType%SaveOneSimval for each MawType observation. + ! ************************************************************************** + ! + ! SPECIFICATIONS: + ! -------------------------------------------------------------------------- + ! -- dummy + class(MawType), intent(inout) :: this + ! -- local + integer(I4B) :: i, igwfnode, j, jj, n, nn + real(DP) :: cmaw, hmaw, v + real(DP) :: qfact + character(len=200) :: errmsg + type(ObserveType), pointer :: obsrv => null() + !--------------------------------------------------------------------------- + ! + ! Calculate, save, and write simulated values for all MAW observations + if (this%obs%npakobs > 0) then + call this%obs%obs_bd_clear() + do i = 1, this%obs%npakobs + obsrv => this%obs%pakobs(i)%obsrv + nn = size(obsrv%indxbnds) + do j = 1, nn + v = DNODATA + jj = obsrv%indxbnds(j) + select case (obsrv%ObsTypeId) + case ('HEAD') + if (this%iboundpak(jj) /= 0) then + v = this%xnewpak(jj) + end if + case ('FROM-MVR') + if (this%iboundpak(jj) /= 0) then + if (this%imover == 1) then + v = this%pakmvrobj%get_qfrommvr(jj) + end if + end if + case ('MAW') + n = this%imap(jj) + if (this%iboundpak(n) /= 0) then + v = this%qleak(jj) + end if + case ('RATE') + if (this%iboundpak(jj) /= 0) then + v = this%mawwells(jj)%ratesim + if (v < DZERO .and. this%qout(jj) < DZERO) then + qfact = v / this%qout(jj) + if (this%imover == 1) then + v = v + this%pakmvrobj%get_qtomvr(jj) * qfact + end if + end if + end if + case ('RATE-TO-MVR') + if (this%iboundpak(jj) /= 0) then + if (this%imover == 1) then + v = this%mawwells(jj)%ratesim + qfact = DZERO + if (v < DZERO .and. this%qout(jj) < DZERO) then + qfact = v / this%qout(jj) + end if + v = this%pakmvrobj%get_qtomvr(jj) * qfact + if (v > DZERO) then + v = -v + end if + end if + end if + case ('FW-RATE') + if (this%iboundpak(jj) /= 0 .and. this%iflowingwells /= 0) then + hmaw = this%xnewpak(jj) + cmaw = this%mawwells(jj)%fwcondsim + v = cmaw * (this%mawwells(jj)%fwelev - hmaw) + if (v < DZERO .and. this%qout(jj) < DZERO) then + qfact = v / this%qout(jj) + if (this%imover == 1) then + v = v + this%pakmvrobj%get_qtomvr(jj) * qfact + end if + end if + end if + case ('FW-TO-MVR') + if (this%iboundpak(jj) /= 0 .and. this%iflowingwells /= 0) then + if (this%imover == 1) then + hmaw = this%xnewpak(jj) + cmaw = this%mawwells(jj)%fwcondsim + v = cmaw * (this%mawwells(jj)%fwelev - hmaw) + qfact = DZERO + if (v < DZERO .and. this%qout(jj) < DZERO) then + qfact = v / this%qout(jj) + end if + v = this%pakmvrobj%get_qtomvr(jj) * qfact + if (v > DZERO) then + v = -v + end if + end if + end if + case ('STORAGE') + if (this%iboundpak(jj) /= 0 .and. this%imawissopt /= 1) then + v = this%qsto(jj) + end if + case ('CONSTANT') + if (this%iboundpak(jj) /= 0) then + v = this%qconst(jj) + end if + case ('CONDUCTANCE') + n = this%imap(jj) + if (this%iboundpak(n) /= 0) then + nn = jj - this%idxmawconn(n) + 1 + igwfnode = this%mawwells(n)%gwfnodes(nn) + v = this%mawwells(n)%simcond(nn) + end if + case ('FW-CONDUCTANCE') + if (this%iboundpak(jj) /= 0) then + v = this%mawwells(jj)%fwcondsim + end if + case default + errmsg = 'Error: Unrecognized observation type: ' // & + trim(obsrv%ObsTypeId) + call store_error(errmsg) + call ustop() + end select + call this%obs%SaveOneSimval(obsrv, v) + end do + end do + end if + ! + ! -- return + return + end subroutine maw_bd_obs + + + subroutine maw_rp_obs(this) + ! -- dummy + class(MawType), intent(inout) :: this + ! -- local + integer(I4B) :: i, j, n, nn1, nn2 + integer(I4B) :: jj + character(len=200) :: ermsg + character(len=LENBOUNDNAME) :: bname + logical :: jfound + class(ObserveType), pointer :: obsrv => null() + ! -------------------------------------------------------------------------- + ! -- formats +10 format('Error: Boundary "',a,'" for observation "',a, & + '" is invalid in package "',a,'"') + ! + ! + do i = 1, this%obs%npakobs + obsrv => this%obs%pakobs(i)%obsrv + ! + ! -- indxbnds needs to be deallocated and reallocated (using + ! ExpandArray) each stress period because list of boundaries + ! can change each stress period. + if (allocated(obsrv%indxbnds)) then + deallocate(obsrv%indxbnds) + end if + ! + ! -- get node number 1 + nn1 = obsrv%NodeNumber + if (nn1 == NAMEDBOUNDFLAG) then + bname = obsrv%FeatureName + if (bname /= '') then + ! -- Observation maw is based on a boundary name. + ! Iterate through all multi-aquifer wells to identify and store + ! corresponding index in bound array. + jfound = .false. + if (obsrv%ObsTypeId=='MAW' .or. & + obsrv%ObsTypeId=='CONDUCTANCE') then + do j = 1, this%nmawwells + do jj = this%idxmawconn(j), this%idxmawconn(j+1) - 1 + if (this%boundname(jj) == bname) then + jfound = .true. + call ExpandArray(obsrv%indxbnds) + n = size(obsrv%indxbnds) + obsrv%indxbnds(n) = jj + end if + end do + end do + else + do j = 1, this%nmawwells + if (this%cmawname(j) == bname) then + jfound = .true. + call ExpandArray(obsrv%indxbnds) + n = size(obsrv%indxbnds) + obsrv%indxbnds(n) = j + end if + end do + end if + if (.not. jfound) then + write(ermsg,10)trim(bname), trim(obsrv%Name), trim(this%name) + call store_error(ermsg) + end if + end if + else + call ExpandArray(obsrv%indxbnds) + n = size(obsrv%indxbnds) + if (n == 1) then + if (obsrv%ObsTypeId=='MAW' .or. & + obsrv%ObsTypeId=='CONDUCTANCE') then + nn2 = obsrv%NodeNumber2 + j = this%idxmawconn(nn1) + nn2 - 1 + obsrv%indxbnds(1) = j + else + obsrv%indxbnds(1) = nn1 + end if + else + ermsg = 'Programming error in maw_rp_obs' + call store_error(ermsg) + endif + end if + ! + ! -- catch non-cumulative observation assigned to observation defined + ! by a boundname that is assigned to more than one element + if (obsrv%ObsTypeId == 'HEAD') then + n = size(obsrv%indxbnds) + if (n > 1) then + write (ermsg, '(4x,a,4(1x,a))') & + 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & + 'for observation', trim(adjustl(obsrv%Name)), & + ' must be assigned to a multi-aquifer well with a unique boundname.' + call store_error(ermsg) + end if + end if + ! + ! -- check that index values are valid + if (obsrv%ObsTypeId=='MAW' .or. & + obsrv%ObsTypeId=='CONDUCTANCE') then + do j = 1, size(obsrv%indxbnds) + nn1 = obsrv%indxbnds(j) + n = this%imap(nn1) + nn2 = nn1 - this%idxmawconn(n) + 1 + jj = this%idxmawconn(n+1) - this%idxmawconn(n) + if (nn1 < 1 .or. nn1 > this%maxbound) then + write (ermsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & + 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & + ' multi-aquifer well connection number must be > 0 and <=', & + jj, '(specified value is ', nn2, ')' + call store_error(ermsg) + end if + end do + else + do j = 1, size(obsrv%indxbnds) + nn1 = obsrv%indxbnds(j) + if (nn1 < 1 .or. nn1 > this%nmawwells) then + write (ermsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & + 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & + ' multi-aquifer well must be > 0 and <=', this%nmawwells, & + '(specified value is ', nn1, ')' + call store_error(ermsg) + end if + end do + end if + end do + ! + ! -- check if any error were encountered + if (count_errors() > 0) call ustop() + ! + ! -- return + return + end subroutine maw_rp_obs + + + ! + ! -- Procedures related to observations (NOT type-bound) + subroutine maw_process_obsID(obsrv, dis, inunitobs, iout) + ! -- This procedure is pointed to by ObsDataType%ProcesssIdPtr. It processes + ! the ID string of an observation definition for MAW package observations. + ! -- dummy + type(ObserveType), intent(inout) :: obsrv + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: inunitobs + integer(I4B), intent(in) :: iout + ! -- local + integer(I4B) :: nn1, nn2 + integer(I4B) :: icol, istart, istop + character(len=LINELENGTH) :: strng + character(len=LENBOUNDNAME) :: bndname + ! formats + ! + strng = obsrv%IDstring + ! -- Extract multi-aquifer well number from strng and store it. + ! If 1st item is not an integer(I4B), it should be a + ! maw name--deal with it. + icol = 1 + ! -- get multi-aquifer well number or boundary name + call extract_idnum_or_bndname(strng, icol, istart, istop, nn1, bndname) + if (nn1 == NAMEDBOUNDFLAG) then + obsrv%FeatureName = bndname + else + if (obsrv%ObsTypeId=='MAW' .or. & + obsrv%ObsTypeId=='CONDUCTANCE') then + call extract_idnum_or_bndname(strng, icol, istart, istop, nn2, bndname) + if (nn2 == NAMEDBOUNDFLAG) then + obsrv%FeatureName = bndname + ! -- reset nn1 + nn1 = nn2 + else + obsrv%NodeNumber2 = nn2 + end if + end if + end if + ! -- store multi-aquifer well number (NodeNumber) + obsrv%NodeNumber = nn1 + ! + ! -- return + return + end subroutine maw_process_obsID + + ! + ! -- private MAW methods + ! + subroutine maw_calculate_satcond(this, i, j, node) + ! -- dummy + class(MawType),intent(inout) :: this + integer(I4B), intent(in) :: i + integer(I4B), intent(in) :: j + integer(I4B), intent(in) :: node + ! -- local + character(len=LINELENGTH) :: errmsg + integer(I4B) :: iTcontrastErr + real(DP) :: c + real(DP) :: k11 + real(DP) :: k22 + real(DP) :: sqrtk11k22 + real(DP) :: hks + real(DP) :: area + real(DP) :: eradius + real(DP) :: topw + real(DP) :: botw + real(DP) :: tthkw + real(DP) :: tthka + real(DP) :: Tcontrast + real(DP) :: skin + real(DP) :: ravg + real(DP) :: slen + real(DP) :: pavg + real(DP) :: gwfsat + real(DP) :: gwftop + real(DP) :: gwfbot + real(DP) :: lc1 + real(DP) :: lc2 + real(DP) :: dx + real(DP) :: dy + real(DP) :: Txx + real(DP) :: Tyy + real(DP) :: T2pi + real(DP) :: yx4 + real(DP) :: xy4 + ! -- formats + ! ------------------------------------------------------------------------------ + ! + ! -- initialize conductance variables + iTcontrastErr = 0 + lc1 = DZERO + lc2 = DZERO + ! + ! -- set K11 and K22 + k11 = this%gwfk11(node) + if (this%gwfik22 == 0) then + k22 = this%gwfk11(node) + else + k22 = this%gwfk22(node) + endif + sqrtk11k22 = sqrt(k11 * k22) + ! + ! -- set gwftop, gwfbot, and gwfsat + gwftop = this%dis%top(node) + gwfbot = this%dis%bot(node) + tthka = gwftop - gwfbot + gwfsat = this%gwfsat(node) + ! + ! -- set top and bottom of well screen + c = DZERO + topw = this%mawwells(i)%topscrn(j) + botw = this%mawwells(i)%botscrn(j) + tthkw = topw - botw + ! + ! -- scale screen thickness using gwfsat (for NPF Package THICKSTRT) + if (gwftop == topw .and. gwfbot == botw) then + if (this%icelltype(node) == 0) then + tthkw = tthkw * gwfsat + tthka = tthka * gwfsat + end if + end if + ! + ! -- calculate the aquifer transmissivity (T2pi) + T2pi = DTWOPI * tthka * sqrtk11k22 + ! + ! -- calculate effective radius + if (this%dis%ndim == 3 .and. this%ieffradopt /= 0) then + Txx = k11 * tthka + Tyy = k22 * tthka + dx = sqrt(this%dis%area(node)) + dy = dx + yx4 = (Tyy/Txx)**DQUARTER + xy4 = (Txx/Tyy)**DQUARTER + eradius = 0.28_DP * ((yx4*dx)**DTWO + (xy4*dy)**DTWO)**DHALF / (yx4+xy4) + else + area = this%dis%area(node) + eradius = sqrt(area / (DEIGHT * DPI)) + end if + ! + ! -- conductance calculations + ! -- Thiem equation (1) and cumulative Thiem and skin equations (3) + if (this%mawwells(i)%ieqn == 1 .or. this%mawwells(i)%ieqn == 3) then + lc1 = log(eradius / this%mawwells(i)%radius) / T2pi + end if + ! -- skin equation (2) and cumulative Thiem and skin equations (3) + if (this%mawwells(i)%ieqn == 2 .or. this%mawwells(i)%ieqn == 3) then + hks = this%mawwells(i)%hk(j) + if (tthkw * hks > DZERO) then + Tcontrast = (sqrtk11k22 * tthka) / (hks * tthkw) + skin = (Tcontrast - DONE) * & + log(this%mawwells(i)%sradius(j) / this%mawwells(i)%radius) + ! -- trap invalid transmissvity contrast if using skin equation (2). + ! Not trapped for cumulative Thiem and skin equations (3) + ! because the MNW2 package allowed this condition (for + ! backward compatibility with the MNW2 package for + ! MODFLOW-2005, MODFLOW-NWT, and MODFLOW-USG). + if (Tcontrast <= 1 .and. this%mawwells(i)%ieqn == 2) then + iTcontrastErr = 1 + write(errmsg, '(4x,a,g0,a,1x,i0,1x,a,1x,i0,a,4(1x,a))') & + '****ERROR. INVALID CALCULATED TRANSMISSIVITY CONTRAST (', Tcontrast,& + ') for MAW WELL', i, 'CONNECTION', j, '.', 'THIS HAPPENS WHEN THE', & + 'SKIN TRANSMISSIVITY EQUALS OR EXCEEDS THE AQUIFER TRANSMISSIVITY.', & + 'CONSIDER DECREASING HK_SKIN FOR THE CONNECTION OR USING THE', & + 'CUMULATIVE OR MEAN CONDUCTANCE EQUATIONS.' + call store_error(errmsg) + else + lc2 = skin / T2pi + end if + end if + end if + ! -- conductance using screen elevations, hk, well radius, + ! and screen radius + if (this%mawwells(i)%ieqn == 4) then + hks = this%mawwells(i)%hk(j) + ravg = DHALF * (this%mawwells(i)%radius + this%mawwells(i)%sradius(j)) + slen = this%mawwells(i)%sradius(j) - this%mawwells(i)%radius + pavg = DTWOPI * ravg + c = hks * pavg * tthkw / slen + end if + ! + ! -- calculate final conductance for Theim (1), Skin (2), and + ! and cumulative Thiem and skin equations (3) + if (this%mawwells(i)%ieqn < 4) then + if (lc1 + lc2 /= DZERO) then + c = DONE / (lc1 + lc2) + else + c = -DNODATA + end if + end if + ! + ! -- ensure that the conductance is not negative. Only write error message + ! if error condition has not occured for skin calculations (LC2) + if (c < DZERO .and. iTcontrastErr == 0) then + write(errmsg, '(4x,a,g0,a,1x,i0,1x,a,1x,i0,a,4(1x,a))') & + '****ERROR. INVALID CALCULATED NEGATIVE CONDUCTANCE (', c, & + ') for MAW WELL', i, 'CONNECTION', j, '.', 'THIS HAPPENS WHEN THE', & + 'SKIN TRANSMISSIVITY EQUALS OR EXCEEDS THE AQUIFER TRANSMISSIVITY.', & + 'CONSIDER DECREASING HK_SKIN FOR THE CONNECTION OR USING THE', & + 'MEAN CONDUCTANCE EQUATION.' + call store_error(errmsg) + end if + ! + ! -- set saturated conductance + this%mawwells(i)%satcond(j) = c + ! + ! -- return + return + end subroutine maw_calculate_satcond + + + subroutine maw_calculate_saturation(this, i, j, node, sat) + ! -- dummy + class(MawType),intent(inout) :: this + integer(I4B), intent(in) :: i + integer(I4B), intent(in) :: j + integer(I4B), intent(in) :: node + real(DP), intent(inout) :: sat + ! -- local + real(DP) :: htmp + real(DP) :: hwell + real(DP) :: topw + real(DP) :: botw + ! -- formats + ! ------------------------------------------------------------------------------ + ! + ! -- initialize saturation + sat = DZERO + ! + ! -- calculate current saturation for convertible cells + if (this%icelltype(node) /= 0) then + ! + ! -- set hwell + hwell = this%xnewpak(i) + ! -- set top and bottom of the well connection + topw = this%mawwells(i)%topscrn(j) + botw = this%mawwells(i)%botscrn(j) + ! + ! -- calculate appropriate saturation + if (this%inewton /= 1) then + htmp = this%xnew(node) + if (htmp < botw) htmp = botw + if (hwell < botw) hwell = botw + htmp = DHALF * (htmp + hwell) + else + htmp = this%xnew(node) + if (hwell > htmp) htmp = hwell + if (htmp < botw) htmp = botw + end if + ! -- calculate saturation + sat = sQuadraticSaturation(topw, botw, htmp, this%satomega) + else + sat = DONE + end if + ! + ! -- return + return + end subroutine maw_calculate_saturation + + subroutine maw_calculate_wellq(this, n, hmaw, q) +! ************************************************************************** +! maw_calculate_wellq-- Calculate well pumping rate based on constraints +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + ! -- dummy + class(MawType) :: this + integer(I4B), intent(in) :: n + real(DP), intent(in) :: hmaw + real(DP), intent(inout) :: q + ! -- local + real(DP) :: scale + real(DP) :: tp + real(DP) :: bt + real(DP) :: rate + real(DP) :: weight + real(DP) :: dq +! -------------------------------------------------------------------------- + ! + ! -- Initialize q + q = DZERO + ! + ! -- Assign rate as the user-provided base pumping rate + rate = this%mawwells(n)%rate%value + ! + ! -- Assign q differently depending on whether this is an extraction well + ! (rate < 0) or an injection well (rate > 0). + if (rate < DZERO) then + ! + ! -- If well shut off is activated, then turn off well if necessary, + ! or if shut off is not activated then check to see if rate scaling + ! is on. + if (this%mawwells(n)%shutofflevel /= DEP20) then + call this%maw_calculate_qpot(n, q) + if (q < DZERO) q = DZERO + if (q > -rate) q = -rate + + if (this%ishutoffcnt == 1) then + this%mawwells(n)%shutoffweight = DONE + this%mawwells(n)%shutoffdq = DZERO + this%mawwells(n)%shutoffqold = q + end if + + dq = q - this%mawwells(n)%shutoffqold + weight = this%mawwells(n)%shutoffweight + + ! -- for flip-flop condition, decrease factor + if ( this%mawwells(n)%shutoffdq*dq < DZERO ) then + weight = this%theta * this%mawwells(n)%shutoffweight + ! -- when change is of same sign, increase factor + else + weight = this%mawwells(n)%shutoffweight + this%kappa + end if + if ( weight > DONE ) weight = DONE + + q = this%mawwells(n)%shutoffqold + weight * dq + + this%mawwells(n)%shutoffqold = q + this%mawwells(n)%shutoffdq = dq + this%mawwells(n)%shutoffweight = weight + + ! + ! -- If shutoffmin and shutoffmax are specified then apply + ! additional checks for when to shut off the well. + if (this%mawwells(n)%shutoffmin > DZERO) then + if (hmaw < this%mawwells(n)%shutofflevel) then + ! + ! -- calculate adjusted well rate subject to constraints + ! -- well is shutoff + if (this%mawwells(n)%ishutoff /= 0) then + q = DZERO + ! --- well is not shut off + else + ! -- turn off well if q is less than the minimum rate and + ! reset the ishutoff flag if at least on iteration 3 + if (q < this%mawwells(n)%shutoffmin) then + if (this%ishutoffcnt > 2) then + this%mawwells(n)%ishutoff = 1 + end if + q = DZERO + ! -- leave well on and use the specified rate + ! or the potential rate + end if + end if + ! -- try to use the specified rate or the potential rate + else + if (q > this%mawwells(n)%shutoffmax) then + if (this%ishutoffcnt <= 2) then + this%mawwells(n)%ishutoff = 0 + end if + end if + if (this%mawwells(n)%ishutoff /= 0) then + q = DZERO + end if + end if + end if + + if (q /= DZERO) q = -q + + else + scale = DONE + ! -- Apply rate scaling by reducing pumpage when hmaw is less than the + ! sum of maw pump elevation (pumpelev) and the specified reduction + ! length. The rate will go to zero as hmaw drops to the pump + ! elevation. + if (this%mawwells(n)%reduction_length /= DEP20) then + bt = this%mawwells(n)%pumpelev + tp = bt + this%mawwells(n)%reduction_length + scale = sQSaturation(tp, bt, hmaw) + end if + q = scale * rate + end if + ! + else + ! + ! -- Handle the injection case (rate > 0) differently than extraction. + q = rate + if (this%mawwells(n)%shutofflevel /= DEP20) then + call this%maw_calculate_qpot(n, q) + q = -q + if (q < DZERO) q = DZERO + if (q > rate) q = rate + + if (this%ishutoffcnt == 1) then + this%mawwells(n)%shutoffweight = DONE + this%mawwells(n)%shutoffdq = DZERO + this%mawwells(n)%shutoffqold = q + end if + + dq = q - this%mawwells(n)%shutoffqold + weight = this%mawwells(n)%shutoffweight + + ! -- for flip-flop condition, decrease factor + if ( this%mawwells(n)%shutoffdq*dq < DZERO ) then + weight = this%theta * this%mawwells(n)%shutoffweight + ! -- when change is of same sign, increase factor + else + weight = this%mawwells(n)%shutoffweight + this%kappa + end if + if ( weight > DONE ) weight = DONE + + q = this%mawwells(n)%shutoffqold + weight * dq + + this%mawwells(n)%shutoffqold = q + this%mawwells(n)%shutoffdq = dq + this%mawwells(n)%shutoffweight = weight + + else + scale = DONE + ! -- Apply rate scaling for an injection well by reducting the + ! injection rate as hmaw rises above the pump elevation. The rate + ! will approach zero as hmaw approaches pumpelev + reduction_length. + if (this%mawwells(n)%reduction_length /= DEP20) then + bt = this%mawwells(n)%pumpelev + tp = bt + this%mawwells(n)%reduction_length + scale = DONE - sQSaturation(tp, bt, hmaw) + endif + q = scale * rate + endif + end if + ! + ! -- return + return + end subroutine maw_calculate_wellq + + subroutine maw_calculate_qpot(this, n, qnet) +! ****************************************************************************** +! maw_calculate_qpot -- Calculate groundwater inflow to a maw well +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use TdisModule,only:delt + ! -- dummy + class(MawType),intent(inout) :: this + integer(I4B), intent(in) :: n + real(DP), intent(inout) :: qnet + ! -- local + integer(I4B) :: j + integer(I4B) :: igwfnode + real(DP) :: bt + real(DP) :: tp + real(DP) :: scale + real(DP) :: cfw + real(DP) :: hdterm + real(DP) :: sat + real(DP) :: cmaw + real(DP) :: hgwf + real(DP) :: bmaw + real(DP) :: htmp + real(DP) :: hv + ! -- format +! ------------------------------------------------------------------------------ + !--initialize qnet + qnet = DZERO + ! -- + htmp = this%mawwells(n)%shutofflevel + ! -- calculate discharge to flowing wells + if (this%iflowingwells > 0) then + if (this%mawwells(n)%fwcond > DZERO) then + bt = this%mawwells(n)%fwelev + tp = bt + this%mawwells(n)%fwrlen + scale = sQSaturation(tp, bt, htmp) + cfw = scale * this%mawwells(n)%fwcond + this%mawwells(n)%ifwdischarge = 0 + if (cfw > DZERO) then + this%mawwells(n)%ifwdischarge = 1 + this%mawwells(n)%xsto = bt + end if + qnet = qnet + cfw * (bt - htmp) + end if + end if + ! -- calculate maw storage changes + if (this%imawiss /= 1) then + if (this%mawwells(n)%ifwdischarge /= 1) then + hdterm = this%mawwells(n)%xoldsto - htmp + else + hdterm = this%mawwells(n)%xoldsto - this%mawwells(n)%fwelev + end if + qnet = qnet - (this%mawwells(n)%area * hdterm / delt) + end if + ! -- calculate inflow from aquifer + do j = 1, this%mawwells(n)%ngwfnodes + igwfnode = this%mawwells(n)%gwfnodes(j) + call this%maw_calculate_saturation(n, j, igwfnode, sat) !, hv) + cmaw = this%mawwells(n)%satcond(j) * sat + hgwf = this%xnew(igwfnode) + bmaw = this%mawwells(n)%botscrn(j) + hv = htmp + if (hv < bmaw) then + hv = bmaw + end if + if (hgwf < bmaw) then + hgwf = bmaw + end if + qnet = qnet + cmaw * (hgwf - hv) + end do + ! + ! -- return + return + end subroutine maw_calculate_qpot + + subroutine maw_cfupdate(this) + ! ****************************************************************************** + ! maw_cfupdate -- Update MAW satcond and package rhs and hcof + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + class(MawType) :: this + integer(I4B) :: j, n, node + integer(I4B) :: ibnd + real(DP) :: sat, cmaw, hmaw, bmaw + ! ------------------------------------------------------------------------------ + ! + ! -- Return if no maw wells + if(this%nbound.eq.0) return + ! + ! -- Update shutoff count + this%ishutoffcnt = this%ishutoffcnt + 1 + ! + ! -- Calculate hcof and rhs for each maw entry + ibnd = 1 + do n = 1, this%nmawwells + hmaw = this%xnewpak(n) + do j = 1, this%mawwells(n)%ngwfnodes + node = this%nodelist(ibnd) + this%hcof(ibnd) = DZERO + this%rhs(ibnd) = DZERO + ! + ! -- set bound, hcof, and rhs components + call this%maw_calculate_saturation(n, j, node, sat) + if (this%iboundpak(n) == 0) then + cmaw = DZERO + else + cmaw = this%mawwells(n)%satcond(j) * sat + endif + this%mawwells(n)%simcond(j) = cmaw + + this%bound(2,ibnd) = cmaw + + bmaw = this%bound(3,ibnd) + + this%hcof(ibnd) = -cmaw + ! + ! -- fill rhs + if (hmaw < bmaw) then + this%rhs(ibnd) = -cmaw * bmaw + else + this%rhs(ibnd) = -cmaw * hmaw + end if + ! + ! -- increment boundary number + ibnd = ibnd + 1 + end do + end do + ! + ! -- Return + return + end subroutine maw_cfupdate + + + subroutine maw_allocate_well(this, n) +! ****************************************************************************** +! allocate_reach -- Allocate pointers for multi-aquifer well mawwells(n). +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(MawType) :: this + integer(I4B), intent(in) :: n + ! -- local + character(len=LINELENGTH) :: ermsg + character(len=10) :: cwel + integer(I4B) :: iaux +! ------------------------------------------------------------------------------ + ! + ! -- make sure maw well has not been allocated + if (associated(this%mawwells(n)%ieqn)) then + write (cwel, '(i10)') n + ermsg = 'multi-aquifer well ' // trim(cwel) // ' is already allocated' + call store_error(ermsg) + call ustop() + end if + ! -- allocate pointers + !allocate(character (len=LENBOUNDNAME) :: this%mawwells(n)%name) + allocate(this%mawwells(n)%name) + allocate(this%mawwells(n)%status) + allocate(this%mawwells(n)%ngwfnodes) + allocate(this%mawwells(n)%ieqn) + allocate(this%mawwells(n)%ishutoff) + allocate(this%mawwells(n)%ifwdischarge) + allocate(this%mawwells(n)%strt) + allocate(this%mawwells(n)%radius) + allocate(this%mawwells(n)%area) + allocate(this%mawwells(n)%pumpelev) + allocate(this%mawwells(n)%bot) + allocate(this%mawwells(n)%ratesim) + allocate(this%mawwells(n)%reduction_length) + allocate(this%mawwells(n)%fwelev) + allocate(this%mawwells(n)%fwcond) + allocate(this%mawwells(n)%fwrlen) + allocate(this%mawwells(n)%fwcondsim) + allocate(this%mawwells(n)%xsto) + allocate(this%mawwells(n)%xoldsto) + allocate(this%mawwells(n)%shutoffmin) + allocate(this%mawwells(n)%shutoffmax) + allocate(this%mawwells(n)%shutofflevel) + allocate(this%mawwells(n)%shutoffweight) + allocate(this%mawwells(n)%shutoffdq) + allocate(this%mawwells(n)%shutoffqold) + ! -- timeseries aware data + if (this%naux > 0) then + allocate(this%mawwells(n)%auxvar(this%naux)) + do iaux = 1, this%naux + allocate(this%mawwells(n)%auxvar(iaux)%name) + allocate(this%mawwells(n)%auxvar(iaux)%value) + end do + end if + allocate(this%mawwells(n)%rate) + allocate(this%mawwells(n)%rate%name) + allocate(this%mawwells(n)%rate%value) + allocate(this%mawwells(n)%head) + allocate(this%mawwells(n)%head%name) + allocate(this%mawwells(n)%head%value) + ! + ! -- initialize a few well variables + this%mawwells(n)%name = '' + this%mawwells(n)%status = 'ACTIVE' + this%mawwells(n)%ngwfnodes = 0 + this%mawwells(n)%ieqn = 0 + this%mawwells(n)%ishutoff = 0 + this%mawwells(n)%ifwdischarge = 0 + this%mawwells(n)%strt = DEP20 + this%mawwells(n)%radius = DEP20 + this%mawwells(n)%area = DZERO + this%mawwells(n)%pumpelev = DEP20 + this%mawwells(n)%bot = DEP20 + this%mawwells(n)%ratesim = DZERO + this%mawwells(n)%reduction_length = DEP20 + this%mawwells(n)%fwelev = DZERO + this%mawwells(n)%fwcond = DZERO + this%mawwells(n)%fwrlen = DZERO + this%mawwells(n)%fwcondsim = DZERO + this%mawwells(n)%xsto = DZERO + this%mawwells(n)%xoldsto = DZERO + this%mawwells(n)%shutoffmin = DZERO + this%mawwells(n)%shutoffmax = DZERO + this%mawwells(n)%shutofflevel = DEP20 + this%mawwells(n)%shutoffweight = DONE + this%mawwells(n)%shutoffdq = DONE + this%mawwells(n)%shutoffqold = DONE + ! -- timeseries aware data + do iaux = 1, this%naux + this%mawwells(n)%auxvar(iaux)%name = '' + this%mawwells(n)%auxvar(iaux)%value = DZERO + end do + this%mawwells(n)%rate%name = '' + this%mawwells(n)%rate%value = DZERO + this%mawwells(n)%head%name = '' + this%mawwells(n)%head%value = DZERO + ! + ! -- return + return + end subroutine maw_allocate_well + + subroutine maw_deallocate_well(this, n) +! ****************************************************************************** +! maw_deallocate_well -- deallocate pointers for multi-aquifer well mawwells(n). +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(MawType) :: this + integer(I4B), intent(in) :: n + ! -- local + integer(I4B) :: iaux +! ------------------------------------------------------------------------------ + ! + deallocate(this%mawwells(n)%gwfnodes) + deallocate(this%mawwells(n)%satcond) + deallocate(this%mawwells(n)%simcond) + deallocate(this%mawwells(n)%topscrn) + deallocate(this%mawwells(n)%botscrn) + if (this%mawwells(n)%ieqn==2 .OR. this%mawwells(n)%ieqn==3 .OR. & + this%mawwells(n)%ieqn==4) then + deallocate(this%mawwells(n)%hk) + end if + if (this%mawwells(n)%ieqn==2 .OR. this%mawwells(n)%ieqn==3 .OR. & + this%mawwells(n)%ieqn==4) then + deallocate(this%mawwells(n)%sradius) + end if + deallocate(this%mawwells(n)%name) + deallocate(this%mawwells(n)%status) + deallocate(this%mawwells(n)%ngwfnodes) + deallocate(this%mawwells(n)%ieqn) + deallocate(this%mawwells(n)%ishutoff) + deallocate(this%mawwells(n)%ifwdischarge) + deallocate(this%mawwells(n)%strt) + deallocate(this%mawwells(n)%radius) + deallocate(this%mawwells(n)%area) + deallocate(this%mawwells(n)%pumpelev) + deallocate(this%mawwells(n)%bot) + deallocate(this%mawwells(n)%ratesim) + deallocate(this%mawwells(n)%reduction_length) + deallocate(this%mawwells(n)%fwelev) + deallocate(this%mawwells(n)%fwcond) + deallocate(this%mawwells(n)%fwrlen) + deallocate(this%mawwells(n)%fwcondsim) + deallocate(this%mawwells(n)%xsto) + deallocate(this%mawwells(n)%xoldsto) + deallocate(this%mawwells(n)%shutoffmin) + deallocate(this%mawwells(n)%shutoffmax) + deallocate(this%mawwells(n)%shutofflevel) + deallocate(this%mawwells(n)%shutoffweight) + deallocate(this%mawwells(n)%shutoffdq) + deallocate(this%mawwells(n)%shutoffqold) + ! -- timeseries aware data + if (this%naux > 0) then + do iaux = 1, this%naux + deallocate(this%mawwells(n)%auxvar(iaux)%name) + deallocate(this%mawwells(n)%auxvar(iaux)%value) + end do + deallocate(this%mawwells(n)%auxvar) + end if + deallocate(this%mawwells(n)%rate%name) + deallocate(this%mawwells(n)%rate%value) + deallocate(this%mawwells(n)%rate) + deallocate(this%mawwells(n)%head%name) + deallocate(this%mawwells(n)%head%value) + deallocate(this%mawwells(n)%head) + ! + ! -- return + return + end subroutine maw_deallocate_well + + subroutine maw_setup_budobj(this) +! ****************************************************************************** +! maw_setup_budobj -- Set up the budget object that stores all the maw flows +! The terms listed here must correspond in number and order to the ones +! listed in the maw_fill_budobj routine. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LENBUDTXT + ! -- dummy + class(MawType) :: this + ! -- local + integer(I4B) :: nbudterm + integer(I4B) :: n, j, n2 + real(DP) :: q + integer(I4B) :: maxlist, naux + integer(I4B) :: idx + character(len=LENBUDTXT) :: text + character(len=LENBUDTXT), dimension(1) :: auxtxt +! ------------------------------------------------------------------------------ + ! + ! -- Determine the number of maw budget terms. These are fixed for + ! the simulation and cannot change. + ! gwf rate [flowing_well] storage constant_flow [frommvr tomvr tomvrcf [tomvrfw]] [aux] + nbudterm = 4 + if (this%iflowingwells > 0) nbudterm = nbudterm + 1 + if (this%imover == 1) then + nbudterm = nbudterm + 3 + if (this%iflowingwells > 0) nbudterm = nbudterm + 1 + end if + if (this%naux > 0) nbudterm = nbudterm + 1 + ! + ! -- set up budobj + call budgetobject_cr(this%budobj, this%name) + call this%budobj%budgetobject_df(this%nmawwells, nbudterm, 0, 0) + idx = 0 + ! + ! -- Go through and set up each budget term + ! + ! -- + text = ' GWF' + idx = idx + 1 + maxlist = this%maxbound + naux = 1 + auxtxt(1) = ' FLOW-AREA' + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name_model, & + maxlist, .false., .true., & + naux, auxtxt) + call this%budobj%budterm(idx)%reset(this%maxbound) + q = DZERO + do n = 1, this%nmawwells + do j = 1, this%mawwells(n)%ngwfnodes + n2 = this%mawwells(n)%gwfnodes(j) + call this%budobj%budterm(idx)%update_term(n, n2, q) + end do + end do + ! + ! -- + text = ' RATE' + idx = idx + 1 + maxlist = this%nmawwells + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- + if (this%iflowingwells > 0) then + text = ' FW-RATE' + idx = idx + 1 + maxlist = this%nmawwells + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + end if + ! + ! -- + text = ' STORAGE' + idx = idx + 1 + maxlist = this%nmawwells + naux = 1 + auxtxt(1) = ' VOLUME' + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name_model, & + maxlist, .false., .true., & + naux, auxtxt) + ! + ! -- + text = ' CONSTANT' + idx = idx + 1 + maxlist = this%nmawwells + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- + if (this%imover == 1) then + ! + ! -- + text = ' FROM-MVR' + idx = idx + 1 + maxlist = this%nmawwells + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' RATE-TO-MVR' + idx = idx + 1 + maxlist = this%nmawwells + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- constant-head flow to mover + text = ' CONSTANT-TO-MVR' + idx = idx + 1 + maxlist = this%nmawwells + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- + if (this%iflowingwells > 0) then + ! + ! -- + text = ' FW-RATE-TO-MVR' + idx = idx + 1 + maxlist = this%nmawwells + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + end if + end if + ! + ! -- + naux = this%naux + if (naux > 0) then + ! + ! -- + text = ' AUXILIARY' + idx = idx + 1 + maxlist = this%maxbound + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux, this%auxname) + end if + ! + ! -- if maw flow for each reach are written to the listing file + if (this%iprflow /= 0) then + call this%budobj%flowtable_df(this%iout) + end if + ! + ! -- return + return + end subroutine maw_setup_budobj + + subroutine maw_fill_budobj(this) +! ****************************************************************************** +! maw_fill_budobj -- copy flow terms into this%budobj +! +! gwf rate [flowing_well] [storage] constant_flow [frommvr tomvr tomvrcf [tomvrfw]] [aux] +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(MawType) :: this + ! -- local + integer(I4B) :: naux + integer(I4B) :: j, n, n2 + integer(I4B) :: idx + integer(I4B) :: ibnd + real(DP) :: q + real(DP) :: tmaw + real(DP) :: bmaw + real(DP) :: sat + real(DP) :: qfact + real(DP) :: q2 + real(DP) :: b + real(DP) :: v + ! -- formats +! ----------------------------------------------------------------------------- + ! + ! -- initialize counter + idx = 0 + ! + ! -- GWF (LEAKAGE) and connection surface area (aux) + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound) + ibnd = 1 + do n = 1, this%nmawwells + do j = 1, this%mawwells(n)%ngwfnodes + n2 = this%mawwells(n)%gwfnodes(j) + tmaw = this%mawwells(n)%topscrn(j) + bmaw = this%mawwells(n)%botscrn(j) + call this%maw_calculate_saturation(n, j, n2, sat) + this%qauxcbc(1) = DTWO * DPI * this%mawwells(n)%radius * sat * (tmaw - bmaw) + q = this%qleak(ibnd) + call this%budobj%budterm(idx)%update_term(n, n2, q, this%qauxcbc) + ibnd = ibnd + 1 + end do + end do + ! + ! -- RATE (WITHDRAWAL RATE) + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nmawwells) + do n = 1, this%nmawwells + q = this%mawwells(n)%ratesim + ! -- adjust if well rate is an outflow + if (this%imover == 1 .and. q < DZERO) then + qfact = DONE + if (this%qout(n) < DZERO) then + qfact = q / this%qout(n) + end if + q = q + qfact * this%pakmvrobj%get_qtomvr(n) + end if + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + ! + ! -- FLOWING WELL + if (this%iflowingwells > 0) then + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nmawwells) + do n = 1, this%nmawwells + q = this%qfw(n) + if (this%imover == 1) then + qfact = DONE + ! -- adjust if well rate is an outflow + if (this%qout(n) < DZERO) then + qfact = q / this%qout(n) + end if + q = q + qfact * this%pakmvrobj%get_qtomvr(n) + end if + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + end if + ! + ! -- STORAGE (AND VOLUME AS AUX) + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nmawwells) + do n = 1, this%nmawwells + b = this%mawwells(n)%xsto - this%mawwells(n)%bot + if (b < DZERO) then + b = DZERO + end if + v = this%mawwells(n)%area * b + if (this%imawissopt /= 1) then + q = this%qsto(n) + else + q = DZERO + end if + this%qauxcbc(1) = v + call this%budobj%budterm(idx)%update_term(n, n, q, this%qauxcbc) + end do + ! + ! -- CONSTANT FLOW + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nmawwells) + do n = 1, this%nmawwells + q = this%qconst(n) + ! + ! -- adjust if constant-flow rate is an outflow + if (this%imover == 1 .and. q < DZERO) then + qfact = DONE + if (this%qout(n) < DZERO) then + qfact = q / this%qout(n) + end if + q = q + qfact * this%pakmvrobj%get_qtomvr(n) + end if + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + ! + ! -- MOVER + if (this%imover == 1) then + ! + ! -- FROM MOVER + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nmawwells) + do n = 1, this%nmawwells + if (this%iboundpak(n) == 0) then + q = DZERO + else + q = this%pakmvrobj%get_qfrommvr(n) + end if + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + ! + ! -- RATE TO MOVER + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nmawwells) + do n = 1, this%nmawwells + q = this%pakmvrobj%get_qtomvr(n) + if (q > DZERO) then + q = -q + q2 = this%mawwells(n)%ratesim + ! -- adjust TO MOVER if well rate is outflow + if (q2 < DZERO) then + qfact = q2 / this%qout(n) + q = q * qfact + else + q = DZERO + end if + end if + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + ! + ! -- CONSTANT TO MOVER + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nmawwells) + do n = 1, this%nmawwells + q = this%pakmvrobj%get_qtomvr(n) + if (q > DZERO) then + q = -q + q2 = this%qconst(n) + ! -- adjust TO MOVER if well rate is outflow + if (q2 < DZERO) then + qfact = q2 / this%qout(n) + q = q * qfact + else + q = DZERO + end if + end if + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + ! + ! -- FLOWING WELL TO MOVER + if (this%iflowingwells > 0) then + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nmawwells) + do n = 1, this%nmawwells + q = this%pakmvrobj%get_qtomvr(n) + if (q > DZERO) then + q = -q + q2 = this%mawwells(n)%ratesim + ! -- adjust TO MOVER if well rate is outflow + qfact = DONE + if (this%qout(n) < DZERO) then + qfact = this%qfw(n) / this%qout(n) + end if + q = q * qfact + end if + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + end if + + end if + ! + ! -- AUXILIARY VARIABLES + naux = this%naux + if (naux > 0) then + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nmawwells) + do n = 1, this%nmawwells + q = DZERO + call this%budobj%budterm(idx)%update_term(n, n, q, this%auxvar(:, n)) + end do + end if + ! + ! --Terms are filled, now accumulate them for this time step + call this%budobj%accumulate_terms() + ! + ! -- return + return + end subroutine maw_fill_budobj + + subroutine maw_setup_tableobj(this) +! ****************************************************************************** +! maw_setup_tableobj -- Set up the table object that is used to write the maw +! head data. The terms listed here must correspond in +! number and order to the ones written to the head table +! in the maw_ot method. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH, LENBUDTXT + ! -- dummy + class(MawType) :: this + ! -- local + integer(I4B) :: nterms + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: text +! ------------------------------------------------------------------------------ + ! + ! -- setup well head table + if (this%iprhed > 0) then + ! + ! -- Determine the number of head table columns + nterms = 2 + if (this%inamedbound == 1) nterms = nterms + 1 + ! + ! -- set up table title + title = trim(adjustl(this%text)) // ' PACKAGE (' // & + trim(adjustl(this%name)) //') HEADS FOR EACH CONTROL VOLUME' + ! + ! -- set up head tableobj + call table_cr(this%headtab, this%name, title) + call this%headtab%table_df(this%nmawwells, nterms, this%iout, & + transient=.TRUE.) + ! + ! -- Go through and set up table budget term + if (this%inamedbound == 1) then + text = 'NAME' + call this%headtab%initialize_column(text, 20, alignment=TABLEFT) + end if + ! + ! -- reach number + text = 'NUMBER' + call this%headtab%initialize_column(text, 10, alignment=TABCENTER) + ! + ! -- reach stage + text = 'HEAD' + call this%headtab%initialize_column(text, 12, alignment=TABCENTER) + end if + ! + ! -- return + return + end subroutine maw_setup_tableobj + +end module MawModule diff --git a/src/Model/GroundWaterFlow/gwf3mvr8.f90 b/src/Model/GroundWaterFlow/gwf3mvr8.f90 index b1f8445ffc8..a3b87c02e49 100644 --- a/src/Model/GroundWaterFlow/gwf3mvr8.f90 +++ b/src/Model/GroundWaterFlow/gwf3mvr8.f90 @@ -1,1242 +1,1242 @@ -!GWF Water Mover Module -!This module contains a derived type, called GwfMvrType, that -!is attached to the GWF model. The water mover can be used to move water -!between packages. The mover requires that mover-aware packages have access -!to four arrays: qtformvr, qformvr, qtomvr, and qfrommvr. These arrays are -!stored and managed by a separate PackageMoverType object. qformvr is a -!vector of volumetric flow rates available for the mover. The package -!must fill the vector (dimensioned by number of reaches) with the available -!water. qtomvr is a vector containing how much water was actually moved -!by the mover. The package should use this value in the budgeting part -!to track how much water was actually provided to the mover. Lastly, -!the qfrommvr is a vector that contains volumetric rates for how much -!water was provided by the mover as a source of water to the package. -! -!The mover is designed so that a reach can provide water to more than one -!receiving reaches. The available water will be consumed in order of -!the movers listed in the package. The mover is also designed so that -!a receiver can receive water from more than one provider. -! -! 1. The mover is instantiated as a model member: -! -! type(GwfMvrType), pointer :: mvr => null() -! -! Mover aware packages have access to the following vectors of mover -! information, which are stored in the PackageMoverType object: -! -! integer(I4B), pointer :: imover => null() -! real(DP), dimension(:), pointer, contiguous :: qtformvr => null() -! real(DP), dimension(:), pointer, contiguous :: qformvr => null() -! real(DP), dimension(:), pointer, contiguous :: qtomvr => null() -! real(DP), dimension(:), pointer, contiguous :: qfrommvr => null() -! -! Note qtformvr is filled as a positive number to indicate that it is -! water available to be moved. If qtformvr is negative, then -! no water will be moved for that reach. qformvr is also the available -! water, but this value decreases as the mover object consumes water from -! it. -! -! 2. In gwf_cr create the mover package by calling the CR subroutine: -! -! call mvr_cr(this%mvr, this%name, this%inmvr, this%iout) -! -! 3. In gwf_ar call the AR method for the mover: -! -! if(this%inmvr > 0) call this%mvr%mvr_ar() -! -! Mover aware packages allocate the four vectors. The first three -! (qtformvr, qformvr, qtomvr) are allocated to the number of providers -! and the last one (qfrommvr) is allocated to the number of receivers. -! -! 4. In gwf_rp call the RP method for the mover. This reads the -! movers active for the current period. -! -! if(this%inmvr > 0) call this%mvr%mvr_rp() -! -! 5. In gwf_ad call the AD method for the mover. This saves qtomvr from the -! the last time step. -! -! if(this%inmvr > 0) call this%mvr%mvr_ad() -! -! Mover aware packages then set: -! qtomvr(:) = 0. -! qformvr(:) = 0. -! -! 6. In gwf_cf call the CF routine. Mover aware packages set: -! qtformvr(:) = qformvr(:) -! qfrommvr(:) = 0. -! qtomvr(:) = 0. -! -! 7. The FC method for the mover is called. This method calculates the -! amount of water to move based on the amount of water available from the -! previous iteration. This call updates the values in the qtomvr and -! qfrommvr vectors inside the packages. This is done by the mover package -! using pointers to the appropriate reach locations in qtomvr and qfrommvr. -! -! if(this%inmvr > 0) call this%mvr%mvr_fc() ! called from gwf%gwf_fc() -! -! a. Mover aware packages first set qformvr(:) = 0. -! b. Mover aware packages that are receivers (MAW, SFR, LAK, UZF) add -! qfrommvr terms to their individual control volume equations as a -! source of water. -! c. Mover aware packages calculate qformvr as amount of water available -! to be moved (these qformvr terms are used in the next iteration -! by this%mvr%mvr_fc() to calculate how much water is actually moved) -! -! 8. The BD method for the mover is called. This method writes the moved -! water rates if requested. -! -! if(this%inmvr > 0) call this%mvr%mvr_bd() -! -! Mover aware packages account for qtomvr and qfrommvr terms in their -! individual budget routines. -! -! 9. The OT method for the mover is called. This method outputs a mover -! budget table. -! -! if(this%inmvr > 0) call this%mvr%mvr_ot() -! -module GwfMvrModule - use KindModule, only: DP, I4B - use ConstantsModule, only: LENORIGIN, LENPACKAGENAME, LENMODELNAME, & - LENBUDTXT, LENAUXNAME, LENPAKLOC, & - DZERO, DNODATA, MAXCHARLEN - use MvrModule, only: MvrType - use BudgetModule, only: BudgetType, budget_cr - use BudgetObjectModule, only: BudgetObjectType, budgetobject_cr - use NumericalPackageModule, only: NumericalPackageType - use BlockParserModule, only: BlockParserType - use PackageMoverModule, only: PackageMoverType - use BaseDisModule, only: DisBaseType - use InputOutputModule, only: urword - - implicit none - private - public :: GwfMvrType, mvr_cr - - type, extends(NumericalPackageType) :: GwfMvrType - integer(I4B), pointer :: ibudgetout => null() !binary budget output file - integer(I4B), pointer :: maxmvr => null() !max number of movers to be specified - integer(I4B), pointer :: maxpackages => null() !max number of packages to be specified - integer(I4B), pointer :: maxcomb => null() !max number of combination of packages - integer(I4B), pointer :: nmvr => null() !number of movers for current stress period - integer(I4B), pointer :: iexgmvr => null() !indicate mover is for an exchange (not for a single model) - integer(I4B), pointer :: imodelnames => null() !indicate package input file has model names in it - real(DP), pointer :: omega => null() !temporal weighting factor (not presently used) - integer(I4B), dimension(:), pointer, contiguous :: ientries => null() !number of entries for each combination - character(len=LENORIGIN+1), & - dimension(:), pointer, contiguous :: pakorigins !array of model//package names - character(len=LENPACKAGENAME), & - dimension(:), pointer, contiguous :: paknames => null() !array of package names - type(MvrType), dimension(:), pointer, contiguous :: mvr => null() !array of movers - type(BudgetType), pointer :: budget => null() !mover budget object (used to write table) - type(BudgetObjectType), pointer :: budobj => null() !new budget container (used to write binary file) - type(PackageMoverType), & - dimension(:), pointer, contiguous :: pakmovers => null() !pointer to package mover objects - contains - procedure :: mvr_ar - procedure :: mvr_rp - procedure :: mvr_ad - procedure :: mvr_fc - procedure :: mvr_cc - procedure :: mvr_bd - procedure :: mvr_ot - procedure :: mvr_da - procedure :: read_options - procedure :: check_options - procedure :: read_dimensions - procedure :: read_packages - procedure :: check_packages - procedure :: assign_packagemovers - procedure :: allocate_scalars - procedure :: allocate_arrays - procedure, private :: mvr_setup_budobj - procedure, private :: mvr_fill_budobj - end type GwfMvrType - - contains - - subroutine mvr_cr(mvrobj, name_parent, inunit, iout, iexgmvr, dis) -! ****************************************************************************** -! mvr_cr -- Create a new mvr object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - type(GwfMvrType), pointer :: mvrobj - character(len=*), intent(in) :: name_parent - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - integer(I4B), optional :: iexgmvr - class(DisBaseType), pointer, intent(in), optional :: dis -! ------------------------------------------------------------------------------ - ! - ! -- Create the object - allocate(mvrobj) - ! - ! -- create name and origin. name_parent will either be model name or the - ! exchange name. - call mvrobj%set_names(1, name_parent, 'MVR', 'MVR') - ! - ! -- Allocate scalars - call mvrobj%allocate_scalars() - ! - ! -- Set pointer to dis - if (present(dis)) mvrobj%dis => dis - ! - ! -- Set variables - mvrobj%inunit = inunit - mvrobj%iout = iout - ! - ! -- Set iexgmvr - if(present(iexgmvr)) mvrobj%iexgmvr = iexgmvr - ! - ! -- Create the budget object - if (inunit > 0) then - call budget_cr(mvrobj%budget, mvrobj%origin) - ! - ! -- Initialize block parser - call mvrobj%parser%Initialize(mvrobj%inunit, mvrobj%iout) - endif - ! - ! -- Return - return - end subroutine mvr_cr - - subroutine mvr_ar(this) -! ****************************************************************************** -! mvr_ar -- Allocate and read water mover information -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(GwfMvrType) :: this - ! -- locals -! ------------------------------------------------------------------------------ - ! - ! -- Print a message identifying the water mover package. - write(this%iout, 1) this%inunit - 1 format(1x,/1x,'MVR -- WATER MOVER PACKAGE, VERSION 8, 1/29/2016', & - ' INPUT READ FROM UNIT ', i0) - ! - ! -- Read and check options - call this%read_options() - call this%check_options() - ! - ! -- Read options - call this%read_dimensions() - ! - ! -- Allocate arrays - call this%allocate_arrays() - ! - ! -- Read and check package names - call this%read_packages() - call this%check_packages() - ! - ! -- Define the budget object to be the size of package names - call this%budget%budget_df(this%maxpackages, 'WATER MOVER') - ! - ! -- setup the budget object - call this%mvr_setup_budobj() - ! - ! -- Return - return - end subroutine mvr_ar - - subroutine mvr_rp(this) -! ****************************************************************************** -! mvr_rp -- Read and Prepare -! Subroutine: (1) read itmp -! (2) read new boundaries if itmp>0 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use TdisModule, only: kper, nper - use SimModule, only: ustop, store_error, store_error_unit, count_errors - use ArrayHandlersModule, only: ifind - ! -- dummy - class(GwfMvrType),intent(inout) :: this - ! -- local - integer(I4B) :: i, ierr, nlist, ipos - integer(I4B) :: ii, jj - logical :: isfound, endOfBlock - character(len=LINELENGTH) :: line, errmsg - character(len=LENMODELNAME) :: mname - ! -- formats - character(len=*),parameter :: fmtblkerr = & - "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - character(len=*),parameter :: fmtlsp = & - "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" - character(len=*), parameter :: fmtnbd = & - "(1X,/1X,'THE NUMBER OF ACTIVE ',A,'S (',I6, & - &') IS GREATER THAN MAXIMUM(',I6,')')" -! ------------------------------------------------------------------------------ - ! - ! -- Set ionper to the stress period number for which a new block of data - ! will be read. - if(this%inunit == 0) return - ! - ! -- get stress period data - if (this%ionper < kper) then - ! - ! -- get period block - call this%parser%GetBlock('PERIOD', isfound, ierr, & - supportOpenClose=.true.) - if(isfound) then - ! - ! -- read ionper and check for increasing period numbers - call this%read_check_ionper() - else - ! - ! -- PERIOD block not found - if (ierr < 0) then - ! -- End of file found; data applies for remainder of simulation. - this%ionper = nper + 1 - else - ! -- Found invalid block - write(errmsg, fmtblkerr) adjustl(trim(line)) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - endif - end if - ! - ! -- read data if ionper == kper - if(this%ionper == kper) then - write(this%iout, '(/,2x,a,i0)') 'READING WATER MOVERS FOR PERIOD ', kper - nlist = -1 - i = 1 - ! - ! -- set mname to '' if this is an exchange mover, or to the model name - if(this%iexgmvr == 0) then - mname = this%name_model - else - mname = '' - endif - ! - ! -- Assign a pointer to the package mover object. The pointer assignment - ! will happen only the first time - call this%assign_packagemovers() - ! - ! -- Read each mover entry - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetCurrentLine(line) - ! - ! -- Raise error if movers exceeds maxmvr - if (i > this%maxmvr) then - write(errmsg,'(4x,a,a)')'****ERROR. MOVERS EXCEED MAXMVR ON LINE: ', & - trim(adjustl(line)) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Process the water mover line (mname = '' if this is an exchange) - call this%mvr(i)%set(line, this%parser%iuactive, this%iout, mname, & - this%pakorigins, this%pakmovers) - ! - ! -- Echo input - if(this%iprpak == 1) call this%mvr(i)%echo(this%iout) - ! - ! -- increment counter - i = i + 1 - end do - write(this%iout,'(/,1x,a,1x,i6,/)') 'END OF DATA FOR PERIOD', kper - nlist = i - 1 - ! - ! -- Set the number of movers for this period to nlist - this%nmvr = nlist - write(this%iout, '(4x, i0, a, i0)') this%nmvr, & - ' MOVERS READ FOR PERIOD ', kper - ! - ! -- Check to make sure all providers and receivers are in pakorigins - do i = 1, this%nmvr - ipos = ifind(this%pakorigins, this%mvr(i)%pname1) - if(ipos < 1) then - write(errmsg,'(4x,a,a,a)') 'ERROR. PROVIDER ', & - trim(this%mvr(i)%pname1), ' NOT LISTED IN PACKAGES BLOCK.' - call store_error(errmsg) - endif - ipos = ifind(this%pakorigins, this%mvr(i)%pname2) - if(ipos < 1) then - write(errmsg,'(4x,a,a,a)') 'ERROR. RECEIVER ', & - trim(this%mvr(i)%pname2), ' NOT LISTED IN PACKAGES BLOCK.' - call store_error(errmsg) - endif - enddo - if(count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- reset ientries - do i = 1, this%maxcomb - this%ientries(i) = 0 - end do - ! - ! -- - do i = 1, this%nmvr - ii = ifind(this%pakorigins, this%mvr(i)%pname1) - jj = ifind(this%pakorigins, this%mvr(i)%pname2) - ipos = (ii - 1) * this%maxpackages + jj - this%ientries(ipos) = this%ientries(ipos) + 1 - end do - else - write(this%iout, fmtlsp) 'MVR' - ! - ! -- New stress period, but no new movers. Set qpold to zero - do i = 1, this%nmvr - call this%mvr(i)%set_qpold(DZERO) - enddo - ! - endif - ! - ! -- return - return - end subroutine mvr_rp - - subroutine mvr_ad(this) -! ****************************************************************************** -! mvr_ad -- Advance mover -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(GwfMvrType) :: this - ! -- locals - integer(I4B) :: i -! ------------------------------------------------------------------------------ - ! - do i = 1, this%nmvr - call this%mvr(i)%advance() - enddo - ! - ! -- Return - return - end subroutine mvr_ad - - subroutine mvr_fc(this) -! ****************************************************************************** -! mvr_fc -- Calculate qfrommvr as a function of qtomvr -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(GwfMvrType) :: this - ! -- locals - integer(I4B) :: i -! ------------------------------------------------------------------------------ - ! - do i = 1, this%nmvr - call this%mvr(i)%fc(this%omega) - enddo - ! - ! -- Return - return - end subroutine mvr_fc - - subroutine mvr_cc(this, kiter, iend, icnvgmod, cpak, dpak) -! ****************************************************************************** -! mvr_cc -- extra convergence check for mover -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfMvrType) :: this - integer(I4B),intent(in) :: kiter - integer(I4B),intent(in) :: iend - integer(I4B),intent(in) :: icnvgmod - character(len=LENPAKLOC), intent(inout) :: cpak - real(DP), intent(inout) :: dpak - ! -- local - ! -- formats - character(len=*),parameter :: fmtmvrcnvg = & - "(/,1x,'MOVER PACKAGE REQUIRES AT LEAST TWO OUTER ITERATIONS. CONVERGE & - &FLAG HAS BEEN RESET TO FALSE.')" -! ------------------------------------------------------------------------------ - ! - ! -- If there are active movers, then at least 2 outers required - if (this%nmvr > 0) then - if (icnvgmod == 1 .and. kiter == 1) then - dpak = DNODATA - cpak = trim(this%name) - write(this%iout, fmtmvrcnvg) - endif - endif - ! - ! -- return - return - end subroutine mvr_cc - - subroutine mvr_bd(this, icbcfl, ibudfl, isuppress_output) -! ****************************************************************************** -! mvr_bd -- Write mover terms to listing file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only : kstp, kper, delt, pertim, totim - use InputOutputModule, only: ubdsv06, ubdsvd - ! -- dummy - class(GwfMvrType) :: this - integer(I4B), intent(in) :: icbcfl - integer(I4B), intent(in) :: ibudfl - integer(I4B), intent(in) :: isuppress_output - ! -- locals - integer(I4B) :: i - integer(I4B) :: ibinun - ! -- formats - character(len=*), parameter :: fmttkk = & - "(1X,/1X,A,' PERIOD ',I0,' STEP ',I0)" -! ------------------------------------------------------------------------------ - ! - if(ibudfl /= 0 .and. this%iprflow == 1 .and. isuppress_output == 0) then - write(this%iout, fmttkk) ' MVR SUMMARY', kper, kstp - do i = 1, this%nmvr - call this%mvr(i)%writeflow(this%iout) - enddo - endif - ! - ! -- fill the budget object - call this%mvr_fill_budobj() - ! - ! -- write the flows from the budobj - ibinun = 0 - if(this%ibudgetout /= 0) then - ibinun = this%ibudgetout - end if - if(icbcfl == 0) ibinun = 0 - if (isuppress_output /= 0) ibinun = 0 - if (ibinun > 0) then - call this%budobj%save_flows(this%dis, ibinun, kstp, kper, delt, & - pertim, totim, this%iout) - end if - ! - ! -- Return - return - end subroutine mvr_bd - - subroutine mvr_ot(this) -! ****************************************************************************** -! mvr_ot -- Write mover budget to listing file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: kstp, kper, delt - use ArrayHandlersModule, only: ifind, expandarray - ! -- dummy - class(GwfMvrType) :: this - ! -- locals - character(len=LENORIGIN+1) :: pname - integer(I4B) :: i, j - real(DP), allocatable, dimension(:) :: ratin, ratout -! ------------------------------------------------------------------------------ - ! - ! -- Allocate and initialize ratin/ratout - allocate(ratin(this%maxpackages), ratout(this%maxpackages)) - do j = 1, this%maxpackages - ratin(j) = DZERO - ratout(j) = DZERO - enddo - ! - ! -- Accumulate the rates - do i = 1, this%nmvr - do j = 1, this%maxpackages - if(this%pakorigins(j) == this%mvr(i)%pname1) then - ratin(j) = ratin(j) + this%mvr(i)%qpactual - endif - if(this%pakorigins(j) == this%mvr(i)%pname2) then - ratout(j) = ratout(j) + this%mvr(i)%qpactual - endif - enddo - enddo - ! - ! -- Send rates to budget object - call this%budget%reset() - do j = 1, this%maxpackages - if((this%iexgmvr) == 1) then - pname = this%pakorigins(j) - else - pname = this%paknames(j) - endif - call this%budget%addentry(ratin(j), ratout(j), delt, pname) - enddo - ! - ! -- Write the budget - call this%budget%budget_ot(kstp, kper, this%iout) - ! - ! -- Deallocate - deallocate(ratin, ratout) - ! - ! -- Output mvr budget - ! Not using budobj write_table here because it would result - ! in a table that has one entry. A custom table looks - ! better here with a row for each package. - !call this%budobj%write_budtable(kstp, kper, this%iout) - ! - ! -- Return - return - end subroutine mvr_ot - - subroutine mvr_da(this) -! ****************************************************************************** -! mvr_da -- deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DONE - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(GwfMvrType) :: this - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- Arrays - if (this%inunit > 0) then - call mem_deallocate(this%ientries) - deallocate(this%mvr) - deallocate(this%pakorigins) - deallocate(this%paknames) - deallocate(this%pakmovers) - ! - ! -- budget object - call this%budget%budget_da() - deallocate(this%budget) - ! - ! -- budobj - call this%budobj%budgetobject_da() - deallocate(this%budobj) - nullify(this%budobj) - endif - ! - ! -- Scalars - call mem_deallocate(this%ibudgetout) - call mem_deallocate(this%maxmvr) - call mem_deallocate(this%maxpackages) - call mem_deallocate(this%maxcomb) - call mem_deallocate(this%nmvr) - call mem_deallocate(this%iexgmvr) - call mem_deallocate(this%imodelnames) - call mem_deallocate(this%omega) - ! - ! -- deallocate scalars in NumericalPackageType - call this%NumericalPackageType%da() - ! - ! -- Return - return - end subroutine mvr_da - - subroutine read_options(this) -! ****************************************************************************** -! read_options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH, DZERO, DONE - use OpenSpecModule, only: access, form - use SimModule, only: ustop, store_error, store_error_unit - use InputOutputModule, only: urword, getunit, openfile - ! -- dummy - class(GwfMvrType) :: this - ! -- local - character(len=LINELENGTH) :: errmsg - character(len=MAXCHARLEN) :: fname, keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock - ! -- formats - character(len=*),parameter :: fmtmvrbin = & - "(4x, 'MVR ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" -! ------------------------------------------------------------------------------ - ! - ! -- 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 MVR OPTIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case('BUDGET') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ibudgetout = getunit() - call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE') - write(this%iout,fmtmvrbin) 'BUDGET', fname, this%ibudgetout - else - call store_error('OPTIONAL BUDGET KEYWORD MUST BE FOLLOWED BY FILEOUT') - end if - case ('PRINT_INPUT') - this%iprpak = 1 - write(this%iout,'(4x,a)') 'WATER MOVER INPUT '// & - 'WILL BE PRINTED TO LIST FILE.' - case ('PRINT_FLOWS') - this%iprflow = 1 - write(this%iout,'(4x,a)') 'LISTS OF WATER MOVER FLOWS '// & - 'WILL BE PRINTED TO LIST FILE.' - case ('MODELNAMES') - this%imodelnames = 1 - write(this%iout,'(4x,a)') 'ALL PACKAGE NAMES ARE PRECEDED '// & - 'BY THE NAME OF THE MODEL CONTAINING THE PACKAGE.' - if (this%iexgmvr == 0) then - write(errmsg,'(4x,a,a)') & - '****ERROR. MODELNAMES CANNOT BE SPECIFIED UNLESS THE ' // & - 'MOVER PACKAGE IS FOR AN EXCHANGE.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN MVR OPTION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - end do - write(this%iout,'(1x,a)')'END OF MVR OPTIONS' - end if - ! - ! -- Return - return - end subroutine read_options - - subroutine check_options(this) -! ****************************************************************************** -! check_options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, store_error_unit - ! -- dummy - class(GwfMvrType) :: this - ! -- local - character(len=LINELENGTH) :: errmsg - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- Check if not exchange mover but model names are specified - if (this%iexgmvr == 0 .and. this%imodelnames == 1) then - write(errmsg,'(4x,a,a)') & - '****ERROR. MODELNAMES CANNOT BE SPECIFIED UNLESS THE ' // & - 'MOVER PACKAGE IS FOR AN EXCHANGE.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Check if exchange mover but model names not specified - if (this%iexgmvr /= 0 .and. this%imodelnames == 0) then - write(errmsg,'(4x,a,a)') & - '****ERROR. MODELNAMES OPTION MUST BE SPECIFIED BECAUSE ' // & - 'MOVER PACKAGE IS FOR AN EXCHANGE.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Return - return - end subroutine check_options - - subroutine read_dimensions(this) -! ****************************************************************************** -! read_dimensions -- Read the dimensions for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors, store_error_unit - ! -- dummy - class(GwfMvrType),intent(inout) :: this - ! -- local - character (len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock - integer(I4B) :: i - integer(I4B) :: j - ! -- format -! ------------------------------------------------------------------------------ - ! - ! -- 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 MVR DIMENSIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('MAXMVR') - this%maxmvr = this%parser%GetInteger() - write(this%iout,'(4x,a,i0)')'MAXMVR = ', this%maxmvr - case ('MAXPACKAGES') - this%maxpackages = this%parser%GetInteger() - write(this%iout,'(4x,a,i0)')'MAXPACKAGES = ', this%maxpackages - case default - write(errmsg,'(4x,a,a)') & - '****ERROR. UNKNOWN MVR DIMENSION: ', trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - end do - write(this%iout,'(1x,a)')'END OF MVR DIMENSIONS' - else - call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- calculate maximum number of combinations - this%maxcomb = 0 - do i = 1, this%maxpackages - do j = 1, this%maxpackages - this%maxcomb = this%maxcomb + 1 - end do - end do - ! - ! -- verify dimensions were set - if(this%maxmvr < 0) then - write(errmsg, '(1x,a)') & - 'ERROR. MAXMVR WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - if(this%maxpackages < 0) then - write(errmsg, '(1x,a)') & - 'ERROR. MAXPACKAGES WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- return - return - end subroutine read_dimensions - - subroutine read_packages(this) -! ****************************************************************************** -! read_packages -- Read the packages that will be managed by this mover -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors, store_error_unit - ! -- dummy - class(GwfMvrType),intent(inout) :: this - ! -- local - character (len=LINELENGTH) :: errmsg, word, word1, word2 - integer(I4B) :: lloc, ierr - integer(I4B) :: npak - logical :: isfound, endOfBlock - ! -- format -! ------------------------------------------------------------------------------ - ! - ! -- get packages block - call this%parser%GetBlock('PACKAGES', isfound, ierr, & - supportOpenClose=.true.) - ! - ! -- parse packages block - if (isfound) then - write(this%iout,'(/1x,a)')'PROCESSING MVR PACKAGES' - npak = 0 - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(word1) - lloc = 1 - npak = npak + 1 - if (npak > this%maxpackages) then - call store_error('ERROR. MAXPACKAGES NOT SET LARGE ENOUGH.') - call this%parser%StoreErrorUnit() - call ustop() - endif - if(this%iexgmvr == 0) then - this%pakorigins(npak) = trim(adjustl(this%name_model)) // ' ' // & - trim(word1) - word = word1 - else - this%pakorigins(npak) = trim(word1) - call this%parser%GetStringCaps(word2) - this%pakorigins(npak) = trim(this%pakorigins(npak)) // ' ' // & - trim(word2) - word = word2 - endif - this%paknames(npak) = trim(word) - write(this%iout,'(3x,a,a)')'INCLUDING PACKAGE: ', & - trim(this%pakorigins(npak)) - end do - write(this%iout,'(1x,a)')'END OF MVR PACKAGES' - else - call store_error('ERROR. REQUIRED PACKAGES BLOCK NOT FOUND.') - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- Check to make sure npak = this%maxpackages - if(npak /= this%maxpackages) then - write(errmsg, '(a, i0, a, i0, a)') & - 'ERROR. NUMBER OF PACKAGES (', npak, ') DOES NOT EQUAL ' // & - 'MAXPACKAGES (', this%maxpackages, ').' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- return - return - end subroutine read_packages - - subroutine check_packages(this) -! ****************************************************************************** -! check_packages -- check to make sure packages have mover activated -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use MemoryManagerModule, only: mem_setptr - use SimModule, only: ustop, store_error, count_errors, store_error_unit - ! -- dummy - class(GwfMvrType),intent(inout) :: this - ! -- local - character (len=LINELENGTH) :: errmsg - integer(I4B) :: i - integer(I4B), pointer :: imover_ptr - ! -- format -! ------------------------------------------------------------------------------ - ! - ! -- Check to make sure mover is activated for each package - do i = 1, size(this%pakorigins) - imover_ptr => null() - call mem_setptr(imover_ptr, 'IMOVER', trim(this%pakorigins(i))) - if (imover_ptr == 0) then - write(errmsg, '(a, a, a)') & - 'ERROR. MODEL AND PACKAGE "', & - trim(this%pakorigins(i)), & - '" DOES NOT HAVE MOVER SPECIFIED IN OPTIONS BLOCK.' - call store_error(errmsg) - end if - end do - ! - ! -- Terminate if errors detected. - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- return - return - end subroutine check_packages - - subroutine assign_packagemovers(this) -! ****************************************************************************** -! assign_packagemovers -- assign pointer to each package's packagemover object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use PackageMoverModule, only: set_packagemover_pointer - ! -- dummy - class(GwfMvrType),intent(inout) :: this - ! -- local - integer(I4B) :: i - ! -- format -! ------------------------------------------------------------------------------ - ! - ! -- Assign the package mover pointer if it hasn't been assigned yet - do i = 1, size(this%pakorigins) - if (this%pakmovers(i)%origin == '') then - call set_packagemover_pointer(this%pakmovers(i), & - trim(this%pakorigins(i))) - end if - end do - ! - ! -- return - return - end subroutine assign_packagemovers - - subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DONE - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(GwfMvrType) :: this - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- allocate scalars in NumericalPackageType - call this%NumericalPackageType%allocate_scalars() - ! - ! -- Allocate - call mem_allocate(this%ibudgetout, 'IBUDGETOUT', this%origin) - call mem_allocate(this%omega, 'OMEGA', this%origin) - call mem_allocate(this%maxmvr, 'MAXMVR', this%origin) - call mem_allocate(this%maxpackages, 'MAXPACKAGES', this%origin) - call mem_allocate(this%maxcomb, 'MAXCOMB', this%origin) - call mem_allocate(this%nmvr, 'NMVR', this%origin) - call mem_allocate(this%iexgmvr, 'IEXGMVR', this%origin) - call mem_allocate(this%imodelnames, 'IMODELNAMES', this%origin) - ! - ! -- Initialize - this%ibudgetout = 0 - this%maxmvr = -1 - this%maxpackages = -1 - this%maxcomb = 0 - this%nmvr = 0 - this%iexgmvr = 0 - this%imodelnames = 0 - this%omega = DONE - ! - ! -- Return - return - end subroutine allocate_scalars - - subroutine allocate_arrays(this) -! ****************************************************************************** -! allocate_arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - use ConstantsModule, only: DZERO - use PackageMoverModule, only: nulllify_packagemover_pointer - ! -- dummy - class(GwfMvrType) :: this - ! -- local - integer(I4B) :: i -! ------------------------------------------------------------------------------ - ! - ! -- Allocate - allocate(this%mvr(this%maxmvr)) - allocate(this%pakorigins(this%maxpackages)) - allocate(this%paknames(this%maxpackages)) - allocate(this%pakmovers(this%maxpackages)) - ! - ! -- nullify the pakmovers - do i = 1, this%maxpackages - call nulllify_packagemover_pointer(this%pakmovers(i)) - end do - ! - ! -- allocate the object and assign values to object variables - call mem_allocate(this%ientries, this%maxcomb, 'IENTRIES', this%origin) - ! - ! -- Return - return - end subroutine allocate_arrays - - subroutine mvr_setup_budobj(this) -! ****************************************************************************** -! mvr_setup_budobj -- Set up the budget object that stores all the mvr flows -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LENBUDTXT - ! -- dummy - class(GwfMvrType) :: this - ! -- local - integer(I4B) :: nbudterm - integer(I4B) :: ncv - integer(I4B) :: i - integer(I4B) :: j - integer(I4B) :: ival - integer(I4B) :: naux - integer(I4B) :: lloc - integer(I4B) :: istart - integer(I4B) :: istop - real(DP) :: rval - character (len=LENMODELNAME) :: modelname1, modelname2 - character (len=LENPACKAGENAME) :: packagename1, packagename2 - character (len=LENORIGIN+1) :: pakoriginsdummy - integer(I4B) :: maxlist - integer(I4B) :: idx - character(len=LENBUDTXT) :: text -! ------------------------------------------------------------------------------ - ! - ! -- Determine the number of mover budget terms. These are fixed for - ! the simulation and cannot change. A separate term is required - ! for each possible provider/receiver combination. - nbudterm = 0 - do i = 1, this%maxpackages - do j = 1, this%maxpackages - nbudterm = nbudterm + 1 - end do - end do - ! - ! -- Number of control volumes is set to be 0, because there aren't - ! any for the mover - ncv = 0 - ! - ! -- set up budobj - call budgetobject_cr(this%budobj, 'WATER MOVER') - call this%budobj%budgetobject_df(ncv, nbudterm, 0, 0) - idx = 0 - ! - ! -- Go through and set up each budget term - text = ' MOVER-FLOW' - maxlist = this%maxmvr - naux = 0 - do i = 1, this%maxpackages - lloc = 1 - call urword(this%pakorigins(i), lloc, istart, istop, 1, ival, rval, -1, -1) - pakoriginsdummy = this%pakorigins(i) - modelname1 = pakoriginsdummy(istart:istop) - call urword(this%pakorigins(i), lloc, istart, istop, 1, ival, rval, -1, -1) - pakoriginsdummy = this%pakorigins(i) - packagename1 = pakoriginsdummy(istart:istop) - do j = 1, this%maxpackages - lloc = 1 - call urword(this%pakorigins(j), lloc, istart, istop, 1, ival, rval, -1, -1) - pakoriginsdummy = this%pakorigins(j) - modelname2 = pakoriginsdummy(istart:istop) - call urword(this%pakorigins(j), lloc, istart, istop, 1, ival, rval, -1, -1) - pakoriginsdummy = this%pakorigins(j) - packagename2 = pakoriginsdummy(istart:istop) - idx = idx + 1 - call this%budobj%budterm(idx)%initialize(text, & - modelname1, & - packagename1, & - modelname2, & - packagename2, & - maxlist, .false., .false., & - naux) - end do - end do - ! - ! -- return - return - end subroutine mvr_setup_budobj - - subroutine mvr_fill_budobj(this) -! ****************************************************************************** -! mvr_fill_budobj -- copy flow terms into this%budobj -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(GwfMvrType) :: this - ! -- local - integer(I4B) :: idx - integer(I4B) :: i - integer(I4B) :: j - integer(I4B) :: n, n1, n2 - integer(I4B) :: ipos - integer(I4B) :: ival - integer(I4B) :: nitems - integer(I4B) :: lloc - integer(I4B) :: istart - integer(I4B) :: istop - real(DP) :: rval - character (len=LENMODELNAME) :: modelname1, modelname2 - character (len=LENPACKAGENAME) :: packagename1, packagename2 - character (len=LENORIGIN+1) :: pakoriginsdummy - real(DP) :: q - ! -- formats -! ----------------------------------------------------------------------------- - ! - ! -- initialize counter - idx = 0 - - - do i = 1, this%maxpackages - ! -- Retrieve modelname1 and packagename1 - lloc = 1 - call urword(this%pakorigins(i), lloc, istart, istop, 1, ival, rval, -1, -1) - pakoriginsdummy = this%pakorigins(i) - modelname1 = pakoriginsdummy(istart:istop) - call urword(this%pakorigins(i), lloc, istart, istop, 1, ival, rval, -1, -1) - pakoriginsdummy = this%pakorigins(i) - packagename1 = pakoriginsdummy(istart:istop) - do j = 1, this%maxpackages - ! -- Retrieve modelname2 and packagename2 - lloc = 1 - call urword(this%pakorigins(j), lloc, istart, istop, 1, ival, rval, -1, -1) - pakoriginsdummy = this%pakorigins(j) - modelname2 = pakoriginsdummy(istart:istop) - call urword(this%pakorigins(j), lloc, istart, istop, 1, ival, rval, -1, -1) - pakoriginsdummy = this%pakorigins(j) - packagename2 = pakoriginsdummy(istart:istop) - ipos = (i - 1) * this%maxpackages + j - nitems = this%ientries(ipos) - ! - ! -- nitems is the number of mover connections for this - ! model-package / model-package combination. Cycle if none. - idx = idx + 1 - call this%budobj%budterm(idx)%reset(nitems) - if (nitems < 1) cycle - do n = 1, this%nmvr - ! - ! -- pname1 is provider, pname2 is receiver - ! flow is always negative because it is coming from provider - if(this%pakorigins(i) == this%mvr(n)%pname1) then - if(this%pakorigins(j) == this%mvr(n)%pname2) then - q = -this%mvr(n)%qpactual - n1 = this%mvr(n)%irch1 - n2 = this%mvr(n)%irch2 - call this%budobj%budterm(idx)%update_term(n1, n2, q) - end if - end if - end do - end do - end do - ! - ! --Terms are filled, now accumulate them for this time step - call this%budobj%accumulate_terms() - ! - ! -- return - return - end subroutine mvr_fill_budobj - -end module +!GWF Water Mover Module +!This module contains a derived type, called GwfMvrType, that +!is attached to the GWF model. The water mover can be used to move water +!between packages. The mover requires that mover-aware packages have access +!to four arrays: qtformvr, qformvr, qtomvr, and qfrommvr. These arrays are +!stored and managed by a separate PackageMoverType object. qformvr is a +!vector of volumetric flow rates available for the mover. The package +!must fill the vector (dimensioned by number of reaches) with the available +!water. qtomvr is a vector containing how much water was actually moved +!by the mover. The package should use this value in the budgeting part +!to track how much water was actually provided to the mover. Lastly, +!the qfrommvr is a vector that contains volumetric rates for how much +!water was provided by the mover as a source of water to the package. +! +!The mover is designed so that a reach can provide water to more than one +!receiving reaches. The available water will be consumed in order of +!the movers listed in the package. The mover is also designed so that +!a receiver can receive water from more than one provider. +! +! 1. The mover is instantiated as a model member: +! +! type(GwfMvrType), pointer :: mvr => null() +! +! Mover aware packages have access to the following vectors of mover +! information, which are stored in the PackageMoverType object: +! +! integer(I4B), pointer :: imover => null() +! real(DP), dimension(:), pointer, contiguous :: qtformvr => null() +! real(DP), dimension(:), pointer, contiguous :: qformvr => null() +! real(DP), dimension(:), pointer, contiguous :: qtomvr => null() +! real(DP), dimension(:), pointer, contiguous :: qfrommvr => null() +! +! Note qtformvr is filled as a positive number to indicate that it is +! water available to be moved. If qtformvr is negative, then +! no water will be moved for that reach. qformvr is also the available +! water, but this value decreases as the mover object consumes water from +! it. +! +! 2. In gwf_cr create the mover package by calling the CR subroutine: +! +! call mvr_cr(this%mvr, this%name, this%inmvr, this%iout) +! +! 3. In gwf_ar call the AR method for the mover: +! +! if(this%inmvr > 0) call this%mvr%mvr_ar() +! +! Mover aware packages allocate the four vectors. The first three +! (qtformvr, qformvr, qtomvr) are allocated to the number of providers +! and the last one (qfrommvr) is allocated to the number of receivers. +! +! 4. In gwf_rp call the RP method for the mover. This reads the +! movers active for the current period. +! +! if(this%inmvr > 0) call this%mvr%mvr_rp() +! +! 5. In gwf_ad call the AD method for the mover. This saves qtomvr from the +! the last time step. +! +! if(this%inmvr > 0) call this%mvr%mvr_ad() +! +! Mover aware packages then set: +! qtomvr(:) = 0. +! qformvr(:) = 0. +! +! 6. In gwf_cf call the CF routine. Mover aware packages set: +! qtformvr(:) = qformvr(:) +! qfrommvr(:) = 0. +! qtomvr(:) = 0. +! +! 7. The FC method for the mover is called. This method calculates the +! amount of water to move based on the amount of water available from the +! previous iteration. This call updates the values in the qtomvr and +! qfrommvr vectors inside the packages. This is done by the mover package +! using pointers to the appropriate reach locations in qtomvr and qfrommvr. +! +! if(this%inmvr > 0) call this%mvr%mvr_fc() ! called from gwf%gwf_fc() +! +! a. Mover aware packages first set qformvr(:) = 0. +! b. Mover aware packages that are receivers (MAW, SFR, LAK, UZF) add +! qfrommvr terms to their individual control volume equations as a +! source of water. +! c. Mover aware packages calculate qformvr as amount of water available +! to be moved (these qformvr terms are used in the next iteration +! by this%mvr%mvr_fc() to calculate how much water is actually moved) +! +! 8. The BD method for the mover is called. This method writes the moved +! water rates if requested. +! +! if(this%inmvr > 0) call this%mvr%mvr_bd() +! +! Mover aware packages account for qtomvr and qfrommvr terms in their +! individual budget routines. +! +! 9. The OT method for the mover is called. This method outputs a mover +! budget table. +! +! if(this%inmvr > 0) call this%mvr%mvr_ot() +! +module GwfMvrModule + use KindModule, only: DP, I4B + use ConstantsModule, only: LENORIGIN, LENPACKAGENAME, LENMODELNAME, & + LENBUDTXT, LENAUXNAME, LENPAKLOC, & + DZERO, DNODATA, MAXCHARLEN + use MvrModule, only: MvrType + use BudgetModule, only: BudgetType, budget_cr + use BudgetObjectModule, only: BudgetObjectType, budgetobject_cr + use NumericalPackageModule, only: NumericalPackageType + use BlockParserModule, only: BlockParserType + use PackageMoverModule, only: PackageMoverType + use BaseDisModule, only: DisBaseType + use InputOutputModule, only: urword + + implicit none + private + public :: GwfMvrType, mvr_cr + + type, extends(NumericalPackageType) :: GwfMvrType + integer(I4B), pointer :: ibudgetout => null() !binary budget output file + integer(I4B), pointer :: maxmvr => null() !max number of movers to be specified + integer(I4B), pointer :: maxpackages => null() !max number of packages to be specified + integer(I4B), pointer :: maxcomb => null() !max number of combination of packages + integer(I4B), pointer :: nmvr => null() !number of movers for current stress period + integer(I4B), pointer :: iexgmvr => null() !indicate mover is for an exchange (not for a single model) + integer(I4B), pointer :: imodelnames => null() !indicate package input file has model names in it + real(DP), pointer :: omega => null() !temporal weighting factor (not presently used) + integer(I4B), dimension(:), pointer, contiguous :: ientries => null() !number of entries for each combination + character(len=LENORIGIN+1), & + dimension(:), pointer, contiguous :: pakorigins !array of model//package names + character(len=LENPACKAGENAME), & + dimension(:), pointer, contiguous :: paknames => null() !array of package names + type(MvrType), dimension(:), pointer, contiguous :: mvr => null() !array of movers + type(BudgetType), pointer :: budget => null() !mover budget object (used to write table) + type(BudgetObjectType), pointer :: budobj => null() !new budget container (used to write binary file) + type(PackageMoverType), & + dimension(:), pointer, contiguous :: pakmovers => null() !pointer to package mover objects + contains + procedure :: mvr_ar + procedure :: mvr_rp + procedure :: mvr_ad + procedure :: mvr_fc + procedure :: mvr_cc + procedure :: mvr_bd + procedure :: mvr_ot + procedure :: mvr_da + procedure :: read_options + procedure :: check_options + procedure :: read_dimensions + procedure :: read_packages + procedure :: check_packages + procedure :: assign_packagemovers + procedure :: allocate_scalars + procedure :: allocate_arrays + procedure, private :: mvr_setup_budobj + procedure, private :: mvr_fill_budobj + end type GwfMvrType + + contains + + subroutine mvr_cr(mvrobj, name_parent, inunit, iout, iexgmvr, dis) +! ****************************************************************************** +! mvr_cr -- Create a new mvr object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + type(GwfMvrType), pointer :: mvrobj + character(len=*), intent(in) :: name_parent + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + integer(I4B), optional :: iexgmvr + class(DisBaseType), pointer, intent(in), optional :: dis +! ------------------------------------------------------------------------------ + ! + ! -- Create the object + allocate(mvrobj) + ! + ! -- create name and origin. name_parent will either be model name or the + ! exchange name. + call mvrobj%set_names(1, name_parent, 'MVR', 'MVR') + ! + ! -- Allocate scalars + call mvrobj%allocate_scalars() + ! + ! -- Set pointer to dis + if (present(dis)) mvrobj%dis => dis + ! + ! -- Set variables + mvrobj%inunit = inunit + mvrobj%iout = iout + ! + ! -- Set iexgmvr + if(present(iexgmvr)) mvrobj%iexgmvr = iexgmvr + ! + ! -- Create the budget object + if (inunit > 0) then + call budget_cr(mvrobj%budget, mvrobj%origin) + ! + ! -- Initialize block parser + call mvrobj%parser%Initialize(mvrobj%inunit, mvrobj%iout) + endif + ! + ! -- Return + return + end subroutine mvr_cr + + subroutine mvr_ar(this) +! ****************************************************************************** +! mvr_ar -- Allocate and read water mover information +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfMvrType) :: this + ! -- locals +! ------------------------------------------------------------------------------ + ! + ! -- Print a message identifying the water mover package. + write(this%iout, 1) this%inunit + 1 format(1x,/1x,'MVR -- WATER MOVER PACKAGE, VERSION 8, 1/29/2016', & + ' INPUT READ FROM UNIT ', i0) + ! + ! -- Read and check options + call this%read_options() + call this%check_options() + ! + ! -- Read options + call this%read_dimensions() + ! + ! -- Allocate arrays + call this%allocate_arrays() + ! + ! -- Read and check package names + call this%read_packages() + call this%check_packages() + ! + ! -- Define the budget object to be the size of package names + call this%budget%budget_df(this%maxpackages, 'WATER MOVER') + ! + ! -- setup the budget object + call this%mvr_setup_budobj() + ! + ! -- Return + return + end subroutine mvr_ar + + subroutine mvr_rp(this) +! ****************************************************************************** +! mvr_rp -- Read and Prepare +! Subroutine: (1) read itmp +! (2) read new boundaries if itmp>0 +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use TdisModule, only: kper, nper + use SimModule, only: ustop, store_error, store_error_unit, count_errors + use ArrayHandlersModule, only: ifind + ! -- dummy + class(GwfMvrType),intent(inout) :: this + ! -- local + integer(I4B) :: i, ierr, nlist, ipos + integer(I4B) :: ii, jj + logical :: isfound, endOfBlock + character(len=LINELENGTH) :: line, errmsg + character(len=LENMODELNAME) :: mname + ! -- formats + character(len=*),parameter :: fmtblkerr = & + "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + character(len=*),parameter :: fmtlsp = & + "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" + character(len=*), parameter :: fmtnbd = & + "(1X,/1X,'THE NUMBER OF ACTIVE ',A,'S (',I6, & + &') IS GREATER THAN MAXIMUM(',I6,')')" +! ------------------------------------------------------------------------------ + ! + ! -- Set ionper to the stress period number for which a new block of data + ! will be read. + if(this%inunit == 0) return + ! + ! -- get stress period data + if (this%ionper < kper) then + ! + ! -- get period block + call this%parser%GetBlock('PERIOD', isfound, ierr, & + supportOpenClose=.true.) + if(isfound) then + ! + ! -- read ionper and check for increasing period numbers + call this%read_check_ionper() + else + ! + ! -- PERIOD block not found + if (ierr < 0) then + ! -- End of file found; data applies for remainder of simulation. + this%ionper = nper + 1 + else + ! -- Found invalid block + write(errmsg, fmtblkerr) adjustl(trim(line)) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end if + endif + end if + ! + ! -- read data if ionper == kper + if(this%ionper == kper) then + write(this%iout, '(/,2x,a,i0)') 'READING WATER MOVERS FOR PERIOD ', kper + nlist = -1 + i = 1 + ! + ! -- set mname to '' if this is an exchange mover, or to the model name + if(this%iexgmvr == 0) then + mname = this%name_model + else + mname = '' + endif + ! + ! -- Assign a pointer to the package mover object. The pointer assignment + ! will happen only the first time + call this%assign_packagemovers() + ! + ! -- Read each mover entry + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetCurrentLine(line) + ! + ! -- Raise error if movers exceeds maxmvr + if (i > this%maxmvr) then + write(errmsg,'(4x,a,a)')'****ERROR. MOVERS EXCEED MAXMVR ON LINE: ', & + trim(adjustl(line)) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Process the water mover line (mname = '' if this is an exchange) + call this%mvr(i)%set(line, this%parser%iuactive, this%iout, mname, & + this%pakorigins, this%pakmovers) + ! + ! -- Echo input + if(this%iprpak == 1) call this%mvr(i)%echo(this%iout) + ! + ! -- increment counter + i = i + 1 + end do + write(this%iout,'(/,1x,a,1x,i6,/)') 'END OF DATA FOR PERIOD', kper + nlist = i - 1 + ! + ! -- Set the number of movers for this period to nlist + this%nmvr = nlist + write(this%iout, '(4x, i0, a, i0)') this%nmvr, & + ' MOVERS READ FOR PERIOD ', kper + ! + ! -- Check to make sure all providers and receivers are in pakorigins + do i = 1, this%nmvr + ipos = ifind(this%pakorigins, this%mvr(i)%pname1) + if(ipos < 1) then + write(errmsg,'(4x,a,a,a)') 'ERROR. PROVIDER ', & + trim(this%mvr(i)%pname1), ' NOT LISTED IN PACKAGES BLOCK.' + call store_error(errmsg) + endif + ipos = ifind(this%pakorigins, this%mvr(i)%pname2) + if(ipos < 1) then + write(errmsg,'(4x,a,a,a)') 'ERROR. RECEIVER ', & + trim(this%mvr(i)%pname2), ' NOT LISTED IN PACKAGES BLOCK.' + call store_error(errmsg) + endif + enddo + if(count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- reset ientries + do i = 1, this%maxcomb + this%ientries(i) = 0 + end do + ! + ! -- + do i = 1, this%nmvr + ii = ifind(this%pakorigins, this%mvr(i)%pname1) + jj = ifind(this%pakorigins, this%mvr(i)%pname2) + ipos = (ii - 1) * this%maxpackages + jj + this%ientries(ipos) = this%ientries(ipos) + 1 + end do + else + write(this%iout, fmtlsp) 'MVR' + ! + ! -- New stress period, but no new movers. Set qpold to zero + do i = 1, this%nmvr + call this%mvr(i)%set_qpold(DZERO) + enddo + ! + endif + ! + ! -- return + return + end subroutine mvr_rp + + subroutine mvr_ad(this) +! ****************************************************************************** +! mvr_ad -- Advance mover +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfMvrType) :: this + ! -- locals + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + do i = 1, this%nmvr + call this%mvr(i)%advance() + enddo + ! + ! -- Return + return + end subroutine mvr_ad + + subroutine mvr_fc(this) +! ****************************************************************************** +! mvr_fc -- Calculate qfrommvr as a function of qtomvr +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfMvrType) :: this + ! -- locals + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + do i = 1, this%nmvr + call this%mvr(i)%fc(this%omega) + enddo + ! + ! -- Return + return + end subroutine mvr_fc + + subroutine mvr_cc(this, kiter, iend, icnvgmod, cpak, dpak) +! ****************************************************************************** +! mvr_cc -- extra convergence check for mover +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfMvrType) :: this + integer(I4B),intent(in) :: kiter + integer(I4B),intent(in) :: iend + integer(I4B),intent(in) :: icnvgmod + character(len=LENPAKLOC), intent(inout) :: cpak + real(DP), intent(inout) :: dpak + ! -- local + ! -- formats + character(len=*),parameter :: fmtmvrcnvg = & + "(/,1x,'MOVER PACKAGE REQUIRES AT LEAST TWO OUTER ITERATIONS. CONVERGE & + &FLAG HAS BEEN RESET TO FALSE.')" +! ------------------------------------------------------------------------------ + ! + ! -- If there are active movers, then at least 2 outers required + if (this%nmvr > 0) then + if (icnvgmod == 1 .and. kiter == 1) then + dpak = DNODATA + cpak = trim(this%name) + write(this%iout, fmtmvrcnvg) + endif + endif + ! + ! -- return + return + end subroutine mvr_cc + + subroutine mvr_bd(this, icbcfl, ibudfl, isuppress_output) +! ****************************************************************************** +! mvr_bd -- Write mover terms to listing file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only : kstp, kper, delt, pertim, totim + use InputOutputModule, only: ubdsv06, ubdsvd + ! -- dummy + class(GwfMvrType) :: this + integer(I4B), intent(in) :: icbcfl + integer(I4B), intent(in) :: ibudfl + integer(I4B), intent(in) :: isuppress_output + ! -- locals + integer(I4B) :: i + integer(I4B) :: ibinun + ! -- formats + character(len=*), parameter :: fmttkk = & + "(1X,/1X,A,' PERIOD ',I0,' STEP ',I0)" +! ------------------------------------------------------------------------------ + ! + if(ibudfl /= 0 .and. this%iprflow == 1 .and. isuppress_output == 0) then + write(this%iout, fmttkk) ' MVR SUMMARY', kper, kstp + do i = 1, this%nmvr + call this%mvr(i)%writeflow(this%iout) + enddo + endif + ! + ! -- fill the budget object + call this%mvr_fill_budobj() + ! + ! -- write the flows from the budobj + ibinun = 0 + if(this%ibudgetout /= 0) then + ibinun = this%ibudgetout + end if + if(icbcfl == 0) ibinun = 0 + if (isuppress_output /= 0) ibinun = 0 + if (ibinun > 0) then + call this%budobj%save_flows(this%dis, ibinun, kstp, kper, delt, & + pertim, totim, this%iout) + end if + ! + ! -- Return + return + end subroutine mvr_bd + + subroutine mvr_ot(this) +! ****************************************************************************** +! mvr_ot -- Write mover budget to listing file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: kstp, kper, delt + use ArrayHandlersModule, only: ifind, expandarray + ! -- dummy + class(GwfMvrType) :: this + ! -- locals + character(len=LENORIGIN+1) :: pname + integer(I4B) :: i, j + real(DP), allocatable, dimension(:) :: ratin, ratout +! ------------------------------------------------------------------------------ + ! + ! -- Allocate and initialize ratin/ratout + allocate(ratin(this%maxpackages), ratout(this%maxpackages)) + do j = 1, this%maxpackages + ratin(j) = DZERO + ratout(j) = DZERO + enddo + ! + ! -- Accumulate the rates + do i = 1, this%nmvr + do j = 1, this%maxpackages + if(this%pakorigins(j) == this%mvr(i)%pname1) then + ratin(j) = ratin(j) + this%mvr(i)%qpactual + endif + if(this%pakorigins(j) == this%mvr(i)%pname2) then + ratout(j) = ratout(j) + this%mvr(i)%qpactual + endif + enddo + enddo + ! + ! -- Send rates to budget object + call this%budget%reset() + do j = 1, this%maxpackages + if((this%iexgmvr) == 1) then + pname = this%pakorigins(j) + else + pname = this%paknames(j) + endif + call this%budget%addentry(ratin(j), ratout(j), delt, pname) + enddo + ! + ! -- Write the budget + call this%budget%budget_ot(kstp, kper, this%iout) + ! + ! -- Deallocate + deallocate(ratin, ratout) + ! + ! -- Output mvr budget + ! Not using budobj write_table here because it would result + ! in a table that has one entry. A custom table looks + ! better here with a row for each package. + !call this%budobj%write_budtable(kstp, kper, this%iout) + ! + ! -- Return + return + end subroutine mvr_ot + + subroutine mvr_da(this) +! ****************************************************************************** +! mvr_da -- deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DONE + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(GwfMvrType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Arrays + if (this%inunit > 0) then + call mem_deallocate(this%ientries) + deallocate(this%mvr) + deallocate(this%pakorigins) + deallocate(this%paknames) + deallocate(this%pakmovers) + ! + ! -- budget object + call this%budget%budget_da() + deallocate(this%budget) + ! + ! -- budobj + call this%budobj%budgetobject_da() + deallocate(this%budobj) + nullify(this%budobj) + endif + ! + ! -- Scalars + call mem_deallocate(this%ibudgetout) + call mem_deallocate(this%maxmvr) + call mem_deallocate(this%maxpackages) + call mem_deallocate(this%maxcomb) + call mem_deallocate(this%nmvr) + call mem_deallocate(this%iexgmvr) + call mem_deallocate(this%imodelnames) + call mem_deallocate(this%omega) + ! + ! -- deallocate scalars in NumericalPackageType + call this%NumericalPackageType%da() + ! + ! -- Return + return + end subroutine mvr_da + + subroutine read_options(this) +! ****************************************************************************** +! read_options +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH, DZERO, DONE + use OpenSpecModule, only: access, form + use SimModule, only: ustop, store_error, store_error_unit + use InputOutputModule, only: urword, getunit, openfile + ! -- dummy + class(GwfMvrType) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + character(len=MAXCHARLEN) :: fname, keyword + integer(I4B) :: ierr + logical :: isfound, endOfBlock + ! -- formats + character(len=*),parameter :: fmtmvrbin = & + "(4x, 'MVR ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" +! ------------------------------------------------------------------------------ + ! + ! -- 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 MVR OPTIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case('BUDGET') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ibudgetout = getunit() + call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE') + write(this%iout,fmtmvrbin) 'BUDGET', fname, this%ibudgetout + else + call store_error('OPTIONAL BUDGET KEYWORD MUST BE FOLLOWED BY FILEOUT') + end if + case ('PRINT_INPUT') + this%iprpak = 1 + write(this%iout,'(4x,a)') 'WATER MOVER INPUT '// & + 'WILL BE PRINTED TO LIST FILE.' + case ('PRINT_FLOWS') + this%iprflow = 1 + write(this%iout,'(4x,a)') 'LISTS OF WATER MOVER FLOWS '// & + 'WILL BE PRINTED TO LIST FILE.' + case ('MODELNAMES') + this%imodelnames = 1 + write(this%iout,'(4x,a)') 'ALL PACKAGE NAMES ARE PRECEDED '// & + 'BY THE NAME OF THE MODEL CONTAINING THE PACKAGE.' + if (this%iexgmvr == 0) then + write(errmsg,'(4x,a,a)') & + '****ERROR. MODELNAMES CANNOT BE SPECIFIED UNLESS THE ' // & + 'MOVER PACKAGE IS FOR AN EXCHANGE.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + case default + write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN MVR OPTION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + end do + write(this%iout,'(1x,a)')'END OF MVR OPTIONS' + end if + ! + ! -- Return + return + end subroutine read_options + + subroutine check_options(this) +! ****************************************************************************** +! check_options +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, store_error_unit + ! -- dummy + class(GwfMvrType) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- Check if not exchange mover but model names are specified + if (this%iexgmvr == 0 .and. this%imodelnames == 1) then + write(errmsg,'(4x,a,a)') & + '****ERROR. MODELNAMES CANNOT BE SPECIFIED UNLESS THE ' // & + 'MOVER PACKAGE IS FOR AN EXCHANGE.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Check if exchange mover but model names not specified + if (this%iexgmvr /= 0 .and. this%imodelnames == 0) then + write(errmsg,'(4x,a,a)') & + '****ERROR. MODELNAMES OPTION MUST BE SPECIFIED BECAUSE ' // & + 'MOVER PACKAGE IS FOR AN EXCHANGE.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Return + return + end subroutine check_options + + subroutine read_dimensions(this) +! ****************************************************************************** +! read_dimensions -- Read the dimensions for this package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors, store_error_unit + ! -- dummy + class(GwfMvrType),intent(inout) :: this + ! -- local + character (len=LINELENGTH) :: errmsg, keyword + integer(I4B) :: ierr + logical :: isfound, endOfBlock + integer(I4B) :: i + integer(I4B) :: j + ! -- format +! ------------------------------------------------------------------------------ + ! + ! -- 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 MVR DIMENSIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('MAXMVR') + this%maxmvr = this%parser%GetInteger() + write(this%iout,'(4x,a,i0)')'MAXMVR = ', this%maxmvr + case ('MAXPACKAGES') + this%maxpackages = this%parser%GetInteger() + write(this%iout,'(4x,a,i0)')'MAXPACKAGES = ', this%maxpackages + case default + write(errmsg,'(4x,a,a)') & + '****ERROR. UNKNOWN MVR DIMENSION: ', trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + end do + write(this%iout,'(1x,a)')'END OF MVR DIMENSIONS' + else + call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- calculate maximum number of combinations + this%maxcomb = 0 + do i = 1, this%maxpackages + do j = 1, this%maxpackages + this%maxcomb = this%maxcomb + 1 + end do + end do + ! + ! -- verify dimensions were set + if(this%maxmvr < 0) then + write(errmsg, '(1x,a)') & + 'ERROR. MAXMVR WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + if(this%maxpackages < 0) then + write(errmsg, '(1x,a)') & + 'ERROR. MAXPACKAGES WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- return + return + end subroutine read_dimensions + + subroutine read_packages(this) +! ****************************************************************************** +! read_packages -- Read the packages that will be managed by this mover +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors, store_error_unit + ! -- dummy + class(GwfMvrType),intent(inout) :: this + ! -- local + character (len=LINELENGTH) :: errmsg, word, word1, word2 + integer(I4B) :: lloc, ierr + integer(I4B) :: npak + logical :: isfound, endOfBlock + ! -- format +! ------------------------------------------------------------------------------ + ! + ! -- get packages block + call this%parser%GetBlock('PACKAGES', isfound, ierr, & + supportOpenClose=.true.) + ! + ! -- parse packages block + if (isfound) then + write(this%iout,'(/1x,a)')'PROCESSING MVR PACKAGES' + npak = 0 + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(word1) + lloc = 1 + npak = npak + 1 + if (npak > this%maxpackages) then + call store_error('ERROR. MAXPACKAGES NOT SET LARGE ENOUGH.') + call this%parser%StoreErrorUnit() + call ustop() + endif + if(this%iexgmvr == 0) then + this%pakorigins(npak) = trim(adjustl(this%name_model)) // ' ' // & + trim(word1) + word = word1 + else + this%pakorigins(npak) = trim(word1) + call this%parser%GetStringCaps(word2) + this%pakorigins(npak) = trim(this%pakorigins(npak)) // ' ' // & + trim(word2) + word = word2 + endif + this%paknames(npak) = trim(word) + write(this%iout,'(3x,a,a)')'INCLUDING PACKAGE: ', & + trim(this%pakorigins(npak)) + end do + write(this%iout,'(1x,a)')'END OF MVR PACKAGES' + else + call store_error('ERROR. REQUIRED PACKAGES BLOCK NOT FOUND.') + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- Check to make sure npak = this%maxpackages + if(npak /= this%maxpackages) then + write(errmsg, '(a, i0, a, i0, a)') & + 'ERROR. NUMBER OF PACKAGES (', npak, ') DOES NOT EQUAL ' // & + 'MAXPACKAGES (', this%maxpackages, ').' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- return + return + end subroutine read_packages + + subroutine check_packages(this) +! ****************************************************************************** +! check_packages -- check to make sure packages have mover activated +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use MemoryManagerModule, only: mem_setptr + use SimModule, only: ustop, store_error, count_errors, store_error_unit + ! -- dummy + class(GwfMvrType),intent(inout) :: this + ! -- local + character (len=LINELENGTH) :: errmsg + integer(I4B) :: i + integer(I4B), pointer :: imover_ptr + ! -- format +! ------------------------------------------------------------------------------ + ! + ! -- Check to make sure mover is activated for each package + do i = 1, size(this%pakorigins) + imover_ptr => null() + call mem_setptr(imover_ptr, 'IMOVER', trim(this%pakorigins(i))) + if (imover_ptr == 0) then + write(errmsg, '(a, a, a)') & + 'ERROR. MODEL AND PACKAGE "', & + trim(this%pakorigins(i)), & + '" DOES NOT HAVE MOVER SPECIFIED IN OPTIONS BLOCK.' + call store_error(errmsg) + end if + end do + ! + ! -- Terminate if errors detected. + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- return + return + end subroutine check_packages + + subroutine assign_packagemovers(this) +! ****************************************************************************** +! assign_packagemovers -- assign pointer to each package's packagemover object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use PackageMoverModule, only: set_packagemover_pointer + ! -- dummy + class(GwfMvrType),intent(inout) :: this + ! -- local + integer(I4B) :: i + ! -- format +! ------------------------------------------------------------------------------ + ! + ! -- Assign the package mover pointer if it hasn't been assigned yet + do i = 1, size(this%pakorigins) + if (this%pakmovers(i)%origin == '') then + call set_packagemover_pointer(this%pakmovers(i), & + trim(this%pakorigins(i))) + end if + end do + ! + ! -- return + return + end subroutine assign_packagemovers + + subroutine allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DONE + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GwfMvrType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- allocate scalars in NumericalPackageType + call this%NumericalPackageType%allocate_scalars() + ! + ! -- Allocate + call mem_allocate(this%ibudgetout, 'IBUDGETOUT', this%origin) + call mem_allocate(this%omega, 'OMEGA', this%origin) + call mem_allocate(this%maxmvr, 'MAXMVR', this%origin) + call mem_allocate(this%maxpackages, 'MAXPACKAGES', this%origin) + call mem_allocate(this%maxcomb, 'MAXCOMB', this%origin) + call mem_allocate(this%nmvr, 'NMVR', this%origin) + call mem_allocate(this%iexgmvr, 'IEXGMVR', this%origin) + call mem_allocate(this%imodelnames, 'IMODELNAMES', this%origin) + ! + ! -- Initialize + this%ibudgetout = 0 + this%maxmvr = -1 + this%maxpackages = -1 + this%maxcomb = 0 + this%nmvr = 0 + this%iexgmvr = 0 + this%imodelnames = 0 + this%omega = DONE + ! + ! -- Return + return + end subroutine allocate_scalars + + subroutine allocate_arrays(this) +! ****************************************************************************** +! allocate_arrays +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + use ConstantsModule, only: DZERO + use PackageMoverModule, only: nulllify_packagemover_pointer + ! -- dummy + class(GwfMvrType) :: this + ! -- local + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + ! -- Allocate + allocate(this%mvr(this%maxmvr)) + allocate(this%pakorigins(this%maxpackages)) + allocate(this%paknames(this%maxpackages)) + allocate(this%pakmovers(this%maxpackages)) + ! + ! -- nullify the pakmovers + do i = 1, this%maxpackages + call nulllify_packagemover_pointer(this%pakmovers(i)) + end do + ! + ! -- allocate the object and assign values to object variables + call mem_allocate(this%ientries, this%maxcomb, 'IENTRIES', this%origin) + ! + ! -- Return + return + end subroutine allocate_arrays + + subroutine mvr_setup_budobj(this) +! ****************************************************************************** +! mvr_setup_budobj -- Set up the budget object that stores all the mvr flows +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LENBUDTXT + ! -- dummy + class(GwfMvrType) :: this + ! -- local + integer(I4B) :: nbudterm + integer(I4B) :: ncv + integer(I4B) :: i + integer(I4B) :: j + integer(I4B) :: ival + integer(I4B) :: naux + integer(I4B) :: lloc + integer(I4B) :: istart + integer(I4B) :: istop + real(DP) :: rval + character (len=LENMODELNAME) :: modelname1, modelname2 + character (len=LENPACKAGENAME) :: packagename1, packagename2 + character (len=LENORIGIN+1) :: pakoriginsdummy + integer(I4B) :: maxlist + integer(I4B) :: idx + character(len=LENBUDTXT) :: text +! ------------------------------------------------------------------------------ + ! + ! -- Determine the number of mover budget terms. These are fixed for + ! the simulation and cannot change. A separate term is required + ! for each possible provider/receiver combination. + nbudterm = 0 + do i = 1, this%maxpackages + do j = 1, this%maxpackages + nbudterm = nbudterm + 1 + end do + end do + ! + ! -- Number of control volumes is set to be 0, because there aren't + ! any for the mover + ncv = 0 + ! + ! -- set up budobj + call budgetobject_cr(this%budobj, 'WATER MOVER') + call this%budobj%budgetobject_df(ncv, nbudterm, 0, 0) + idx = 0 + ! + ! -- Go through and set up each budget term + text = ' MOVER-FLOW' + maxlist = this%maxmvr + naux = 0 + do i = 1, this%maxpackages + lloc = 1 + call urword(this%pakorigins(i), lloc, istart, istop, 1, ival, rval, -1, -1) + pakoriginsdummy = this%pakorigins(i) + modelname1 = pakoriginsdummy(istart:istop) + call urword(this%pakorigins(i), lloc, istart, istop, 1, ival, rval, -1, -1) + pakoriginsdummy = this%pakorigins(i) + packagename1 = pakoriginsdummy(istart:istop) + do j = 1, this%maxpackages + lloc = 1 + call urword(this%pakorigins(j), lloc, istart, istop, 1, ival, rval, -1, -1) + pakoriginsdummy = this%pakorigins(j) + modelname2 = pakoriginsdummy(istart:istop) + call urword(this%pakorigins(j), lloc, istart, istop, 1, ival, rval, -1, -1) + pakoriginsdummy = this%pakorigins(j) + packagename2 = pakoriginsdummy(istart:istop) + idx = idx + 1 + call this%budobj%budterm(idx)%initialize(text, & + modelname1, & + packagename1, & + modelname2, & + packagename2, & + maxlist, .false., .false., & + naux) + end do + end do + ! + ! -- return + return + end subroutine mvr_setup_budobj + + subroutine mvr_fill_budobj(this) +! ****************************************************************************** +! mvr_fill_budobj -- copy flow terms into this%budobj +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfMvrType) :: this + ! -- local + integer(I4B) :: idx + integer(I4B) :: i + integer(I4B) :: j + integer(I4B) :: n, n1, n2 + integer(I4B) :: ipos + integer(I4B) :: ival + integer(I4B) :: nitems + integer(I4B) :: lloc + integer(I4B) :: istart + integer(I4B) :: istop + real(DP) :: rval + character (len=LENMODELNAME) :: modelname1, modelname2 + character (len=LENPACKAGENAME) :: packagename1, packagename2 + character (len=LENORIGIN+1) :: pakoriginsdummy + real(DP) :: q + ! -- formats +! ----------------------------------------------------------------------------- + ! + ! -- initialize counter + idx = 0 + + + do i = 1, this%maxpackages + ! -- Retrieve modelname1 and packagename1 + lloc = 1 + call urword(this%pakorigins(i), lloc, istart, istop, 1, ival, rval, -1, -1) + pakoriginsdummy = this%pakorigins(i) + modelname1 = pakoriginsdummy(istart:istop) + call urword(this%pakorigins(i), lloc, istart, istop, 1, ival, rval, -1, -1) + pakoriginsdummy = this%pakorigins(i) + packagename1 = pakoriginsdummy(istart:istop) + do j = 1, this%maxpackages + ! -- Retrieve modelname2 and packagename2 + lloc = 1 + call urword(this%pakorigins(j), lloc, istart, istop, 1, ival, rval, -1, -1) + pakoriginsdummy = this%pakorigins(j) + modelname2 = pakoriginsdummy(istart:istop) + call urword(this%pakorigins(j), lloc, istart, istop, 1, ival, rval, -1, -1) + pakoriginsdummy = this%pakorigins(j) + packagename2 = pakoriginsdummy(istart:istop) + ipos = (i - 1) * this%maxpackages + j + nitems = this%ientries(ipos) + ! + ! -- nitems is the number of mover connections for this + ! model-package / model-package combination. Cycle if none. + idx = idx + 1 + call this%budobj%budterm(idx)%reset(nitems) + if (nitems < 1) cycle + do n = 1, this%nmvr + ! + ! -- pname1 is provider, pname2 is receiver + ! flow is always negative because it is coming from provider + if(this%pakorigins(i) == this%mvr(n)%pname1) then + if(this%pakorigins(j) == this%mvr(n)%pname2) then + q = -this%mvr(n)%qpactual + n1 = this%mvr(n)%irch1 + n2 = this%mvr(n)%irch2 + call this%budobj%budterm(idx)%update_term(n1, n2, q) + end if + end if + end do + end do + end do + ! + ! --Terms are filled, now accumulate them for this time step + call this%budobj%accumulate_terms() + ! + ! -- return + return + end subroutine mvr_fill_budobj + +end module diff --git a/src/Model/GroundWaterFlow/gwf3npf8.f90 b/src/Model/GroundWaterFlow/gwf3npf8.f90 index 24919abccb9..9ac8cfce17b 100644 --- a/src/Model/GroundWaterFlow/gwf3npf8.f90 +++ b/src/Model/GroundWaterFlow/gwf3npf8.f90 @@ -1,3479 +1,3479 @@ -module GwfNpfModule - use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, DEM9, DEM8, DEM7, DEM6, DEM2, & - DHALF, DP9, DONE, DTWO, & - DLNLOW, DLNHIGH, & - DHNOFLO, DHDRY, DEM10 - use SmoothingModule, only: sQuadraticSaturation, & - sQuadraticSaturationDerivative - use NumericalPackageModule, only: NumericalPackageType - use BaseDisModule, only: DisBaseType - use GwfIcModule, only: GwfIcType - use Xt3dModule, only: Xt3dType - use BlockParserModule, only: BlockParserType - - implicit none - - private - public :: GwfNpfType - public :: npf_cr - public :: hcond - public :: vcond - public :: condmean - public :: thksatnm - public :: hyeff_calc - - type, extends(NumericalPackageType) :: GwfNpfType - - type(GwfIcType), pointer :: ic => null() ! initial conditions object - type(Xt3dType), pointer :: xt3d => null() ! xt3d pointer - integer(I4B), pointer :: iname => null() ! length of variable names - character(len=24), dimension(:), pointer :: aname => null() ! variable names - 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 :: 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 - integer(I4B), pointer :: ithickstrt => null() ! thickstrt option flag - integer(I4B), pointer :: igwfnewtonur => null() ! newton head dampening using node bottom option flag - integer(I4B), pointer :: iusgnrhc => null() ! MODFLOW-USG saturation calculation option flag - integer(I4B), pointer :: inwtupw => null() ! MODFLOW-NWT upstream weighting option flag - integer(I4B), pointer :: icalcspdis => null() ! Calculate specific discharge at cell centers - integer(I4B), pointer :: isavspdis => null() ! Save specific discharge at cell centers - integer(I4B), pointer :: isavsat => null() ! Save sat to budget file - real(DP), pointer :: hnoflo => null() ! default is 1.e30 - real(DP), pointer :: satomega => null() ! newton-raphson saturation omega - integer(I4B),pointer :: irewet => null() ! rewetting (0:off, 1:on) - integer(I4B),pointer :: iwetit => null() ! wetting interval (default is 1) - integer(I4B),pointer :: ihdwet => null() ! (0 or not 0) - integer(I4B), pointer :: icellavg => null() ! harmonic(0), logarithmic(1), or arithmetic thick-log K (2) - real(DP), pointer :: wetfct => null() ! wetting factor - real(DP), pointer :: hdry => null() ! default is -1.d30 - integer(I4B), dimension(:), pointer, contiguous :: icelltype => null() ! confined (0) or convertible (1) - ! - ! K properties - real(DP), dimension(:), pointer, contiguous :: k11 => null() ! hydraulic conductivity; if anisotropic, then this is Kx prior to rotation - real(DP), dimension(:), pointer, contiguous :: k22 => null() ! hydraulic conductivity; if specified then this is Ky prior to rotation - real(DP), dimension(:), pointer, contiguous :: k33 => null() ! hydraulic conductivity; if specified then this is Kz prior to rotation - integer(I4B), pointer :: ik22 => null() ! flag that k22 is specified - integer(I4B), pointer :: ik33 => null() ! flag that k33 is specified - integer(I4B), pointer :: ik22overk => null() ! flag that k22 is specified as anisotropy ratio - integer(I4B), pointer :: ik33overk => null() ! flag that k33 is specified as anisotropy ratio - integer(I4B), pointer :: iangle1 => null() ! flag to indicate angle1 was read - integer(I4B), pointer :: iangle2 => null() ! flag to indicate angle2 was read - integer(I4B), pointer :: iangle3 => null() ! flag to indicate angle3 was read - real(DP), dimension(:), pointer, contiguous :: angle1 => null() ! k ellipse rotation in xy plane around z axis (yaw) - real(DP), dimension(:), pointer, contiguous :: angle2 => null() ! k ellipse rotation up from xy plane around y axis (pitch) - real(DP), dimension(:), pointer, contiguous :: angle3 => null() ! k tensor rotation around x axis (roll) - ! - integer(I4B), pointer :: iwetdry => null() ! flag to indicate angle1 was read - real(DP), dimension(:), pointer, contiguous :: wetdry => null() ! wetdry array - real(DP), dimension(:), pointer, contiguous :: sat => null() ! saturation (0. to 1.) for each cell - real(DP), dimension(:), pointer, contiguous :: condsat => null() ! saturated conductance (symmetric array) - real(DP), pointer :: satmin => null() ! minimum saturated thickness - integer(I4B), dimension(:), pointer, contiguous :: ibotnode => null() ! bottom node used if igwfnewtonur /= 0 - ! - real(DP), dimension(:, :), pointer, contiguous :: spdis => null() ! specific discharge : qx, qy, qz (nodes, 3) - integer(I4B), pointer :: nedges => null() ! number of cell edges - integer(I4B), pointer :: lastedge => null() ! last edge number - integer(I4B), dimension(:), pointer, contiguous :: nodedge => null() ! array of node numbers that have edges - integer(I4B), dimension(:), pointer, contiguous :: ihcedge => null() ! edge type (horizontal or vertical) - real(DP), dimension(:, :), pointer, contiguous :: propsedge => null() ! edge properties (Q, area, nx, ny, distance) - ! - contains - procedure :: npf_df - procedure :: npf_ac - procedure :: npf_mc - procedure :: npf_ar - procedure :: npf_init_mem - procedure :: npf_ad - procedure :: npf_cf - procedure :: npf_fc - procedure :: npf_fn - procedure :: npf_flowja - procedure :: npf_bdadj - procedure :: npf_nur - procedure :: npf_ot - procedure :: npf_da - procedure, private :: thksat => sgwf_npf_thksat - procedure, private :: qcalc => sgwf_npf_qcalc - procedure, private :: wd => sgwf_npf_wetdry - procedure, private :: wdmsg => sgwf_npf_wdmsg - procedure :: allocate_scalars - procedure, private :: allocate_arrays - procedure, private :: read_options - procedure, private :: rewet_options - procedure, private :: check_options - procedure, private :: read_data - procedure, private :: prepcheck - procedure, public :: rewet_check - procedure, public :: hy_eff - procedure, public :: calc_spdis - procedure, public :: sav_spdis - procedure, public :: sav_sat - procedure, public :: increase_edge_count - procedure, public :: set_edge_properties - endtype - - contains - - subroutine npf_cr(npfobj, name_model, inunit, iout) -! ****************************************************************************** -! npf_cr -- Create a new NPF object. Pass a inunit value of 0 if npf data will -! initialized from memory -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - type(GwfNpftype), pointer :: npfobj - character(len=*), intent(in) :: name_model - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout -! ------------------------------------------------------------------------------ - ! - ! -- Create the object - allocate(npfobj) - ! - ! -- create name and origin - call npfobj%set_names(1, name_model, 'NPF', 'NPF') - ! - ! -- Allocate scalars - call npfobj%allocate_scalars() - ! - ! -- Set variables - npfobj%inunit = inunit - npfobj%iout = iout - ! - ! -- Return - return - end subroutine npf_cr - - subroutine npf_df(this, dis, xt3d, ingnc) -! ****************************************************************************** -! npf_df -- Define -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: ustop, store_error - use Xt3dModule, only: xt3d_cr - ! -- dummy - class(GwfNpftype) :: this - class(DisBaseType), pointer, intent(inout) :: dis - type(Xt3dType), pointer :: xt3d - integer(I4B), intent(in) :: ingnc - ! -- local - ! -- formats - character(len=*), parameter :: fmtheader = & - "(1x, /1x, 'NPF -- NODE PROPERTY FLOW PACKAGE, VERSION 1, 3/30/2015', & - &' INPUT READ FROM UNIT ', i0, //)" - ! -- data -! ------------------------------------------------------------------------------ - ! - ! -- Print a message identifying the node property flow package. - write(this%iout, fmtheader) this%inunit - ! - ! -- Set a pointer to dis - this%dis => dis - ! - ! -- Initialize block parser - call this%parser%Initialize(this%inunit, this%iout) - ! - ! -- set, read, and check options - call this%read_options() - call this%check_options() - ! - ! -- Save pointer to xt3d object - this%xt3d => xt3d - if (this%ixt3d /= 0) xt3d%ixt3d = this%ixt3d - call this%xt3d%xt3d_df(dis) - ! - ! -- Ensure GNC and XT3D are not both on at the same time - if (this%ixt3d /= 0 .and. ingnc > 0) then - call store_error('Error in model ' // trim(this%name_model) // & - '. The XT3D option cannot be used with the GNC Package.') - call ustop() - endif - ! - ! -- Return - return - end subroutine npf_df - - subroutine npf_ac(this, moffset, sparse) -! ****************************************************************************** -! npf_ac -- Add connections for extended neighbors to the sparse matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SparseModule, only: sparsematrix - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(GwfNpftype) :: this - integer(I4B), intent(in) :: moffset - type(sparsematrix), intent(inout) :: sparse - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- Add extended neighbors (neighbors of neighbors) - if(this%ixt3d /= 0) call this%xt3d%xt3d_ac(moffset, sparse) - ! - ! -- Return - return - end subroutine npf_ac - - subroutine npf_mc(this, moffset, iasln, jasln) -! ****************************************************************************** -! npf_mc -- Map connections and construct iax, jax, and idxglox -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(GwfNpftype) :: this - integer(I4B), intent(in) :: moffset - integer(I4B), dimension(:), intent(in) :: iasln - integer(I4B), dimension(:), intent(in) :: jasln - ! -- local -! ------------------------------------------------------------------------------ - ! - if(this%ixt3d /= 0) call this%xt3d%xt3d_mc(moffset, iasln, & - jasln, this%inewton) - ! - ! -- Return - return - end subroutine npf_mc - - subroutine npf_init_mem(this, dis, ixt3d, icelltype, k11, k22, k33, wetdry, & - angle1, angle2, angle3) -! ****************************************************************************** -! npf_cr -- Create a new NPF object from memory -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(GwfNpftype) :: this - class(DisBaseType), pointer, intent(inout) :: dis - integer(I4B), pointer, intent(in) :: ixt3d - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: icelltype - real(DP), dimension(:), pointer, contiguous, intent(inout) :: k11 - real(DP), dimension(:), pointer, contiguous, intent(inout), optional :: k22 - real(DP), dimension(:), pointer, contiguous, intent(inout), optional :: k33 - real(DP), dimension(:), pointer, contiguous, intent(inout), optional :: wetdry - real(DP), dimension(:), pointer, contiguous, intent(inout), optional :: angle1 - real(DP), dimension(:), pointer, contiguous, intent(inout), optional :: angle2 - real(DP), dimension(:), pointer, contiguous, intent(inout), optional :: angle3 - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- Store pointers to arguments that were passed in - this%dis => dis - ! - ! -- set ixt3d (1 - HCOF and RHS; 2 - RHS only) - this%ixt3d = ixt3d - ! - ! -- allocate arrays - call this%allocate_arrays(dis%nodes, dis%njas) - ! - ! -- fill icelltype - call dis%fill_grid_array(icelltype, this%icelltype) - ! - ! -- fill k data - ! -- k11 - call dis%fill_grid_array(k11, this%k11) - ! -- k22 - if (present(k22)) then - this%ik22 = 1 - call dis%fill_grid_array(k22, this%k22) - end if - ! -- k33 - if (present(k33)) then - this%ik33 = 1 - call dis%fill_grid_array(k33, this%k33) - end if - ! - ! -- fill angle data - ! -- angle1 - if (present(angle1)) then - this%iangle1 = 1 - call dis%fill_grid_array(angle1, this%angle1) - end if - ! -- angle2 - if (present(angle2)) then - this%iangle2 = 1 - call dis%fill_grid_array(angle2, this%angle2) - end if - ! -- angle3 - if (present(angle3)) then - this%iangle3 = 1 - call dis%fill_grid_array(angle3, this%angle3) - end if - ! - ! -- fill wetdry data - if (present(wetdry)) then - this%iwetdry = 1 - this%irewet = 1 - end if - ! - ! -- Return - return - end subroutine npf_init_mem - - subroutine npf_ar(this, ic, ibound, hnew) -! ****************************************************************************** -! npf_ar -- Allocate and Read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfNpftype) :: this - type(GwfIcType), pointer, intent(in) :: ic - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: ibound - real(DP), dimension(:), pointer, contiguous, intent(inout) :: hnew - ! -- local - ! -- formats - ! -- data -! ------------------------------------------------------------------------------ - ! - ! -- Store pointers to arguments that were passed in - this%ic => ic - this%ibound => ibound - this%hnew => hnew - ! - ! -- read data from files - if (this%inunit /= 0) then - ! - ! -- allocate arrays - call this%allocate_arrays(this%dis%nodes, this%dis%njas) - ! - ! -- read the data block - call this%read_data() - end if - ! - ! -- Initialize and check data - call this%prepcheck() - ! - ! -- xt3d - if (this%ixt3d /= 0) then - call this%xt3d%xt3d_ar(ibound, this%k11, this%ik33, this%k33, & - this%sat, this%ik22, this%k22, this%inewton, & - this%icelltype, this%iangle1, & - this%iangle2, this%iangle3, this%angle1, & - this%angle2, this%angle3) - end if - ! - ! -- Return - return - end subroutine npf_ar - - subroutine npf_ad(this, nodes, hold) -! ****************************************************************************** -! npf_ad -- Advance -! Subroutine (1) Sets hold to bot whenever a wettable cell is dry -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - class(GwfNpfType) :: this - integer(I4B),intent(in) :: nodes - real(DP),dimension(nodes),intent(inout) :: hold - integer(I4B) :: n -! ------------------------------------------------------------------------------ - ! - ! -- loop through all cells and set hold=bot if wettable cell is dry - if(this%irewet > 0) then - do n = 1, this%dis%nodes - if(this%wetdry(n) == DZERO) cycle - if(this%ibound(n) /= 0) cycle - hold(n) = this%dis%bot(n) - enddo - endif - ! - ! -- Return - return - end subroutine npf_ad - - subroutine npf_cf(this, kiter, nodes, hnew) -! ****************************************************************************** -! npf_cf -- Formulate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfNpfType) :: this - integer(I4B) :: kiter - integer(I4B),intent(in) :: nodes - real(DP),intent(inout),dimension(nodes) :: hnew - ! -- local - integer(I4B) :: n - real(DP) :: satn -! ------------------------------------------------------------------------------ - ! - ! -- Perform wetting and drying - if (this%inewton /= 1) then - call this%wd(kiter, hnew) - end if - ! - ! -- Calculate saturation for convertible cells - do n = 1, this%dis%nodes - if(this%icelltype(n) /= 0) then - if(this%ibound(n) == 0) then - satn = DZERO - else - call this%thksat(n, hnew(n), satn) - endif - this%sat(n) = satn - endif - enddo - ! - ! -- Return - return - end subroutine npf_cf - - subroutine npf_fc(this, kiter, njasln, amat, idxglo, rhs, hnew) -! ****************************************************************************** -! npf_fc -- Formulate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DONE - ! -- dummy - class(GwfNpfType) :: this - integer(I4B) :: kiter - integer(I4B),intent(in) :: njasln - real(DP),dimension(njasln),intent(inout) :: amat - integer(I4B),intent(in),dimension(:) :: idxglo - real(DP),intent(inout),dimension(:) :: rhs - real(DP),intent(inout),dimension(:) :: hnew - ! -- local - integer(I4B) :: n, m, ii, idiag, ihc - integer(I4B) :: isymcon, idiagm - real(DP) :: hyn, hym - real(DP) :: cond -! ------------------------------------------------------------------------------ - ! - ! -- Calculate conductance and put into amat - ! - if(this%ixt3d /= 0) then - call this%xt3d%xt3d_fc(kiter, njasln, amat, idxglo, rhs, hnew) - else - ! - do n = 1, this%dis%nodes - do ii = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 - if (this%dis%con%mask(ii) == 0) cycle - - m = this%dis%con%ja(ii) - ! - ! -- Calculate conductance only for upper triangle but insert into - ! upper and lower parts of amat. - if(m < n) cycle - ihc = this%dis%con%ihc(this%dis%con%jas(ii)) - hyn = this%hy_eff(n, m, ihc, ipos=ii) - hym = this%hy_eff(m, n, ihc, ipos=ii) - ! - ! -- Vertical connection - if(ihc == 0) then - ! - ! -- Calculate vertical conductance - cond = vcond(this%ibound(n), this%ibound(m), & - this%icelltype(n), this%icelltype(m), this%inewton, & - this%ivarcv, this%idewatcv, & - this%condsat(this%dis%con%jas(ii)), hnew(n), hnew(m), & - hyn, hym, & - this%sat(n), this%sat(m), & - this%dis%top(n), this%dis%top(m), & - this%dis%bot(n), this%dis%bot(m), & - this%dis%con%hwva(this%dis%con%jas(ii))) - ! - ! -- Vertical flow for perched conditions - if(this%iperched /= 0) then - if(this%icelltype(m) /= 0) then - if(hnew(m) < this%dis%top(m)) then - ! - ! -- Fill row n - idiag = this%dis%con%ia(n) - rhs(n) = rhs(n) - cond * this%dis%bot(n) - amat(idxglo(idiag)) = amat(idxglo(idiag)) - cond - ! - ! -- Fill row m - isymcon = this%dis%con%isym(ii) - amat(idxglo(isymcon)) = amat(idxglo(isymcon)) + cond - rhs(m) = rhs(m) + cond * this%dis%bot(n) - ! - ! -- cycle the connection loop - cycle - endif - endif - endif - ! - else - ! - ! -- Horizontal conductance - cond = hcond(this%ibound(n), this%ibound(m), & - this%icelltype(n), this%icelltype(m), & - this%inewton, this%inewton, & - this%dis%con%ihc(this%dis%con%jas(ii)), & - this%icellavg, this%iusgnrhc, this%inwtupw, & - this%condsat(this%dis%con%jas(ii)), & - hnew(n), hnew(m), this%sat(n), this%sat(m), hyn, hym, & - this%dis%top(n), this%dis%top(m), & - this%dis%bot(n), this%dis%bot(m), & - this%dis%con%cl1(this%dis%con%jas(ii)), & - this%dis%con%cl2(this%dis%con%jas(ii)), & - this%dis%con%hwva(this%dis%con%jas(ii)), & - this%satomega, this%satmin) - endif - ! - ! -- Fill row n - idiag = this%dis%con%ia(n) - amat(idxglo(ii)) = amat(idxglo(ii)) + cond - amat(idxglo(idiag)) = amat(idxglo(idiag)) - cond - ! - ! -- Fill row m - isymcon = this%dis%con%isym(ii) - idiagm = this%dis%con%ia(m) - amat(idxglo(isymcon)) = amat(idxglo(isymcon)) + cond - amat(idxglo(idiagm)) = amat(idxglo(idiagm)) - cond - enddo - enddo - ! - endif - ! - ! -- Return - return - end subroutine npf_fc - - - subroutine npf_fn(this, kiter, njasln, amat, idxglo, rhs, hnew) -! ****************************************************************************** -! npf_fn -- Fill newton terms -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfNpfType) :: this - integer(I4B) :: kiter - integer(I4B),intent(in) :: njasln - real(DP),dimension(njasln),intent(inout) :: amat - integer(I4B),intent(in),dimension(:) :: idxglo - real(DP),intent(inout),dimension(:) :: rhs - real(DP),intent(inout),dimension(:) :: hnew - ! -- local - integer(I4B) :: nodes, nja - integer(I4B) :: n,m,ii,idiag - integer(I4B) :: isymcon, idiagm - integer(I4B) :: iups - integer(I4B) :: idn - real(DP) :: cond - real(DP) :: consterm - real(DP) :: filledterm - real(DP) :: derv - real(DP) :: hds - real(DP) :: term - real(DP) :: afac - real(DP) :: topup - real(DP) :: botup - real(DP) :: topdn - real(DP) :: botdn -! ------------------------------------------------------------------------------ - ! - ! -- add newton terms to solution matrix - ! - nodes = this%dis%nodes - nja = this%dis%con%nja - if(this%ixt3d /= 0) then - call this%xt3d%xt3d_fn(kiter, nodes, nja, njasln, amat, idxglo, rhs, hnew) - else - ! - do n=1, nodes - idiag=this%dis%con%ia(n) - do ii=this%dis%con%ia(n)+1,this%dis%con%ia(n+1)-1 - if (this%dis%con%mask(ii) == 0) cycle - - m=this%dis%con%ja(ii) - isymcon = this%dis%con%isym(ii) - ! work on upper triangle - if(m < n) cycle - if(this%dis%con%ihc(this%dis%con%jas(ii))==0 .and. & - this%ivarcv == 0) then - !call this%vcond(n,m,hnew(n),hnew(m),ii,cond) - ! do nothing - else - ! determine upstream node - iups = m - if (hnew(m) < hnew(n)) iups = n - idn = n - if (iups == n) idn = m - ! - ! -- no newton terms if upstream cell is confined - if (this%icelltype(iups) == 0) cycle - ! - ! -- Set the upstream top and bot, and then recalculate for a - ! vertically staggered horizontal connection - topup = this%dis%top(iups) - botup = this%dis%bot(iups) - if(this%dis%con%ihc(this%dis%con%jas(ii)) == 2) then - topup = min(this%dis%top(n), this%dis%top(m)) - botup = max(this%dis%bot(n), this%dis%bot(m)) - endif - ! - ! get saturated conductivity for derivative - cond = this%condsat(this%dis%con%jas(ii)) - ! - ! -- if using MODFLOW-NWT upstream weighting option apply - ! factor to remove average thickness - if (this%inwtupw /= 0) then - topdn = this%dis%top(idn) - botdn = this%dis%bot(idn) - afac = DTWO / (DONE + (topdn - botdn) / (topup - botup)) - cond = cond * afac - end if - ! - ! compute additional term - consterm = -cond * (hnew(iups) - hnew(idn)) !needs to use hwadi instead of hnew(idn) - !filledterm = cond - filledterm = amat(idxglo(ii)) - derv = sQuadraticSaturationDerivative(topup, botup, hnew(iups), & - this%satomega, this%satmin) - idiagm = this%dis%con%ia(m) - ! fill jacobian for n being the upstream node - if (iups == n) then - hds = hnew(m) - !isymcon = this%dis%con%isym(ii) - term = consterm * derv - rhs(n) = rhs(n) + term * hnew(n) !+ amat(idxglo(isymcon)) * (dwadi * hds - hds) !need to add dwadi - rhs(m) = rhs(m) - term * hnew(n) !- amat(idxglo(isymcon)) * (dwadi * hds - hds) !need to add dwadi - ! fill in row of n - amat(idxglo(idiag)) = amat(idxglo(idiag)) + term - ! fill newton term in off diagonal if active cell - if (this%ibound(n) > 0) then - amat(idxglo(ii)) = amat(idxglo(ii)) !* dwadi !need to add dwadi - end if - !fill row of m - amat(idxglo(idiagm)) = amat(idxglo(idiagm)) !- filledterm * (dwadi - DONE) !need to add dwadi - ! fill newton term in off diagonal if active cell - if (this%ibound(m) > 0) then - amat(idxglo(isymcon)) = amat(idxglo(isymcon)) - term - end if - ! fill jacobian for m being the upstream node - else - hds = hnew(n) - term = -consterm * derv - rhs(n) = rhs(n) + term * hnew(m) !+ amat(idxglo(ii)) * (dwadi * hds - hds) !need to add dwadi - rhs(m) = rhs(m) - term * hnew(m) !- amat(idxglo(ii)) * (dwadi * hds - hds) !need to add dwadi - ! fill in row of n - amat(idxglo(idiag)) = amat(idxglo(idiag)) !- filledterm * (dwadi - DONE) !need to add dwadi - ! fill newton term in off diagonal if active cell - if (this%ibound(n) > 0) then - amat(idxglo(ii)) = amat(idxglo(ii)) + term - end if - !fill row of m - amat(idxglo(idiagm)) = amat(idxglo(idiagm)) - term - ! fill newton term in off diagonal if active cell - if (this%ibound(m) > 0) then - amat(idxglo(isymcon)) = amat(idxglo(isymcon)) !* dwadi !need to add dwadi - end if - end if - endif - - enddo - end do - ! - end if - ! - ! -- Return - return - end subroutine npf_fn - - subroutine npf_nur(this, neqmod, x, xtemp, dx, inewtonur, dxmax, locmax) -! ****************************************************************************** -! bnd_nur -- under-relaxation -! Subroutine: (1) Under-relaxation of Groundwater Flow Model Heads for current -! outer iteration using the cell bottoms at the bottom of the -! model -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfNpfType) :: this - integer(I4B), intent(in) :: neqmod - real(DP), dimension(neqmod), intent(inout) :: x - real(DP), dimension(neqmod), intent(in) :: xtemp - real(DP), dimension(neqmod), intent(inout) :: dx - integer(I4B), intent(inout) :: inewtonur - real(DP), intent(inout) :: dxmax - integer(I4B), intent(inout) :: locmax - ! -- local - integer(I4B) :: n - real(DP) :: botm - real(DP) :: xx - real(DP) :: dxx -! ------------------------------------------------------------------------------ - - ! - ! -- Newton-Raphson under-relaxation - do n = 1, this%dis%nodes - if (this%ibound(n) < 1) cycle - if (this%icelltype(n) > 0) then - botm = this%dis%bot(this%ibotnode(n)) - ! -- only apply Newton-Raphson under-relaxation if - ! solution head is below the bottom of the model - if (x(n) < botm) then - inewtonur = 1 - xx = xtemp(n)*(DONE-DP9) + botm*DP9 - dxx = x(n) - xx - if (abs(dxx) > abs(dxmax)) then - locmax = n - dxmax = dxx - end if - x(n) = xx - dx(n) = DZERO - end if - end if - enddo - ! - ! -- return - return - end subroutine npf_nur - - subroutine npf_flowja(this, hnew, flowja) -! ****************************************************************************** -! npf_flowja -- Calculate flowja -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfNpfType) :: this - real(DP),intent(inout),dimension(:) :: hnew - real(DP),intent(inout),dimension(:) :: flowja - ! -- local - integer(I4B) :: n, ipos, m - real(DP) :: qnm -! ------------------------------------------------------------------------------ - ! - ! -- Calculate the flow across each cell face and store in flowja - ! - if(this%ixt3d /= 0) then - call this%xt3d%xt3d_flowja(hnew, flowja) - else - ! - do n = 1, this%dis%nodes - do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 - m = this%dis%con%ja(ipos) - if(m < n) cycle - call this%qcalc(n, m, hnew(n), hnew(m), ipos, qnm) - flowja(ipos) = qnm - flowja(this%dis%con%isym(ipos)) = -qnm - enddo - enddo - ! - endif - ! - ! -- Return - return - end subroutine npf_flowja - - subroutine sgwf_npf_thksat(this, n, hn, thksat) -! ****************************************************************************** -! sgwf_npf_thksat -- Fractional cell saturation -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfNpfType) :: this - integer(I4B),intent(in) :: n - real(DP),intent(in) :: hn - real(DP),intent(inout) :: thksat -! ------------------------------------------------------------------------------ - ! - ! -- Standard Formulation - if(hn >= this%dis%top(n)) then - thksat = DONE - else - thksat = (hn - this%dis%bot(n)) / (this%dis%top(n) - this%dis%bot(n)) - endif - ! - ! -- Newton-Raphson Formulation - if(this%inewton /= 0) then - thksat = sQuadraticSaturation(this%dis%top(n), this%dis%bot(n), hn, & - this%satomega, this%satmin) - !if (thksat < this%satmin) thksat = this%satmin - endif - ! - ! -- Return - return - end subroutine sgwf_npf_thksat - - subroutine sgwf_npf_qcalc(this, n, m, hn, hm, icon, qnm) -! ****************************************************************************** -! sgwf_npf_qcalc -- Flow between two cells -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfNpfType) :: this - integer(I4B),intent(in) :: n - integer(I4B),intent(in) :: m - real(DP),intent(in) :: hn - real(DP),intent(in) :: hm - integer(I4B),intent(in) :: icon - real(DP),intent(inout) :: qnm - ! -- local - real(DP) :: hyn, hym - real(DP) :: condnm - real(DP) :: hntemp, hmtemp - integer(I4B) :: ihc -! ------------------------------------------------------------------------------ - ! - ! -- Initialize - ihc = this%dis%con%ihc(this%dis%con%jas(icon)) - hyn = this%hy_eff(n, m, ihc, ipos=icon) - hym = this%hy_eff(m, n, ihc, ipos=icon) - ! - ! -- Calculate conductance - if(ihc == 0) then - condnm = vcond(this%ibound(n), this%ibound(m), & - this%icelltype(n), this%icelltype(m), this%inewton, & - this%ivarcv, this%idewatcv, & - this%condsat(this%dis%con%jas(icon)), hn, hm, & - hyn, hym, & - this%sat(n), this%sat(m), & - this%dis%top(n), this%dis%top(m), & - this%dis%bot(n), this%dis%bot(m), & - this%dis%con%hwva(this%dis%con%jas(icon))) - else - condnm = hcond(this%ibound(n), this%ibound(m), & - this%icelltype(n), this%icelltype(m), & - this%inewton, this%inewton, & - this%dis%con%ihc(this%dis%con%jas(icon)), & - this%icellavg, this%iusgnrhc, this%inwtupw, & - this%condsat(this%dis%con%jas(icon)), & - hn, hm, this%sat(n), this%sat(m), hyn, hym, & - this%dis%top(n), this%dis%top(m), & - this%dis%bot(n), this%dis%bot(m), & - this%dis%con%cl1(this%dis%con%jas(icon)), & - this%dis%con%cl2(this%dis%con%jas(icon)), & - this%dis%con%hwva(this%dis%con%jas(icon)), & - this%satomega, this%satmin) - endif - ! - ! -- Initialize hntemp and hmtemp - hntemp = hn - hmtemp = hm - ! - ! -- Check and adjust for dewatered conditions - if(this%iperched /= 0) then - if(this%dis%con%ihc(this%dis%con%jas(icon)) == 0) then - if(n > m) then - if(this%icelltype(n) /= 0) then - if(hn < this%dis%top(n)) hntemp = this%dis%bot(m) - endif - else - if(this%icelltype(m) /= 0) then - if(hm < this%dis%top(m)) hmtemp = this%dis%bot(n) - endif - endif - endif - endif - ! - ! -- Calculate flow positive into cell n - qnm = condnm * (hmtemp - hntemp) - ! - ! -- Return - return - end subroutine sgwf_npf_qcalc - - subroutine npf_bdadj(this, flowja, icbcfl, icbcun) -! ****************************************************************************** -! npf_bdadj -- Record flowja and calculate specific discharge if requested -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfNpfType) :: this - real(DP),dimension(:),intent(in) :: flowja - integer(I4B), intent(in) :: icbcfl - integer(I4B), intent(in) :: icbcun - ! -- local - integer(I4B) :: ibinun - !data - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- Set unit number for binary output - if(this%ipakcb < 0) then - ibinun = icbcun - elseif(this%ipakcb == 0) then - ibinun = 0 - else - ibinun = this%ipakcb - endif - if(icbcfl == 0) ibinun = 0 - ! - ! -- Write the face flows if requested - if(ibinun /= 0) then - call this%dis%record_connection_array(flowja, ibinun, this%iout) - endif - ! - ! -- Calculate specific discharge at cell centers and write, if requested - if (this%icalcspdis /= 0) then - call this%calc_spdis(flowja) - if(ibinun /= 0) call this%sav_spdis(ibinun) - endif - ! - ! -- Save saturation, if requested - if (this%isavsat /= 0) then - if(ibinun /= 0) call this%sav_sat(ibinun) - endif - ! - ! -- Return - return - end subroutine npf_bdadj - - subroutine npf_ot(this, flowja) -! ****************************************************************************** -! npf_ot -- Budget -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: kper, kstp - use ConstantsModule, only: LENBIGLINE - ! -- dummy - class(GwfNpfType) :: this - real(DP),intent(inout),dimension(:) :: flowja - ! -- local - character(len=LENBIGLINE) :: line - character(len=30) :: tempstr - integer(I4B) :: n, ipos, m - real(DP) :: qnm - ! -- formats - character(len=*), parameter :: fmtiprflow = & - "(/,4x,'CALCULATED INTERCELL FLOW FOR PERIOD ', i0, ' STEP ', i0)" -! ------------------------------------------------------------------------------ - ! - ! -- Write flowja to list file if requested - if (this%iprflow > 0) then - write(this%iout, fmtiprflow) kper, kstp - do n = 1, this%dis%nodes - line = '' - call this%dis%noder_to_string(n, tempstr) - line = trim(tempstr) // ':' - do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 - m = this%dis%con%ja(ipos) - call this%dis%noder_to_string(m, tempstr) - line = trim(line) // ' ' // trim(tempstr) - qnm = flowja(ipos) - write(tempstr, '(1pg15.6)') qnm - line = trim(line) // ' ' // trim(adjustl(tempstr)) - enddo - write(this%iout, '(a)') trim(line) - enddo - endif - ! - ! -- Return - return - end subroutine npf_ot - - subroutine npf_da(this) -! ****************************************************************************** -! npf_da -- Deallocate variables -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(GwfNpftype) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Strings - ! - ! -- Scalars - call mem_deallocate(this%iname) - call mem_deallocate(this%ixt3d) - call mem_deallocate(this%satomega) - call mem_deallocate(this%hnoflo) - call mem_deallocate(this%hdry) - call mem_deallocate(this%icellavg) - call mem_deallocate(this%ik22) - call mem_deallocate(this%ik33) - call mem_deallocate(this%iperched) - call mem_deallocate(this%ivarcv) - call mem_deallocate(this%idewatcv) - call mem_deallocate(this%ithickstrt) - call mem_deallocate(this%iusgnrhc) - call mem_deallocate(this%inwtupw) - call mem_deallocate(this%isavspdis) - call mem_deallocate(this%isavsat) - call mem_deallocate(this%icalcspdis) - call mem_deallocate(this%irewet) - call mem_deallocate(this%wetfct) - call mem_deallocate(this%iwetit) - call mem_deallocate(this%ihdwet) - call mem_deallocate(this%satmin) - call mem_deallocate(this%ibotnode) - call mem_deallocate(this%iwetdry) - call mem_deallocate(this%iangle1) - call mem_deallocate(this%iangle2) - call mem_deallocate(this%iangle3) - call mem_deallocate(this%nedges) - call mem_deallocate(this%lastedge) - call mem_deallocate(this%ik22overk) - call mem_deallocate(this%ik33overk) - ! - ! -- Deallocate arrays - call mem_deallocate(this%icelltype) - call mem_deallocate(this%k11) - call mem_deallocate(this%k22, 'K22', this%origin) - call mem_deallocate(this%k33, 'K33', this%origin) - call mem_deallocate(this%sat) - call mem_deallocate(this%condsat) - call mem_deallocate(this%wetdry) - call mem_deallocate(this%angle1) - call mem_deallocate(this%angle2) - call mem_deallocate(this%angle3) - call mem_deallocate(this%nodedge) - call mem_deallocate(this%ihcedge) - call mem_deallocate(this%propsedge) - call mem_deallocate(this%spdis) - ! - ! -- deallocate parent - call this%NumericalPackageType%da() - ! - ! -- Return - return - end subroutine npf_da - - subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -- Allocate scalar pointer variables -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate, mem_setptr - ! -- dummy - class(GwfNpftype) :: this -! ------------------------------------------------------------------------------ - ! - ! -- allocate scalars in NumericalPackageType - call this%NumericalPackageType%allocate_scalars() - ! - ! -- Allocate scalars - call mem_allocate(this%iname, 'INAME', this%origin) - call mem_allocate(this%ixt3d, 'IXT3D', this%origin) - call mem_allocate(this%satomega, 'SATOMEGA', this%origin) - call mem_allocate(this%hnoflo, 'HNOFLO', this%origin) - call mem_allocate(this%hdry, 'HDRY', this%origin) - call mem_allocate(this%icellavg, 'ICELLAVG', this%origin) - call mem_allocate(this%ik22, 'IK22', this%origin) - call mem_allocate(this%ik33, 'IK33', this%origin) - call mem_allocate(this%ik22overk, 'IK22OVERK', this%origin) - call mem_allocate(this%ik33overk, 'IK33OVERK', this%origin) - call mem_allocate(this%iperched, 'IPERCHED', this%origin) - call mem_allocate(this%ivarcv, 'IVARCV', this%origin) - call mem_allocate(this%idewatcv, 'IDEWATCV', this%origin) - call mem_allocate(this%ithickstrt, 'ITHICKSTRT', this%origin) - call mem_allocate(this%iusgnrhc, 'IUSGNRHC', this%origin) - call mem_allocate(this%inwtupw, 'INWTUPW', this%origin) - call mem_allocate(this%icalcspdis, 'ICALCSPDIS', this%origin) - call mem_allocate(this%isavspdis, 'ISAVSPDIS', this%origin) - call mem_allocate(this%isavsat, 'ISAVSAT', this%origin) - call mem_allocate(this%irewet, 'IREWET', this%origin) - call mem_allocate(this%wetfct, 'WETFCT', this%origin) - call mem_allocate(this%iwetit, 'IWETIT', this%origin) - call mem_allocate(this%ihdwet, 'IHDWET', this%origin) - call mem_allocate(this%satmin, 'SATMIN', this%origin) - call mem_allocate(this%iangle1, 'IANGLE1', this%origin) - call mem_allocate(this%iangle2, 'IANGLE2', this%origin) - call mem_allocate(this%iangle3, 'IANGLE3', this%origin) - call mem_allocate(this%iwetdry, 'IWETDRY', this%origin) - call mem_allocate(this%nedges, 'NEDGES', this%origin) - call mem_allocate(this%lastedge, 'LASTEDGE', this%origin) - ! - ! -- set pointer to inewtonur - call mem_setptr(this%igwfnewtonur, 'INEWTONUR', trim(this%name_model)) - ! - ! -- Initialize value - this%iname = 8 - this%ixt3d = 0 - this%satomega = DZERO - this%hnoflo = DHNOFLO !1.d30 - this%hdry = DHDRY !-1.d30 - this%icellavg = 0 - this%ik22 = 0 - this%ik33 = 0 - this%ik22overk = 0 - this%ik33overk = 0 - this%iperched = 0 - this%ivarcv = 0 - this%idewatcv = 0 - this%ithickstrt = 0 - this%iusgnrhc = 0 - this%inwtupw = 0 - this%icalcspdis = 0 - this%isavspdis = 0 - this%isavsat = 0 - this%irewet = 0 - this%wetfct = DONE - this%iwetit = 1 - this%ihdwet = 0 - this%satmin = DZERO ! DEM7 - this%iangle1 = 0 - this%iangle2 = 0 - this%iangle3 = 0 - this%iwetdry = 0 - this%nedges = 0 - this%lastedge = 0 - ! - ! -- If newton is on, then NPF creates asymmetric matrix - this%iasym = this%inewton - ! - ! -- Return - return - end subroutine allocate_scalars - - subroutine allocate_arrays(this, ncells, njas) -! ****************************************************************************** -! allocate_arrays -- Allocate npf arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(GwfNpftype) :: this - integer(I4B), intent(in) :: ncells - integer(I4B), intent(in) :: njas - ! -- local - integer(I4B) :: n -! ------------------------------------------------------------------------------ - ! - call mem_allocate(this%icelltype, ncells, 'ICELLTYPE', trim(this%origin)) - call mem_allocate(this%k11, ncells, 'K11', trim(this%origin)) - call mem_allocate(this%sat, ncells, 'SAT', trim(this%origin)) - call mem_allocate(this%condsat, njas, 'CONDSAT', trim(this%origin)) - ! - ! -- Optional arrays dimensioned to full size initially - call mem_allocate(this%k22, ncells, 'K22', trim(this%origin)) - call mem_allocate(this%k33, ncells, 'K33', trim(this%origin)) - call mem_allocate(this%wetdry, ncells, 'WETDRY', trim(this%origin)) - call mem_allocate(this%angle1, ncells, 'ANGLE1', trim(this%origin)) - call mem_allocate(this%angle2, ncells, 'ANGLE2', trim(this%origin)) - call mem_allocate(this%angle3, ncells, 'ANGLE3', trim(this%origin)) - ! - ! -- Optional arrays - call mem_allocate(this%ibotnode, 0, 'IBOTNODE', trim(this%origin)) - ! - ! -- Specific discharge - if (this%icalcspdis == 1) then - call mem_allocate(this%spdis, 3, ncells, 'SPDIS', trim(this%origin)) - call mem_allocate(this%nodedge, this%nedges, 'NODEDGE', trim(this%origin)) - call mem_allocate(this%ihcedge, this%nedges, 'IHCEDGE', trim(this%origin)) - call mem_allocate(this%propsedge, 5, this%nedges, 'PROPSEDGE', & - trim(this%origin)) - else - call mem_allocate(this%spdis, 3, 0, 'SPDIS', trim(this%origin)) - call mem_allocate(this%nodedge, 0, 'NODEDGE', trim(this%origin)) - call mem_allocate(this%ihcedge, 0, 'IHCEDGE', trim(this%origin)) - call mem_allocate(this%propsedge, 0, 0, 'PROPSEDGE', trim(this%origin)) - endif - ! - ! -- initialize iangle1, iangle2, iangle3, and wetdry - do n = 1, ncells - this%angle1(n) = DZERO - this%angle2(n) = DZERO - this%angle3(n) = DZERO - this%wetdry(n) = DZERO - end do - ! - ! -- allocate variable names - allocate(this%aname(this%iname)) - this%aname = [' ICELLTYPE', ' K', & - ' K33', ' K22', & - ' WETDRY', ' ANGLE1', & - ' ANGLE2', ' ANGLE3'] - ! - ! -- return - return - end subroutine allocate_arrays - - subroutine read_options(this) -! ****************************************************************************** -! read_options -- Read the options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors - implicit none - ! -- dummy - class(GwfNpftype) :: this - ! -- local - character(len=LINELENGTH) :: errmsg, keyword - 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 -! ------------------------------------------------------------------------------ - ! - ! -- 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() - call ustop() - 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.' - endif - 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 - endif - 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.' - ! - ! -- 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)')'****ERROR. UNKNOWN NPF OPTION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - 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 - this%iusgnrhc = 0 - write(this%iout, '(4x,a,3(1x,a))') & - '****WARNING. MODFLOW-USG saturation calculation not needed', & - 'for a model that is using the standard conductance formulation.', & - 'Resetting DEV_MODFLOWUSG_UPSTREAM_WEIGHTED_SATURATION OPTION from', & - '1 to 0.' - end if - ! - ! -- check that the this%inwtupw option is not specified for non-newton - ! models - if (this%inwtupw /= 0 .and. this%inewton == 0) then - this%inwtupw = 0 - write(this%iout,'(4x,a,3(1x,a))') & - '****WARNING. The DEV_MODFLOWNWT_UPSTREAM_WEIGHTING option has', & - 'been specified for a model that is using the standard conductance', & - 'formulation. Resetting DEV_MODFLOWNWT_UPSTREAM_WEIGHTING OPTION from', & - '1 to 0.' - end if - ! - ! -- check that the transmissivity weighting functions are not specified with - ! with the this%inwtupw option - if (this%inwtupw /= 0 .and. this%icellavg < 2) then - write(errmsg,'(4x,a,2(1x,a))') & - '****ERROR. THE DEV_MODFLOWNWT_UPSTREAM_WEIGHTING OPTION CAN', & - 'ONLY BE SPECIFIED WITH THE AMT-LMK AND AMT-HMK', & - 'ALTERNATIVE_CELL_AVERAGING OPTIONS IN THE NPF PACKAGE.' - call store_error(errmsg) - end if - ! - ! -- check that this%iusgnrhc and this%inwtupw have not both been enabled - if (this%iusgnrhc /= 0 .and. this%inwtupw /= 0) then - write(errmsg,'(4x,a,2(1x,a))') & - '****ERROR. THE DEV_MODFLOWUSG_UPSTREAM_WEIGHTED_SATURATION', & - 'AND DEV_MODFLOWNWT_UPSTREAM_WEIGHTING OPTIONS CANNOT BE', & - 'SPECIFIED IN THE SAME NPF PACKAGE.' - call store_error(errmsg) - end if - ! - ! -- set omega value used for saturation calculations - 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() - call ustop() - end if - ! - ! -- Return - return - end subroutine read_options - - subroutine rewet_options(this) -! ****************************************************************************** -! rewet_options -- Set rewet options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: store_error, ustop - 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() - call ustop() - endif - 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)') & - '****ERROR. NPF REWETTING FLAGS MUST BE SPECIFIED IN ORDER. ' // & - 'FOUND IWETIT BUT WETFCT NOT SPECIFIED.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - 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)') & - '****ERROR. NPF REWETTING FLAGS MUST BE SPECIFIED IN ORDER. ' // & - 'FOUND IHDWET BUT IWETIT NOT SPECIFIED.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - 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)')'****ERROR. UNKNOWN NPF REWET OPTION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - enddo - ! - 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() - call ustop() - endif - ! - ! -- 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, ustop - use ConstantsModule, only: LINELENGTH - ! -- dummy - class(GwfNpftype) :: this - ! -- local - character(len=LINELENGTH) :: errmsg -! ------------------------------------------------------------------------------ - ! - if(this%inewton > 0) then - if(this%iperched > 0) then - write(errmsg, '(a)') 'ERROR IN NPF OPTIONS. NEWTON OPTION CANNOT ' // & - 'BE USED WITH PERCHED OPTION.' - call store_error(errmsg) - endif - if(this%ivarcv > 0) then - write(errmsg, '(a)') 'ERROR IN NPF OPTIONS. NEWTON OPTION CANNOT ' // & - 'BE USED WITH VARIABLECV OPTION.' - call store_error(errmsg) - endif - if(this%irewet > 0) then - write(errmsg, '(a)') 'ERROR IN NPF OPTIONS. NEWTON OPTION CANNOT ' // & - 'BE USED WITH REWET OPTION.' - call store_error(errmsg) - endif - endif - ! - if (this%ixt3d /= 0) then - if(this%icellavg > 0) then - write(errmsg, '(a)') 'ERROR IN NPF OPTIONS. ' // & - 'ALTERNATIVE_CELL_AVERAGING OPTION ' // & - 'CANNOT BE USED WITH XT3D OPTION.' - call store_error(errmsg) - endif - if(this%ithickstrt > 0) then - write(errmsg, '(a)') 'ERROR IN NPF OPTIONS. THICKSTRT OPTION ' // & - 'CANNOT BE USED WITH XT3D OPTION.' - call store_error(errmsg) - endif - if(this%iperched > 0) then - write(errmsg, '(a)') 'ERROR IN NPF OPTIONS. PERCHED OPTION ' // & - 'CANNOT BE USED WITH XT3D OPTION.' - call store_error(errmsg) - endif - if(this%ivarcv > 0) then - write(errmsg, '(a)') 'ERROR IN NPF OPTIONS. VARIABLECV OPTION ' // & - 'CANNOT BE USED WITH XT3D OPTION.' - call store_error(errmsg) - endif - end if - ! - ! -- Terminate if errors - if(count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Return - return - end subroutine check_options - - subroutine read_data(this) -! ****************************************************************************** -! read_data -- read the npf data block -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH, DONE, DPIO180 - use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_deallocate, & - mem_reassignptr - use SimModule, only: ustop, store_error, count_errors - ! -- dummy - class(GwfNpftype) :: this - ! -- local - 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 - ! -- 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)')'ERROR. REQUIRED GRIDDATA BLOCK NOT FOUND.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- Check for ICELLTYPE - if(.not. lname(1)) then - write(errmsg, '(a, a, a)') 'Error in GRIDDATA block: ', & - trim(adjustl(aname(1))), ' not found.' - call store_error(errmsg) - endif - ! - ! -- Check for K - if(.not. lname(2)) then - write(errmsg, '(a, a, a)') 'Error in GRIDDATA block: ', & - trim(adjustl(aname(2))), ' not found.' - call store_error(errmsg) - endif - ! - ! -- 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) - endif - write(this%iout, '(1x, a)') 'K33 not provided. Assuming K33 = K.' - call mem_reassignptr(this%k33, 'K33', trim(this%origin), & - 'K11', trim(this%origin)) - endif - ! - ! -- 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) - endif - write(this%iout, '(1x, a)') 'K22 not provided. Assuming K22 = K.' - call mem_reassignptr(this%k22, 'K22', trim(this%origin), & - 'K11', trim(this%origin)) - endif - ! - ! -- Set WETDRY - if (lname(5)) then - this%iwetdry = 1 - else - call mem_reallocate(this%wetdry, 1, 'WETDRY', trim(this%origin)) - end if - ! - ! -- set angle flags - if (lname(6)) then - this%iangle1 = 1 - else - if (this%ixt3d == 0) then - call mem_reallocate(this%angle1, 1, 'ANGLE1', trim(this%origin)) - end if - endif - if (lname(7)) then - this%iangle2 = 1 - else - if (this%ixt3d == 0) then - call mem_reallocate(this%angle2, 1, 'ANGLE2', trim(this%origin)) - end if - endif - if (lname(8)) then - this%iangle3 = 1 - else - if (this%ixt3d == 0) then - call mem_reallocate(this%angle3, 1, 'ANGLE3', trim(this%origin)) - end if - endif - ! - ! -- terminate if read errors encountered - if(count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Final NPFDATA message - write(this%iout,'(1x,a)')'END PROCESSING GRIDDATA' - ! - ! -- Return - return - end subroutine read_data - - subroutine prepcheck(this) -! ****************************************************************************** -! prepcheck -- Initialize and check NPF data -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH, DONE, DPIO180 - use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_deallocate - use SimModule, only: store_error, ustop, count_errors - ! -- dummy - class(GwfNpfType) :: this - ! -- local - logical :: finished - character(len=24), dimension(:), pointer :: aname - character(len=LINELENGTH) :: cellstr, errmsg - integer(I4B) :: nerr - real(DP) :: csat - real(DP) :: satn, topn, topm, botn - real(DP) :: fawidth - real(DP) :: hn, hm - real(DP) :: hyn, hym - integer(I4B) :: n, m, ii, nn, ihc - integer(I4B) :: nextn - real(DP) :: minbot, botm - integer(I4B), dimension(:), pointer, contiguous :: ithickstartflag - ! -- format - character(len=*), parameter :: fmtkerr = & - "(1x, 'Hydraulic property ',a,' is <= 0 for cell ',a, ' ', 1pg15.6)" - character(len=*), parameter :: fmtkerr2 = & - "(1x, '... ', i0,' additional errors not shown for ',a)" - character(len=*),parameter :: fmtcnv = & - "(1X,'CELL ', A, & - &' ELIMINATED BECAUSE ALL HYDRAULIC CONDUCTIVITIES TO NODE ARE 0.')" - character(len=*),parameter :: fmtnct = & - "(1X,'Negative cell thickness at cell ', A)" - character(len=*),parameter :: fmtihbe = & - "(1X,'Initial head, bottom elevation:',1P,2G13.5)" - character(len=*),parameter :: fmttebe = & - "(1X,'Top elevation, bottom elevation:',1P,2G13.5)" -! ------------------------------------------------------------------------------ - ! - ! -- initialize - aname => this%aname - ! - ! -- check k11 - nerr = 0 - do n = 1, size(this%k11) - if(this%k11(n) <= DZERO) then - nerr = nerr + 1 - if(nerr <= 20) then - call this%dis%noder_to_string(n, cellstr) - write(errmsg, fmtkerr) trim(adjustl(aname(2))), trim(cellstr), & - this%k11(n) - call store_error(errmsg) - endif - endif - enddo - if(nerr > 20) then - write(errmsg, fmtkerr2) nerr, trim(adjustl(aname(2))) - call store_error(errmsg) - endif - ! - ! -- check k33 because it was read - if (this%ik33 /= 0) then - ! - ! -- Check to make sure values are greater than or equal to zero - nerr = 0 - do n = 1, size(this%k33) - if (this%ik33overk /= 0) this%k33(n) = this%k33(n) * this%k11(n) - if(this%k33(n) <= DZERO) then - nerr = nerr + 1 - if(nerr <= 20) then - call this%dis%noder_to_string(n, cellstr) - write(errmsg, fmtkerr) trim(adjustl(aname(3))), trim(cellstr), & - this%k33(n) - call store_error(errmsg) - endif - endif - enddo - if(nerr > 20) then - write(errmsg, fmtkerr2) nerr, trim(adjustl(aname(3))) - call store_error(errmsg) - endif - end if - ! - ! -- check k22 because it was read - if (this%ik22 /= 0) then - ! - ! -- Check to make sure that angles are available - if(this%dis%con%ianglex == 0) then - write(errmsg, '(a)') 'Error. ANGLDEGX not provided in ' // & - 'discretization file, but K22 was specified. ' - call store_error(errmsg) - endif - ! - ! -- Check to make sure values are greater than or equal to zero - nerr = 0 - do n = 1, size(this%k22) - if (this%ik22overk /= 0) this%k22(n) = this%k22(n) * this%k11(n) - if(this%k22(n) <= DZERO) then - nerr = nerr + 1 - if(nerr <= 20) then - call this%dis%noder_to_string(n, cellstr) - write(errmsg, fmtkerr) trim(adjustl(aname(4))), trim(cellstr), & - this%k22(n) - call store_error(errmsg) - endif - endif - enddo - if(nerr > 20) then - write(errmsg, fmtkerr2) nerr, trim(adjustl(aname(4))) - call store_error(errmsg) - endif - end if - ! - ! -- check for wetdry conflicts - if(this%irewet == 1) then - if(this%iwetdry == 0) then - write(errmsg, '(a, a, a)') 'Error in GRIDDATA block: ', & - trim(adjustl(aname(5))), ' not found.' - call store_error(errmsg) - end if - endif - ! - ! -- Check for angle conflicts - if (this%iangle1 /= 0) then - do n = 1, size(this%angle1) - this%angle1(n) = this%angle1(n) * DPIO180 - enddo - else - if(this%ixt3d /= 0) then - this%iangle1 = 1 - write(this%iout, '(a)') 'XT3D IN USE, BUT ANGLE1 NOT SPECIFIED. ' // & - 'SETTING ANGLE1 TO ZERO.' - do n = 1, size(this%angle1) - this%angle1(n) = DZERO - enddo - endif - endif - if (this%iangle2 /= 0) then - if (this%iangle1 == 0) then - write(errmsg, '(a)') 'ANGLE2 SPECIFIED BUT NOT ANGLE1. ' // & - 'ANGLE2 REQUIRES ANGLE1. ' - call store_error(errmsg) - endif - if (this%iangle3 == 0) then - write(errmsg, '(a)') 'ANGLE2 SPECIFIED BUT NOT ANGLE3. ' // & - 'SPECIFY BOTH OR NEITHER ONE. ' - call store_error(errmsg) - endif - do n = 1, size(this%angle2) - this%angle2(n) = this%angle2(n) * DPIO180 - enddo - endif - if (this%iangle3 /= 0) then - if (this%iangle1 == 0) then - write(errmsg, '(a)') 'ANGLE3 SPECIFIED BUT NOT ANGLE1. ' // & - 'ANGLE3 REQUIRES ANGLE1. ' - call store_error(errmsg) - endif - if (this%iangle2 == 0) then - write(errmsg, '(a)') 'ANGLE3 SPECIFIED BUT NOT ANGLE2. ' // & - 'SPECIFY BOTH OR NEITHER ONE. ' - call store_error(errmsg) - endif - do n = 1, size(this%angle3) - this%angle3(n) = this%angle3(n) * DPIO180 - enddo - endif - ! - ! -- terminate if data errors - if(count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- allocate temporary storage to handle thickstart option - call mem_allocate(ithickstartflag, this%dis%nodes, 'ITHICKSTARTFLAG', & - trim(this%origin)) - do n = 1, this%dis%nodes - ithickstartflag(n) = 0 - end do - ! - ! -- Insure that each cell has at least one non-zero transmissive parameter - ! Note that a cell can be deactivated even if it has a valid connection - ! to another model. - nodeloop: do n = 1, this%dis%nodes - ! - ! -- Skip if already inactive - if(this%ibound(n) == 0) then - if(this%irewet /= 0) then - if(this%wetdry(n) == DZERO) cycle nodeloop - else - cycle nodeloop - endif - endif - ! - ! -- Cycle if k11 is not zero - if(this%k11(n) /= DZERO) cycle nodeloop - ! - ! -- Cycle if at least one vertical connection has non-zero k33 - ! for n and m - do ii = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 - m = this%dis%con%ja(ii) - if(this%dis%con%ihc(this%dis%con%jas(ii)) == 0) then - hyn = this%k11(n) - if(this%ik33 /= 0) hyn = this%k33(n) - if(hyn /= DZERO) then - hym = this%k11(m) - if(this%ik33 /= 0) hym = this%k33(m) - if(hym /= DZERO) cycle - endif - endif - enddo - ! - ! -- If this part of the loop is reached, then all connections have - ! zero transmissivity, so convert to noflow. - this%ibound(n) = 0 - this%hnew(n) = this%hnoflo - if(this%irewet /= 0) this%wetdry(n) = DZERO - call this%dis%noder_to_string(n, cellstr) - write(this%iout, fmtcnv) trim(adjustl(cellstr)) - ! - enddo nodeloop - ! - ! -- Preprocess cell status and heads based on initial conditions - if (this%inewton == 0) then - ! - ! -- For standard formulation (non-Newton) call wetdry routine - call this%wd(0, this%hnew) - else - ! - ! -- Newton formulation, so adjust heads to be above bottom - ! (Not used in present formulation because variable cv - ! cannot be used with Newton) - if (this%ivarcv == 1) then - do n = 1, this%dis%nodes - if (this%hnew(n) < this%dis%bot(n)) then - this%hnew(n) = this%dis%bot(n) + DEM6 - end if - end do - end if - end if - ! - ! -- Initialize sat to zero for ibound=0 cells, unless the cell can - ! rewet. Initialize sat to the saturated fraction based on strt - ! if icelltype is negative and the THCKSTRT option is in effect. - ! Initialize sat to 1.0 for all other cells in order to calculate - ! condsat in next section. - do n = 1, this%dis%nodes - if(this%ibound(n) == 0) then - this%sat(n) = DONE - if(this%icelltype(n) < 0 .and. this%ithickstrt /= 0) then - ithickstartflag(n) = 1 - this%icelltype(n) = 0 - endif - else - topn = this%dis%top(n) - botn = this%dis%bot(n) - if(this%icelltype(n) < 0 .and. this%ithickstrt /= 0) then - call this%thksat(n, this%ic%strt(n), satn) - if(botn > this%ic%strt(n)) then - call this%dis%noder_to_string(n, cellstr) - write(errmsg, fmtnct) trim(adjustl(cellstr)) - call store_error(errmsg) - write(errmsg, fmtihbe) this%ic%strt(n), botn - call store_error(errmsg) - endif - ithickstartflag(n) = 1 - this%icelltype(n) = 0 - else - satn = DONE - if(botn > topn) then - call this%dis%noder_to_string(n, cellstr) - write(errmsg, fmtnct) trim(adjustl(cellstr)) - call store_error(errmsg) - write(errmsg, fmttebe) topn, botn - call store_error(errmsg) - endif - endif - this%sat(n) = satn - endif - enddo - if(count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Calculate condsatu, but only if xt3d is not active. If xt3d is - ! active, then condsat is allocated to size of zero. - if (this%ixt3d == 0) then - ! - ! -- Calculate the saturated conductance for all connections assuming - ! that saturation is 1 (except for case where icelltype was entered - ! as a negative value and THCKSTRT option in effect) - do n = 1, this%dis%nodes - ! - topn = this%dis%top(n) - ! - ! -- Go through the connecting cells - do ii = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 - ! - ! -- Set the m cell number and cycle if lower triangle connection - m = this%dis%con%ja(ii) - if (m < n) cycle - ihc = this%dis%con%ihc(this%dis%con%jas(ii)) - topm = this%dis%top(m) - hyn = this%hy_eff(n, m, ihc, ipos=ii) - hym = this%hy_eff(m, n, ihc, ipos=ii) - if (ithickstartflag(n) == 0) then - hn = topn - else - hn = this%ic%strt(n) - end if - if (ithickstartflag(m) == 0) then - hm = topm - else - hm = this%ic%strt(m) - end if - ! - ! -- Calculate conductance depending on whether connection is - ! vertical (0), horizontal (1), or staggered horizontal (2) - if(ihc == 0) then - ! - ! -- Vertical conductance for fully saturated conditions - csat = vcond(1, 1, 1, 1, 0, 1, 1, DONE, & - this%dis%bot(n), this%dis%bot(m), & - hyn, hym, & - this%sat(n), this%sat(m), & - topn, topm, & - this%dis%bot(n), this%dis%bot(m), & - this%dis%con%hwva(this%dis%con%jas(ii))) - else - ! - ! -- Horizontal conductance for fully saturated conditions - fawidth = this%dis%con%hwva(this%dis%con%jas(ii)) - csat = hcond(1, 1, 1, 1, this%inewton, 0, & - this%dis%con%ihc(this%dis%con%jas(ii)), & - this%icellavg, this%iusgnrhc, this%inwtupw, & - DONE, & - hn, hm, this%sat(n), this%sat(m), hyn, hym, & - topn, topm, & - this%dis%bot(n), this%dis%bot(m), & - this%dis%con%cl1(this%dis%con%jas(ii)), & - this%dis%con%cl2(this%dis%con%jas(ii)), & - fawidth, this%satomega, this%satmin) - end if - this%condsat(this%dis%con%jas(ii)) = csat - enddo - enddo - ! - endif - ! - ! -- Determine the lower most node - if (this%igwfnewtonur /= 0) then - call mem_reallocate(this%ibotnode, this%dis%nodes, 'IBOTNODE', & - trim(this%origin)) - do n = 1, this%dis%nodes - ! - minbot = this%dis%bot(n) - nn = n - finished = .false. - do while(.not. finished) - nextn = 0 - ! - ! -- Go through the connecting cells - do ii = this%dis%con%ia(nn) + 1, this%dis%con%ia(nn + 1) - 1 - ! - ! -- Set the m cell number - m = this%dis%con%ja(ii) - botm = this%dis%bot(m) - ! - ! -- Calculate conductance depending on whether connection is - ! vertical (0), horizontal (1), or staggered horizontal (2) - if(this%dis%con%ihc(this%dis%con%jas(ii)) == 0) then - if (m > nn .and. botm < minbot) then - nextn = m - minbot = botm - end if - end if - end do - if (nextn > 0) then - nn = nextn - else - finished = .true. - end if - end do - this%ibotnode(n) = nn - end do - end if - ! - ! -- nullify unneeded gwf pointers - this%igwfnewtonur => null() - ! - ! - clean up local storage - call mem_deallocate(ithickstartflag) - ! - ! -- Return - return - end subroutine prepcheck - - subroutine sgwf_npf_wetdry(this, kiter, hnew) -! ****************************************************************************** -! sgwf_npf_wetdry -- Perform wetting and drying -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: kstp, kper - use SimModule, only: ustop, store_error - use ConstantsModule, only: LINELENGTH - ! -- dummy - class(GwfNpfType) :: this - integer(I4B),intent(in) :: kiter - real(DP),intent(inout),dimension(:) :: hnew - ! -- local - integer(I4B) :: n, m, ii, ihc - real(DP) :: ttop, bbot, thck - integer(I4B) :: ncnvrt,ihdcnv - character(len=30), dimension(5) :: nodcnvrt - character(len=30) :: nodestr - character(len=3),dimension(5) :: acnvrt - character(len=LINELENGTH) :: errmsg - integer(I4B) :: irewet - ! -- formats - character(len=*),parameter :: fmtnct = & - "(1X,/1X,'Negative cell thickness at (layer,row,col)', & - &I4,',',I5,',',I5)" - character(len=*),parameter :: fmttopbot = & - "(1X,'Top elevation, bottom elevation:',1P,2G13.5)" - character(len=*),parameter :: fmttopbotthk = & - "(1X,'Top elevation, bottom elevation, thickness:',1P,3G13.5)" - character(len=*),parameter :: fmtdrychd = & - "(1X,/1X,'CONSTANT-HEAD CELL WENT DRY -- SIMULATION ABORTED')" - character(len=*),parameter :: fmtni = & - "(1X,'CELLID=',a,' ITERATION=',I0,' TIME STEP=',I0,' STRESS PERIOD=',I0)" -! ------------------------------------------------------------------------------ - ! -- Initialize - ncnvrt = 0 - ihdcnv = 0 - ! - ! -- Convert dry cells to wet - do n = 1, this%dis%nodes - do ii = this%dis%con%ia(n)+1,this%dis%con%ia(n+1)-1 - m = this%dis%con%ja(ii) - ihc = this%dis%con%ihc(this%dis%con%jas(ii)) - call this%rewet_check(kiter, n, hnew(m), this%ibound(m), ihc, hnew, & - irewet) - if(irewet == 1) then - call this%wdmsg(2,ncnvrt,nodcnvrt,acnvrt,ihdcnv,kiter,n) - endif - enddo - enddo - ! - ! -- Perform drying - do n=1,this%dis%nodes - ! - ! -- cycle if inactive or confined - if(this%ibound(n) == 0) cycle - if(this%icelltype(n) == 0) cycle - ! - ! -- check for negative cell thickness - bbot=this%dis%bot(n) - ttop=this%dis%top(n) - if(bbot>ttop) then - write(errmsg, fmtnct) n - call store_error(errmsg) - write(errmsg, fmttopbot) ttop,bbot - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Calculate saturated thickness - if(this%icelltype(n)/=0) then - if(hnew(n) 0) then - itflg=mod(kiter, this%iwetit) - if(itflg == 0) then - if(this%ibound(node) == 0 .and. this%wetdry(node) /= DZERO) then - ! - ! -- Calculate wetting elevation - bbot = this%dis%bot(node) - wd = this%wetdry(node) - awd = wd - if(wd < 0) awd=-wd - turnon = bbot + awd - ! - ! -- Check head in adjacent cells to see if wetting elevation has - ! been reached - if(ihc == 0) then - ! - ! -- check cell below - if(ibdm > 0 .and. hm >= turnon) irewet = 1 - else - if(wd > DZERO) then - ! - ! -- check horizontally adjacent cells - if(ibdm > 0 .and. hm >= turnon) irewet = 1 - end if - endif - ! - if(irewet == 1) then - ! -- rewet cell; use equation 3a if ihdwet=0; use equation 3b if - ! ihdwet is not 0. - if(this%ihdwet==0) then - hnew(node) = bbot + this%wetfct * (hm - bbot) - else - hnew(node) = bbot + this%wetfct * awd !(hm - bbot) - endif - this%ibound(node) = 30000 - endif - endif - endif - endif - ! - ! -- Return - return - end subroutine rewet_check - - subroutine sgwf_npf_wdmsg(this,icode,ncnvrt,nodcnvrt,acnvrt,ihdcnv,kiter,n) -! ****************************************************************************** -! sgwf_npf_wdmsg -- Print wet/dry message -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: kstp, kper - ! -- dummy - class(GwfNpfType) :: this - integer(I4B),intent(in) :: icode - integer(I4B),intent(inout) :: ncnvrt - character(len=30), dimension(5), intent(inout) :: nodcnvrt - character(len=3),dimension(5),intent(inout) :: acnvrt - integer(I4B),intent(inout) :: ihdcnv - integer(I4B),intent(in) :: kiter - integer(I4B),intent(in) :: n - ! -- local - integer(I4B) :: l - ! -- formats - character(len=*),parameter :: fmtcnvtn = & - "(1X,/1X,'CELL CONVERSIONS FOR ITER.=',I0, & - &' STEP=',I0,' PERIOD=',I0,' (NODE or LRC)')" - character(len=*),parameter :: fmtnode = "(1X,3X,5(A4, A20))" -! ------------------------------------------------------------------------------ - ! -- Keep track of cell conversions - if(icode>0) then - ncnvrt=ncnvrt+1 - call this%dis%noder_to_string(n, nodcnvrt(ncnvrt)) - if(icode==1) then - acnvrt(ncnvrt)='DRY' - else - acnvrt(ncnvrt)='WET' - end if - end if - ! - ! -- Print a line if 5 conversions have occurred or if icode indicates that a - ! partial line should be printed - if(ncnvrt==5 .or. (icode==0 .and. ncnvrt>0)) then - if(ihdcnv==0) write(this%iout,fmtcnvtn) kiter,kstp,kper - ihdcnv=1 - write(this%iout,fmtnode) (acnvrt(l), trim(adjustl(nodcnvrt(l))),l=1,ncnvrt) - ncnvrt=0 - endif - ! - ! -- Return - return - end subroutine sgwf_npf_wdmsg - - function hy_eff(this, n, m, ihc, ipos, vg) result(hy) -! ****************************************************************************** -! hy_eff -- Calculate the effective hydraulic conductivity for the n-m -! connection. -! n is primary node node number -! m is connected node (not used if vg is provided) -! ihc is horizontal indicator (0 vertical, 1 horizontal, 2 vertically -! staggered) -! ipos_opt is position of connection in ja array -! vg is the global unit vector that expresses the direction from which to -! calculate an effective hydraulic conductivity. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - real(DP) :: hy - ! -- dummy - class(GwfNpfType) :: this - integer(I4B), intent(in) :: n - integer(I4B), intent(in) :: m - integer(I4B), intent(in) :: ihc - integer(I4B), intent(in), optional :: ipos - real(DP), dimension(3), intent(in), optional :: vg - ! -- local - integer(I4B) :: iipos - real(DP) :: hy11, hy22, hy33 - real(DP) :: ang1, ang2, ang3 - real(DP) :: vg1, vg2, vg3 - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- Initialize - iipos = 0 - if(present(ipos)) iipos = ipos - hy11 = this%k11(n) - hy22 = this%k11(n) - hy33 = this%k11(n) - if(this%ik22 /= 0) hy22 = this%k22(n) - if(this%ik33 /= 0) hy33 = this%k33(n) - ! - ! -- Calculate effective K based on whether connection is vertical - ! or horizontal - if(ihc == 0) then - ! - ! -- Handle rotated anisotropy case that would affect the effective - ! vertical hydraulic conductivity - hy = hy33 - if(this%iangle2 > 0) then - if(present(vg)) then - vg1 = vg(1) - vg2 = vg(2) - vg3 = vg(3) - else - call this%dis%connection_normal(n, m, ihc, vg1, vg2, vg3, iipos) - endif - ang1 = this%angle1(n) - ang2 = this%angle2(n) - ang3 = DZERO - if(this%iangle3 > 0) ang3 = this%angle3(n) - hy = hyeff_calc(hy11, hy22, hy33, ang1, ang2, ang3, vg1, vg2, vg3) - endif - ! - else - ! - ! -- Handle horizontal case - hy = hy11 - if(this%ik22 > 0) then - if(present(vg)) then - vg1 = vg(1) - vg2 = vg(2) - vg3 = vg(3) - else - call this%dis%connection_normal(n, m, ihc, vg1, vg2, vg3, iipos) - endif - ang1 = DZERO - ang2 = DZERO - ang3 = DZERO - if(this%iangle1 > 0) then - ang1 = this%angle1(n) - if(this%iangle2 > 0) then - ang2 = this%angle2(n) - if(this%iangle3 > 0) ang3 = this%angle3(n) - endif - endif - hy = hyeff_calc(hy11, hy22, hy33, ang1, ang2, ang3, vg1, vg2, vg3) - endif - ! - endif - ! - ! -- Return - return - end function hy_eff - - function hcond(ibdn, ibdm, ictn, ictm, inewton, inwtup, ihc, icellavg, iusg, & - iupw, condsat, hn, hm, satn, satm, hkn, hkm, topn, topm, & - botn, botm, cln, clm, fawidth, satomega, satminopt) & - result(condnm) -! ****************************************************************************** -! hcond -- Horizontal conductance between two cells -! inwtup: if 1, then upstream-weight condsat, otherwise recalculate -! -! hcond function uses a weighted transmissivity in the harmonic mean -! conductance calculations. This differs from the MODFLOW-NWT and MODFLOW-USG -! conductance calculations for the Newton-Raphson formulation which use a -! weighted hydraulic conductivity. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - real(DP) :: condnm - ! -- dummy - integer(I4B), intent(in) :: ibdn - integer(I4B), intent(in) :: ibdm - integer(I4B), intent(in) :: ictn - integer(I4B), intent(in) :: ictm - integer(I4B), intent(in) :: inewton - integer(I4B), intent(in) :: inwtup - integer(I4B), intent(in) :: ihc - integer(I4B), intent(in) :: icellavg - integer(I4B), intent(in) :: iusg - integer(I4B), intent(in) :: iupw - real(DP), intent(in) :: condsat - real(DP), intent(in) :: hn - real(DP), intent(in) :: hm - real(DP), intent(in) :: satn - real(DP), intent(in) :: satm - real(DP), intent(in) :: hkn - real(DP), intent(in) :: hkm - real(DP), intent(in) :: topn - real(DP), intent(in) :: topm - real(DP), intent(in) :: botn - real(DP), intent(in) :: botm - real(DP), intent(in) :: cln - real(DP), intent(in) :: clm - real(DP), intent(in) :: fawidth - real(DP), intent(in) :: satomega - real(DP), optional, intent(in) :: satminopt - ! -- local - integer(I4B) :: indk - real(DP) :: satmin - real(DP) :: sn - real(DP) :: sm - real(DP) :: thksatn - real(DP) :: thksatm - real(DP) :: sill_top, sill_bot - real(DP) :: tpn, tpm - real(DP) :: top, bot - real(DP) :: athk - real(DP) :: afac -! ------------------------------------------------------------------------------ - if (present(satminopt)) then - satmin = satminopt - else - satmin = DZERO - end if - ! - ! -- If either n or m is inactive then conductance is zero - if(ibdn == 0 .or. ibdm == 0) then - condnm = DZERO - ! - ! -- if both cells are non-convertible then use condsat - elseif(ictn == 0 .and. ictm == 0) then - if (icellavg /= 4) then - condnm = condsat - else - if (hn > hm) then - condnm = satn * (topn - botn) - else - condnm = satm * (topm - botm) - end if - condnm = condnm * condsat - end if - ! - ! -- At least one of the cells is convertible, so calculate average saturated - ! thickness and multiply with saturated conductance - else - if (inwtup == 1) then - ! -- set flag use to determine if bottom of cells n and m are - ! significantly different - indk = 0 - if (abs(botm-botn) < DEM2) indk = 1 - ! -- recalculate saturation if using MODFLOW-USG saturation - ! calculation approach - if (iusg == 1 .and. indk == 0) then - if (botm > botn) then - top = topm - bot = botm - else - top = topn - bot = botn - end if - sn = sQuadraticSaturation(top, bot, hn, satomega, satmin) - sm = sQuadraticSaturation(top, bot, hm, satomega, satmin) - else - sn = sQuadraticSaturation(topn, botn, hn, satomega, satmin) - sm = sQuadraticSaturation(topm, botm, hm, satomega, satmin) - end if - - if (hn > hm) then - condnm = sn - else - condnm = sm - end if - ! - ! -- if using MODFLOW-NWT upstream weighting option apply - ! factor to remove average thickness - if (iupw /= 0) then - if (hn > hm) then - afac = DTWO / (DONE + (topm - botm) / (topn - botn)) - condnm = condnm * afac - else - afac = DTWO / (DONE + (topn - botn) / (topm - botm)) - condnm = condnm * afac - end if - end if - ! - ! -- multiply condsat by condnm factor - condnm = condnm * condsat - else - thksatn = satn * (topn - botn) - thksatm = satm * (topm - botm) - ! - ! -- If staggered connection, subtract parts of cell that are above and - ! below the sill top and bottom elevations - if(ihc == 2) then - ! - ! -- Calculate sill_top and sill_bot - sill_top = min(topn, topm) - sill_bot = max(botn, botm) - ! - ! -- Calculate tpn and tpm - tpn = botn + thksatn - tpm = botm + thksatm - ! - ! -- Calculate saturated thickness for cells n and m - thksatn = max(min(tpn, sill_top) - sill_bot, DZERO) - thksatm = max(min(tpm, sill_top) - sill_bot, DZERO) - endif - - athk = DONE - if (iusg == 1) then - if (ihc == 2) then - athk = min(thksatn, thksatm) - else - athk = DHALF * (thksatn + thksatm) - end if - thksatn = DONE - thksatm = DONE - end if - ! - condnm = condmean(hkn, hkm, thksatn, thksatm, cln, clm, & - fawidth, icellavg) * athk - end if - endif - ! - ! -- Return - return - end function hcond - - function vcond(ibdn, ibdm, ictn, ictm, inewton, ivarcv, idewatcv, & - condsat, hn, hm, vkn, vkm, satn, satm, topn, topm, botn, & - botm, flowarea) result(condnm) -! ****************************************************************************** -! vcond -- Vertical conductance between two cells -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - real(DP) :: condnm - ! -- dummy - integer(I4B),intent(in) :: ibdn - integer(I4B),intent(in) :: ibdm - integer(I4B), intent(in) :: ictn - integer(I4B), intent(in) :: ictm - integer(I4B), intent(in) :: inewton - integer(I4B), intent(in) :: ivarcv - integer(I4B), intent(in) :: idewatcv - real(DP),intent(in) :: condsat - real(DP),intent(in) :: hn - real(DP),intent(in) :: hm - real(DP), intent(in) :: vkn - real(DP), intent(in) :: vkm - real(DP), intent(in) :: satn - real(DP), intent(in) :: satm - real(DP), intent(in) :: topn - real(DP), intent(in) :: topm - real(DP), intent(in) :: botn - real(DP), intent(in) :: botm - real(DP), intent(in) :: flowarea - ! -- local - real(DP) :: satntmp, satmtmp - real(DP) :: bovk1 - real(DP) :: bovk2 - real(DP) :: denom -! ------------------------------------------------------------------------------ - ! - ! -- If either n or m is inactive then conductance is zero - if(ibdn == 0 .or. ibdm == 0) then - condnm = DZERO - ! - ! -- if constantcv then use condsat - elseif(ivarcv == 0) then - condnm = condsat - ! - ! -- if both cells are non-convertible then use condsat - elseif(ictn == 0 .and. ictm == 0) then - condnm = condsat - ! - ! -- if both cells are fully saturated then use condsat - elseif(hn >= topn .and. hm >= topm) then - condnm = condsat - ! - ! -- At least one cell is partially saturated, so recalculate vertical - ! -- conductance for this connection - ! -- todo: upstream weighting? - else - ! - ! -- Default is for CV correction (dewatered option); use underlying - ! saturation of 1. - satntmp = satn - satmtmp = satm - if(idewatcv == 0) then - if(botn > botm) then - ! -- n is above m - satmtmp = DONE - else - ! -- m is above n - satntmp = DONE - endif - endif - bovk1 = satntmp * (topn - botn) * DHALF / vkn - bovk2 = satmtmp * (topm - botm) * DHALF / vkm - denom = (bovk1 + bovk2) - if(denom /= DZERO) then - condnm = flowarea / denom - else - condnm = DZERO - endif - endif - ! - ! -- Return - return - end function vcond - - function condmean(k1, k2, thick1, thick2, cl1, cl2, width, iavgmeth) -! ****************************************************************************** -! condmean -- Calculate the conductance between two cells -! -! k1 is hydraulic conductivity for cell 1 (in the direction of cell2) -! k2 is hydraulic conductivity for cell 2 (in the direction of cell1) -! thick1 is the saturated thickness for cell 1 -! thick2 is the saturated thickness for cell 2 -! cl1 is the distance from the center of cell1 to the shared face with cell2 -! cl2 is the distance from the center of cell2 to the shared face with cell1 -! h1 is the head for cell1 -! h2 is the head for cell2 -! width is the width perpendicular to flow -! iavgmeth is the averaging method: -! 0 is harmonic averaging -! 1 is logarithmic averaging -! 2 is arithmetic averaging of sat thickness and logarithmic averaging of -! hydraulic conductivity -! 3 is arithmetic averaging of sat thickness and harmonic averaging of -! hydraulic conductivity -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - real(DP) :: condmean - ! -- dummy - real(DP), intent(in) :: k1 - real(DP), intent(in) :: k2 - real(DP), intent(in) :: thick1 - real(DP), intent(in) :: thick2 - real(DP), intent(in) :: cl1 - real(DP), intent(in) :: cl2 - real(DP), intent(in) :: width - integer(I4B), intent(in) :: iavgmeth - ! -- local - real(DP) :: t1 - real(DP) :: t2 - real(DP) :: tmean, kmean, denom -! ------------------------------------------------------------------------------ - ! - ! -- Initialize - t1 = k1 * thick1 - t2 = k2 * thick2 - ! - ! -- Averaging - select case (iavgmeth) - ! - ! -- Harmonic-mean method - case(0) - ! - if (t1*t2 > DZERO) then - condmean = width * t1 * t2 / (t1 * cl2 + t2 * cl1) - else - condmean = DZERO - end if - ! - ! -- Logarithmic-mean method - case(1) - if (t1*t2 > DZERO) then - tmean = logmean(t1, t2) - else - tmean = DZERO - endif - condmean = tmean * width / (cl1 + cl2) - ! - ! -- Arithmetic-mean thickness and logarithmic-mean hydraulic conductivity - case(2) - if (k1*k2 > DZERO) then - kmean = logmean(k1, k2) - else - kmean = DZERO - endif - condmean = kmean * DHALF * (thick1 + thick2) * width / (cl1 + cl2) - ! - ! -- Arithmetic-mean thickness and harmonic-mean hydraulic conductivity - case(3) - denom = (k1 * cl2 + k2 * cl1) - if (denom > DZERO) then - kmean = k1 * k2 / denom - else - kmean = DZERO - end if - condmean = kmean * DHALF * (thick1 + thick2) * width - end select - ! - ! -- Return - return - end function condmean - - function logmean(d1, d2) -! ****************************************************************************** -! logmean -- Calculate the the logarithmic mean of two double precision -! numbers. Use an approximation if the ratio is near 1. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - real(DP) :: logmean - ! -- dummy - real(DP), intent(in) :: d1 - real(DP), intent(in) :: d2 - ! -- local - real(DP) :: drat -! ------------------------------------------------------------------------------ - ! - drat = d2 / d1 - if(drat <= DLNLOW .or. drat >= DLNHIGH) then - logmean = (d2 - d1) / log(drat) - else - logmean = DHALF * (d1 + d2) - endif - ! - ! -- Return - return - end function logmean - - function hyeff_calc(k11, k22, k33, ang1, ang2, ang3, vg1, vg2, vg3) & - result(hyeff) -! ****************************************************************************** -! hyeff_calc -- Calculate the effective horizontal hydraulic conductivity from -! an ellipse using a specified direction (unit vector vg1, vg2, vg3). -! k11 is the hydraulic conductivity of the major ellipse axis -! k22 is the hydraulic conductivity of first minor axis -! k33 is the hydraulic conductivity of the second minor axis -! vg1, vg2, and vg3 are the components of a unit vector in the -! direction of the connection between cell n and m -! a1 is the counter-clockwise rotation (radians) of the ellipse in -! the (x, y) plane -! a2 is the rotation of the conductivity ellipsoid upward or -! downward from the (x, y) plane -! a3 is the rotation of the conductivity ellipsoid about the major -! axis -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DONE - ! -- result - real(DP) :: hyeff - ! -- dummy - real(DP), intent(in) :: k11 - real(DP), intent(in) :: k22 - real(DP), intent(in) :: k33 - real(DP), intent(in) :: ang1 - real(DP), intent(in) :: ang2 - real(DP), intent(in) :: ang3 - real(DP), intent(in) :: vg1 - real(DP), intent(in) :: vg2 - real(DP), intent(in) :: vg3 - ! -- local - real(DP) :: s1, s2, s3, c1, c2, c3 - real(DP), dimension(3,3) :: r - real(DP) :: ve1, ve2, ve3 -! ------------------------------------------------------------------------------ - ! - ! -- Sin and cos of angles - s1 = sin(ang1) - c1 = cos(ang1) - s2 = sin(ang2) - c2 = cos(ang2) - s3 = sin(ang3) - c3 = cos(ang3) - ! - ! -- Rotation matrix - r(1,1) = c1*c2 - r(1,2) = c1*s2*s3 - s1*c3 - r(1,3) = -c1*s2*c3 - s1*s3 - r(2,1) = s1*c2 - r(2,2) = s1*s2*s3 + c1*c3 - r(2,3) = -s1*s2*c3 + c1*s3 - r(3,1) = s2 - r(3,2) = -c2*s3 - r(3,3) = c2*c3 - ! - ! -- Unit vector in direction of n-m connection - ve1 = r(1, 1) * vg1 + r(2, 1) * vg2 + r(3, 1) * vg3 - ve2 = r(1, 2) * vg1 + r(2, 2) * vg2 + r(3, 2) * vg3 - ve3 = r(1, 3) * vg1 + r(2, 3) * vg2 + r(3, 3) * vg3 - ! - ! -- Effective hydraulic conductivity - !hyeff = ve1 ** 2 / k11 + ve2 ** 2 / k22 + ve3 ** 2 / k33 - hyeff = DZERO - if (k11 /= DZERO) hyeff = hyeff + ve1 ** 2 / k11 - if (k22 /= DZERO) hyeff = hyeff + ve2 ** 2 / k22 - if (k33 /= DZERO) hyeff = hyeff + ve3 ** 2 / k33 - if (hyeff /= DZERO) hyeff = DONE / hyeff - ! - ! -- Return - return - end function hyeff_calc - - subroutine calc_spdis(this, flowja) -! ****************************************************************************** -! calc_spdis -- Calculate the 3 conmponents of specific discharge -! at the cell center. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: ustop, store_error - ! -- dummy - class(GwfNpfType) :: this - real(DP), intent(in), dimension(:) :: flowja - ! -- local - integer(I4B) :: n - integer(I4B) :: m - integer(I4B) :: ipos - integer(I4B) :: isympos - integer(I4B) :: ihc - integer(I4B) :: ic - integer(I4B) :: iz - integer(I4B) :: nc - integer(I4B) :: ncz - real(DP) :: qz - real(DP) :: vx - real(DP) :: vy - real(DP) :: vz - real(DP) :: xn - real(DP) :: yn - real(DP) :: zn - real(DP) :: xc - real(DP) :: yc - real(DP) :: zc - real(DP) :: cl1 - real(DP) :: cl2 - real(DP) :: dltot - real(DP) :: ooclsum - real(DP) :: dsumx - real(DP) :: dsumy - real(DP) :: dsumz - real(DP) :: denom - real(DP) :: area - real(DP) :: dz - real(DP) :: axy - real(DP) :: ayx - real(DP), allocatable, dimension(:) :: vi - real(DP), allocatable, dimension(:) :: di - real(DP), allocatable, dimension(:) :: viz - real(DP), allocatable, dimension(:) :: diz - real(DP), allocatable, dimension(:) :: nix - real(DP), allocatable, dimension(:) :: niy - real(DP), allocatable, dimension(:) :: wix - real(DP), allocatable, dimension(:) :: wiy - real(DP), allocatable, dimension(:) :: wiz - real(DP), allocatable, dimension(:) :: bix - real(DP), allocatable, dimension(:) :: biy - logical :: nozee = .true. -! ------------------------------------------------------------------------------ - ! - ! -- Ensure dis has necessary information - if(this%icalcspdis /= 0 .and. this%dis%con%ianglex == 0) then - call store_error('Error. ANGLDEGX not provided in ' // & - 'discretization file. ANGLDEGX required for ' // & - 'calculation of specific discharge.') - call ustop() - endif - ! - ! -- Find max number of connections and allocate weight arrays - nc = 0 - do n = 1, this%dis%nodes - ! - ! -- Count internal model connections - ic = this%dis%con%ia(n + 1) - this%dis%con%ia(n) - 1 - ! - ! -- Count edge connections - do m = 1, this%nedges - if (this%nodedge(m) == n) then - ic = ic + 1 - endif - enddo - ! - ! -- Set max number of connections for any cell - if (ic > nc) nc = ic - end do - ! - ! -- Allocate storage arrays needed for cell-centered spdis calculation - allocate(vi(nc)) - allocate(di(nc)) - allocate(viz(nc)) - allocate(diz(nc)) - allocate(nix(nc)) - allocate(niy(nc)) - allocate(wix(nc)) - allocate(wiy(nc)) - allocate(wiz(nc)) - allocate(bix(nc)) - allocate(biy(nc)) - ! - ! -- Go through each cell and calculate specific discharge - do n = 1, this%dis%nodes - ! - ! -- first calculate geometric properties for x and y directions and - ! the specific discharge at a face (vi) - ic = 0 - iz = 0 - vi(:) = DZERO - di(:) = DZERO - viz(:) = DZERO - diz(:) = DZERO - nix(:) = DZERO - niy(:) = DZERO - do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 - m = this%dis%con%ja(ipos) - isympos = this%dis%con%jas(ipos) - ihc = this%dis%con%ihc(isympos) - area = this%dis%con%hwva(isympos) - if (ihc == 0) then - ! - ! -- vertical connection - iz = iz + 1 - !call this%dis%connection_normal(n, m, ihc, xn, yn, zn, ipos) - call this%dis%connection_vector(n, m, nozee, this%sat(n), this%sat(m), & - ihc, xc, yc, zc, dltot) - cl1 = this%dis%con%cl1(isympos) - cl2 = this%dis%con%cl2(isympos) - ooclsum = DONE / (cl1 + cl2) - diz(iz) = dltot * cl1 * ooclsum - qz = flowja(ipos) - if (n > m) qz = -qz - viz(iz) = qz / area - else - ! - ! -- horizontal connection - ic = ic + 1 - dz = thksatnm(this%ibound(n), this%ibound(m), & - this%icelltype(n), this%icelltype(m), & - this%inewton, ihc, this%iusgnrhc, & - this%hnew(n), this%hnew(m), this%sat(n), this%sat(m), & - this%dis%top(n), this%dis%top(m), this%dis%bot(n), & - this%dis%bot(m), this%satomega, this%satmin) - area = area * dz - call this%dis%connection_normal(n, m, ihc, xn, yn, zn, ipos) - call this%dis%connection_vector(n, m, nozee, this%sat(n), this%sat(m), & - ihc, xc, yc, zc, dltot) - cl1 = this%dis%con%cl1(isympos) - cl2 = this%dis%con%cl2(isympos) - ooclsum = DONE / (cl1 + cl2) - nix(ic) = -xn - niy(ic) = -yn - di(ic) = dltot * cl1 * ooclsum - if (area > DZERO) then - vi(ic) = flowja(ipos) / area - else - vi(ic) = DZERO - endif - endif - end do - ! - ! -- Look through edge flows that may have been provided by an exchange - ! and incorporate them into the averaging arrays - do m = 1, this%nedges - if (this%nodedge(m) == n) then - ! - ! -- propsedge: (Q, area, nx, ny, distance) - ihc = this%ihcedge(m) - area = this%propsedge(2, m) - if (ihc == 0) then - iz = iz + 1 - viz(iz) = this%propsedge(1, m) / area - diz(iz) = this%propsedge(5, m) - else - ic = ic + 1 - nix(ic) = -this%propsedge(3, m) - niy(ic) = -this%propsedge(4, m) - di(ic) = this%propsedge(5, m) - if (area > DZERO) then - vi(ic) = this%propsedge(1, m) / area - else - vi(ic) = DZERO - endif - endif - endif - enddo - ! - ! -- Assign numnber of vertical and horizontal connections - ncz = iz - nc = ic - ! - ! -- calculate z weight (wiz) and z velocity - if (ncz == 1) then - wiz(1) = DONE - else - dsumz = DZERO - do iz = 1, ncz - dsumz = dsumz + diz(iz) - enddo - denom = (ncz - DONE) - if (denom < DZERO) denom = DZERO - dsumz = dsumz + DEM10 * dsumz - do iz = 1, ncz - if (dsumz > DZERO) wiz(iz) = DONE - diz(iz) / dsumz - if (denom > 0) then - wiz(iz) = wiz(iz) / denom - else - wiz(iz) = DZERO - endif - enddo - endif - vz = DZERO - do iz = 1, ncz - vz = vz + wiz(iz) * viz(iz) - enddo - ! - ! -- distance-based weighting - nc = ic - dsumx = DZERO - dsumy = DZERO - dsumz = DZERO - do ic = 1, nc - wix(ic) = di(ic) * abs(nix(ic)) - wiy(ic) = di(ic) * abs(niy(ic)) - dsumx = dsumx + wix(ic) - dsumy = dsumy + wiy(ic) - enddo - ! - ! -- Finish computing omega weights. Add a tiny bit - ! to dsum so that the normalized omega weight later - ! evaluates to (essentially) 1 in the case of a single - ! relevant connection, avoiding 0/0. - dsumx = dsumx + DEM10 * dsumx - dsumy = dsumy + DEM10 * dsumy - do ic = 1, nc - wix(ic) = (dsumx - wix(ic)) * abs(nix(ic)) - wiy(ic) = (dsumy - wiy(ic)) * abs(niy(ic)) - enddo - ! - ! -- compute B weights - dsumx = DZERO - dsumy = DZERO - do ic = 1, nc - bix(ic) = wix(ic) * sign(DONE, nix(ic)) - biy(ic) = wiy(ic) * sign(DONE, niy(ic)) - dsumx = dsumx + wix(ic) * abs(nix(ic)) - dsumy = dsumy + wiy(ic) * abs(niy(ic)) - enddo - if (dsumx > DZERO) dsumx = DONE / dsumx - if (dsumy > DZERO) dsumy = DONE / dsumy - axy = DZERO - ayx = DZERO - do ic = 1, nc - bix(ic) = bix(ic) * dsumx - biy(ic) = biy(ic) * dsumy - axy = axy + bix(ic) * niy(ic) - ayx = ayx + biy(ic) * nix(ic) - enddo - ! - ! -- Calculate specific discharge. The divide by zero checking below - ! is problematic for cells with only one flow, such as can happen - ! with triangular cells in corners. In this case, the resulting - ! cell velocity will be calculated as zero. The method should be - ! improved so that edge flows of zero are included in these - ! calculations. But this needs to be done with consideration for LGR - ! cases in which flows are submitted from an exchange. - vx = DZERO - vy = DZERO - do ic = 1, nc - vx = vx + (bix(ic) - axy * biy(ic)) * vi(ic) - vy = vy + (biy(ic) - ayx * bix(ic)) * vi(ic) - enddo - denom = DONE - axy * ayx - if (denom /= DZERO) then - vx = vx / denom - vy = vy / denom - endif - ! - this%spdis(1, n) = vx - this%spdis(2, n) = vy - this%spdis(3, n) = vz - ! - end do - ! - ! -- cleanup - deallocate(vi) - deallocate(di) - deallocate(nix) - deallocate(niy) - deallocate(wix) - deallocate(wiy) - deallocate(wiz) - deallocate(bix) - deallocate(biy) - ! - ! -- return - return - end subroutine calc_spdis - - subroutine sav_spdis(this, ibinun) -! ****************************************************************************** -! sav_spdis -- save specific discharge in binary format to ibinun -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(GwfNpfType) :: this - integer(I4B), intent(in) :: ibinun - ! -- local - character(len=16) :: text - character(len=16), dimension(3) :: auxtxt - integer(I4B) :: n - integer(I4B) :: naux -! ------------------------------------------------------------------------------ - ! - ! -- Write the header - text = ' DATA-SPDIS' - naux = 3 - auxtxt(:) = [' qx', ' qy', ' qz'] - call this%dis%record_srcdst_list_header(text, this%name_model, this%name, & - this%name_model, this%name, naux, auxtxt, ibinun, this%dis%nodes, & - this%iout) - ! - ! -- Write a zero for Q, and then write qx, qy, qz as aux variables - do n = 1, this%dis%nodes - call this%dis%record_mf6_list_entry(ibinun, n, n, DZERO, naux, & - this%spdis(:, n)) - end do - ! - ! -- return - return - end subroutine sav_spdis - - subroutine sav_sat(this, ibinun) -! ****************************************************************************** -! sav_sat -- save saturation in binary format to ibinun -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(GwfNpfType) :: this - integer(I4B), intent(in) :: ibinun - ! -- local - character(len=16) :: text - character(len=16), dimension(1) :: auxtxt - real(DP), dimension(1) :: a - integer(I4B) :: n - integer(I4B) :: naux -! ------------------------------------------------------------------------------ - ! - ! -- Write the header - text = ' DATA-SAT' - naux = 1 - auxtxt(:) = [' sat'] - call this%dis%record_srcdst_list_header(text, this%name_model, this%name, & - this%name_model, this%name, naux, auxtxt, ibinun, this%dis%nodes, & - this%iout) - ! - ! -- Write a zero for Q, and then write saturation as an aux variables - do n = 1, this%dis%nodes - a(1) = this%sat(n) - call this%dis%record_mf6_list_entry(ibinun, n, n, DZERO, naux, a) - end do - ! - ! -- return - return - end subroutine sav_sat - - subroutine increase_edge_count(this, nedges) -! ****************************************************************************** -! increase_edge_count -- reserve space for nedges cells that have an edge on them. -! This must be called before the npf%allocate_arrays routine, which is called -! from npf%ar. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(GwfNpfType) :: this - integer(I4B), intent(in) :: nedges - ! -- local -! ------------------------------------------------------------------------------ - ! - this%nedges = this%nedges + nedges - ! - ! -- return - return - end subroutine increase_edge_count - - subroutine set_edge_properties(this, nodedge, ihcedge, q, area, nx, ny, & - distance) -! ****************************************************************************** -! edge_count -- provide the npf package with edge properties. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(GwfNpfType) :: this - integer(I4B), intent(in) :: nodedge - integer(I4B), intent(in) :: ihcedge - real(DP), intent(in) :: q - real(DP), intent(in) :: area - real(DP), intent(in) :: nx - real(DP), intent(in) :: ny - real(DP), intent(in) :: distance - ! -- local - integer(I4B) :: lastedge -! ------------------------------------------------------------------------------ - ! - this%lastedge = this%lastedge + 1 - lastedge = this%lastedge - this%nodedge(lastedge) = nodedge - this%ihcedge(lastedge) = ihcedge - this%propsedge(1, lastedge) = q - this%propsedge(2, lastedge) = area - this%propsedge(3, lastedge) = nx - this%propsedge(4, lastedge) = ny - this%propsedge(5, lastedge) = distance - ! - ! -- If this is the last edge, then the next call must be starting a new - ! edge properties assignment loop, so need to reset lastedge to 0 - if (this%lastedge == this%nedges) this%lastedge = 0 - ! - ! -- return - return - end subroutine set_edge_properties - - function thksatnm(ibdn, ibdm, ictn, ictm, inwtup, ihc, iusg, & - hn, hm, satn, satm, topn, topm, botn, botm, & - satomega, satminopt) result(res) -! ****************************************************************************** -! thksatnm -- calculate saturated thickness at interface between two cells -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - real(DP) :: res - ! -- dummy - integer(I4B), intent(in) :: ibdn - integer(I4B), intent(in) :: ibdm - integer(I4B), intent(in) :: ictn - integer(I4B), intent(in) :: ictm - integer(I4B), intent(in) :: inwtup - integer(I4B), intent(in) :: ihc - integer(I4B), intent(in) :: iusg - real(DP), intent(in) :: hn - real(DP), intent(in) :: hm - real(DP), intent(in) :: satn - real(DP), intent(in) :: satm - real(DP), intent(in) :: topn - real(DP), intent(in) :: topm - real(DP), intent(in) :: botn - real(DP), intent(in) :: botm - real(DP), intent(in) :: satomega - real(DP), optional, intent(in) :: satminopt - ! -- local - integer(I4B) :: indk - real(DP) :: satmin - real(DP) :: sn - real(DP) :: sm - real(DP) :: thksatn - real(DP) :: thksatm - real(DP) :: sill_top, sill_bot - real(DP) :: tpn, tpm - real(DP) :: top, bot -! ------------------------------------------------------------------------------ - if (present(satminopt)) then - satmin = satminopt - else - satmin = DZERO - end if - ! - ! -- If either n or m is inactive then saturated thickness is zero - if(ibdn == 0 .or. ibdm == 0) then - res = DZERO - ! - ! -- if both cells are non-convertible then use average cell thickness - elseif(ictn == 0 .and. ictm == 0) then - res = DHALF * (topn - botn + topm - botm) - ! - ! -- At least one of the cells is convertible, so calculate average saturated - ! thickness - else - if (inwtup == 1) then - ! -- set flag used to determine if bottom of cells n and m are - ! significantly different - indk = 0 - if (abs(botm-botn) < DEM2) indk = 1 - ! -- recalculate saturation if using MODFLOW-USG saturation - ! calculation approach - if (iusg == 1 .and. indk == 0) then - if (botm > botn) then - top = topm - bot = botm - else - top = topn - bot = botn - end if - sn = sQuadraticSaturation(top, bot, hn, satomega, satmin) - sm = sQuadraticSaturation(top, bot, hm, satomega, satmin) - else - sn = sQuadraticSaturation(topn, botn, hn, satomega, satmin) - sm = sQuadraticSaturation(topm, botm, hm, satomega, satmin) - end if - ! - ! -- upstream weight the thickness - if (hn > hm) then - res = sn * (topn - botn) - else - res = sm * (topm - botm) - end if - ! - else - thksatn = satn * (topn - botn) - thksatm = satm * (topm - botm) - ! - ! -- If staggered connection, subtract parts of cell that are above and - ! below the sill top and bottom elevations - if(ihc == 2) then - ! - ! -- Calculate sill_top and sill_bot - sill_top = min(topn, topm) - sill_bot = max(botn, botm) - ! - ! -- Calculate tpn and tpm - tpn = botn + thksatn - tpm = botm + thksatm - ! - ! -- Calculate saturated thickness for cells n and m - thksatn = max(min(tpn, sill_top) - sill_bot, DZERO) - thksatm = max(min(tpm, sill_top) - sill_bot, DZERO) - endif - ! - res = DHALF * (thksatn + thksatm) - end if - endif - ! - ! -- Return - return - end function thksatnm - -end module GwfNpfModule +module GwfNpfModule + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, DEM9, DEM8, DEM7, DEM6, DEM2, & + DHALF, DP9, DONE, DTWO, & + DLNLOW, DLNHIGH, & + DHNOFLO, DHDRY, DEM10 + use SmoothingModule, only: sQuadraticSaturation, & + sQuadraticSaturationDerivative + use NumericalPackageModule, only: NumericalPackageType + use BaseDisModule, only: DisBaseType + use GwfIcModule, only: GwfIcType + use Xt3dModule, only: Xt3dType + use BlockParserModule, only: BlockParserType + + implicit none + + private + public :: GwfNpfType + public :: npf_cr + public :: hcond + public :: vcond + public :: condmean + public :: thksatnm + public :: hyeff_calc + + type, extends(NumericalPackageType) :: GwfNpfType + + type(GwfIcType), pointer :: ic => null() ! initial conditions object + type(Xt3dType), pointer :: xt3d => null() ! xt3d pointer + integer(I4B), pointer :: iname => null() ! length of variable names + character(len=24), dimension(:), pointer :: aname => null() ! variable names + 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 :: 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 + integer(I4B), pointer :: ithickstrt => null() ! thickstrt option flag + integer(I4B), pointer :: igwfnewtonur => null() ! newton head dampening using node bottom option flag + integer(I4B), pointer :: iusgnrhc => null() ! MODFLOW-USG saturation calculation option flag + integer(I4B), pointer :: inwtupw => null() ! MODFLOW-NWT upstream weighting option flag + integer(I4B), pointer :: icalcspdis => null() ! Calculate specific discharge at cell centers + integer(I4B), pointer :: isavspdis => null() ! Save specific discharge at cell centers + integer(I4B), pointer :: isavsat => null() ! Save sat to budget file + real(DP), pointer :: hnoflo => null() ! default is 1.e30 + real(DP), pointer :: satomega => null() ! newton-raphson saturation omega + integer(I4B),pointer :: irewet => null() ! rewetting (0:off, 1:on) + integer(I4B),pointer :: iwetit => null() ! wetting interval (default is 1) + integer(I4B),pointer :: ihdwet => null() ! (0 or not 0) + integer(I4B), pointer :: icellavg => null() ! harmonic(0), logarithmic(1), or arithmetic thick-log K (2) + real(DP), pointer :: wetfct => null() ! wetting factor + real(DP), pointer :: hdry => null() ! default is -1.d30 + integer(I4B), dimension(:), pointer, contiguous :: icelltype => null() ! confined (0) or convertible (1) + ! + ! K properties + real(DP), dimension(:), pointer, contiguous :: k11 => null() ! hydraulic conductivity; if anisotropic, then this is Kx prior to rotation + real(DP), dimension(:), pointer, contiguous :: k22 => null() ! hydraulic conductivity; if specified then this is Ky prior to rotation + real(DP), dimension(:), pointer, contiguous :: k33 => null() ! hydraulic conductivity; if specified then this is Kz prior to rotation + integer(I4B), pointer :: ik22 => null() ! flag that k22 is specified + integer(I4B), pointer :: ik33 => null() ! flag that k33 is specified + integer(I4B), pointer :: ik22overk => null() ! flag that k22 is specified as anisotropy ratio + integer(I4B), pointer :: ik33overk => null() ! flag that k33 is specified as anisotropy ratio + integer(I4B), pointer :: iangle1 => null() ! flag to indicate angle1 was read + integer(I4B), pointer :: iangle2 => null() ! flag to indicate angle2 was read + integer(I4B), pointer :: iangle3 => null() ! flag to indicate angle3 was read + real(DP), dimension(:), pointer, contiguous :: angle1 => null() ! k ellipse rotation in xy plane around z axis (yaw) + real(DP), dimension(:), pointer, contiguous :: angle2 => null() ! k ellipse rotation up from xy plane around y axis (pitch) + real(DP), dimension(:), pointer, contiguous :: angle3 => null() ! k tensor rotation around x axis (roll) + ! + integer(I4B), pointer :: iwetdry => null() ! flag to indicate angle1 was read + real(DP), dimension(:), pointer, contiguous :: wetdry => null() ! wetdry array + real(DP), dimension(:), pointer, contiguous :: sat => null() ! saturation (0. to 1.) for each cell + real(DP), dimension(:), pointer, contiguous :: condsat => null() ! saturated conductance (symmetric array) + real(DP), pointer :: satmin => null() ! minimum saturated thickness + integer(I4B), dimension(:), pointer, contiguous :: ibotnode => null() ! bottom node used if igwfnewtonur /= 0 + ! + real(DP), dimension(:, :), pointer, contiguous :: spdis => null() ! specific discharge : qx, qy, qz (nodes, 3) + integer(I4B), pointer :: nedges => null() ! number of cell edges + integer(I4B), pointer :: lastedge => null() ! last edge number + integer(I4B), dimension(:), pointer, contiguous :: nodedge => null() ! array of node numbers that have edges + integer(I4B), dimension(:), pointer, contiguous :: ihcedge => null() ! edge type (horizontal or vertical) + real(DP), dimension(:, :), pointer, contiguous :: propsedge => null() ! edge properties (Q, area, nx, ny, distance) + ! + contains + procedure :: npf_df + procedure :: npf_ac + procedure :: npf_mc + procedure :: npf_ar + procedure :: npf_init_mem + procedure :: npf_ad + procedure :: npf_cf + procedure :: npf_fc + procedure :: npf_fn + procedure :: npf_flowja + procedure :: npf_bdadj + procedure :: npf_nur + procedure :: npf_ot + procedure :: npf_da + procedure, private :: thksat => sgwf_npf_thksat + procedure, private :: qcalc => sgwf_npf_qcalc + procedure, private :: wd => sgwf_npf_wetdry + procedure, private :: wdmsg => sgwf_npf_wdmsg + procedure :: allocate_scalars + procedure, private :: allocate_arrays + procedure, private :: read_options + procedure, private :: rewet_options + procedure, private :: check_options + procedure, private :: read_data + procedure, private :: prepcheck + procedure, public :: rewet_check + procedure, public :: hy_eff + procedure, public :: calc_spdis + procedure, public :: sav_spdis + procedure, public :: sav_sat + procedure, public :: increase_edge_count + procedure, public :: set_edge_properties + endtype + + contains + + subroutine npf_cr(npfobj, name_model, inunit, iout) +! ****************************************************************************** +! npf_cr -- Create a new NPF object. Pass a inunit value of 0 if npf data will +! initialized from memory +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + type(GwfNpftype), pointer :: npfobj + character(len=*), intent(in) :: name_model + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout +! ------------------------------------------------------------------------------ + ! + ! -- Create the object + allocate(npfobj) + ! + ! -- create name and origin + call npfobj%set_names(1, name_model, 'NPF', 'NPF') + ! + ! -- Allocate scalars + call npfobj%allocate_scalars() + ! + ! -- Set variables + npfobj%inunit = inunit + npfobj%iout = iout + ! + ! -- Return + return + end subroutine npf_cr + + subroutine npf_df(this, dis, xt3d, ingnc) +! ****************************************************************************** +! npf_df -- Define +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: ustop, store_error + use Xt3dModule, only: xt3d_cr + ! -- dummy + class(GwfNpftype) :: this + class(DisBaseType), pointer, intent(inout) :: dis + type(Xt3dType), pointer :: xt3d + integer(I4B), intent(in) :: ingnc + ! -- local + ! -- formats + character(len=*), parameter :: fmtheader = & + "(1x, /1x, 'NPF -- NODE PROPERTY FLOW PACKAGE, VERSION 1, 3/30/2015', & + &' INPUT READ FROM UNIT ', i0, //)" + ! -- data +! ------------------------------------------------------------------------------ + ! + ! -- Print a message identifying the node property flow package. + write(this%iout, fmtheader) this%inunit + ! + ! -- Set a pointer to dis + this%dis => dis + ! + ! -- Initialize block parser + call this%parser%Initialize(this%inunit, this%iout) + ! + ! -- set, read, and check options + call this%read_options() + call this%check_options() + ! + ! -- Save pointer to xt3d object + this%xt3d => xt3d + if (this%ixt3d /= 0) xt3d%ixt3d = this%ixt3d + call this%xt3d%xt3d_df(dis) + ! + ! -- Ensure GNC and XT3D are not both on at the same time + if (this%ixt3d /= 0 .and. ingnc > 0) then + call store_error('Error in model ' // trim(this%name_model) // & + '. The XT3D option cannot be used with the GNC Package.') + call ustop() + endif + ! + ! -- Return + return + end subroutine npf_df + + subroutine npf_ac(this, moffset, sparse) +! ****************************************************************************** +! npf_ac -- Add connections for extended neighbors to the sparse matrix +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SparseModule, only: sparsematrix + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GwfNpftype) :: this + integer(I4B), intent(in) :: moffset + type(sparsematrix), intent(inout) :: sparse + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Add extended neighbors (neighbors of neighbors) + if(this%ixt3d /= 0) call this%xt3d%xt3d_ac(moffset, sparse) + ! + ! -- Return + return + end subroutine npf_ac + + subroutine npf_mc(this, moffset, iasln, jasln) +! ****************************************************************************** +! npf_mc -- Map connections and construct iax, jax, and idxglox +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GwfNpftype) :: this + integer(I4B), intent(in) :: moffset + integer(I4B), dimension(:), intent(in) :: iasln + integer(I4B), dimension(:), intent(in) :: jasln + ! -- local +! ------------------------------------------------------------------------------ + ! + if(this%ixt3d /= 0) call this%xt3d%xt3d_mc(moffset, iasln, & + jasln, this%inewton) + ! + ! -- Return + return + end subroutine npf_mc + + subroutine npf_init_mem(this, dis, ixt3d, icelltype, k11, k22, k33, wetdry, & + angle1, angle2, angle3) +! ****************************************************************************** +! npf_cr -- Create a new NPF object from memory +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfNpftype) :: this + class(DisBaseType), pointer, intent(inout) :: dis + integer(I4B), pointer, intent(in) :: ixt3d + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: icelltype + real(DP), dimension(:), pointer, contiguous, intent(inout) :: k11 + real(DP), dimension(:), pointer, contiguous, intent(inout), optional :: k22 + real(DP), dimension(:), pointer, contiguous, intent(inout), optional :: k33 + real(DP), dimension(:), pointer, contiguous, intent(inout), optional :: wetdry + real(DP), dimension(:), pointer, contiguous, intent(inout), optional :: angle1 + real(DP), dimension(:), pointer, contiguous, intent(inout), optional :: angle2 + real(DP), dimension(:), pointer, contiguous, intent(inout), optional :: angle3 + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Store pointers to arguments that were passed in + this%dis => dis + ! + ! -- set ixt3d (1 - HCOF and RHS; 2 - RHS only) + this%ixt3d = ixt3d + ! + ! -- allocate arrays + call this%allocate_arrays(dis%nodes, dis%njas) + ! + ! -- fill icelltype + call dis%fill_grid_array(icelltype, this%icelltype) + ! + ! -- fill k data + ! -- k11 + call dis%fill_grid_array(k11, this%k11) + ! -- k22 + if (present(k22)) then + this%ik22 = 1 + call dis%fill_grid_array(k22, this%k22) + end if + ! -- k33 + if (present(k33)) then + this%ik33 = 1 + call dis%fill_grid_array(k33, this%k33) + end if + ! + ! -- fill angle data + ! -- angle1 + if (present(angle1)) then + this%iangle1 = 1 + call dis%fill_grid_array(angle1, this%angle1) + end if + ! -- angle2 + if (present(angle2)) then + this%iangle2 = 1 + call dis%fill_grid_array(angle2, this%angle2) + end if + ! -- angle3 + if (present(angle3)) then + this%iangle3 = 1 + call dis%fill_grid_array(angle3, this%angle3) + end if + ! + ! -- fill wetdry data + if (present(wetdry)) then + this%iwetdry = 1 + this%irewet = 1 + end if + ! + ! -- Return + return + end subroutine npf_init_mem + + subroutine npf_ar(this, ic, ibound, hnew) +! ****************************************************************************** +! npf_ar -- Allocate and Read +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfNpftype) :: this + type(GwfIcType), pointer, intent(in) :: ic + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: ibound + real(DP), dimension(:), pointer, contiguous, intent(inout) :: hnew + ! -- local + ! -- formats + ! -- data +! ------------------------------------------------------------------------------ + ! + ! -- Store pointers to arguments that were passed in + this%ic => ic + this%ibound => ibound + this%hnew => hnew + ! + ! -- read data from files + if (this%inunit /= 0) then + ! + ! -- allocate arrays + call this%allocate_arrays(this%dis%nodes, this%dis%njas) + ! + ! -- read the data block + call this%read_data() + end if + ! + ! -- Initialize and check data + call this%prepcheck() + ! + ! -- xt3d + if (this%ixt3d /= 0) then + call this%xt3d%xt3d_ar(ibound, this%k11, this%ik33, this%k33, & + this%sat, this%ik22, this%k22, this%inewton, & + this%icelltype, this%iangle1, & + this%iangle2, this%iangle3, this%angle1, & + this%angle2, this%angle3) + end if + ! + ! -- Return + return + end subroutine npf_ar + + subroutine npf_ad(this, nodes, hold) +! ****************************************************************************** +! npf_ad -- Advance +! Subroutine (1) Sets hold to bot whenever a wettable cell is dry +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + class(GwfNpfType) :: this + integer(I4B),intent(in) :: nodes + real(DP),dimension(nodes),intent(inout) :: hold + integer(I4B) :: n +! ------------------------------------------------------------------------------ + ! + ! -- loop through all cells and set hold=bot if wettable cell is dry + if(this%irewet > 0) then + do n = 1, this%dis%nodes + if(this%wetdry(n) == DZERO) cycle + if(this%ibound(n) /= 0) cycle + hold(n) = this%dis%bot(n) + enddo + endif + ! + ! -- Return + return + end subroutine npf_ad + + subroutine npf_cf(this, kiter, nodes, hnew) +! ****************************************************************************** +! npf_cf -- Formulate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfNpfType) :: this + integer(I4B) :: kiter + integer(I4B),intent(in) :: nodes + real(DP),intent(inout),dimension(nodes) :: hnew + ! -- local + integer(I4B) :: n + real(DP) :: satn +! ------------------------------------------------------------------------------ + ! + ! -- Perform wetting and drying + if (this%inewton /= 1) then + call this%wd(kiter, hnew) + end if + ! + ! -- Calculate saturation for convertible cells + do n = 1, this%dis%nodes + if(this%icelltype(n) /= 0) then + if(this%ibound(n) == 0) then + satn = DZERO + else + call this%thksat(n, hnew(n), satn) + endif + this%sat(n) = satn + endif + enddo + ! + ! -- Return + return + end subroutine npf_cf + + subroutine npf_fc(this, kiter, njasln, amat, idxglo, rhs, hnew) +! ****************************************************************************** +! npf_fc -- Formulate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DONE + ! -- dummy + class(GwfNpfType) :: this + integer(I4B) :: kiter + integer(I4B),intent(in) :: njasln + real(DP),dimension(njasln),intent(inout) :: amat + integer(I4B),intent(in),dimension(:) :: idxglo + real(DP),intent(inout),dimension(:) :: rhs + real(DP),intent(inout),dimension(:) :: hnew + ! -- local + integer(I4B) :: n, m, ii, idiag, ihc + integer(I4B) :: isymcon, idiagm + real(DP) :: hyn, hym + real(DP) :: cond +! ------------------------------------------------------------------------------ + ! + ! -- Calculate conductance and put into amat + ! + if(this%ixt3d /= 0) then + call this%xt3d%xt3d_fc(kiter, njasln, amat, idxglo, rhs, hnew) + else + ! + do n = 1, this%dis%nodes + do ii = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 + if (this%dis%con%mask(ii) == 0) cycle + + m = this%dis%con%ja(ii) + ! + ! -- Calculate conductance only for upper triangle but insert into + ! upper and lower parts of amat. + if(m < n) cycle + ihc = this%dis%con%ihc(this%dis%con%jas(ii)) + hyn = this%hy_eff(n, m, ihc, ipos=ii) + hym = this%hy_eff(m, n, ihc, ipos=ii) + ! + ! -- Vertical connection + if(ihc == 0) then + ! + ! -- Calculate vertical conductance + cond = vcond(this%ibound(n), this%ibound(m), & + this%icelltype(n), this%icelltype(m), this%inewton, & + this%ivarcv, this%idewatcv, & + this%condsat(this%dis%con%jas(ii)), hnew(n), hnew(m), & + hyn, hym, & + this%sat(n), this%sat(m), & + this%dis%top(n), this%dis%top(m), & + this%dis%bot(n), this%dis%bot(m), & + this%dis%con%hwva(this%dis%con%jas(ii))) + ! + ! -- Vertical flow for perched conditions + if(this%iperched /= 0) then + if(this%icelltype(m) /= 0) then + if(hnew(m) < this%dis%top(m)) then + ! + ! -- Fill row n + idiag = this%dis%con%ia(n) + rhs(n) = rhs(n) - cond * this%dis%bot(n) + amat(idxglo(idiag)) = amat(idxglo(idiag)) - cond + ! + ! -- Fill row m + isymcon = this%dis%con%isym(ii) + amat(idxglo(isymcon)) = amat(idxglo(isymcon)) + cond + rhs(m) = rhs(m) + cond * this%dis%bot(n) + ! + ! -- cycle the connection loop + cycle + endif + endif + endif + ! + else + ! + ! -- Horizontal conductance + cond = hcond(this%ibound(n), this%ibound(m), & + this%icelltype(n), this%icelltype(m), & + this%inewton, this%inewton, & + this%dis%con%ihc(this%dis%con%jas(ii)), & + this%icellavg, this%iusgnrhc, this%inwtupw, & + this%condsat(this%dis%con%jas(ii)), & + hnew(n), hnew(m), this%sat(n), this%sat(m), hyn, hym, & + this%dis%top(n), this%dis%top(m), & + this%dis%bot(n), this%dis%bot(m), & + this%dis%con%cl1(this%dis%con%jas(ii)), & + this%dis%con%cl2(this%dis%con%jas(ii)), & + this%dis%con%hwva(this%dis%con%jas(ii)), & + this%satomega, this%satmin) + endif + ! + ! -- Fill row n + idiag = this%dis%con%ia(n) + amat(idxglo(ii)) = amat(idxglo(ii)) + cond + amat(idxglo(idiag)) = amat(idxglo(idiag)) - cond + ! + ! -- Fill row m + isymcon = this%dis%con%isym(ii) + idiagm = this%dis%con%ia(m) + amat(idxglo(isymcon)) = amat(idxglo(isymcon)) + cond + amat(idxglo(idiagm)) = amat(idxglo(idiagm)) - cond + enddo + enddo + ! + endif + ! + ! -- Return + return + end subroutine npf_fc + + + subroutine npf_fn(this, kiter, njasln, amat, idxglo, rhs, hnew) +! ****************************************************************************** +! npf_fn -- Fill newton terms +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfNpfType) :: this + integer(I4B) :: kiter + integer(I4B),intent(in) :: njasln + real(DP),dimension(njasln),intent(inout) :: amat + integer(I4B),intent(in),dimension(:) :: idxglo + real(DP),intent(inout),dimension(:) :: rhs + real(DP),intent(inout),dimension(:) :: hnew + ! -- local + integer(I4B) :: nodes, nja + integer(I4B) :: n,m,ii,idiag + integer(I4B) :: isymcon, idiagm + integer(I4B) :: iups + integer(I4B) :: idn + real(DP) :: cond + real(DP) :: consterm + real(DP) :: filledterm + real(DP) :: derv + real(DP) :: hds + real(DP) :: term + real(DP) :: afac + real(DP) :: topup + real(DP) :: botup + real(DP) :: topdn + real(DP) :: botdn +! ------------------------------------------------------------------------------ + ! + ! -- add newton terms to solution matrix + ! + nodes = this%dis%nodes + nja = this%dis%con%nja + if(this%ixt3d /= 0) then + call this%xt3d%xt3d_fn(kiter, nodes, nja, njasln, amat, idxglo, rhs, hnew) + else + ! + do n=1, nodes + idiag=this%dis%con%ia(n) + do ii=this%dis%con%ia(n)+1,this%dis%con%ia(n+1)-1 + if (this%dis%con%mask(ii) == 0) cycle + + m=this%dis%con%ja(ii) + isymcon = this%dis%con%isym(ii) + ! work on upper triangle + if(m < n) cycle + if(this%dis%con%ihc(this%dis%con%jas(ii))==0 .and. & + this%ivarcv == 0) then + !call this%vcond(n,m,hnew(n),hnew(m),ii,cond) + ! do nothing + else + ! determine upstream node + iups = m + if (hnew(m) < hnew(n)) iups = n + idn = n + if (iups == n) idn = m + ! + ! -- no newton terms if upstream cell is confined + if (this%icelltype(iups) == 0) cycle + ! + ! -- Set the upstream top and bot, and then recalculate for a + ! vertically staggered horizontal connection + topup = this%dis%top(iups) + botup = this%dis%bot(iups) + if(this%dis%con%ihc(this%dis%con%jas(ii)) == 2) then + topup = min(this%dis%top(n), this%dis%top(m)) + botup = max(this%dis%bot(n), this%dis%bot(m)) + endif + ! + ! get saturated conductivity for derivative + cond = this%condsat(this%dis%con%jas(ii)) + ! + ! -- if using MODFLOW-NWT upstream weighting option apply + ! factor to remove average thickness + if (this%inwtupw /= 0) then + topdn = this%dis%top(idn) + botdn = this%dis%bot(idn) + afac = DTWO / (DONE + (topdn - botdn) / (topup - botup)) + cond = cond * afac + end if + ! + ! compute additional term + consterm = -cond * (hnew(iups) - hnew(idn)) !needs to use hwadi instead of hnew(idn) + !filledterm = cond + filledterm = amat(idxglo(ii)) + derv = sQuadraticSaturationDerivative(topup, botup, hnew(iups), & + this%satomega, this%satmin) + idiagm = this%dis%con%ia(m) + ! fill jacobian for n being the upstream node + if (iups == n) then + hds = hnew(m) + !isymcon = this%dis%con%isym(ii) + term = consterm * derv + rhs(n) = rhs(n) + term * hnew(n) !+ amat(idxglo(isymcon)) * (dwadi * hds - hds) !need to add dwadi + rhs(m) = rhs(m) - term * hnew(n) !- amat(idxglo(isymcon)) * (dwadi * hds - hds) !need to add dwadi + ! fill in row of n + amat(idxglo(idiag)) = amat(idxglo(idiag)) + term + ! fill newton term in off diagonal if active cell + if (this%ibound(n) > 0) then + amat(idxglo(ii)) = amat(idxglo(ii)) !* dwadi !need to add dwadi + end if + !fill row of m + amat(idxglo(idiagm)) = amat(idxglo(idiagm)) !- filledterm * (dwadi - DONE) !need to add dwadi + ! fill newton term in off diagonal if active cell + if (this%ibound(m) > 0) then + amat(idxglo(isymcon)) = amat(idxglo(isymcon)) - term + end if + ! fill jacobian for m being the upstream node + else + hds = hnew(n) + term = -consterm * derv + rhs(n) = rhs(n) + term * hnew(m) !+ amat(idxglo(ii)) * (dwadi * hds - hds) !need to add dwadi + rhs(m) = rhs(m) - term * hnew(m) !- amat(idxglo(ii)) * (dwadi * hds - hds) !need to add dwadi + ! fill in row of n + amat(idxglo(idiag)) = amat(idxglo(idiag)) !- filledterm * (dwadi - DONE) !need to add dwadi + ! fill newton term in off diagonal if active cell + if (this%ibound(n) > 0) then + amat(idxglo(ii)) = amat(idxglo(ii)) + term + end if + !fill row of m + amat(idxglo(idiagm)) = amat(idxglo(idiagm)) - term + ! fill newton term in off diagonal if active cell + if (this%ibound(m) > 0) then + amat(idxglo(isymcon)) = amat(idxglo(isymcon)) !* dwadi !need to add dwadi + end if + end if + endif + + enddo + end do + ! + end if + ! + ! -- Return + return + end subroutine npf_fn + + subroutine npf_nur(this, neqmod, x, xtemp, dx, inewtonur, dxmax, locmax) +! ****************************************************************************** +! bnd_nur -- under-relaxation +! Subroutine: (1) Under-relaxation of Groundwater Flow Model Heads for current +! outer iteration using the cell bottoms at the bottom of the +! model +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfNpfType) :: this + integer(I4B), intent(in) :: neqmod + real(DP), dimension(neqmod), intent(inout) :: x + real(DP), dimension(neqmod), intent(in) :: xtemp + real(DP), dimension(neqmod), intent(inout) :: dx + integer(I4B), intent(inout) :: inewtonur + real(DP), intent(inout) :: dxmax + integer(I4B), intent(inout) :: locmax + ! -- local + integer(I4B) :: n + real(DP) :: botm + real(DP) :: xx + real(DP) :: dxx +! ------------------------------------------------------------------------------ + + ! + ! -- Newton-Raphson under-relaxation + do n = 1, this%dis%nodes + if (this%ibound(n) < 1) cycle + if (this%icelltype(n) > 0) then + botm = this%dis%bot(this%ibotnode(n)) + ! -- only apply Newton-Raphson under-relaxation if + ! solution head is below the bottom of the model + if (x(n) < botm) then + inewtonur = 1 + xx = xtemp(n)*(DONE-DP9) + botm*DP9 + dxx = x(n) - xx + if (abs(dxx) > abs(dxmax)) then + locmax = n + dxmax = dxx + end if + x(n) = xx + dx(n) = DZERO + end if + end if + enddo + ! + ! -- return + return + end subroutine npf_nur + + subroutine npf_flowja(this, hnew, flowja) +! ****************************************************************************** +! npf_flowja -- Calculate flowja +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfNpfType) :: this + real(DP),intent(inout),dimension(:) :: hnew + real(DP),intent(inout),dimension(:) :: flowja + ! -- local + integer(I4B) :: n, ipos, m + real(DP) :: qnm +! ------------------------------------------------------------------------------ + ! + ! -- Calculate the flow across each cell face and store in flowja + ! + if(this%ixt3d /= 0) then + call this%xt3d%xt3d_flowja(hnew, flowja) + else + ! + do n = 1, this%dis%nodes + do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 + m = this%dis%con%ja(ipos) + if(m < n) cycle + call this%qcalc(n, m, hnew(n), hnew(m), ipos, qnm) + flowja(ipos) = qnm + flowja(this%dis%con%isym(ipos)) = -qnm + enddo + enddo + ! + endif + ! + ! -- Return + return + end subroutine npf_flowja + + subroutine sgwf_npf_thksat(this, n, hn, thksat) +! ****************************************************************************** +! sgwf_npf_thksat -- Fractional cell saturation +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfNpfType) :: this + integer(I4B),intent(in) :: n + real(DP),intent(in) :: hn + real(DP),intent(inout) :: thksat +! ------------------------------------------------------------------------------ + ! + ! -- Standard Formulation + if(hn >= this%dis%top(n)) then + thksat = DONE + else + thksat = (hn - this%dis%bot(n)) / (this%dis%top(n) - this%dis%bot(n)) + endif + ! + ! -- Newton-Raphson Formulation + if(this%inewton /= 0) then + thksat = sQuadraticSaturation(this%dis%top(n), this%dis%bot(n), hn, & + this%satomega, this%satmin) + !if (thksat < this%satmin) thksat = this%satmin + endif + ! + ! -- Return + return + end subroutine sgwf_npf_thksat + + subroutine sgwf_npf_qcalc(this, n, m, hn, hm, icon, qnm) +! ****************************************************************************** +! sgwf_npf_qcalc -- Flow between two cells +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfNpfType) :: this + integer(I4B),intent(in) :: n + integer(I4B),intent(in) :: m + real(DP),intent(in) :: hn + real(DP),intent(in) :: hm + integer(I4B),intent(in) :: icon + real(DP),intent(inout) :: qnm + ! -- local + real(DP) :: hyn, hym + real(DP) :: condnm + real(DP) :: hntemp, hmtemp + integer(I4B) :: ihc +! ------------------------------------------------------------------------------ + ! + ! -- Initialize + ihc = this%dis%con%ihc(this%dis%con%jas(icon)) + hyn = this%hy_eff(n, m, ihc, ipos=icon) + hym = this%hy_eff(m, n, ihc, ipos=icon) + ! + ! -- Calculate conductance + if(ihc == 0) then + condnm = vcond(this%ibound(n), this%ibound(m), & + this%icelltype(n), this%icelltype(m), this%inewton, & + this%ivarcv, this%idewatcv, & + this%condsat(this%dis%con%jas(icon)), hn, hm, & + hyn, hym, & + this%sat(n), this%sat(m), & + this%dis%top(n), this%dis%top(m), & + this%dis%bot(n), this%dis%bot(m), & + this%dis%con%hwva(this%dis%con%jas(icon))) + else + condnm = hcond(this%ibound(n), this%ibound(m), & + this%icelltype(n), this%icelltype(m), & + this%inewton, this%inewton, & + this%dis%con%ihc(this%dis%con%jas(icon)), & + this%icellavg, this%iusgnrhc, this%inwtupw, & + this%condsat(this%dis%con%jas(icon)), & + hn, hm, this%sat(n), this%sat(m), hyn, hym, & + this%dis%top(n), this%dis%top(m), & + this%dis%bot(n), this%dis%bot(m), & + this%dis%con%cl1(this%dis%con%jas(icon)), & + this%dis%con%cl2(this%dis%con%jas(icon)), & + this%dis%con%hwva(this%dis%con%jas(icon)), & + this%satomega, this%satmin) + endif + ! + ! -- Initialize hntemp and hmtemp + hntemp = hn + hmtemp = hm + ! + ! -- Check and adjust for dewatered conditions + if(this%iperched /= 0) then + if(this%dis%con%ihc(this%dis%con%jas(icon)) == 0) then + if(n > m) then + if(this%icelltype(n) /= 0) then + if(hn < this%dis%top(n)) hntemp = this%dis%bot(m) + endif + else + if(this%icelltype(m) /= 0) then + if(hm < this%dis%top(m)) hmtemp = this%dis%bot(n) + endif + endif + endif + endif + ! + ! -- Calculate flow positive into cell n + qnm = condnm * (hmtemp - hntemp) + ! + ! -- Return + return + end subroutine sgwf_npf_qcalc + + subroutine npf_bdadj(this, flowja, icbcfl, icbcun) +! ****************************************************************************** +! npf_bdadj -- Record flowja and calculate specific discharge if requested +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfNpfType) :: this + real(DP),dimension(:),intent(in) :: flowja + integer(I4B), intent(in) :: icbcfl + integer(I4B), intent(in) :: icbcun + ! -- local + integer(I4B) :: ibinun + !data + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- Set unit number for binary output + if(this%ipakcb < 0) then + ibinun = icbcun + elseif(this%ipakcb == 0) then + ibinun = 0 + else + ibinun = this%ipakcb + endif + if(icbcfl == 0) ibinun = 0 + ! + ! -- Write the face flows if requested + if(ibinun /= 0) then + call this%dis%record_connection_array(flowja, ibinun, this%iout) + endif + ! + ! -- Calculate specific discharge at cell centers and write, if requested + if (this%icalcspdis /= 0) then + call this%calc_spdis(flowja) + if(ibinun /= 0) call this%sav_spdis(ibinun) + endif + ! + ! -- Save saturation, if requested + if (this%isavsat /= 0) then + if(ibinun /= 0) call this%sav_sat(ibinun) + endif + ! + ! -- Return + return + end subroutine npf_bdadj + + subroutine npf_ot(this, flowja) +! ****************************************************************************** +! npf_ot -- Budget +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: kper, kstp + use ConstantsModule, only: LENBIGLINE + ! -- dummy + class(GwfNpfType) :: this + real(DP),intent(inout),dimension(:) :: flowja + ! -- local + character(len=LENBIGLINE) :: line + character(len=30) :: tempstr + integer(I4B) :: n, ipos, m + real(DP) :: qnm + ! -- formats + character(len=*), parameter :: fmtiprflow = & + "(/,4x,'CALCULATED INTERCELL FLOW FOR PERIOD ', i0, ' STEP ', i0)" +! ------------------------------------------------------------------------------ + ! + ! -- Write flowja to list file if requested + if (this%iprflow > 0) then + write(this%iout, fmtiprflow) kper, kstp + do n = 1, this%dis%nodes + line = '' + call this%dis%noder_to_string(n, tempstr) + line = trim(tempstr) // ':' + do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 + m = this%dis%con%ja(ipos) + call this%dis%noder_to_string(m, tempstr) + line = trim(line) // ' ' // trim(tempstr) + qnm = flowja(ipos) + write(tempstr, '(1pg15.6)') qnm + line = trim(line) // ' ' // trim(adjustl(tempstr)) + enddo + write(this%iout, '(a)') trim(line) + enddo + endif + ! + ! -- Return + return + end subroutine npf_ot + + subroutine npf_da(this) +! ****************************************************************************** +! npf_da -- Deallocate variables +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(GwfNpftype) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Strings + ! + ! -- Scalars + call mem_deallocate(this%iname) + call mem_deallocate(this%ixt3d) + call mem_deallocate(this%satomega) + call mem_deallocate(this%hnoflo) + call mem_deallocate(this%hdry) + call mem_deallocate(this%icellavg) + call mem_deallocate(this%ik22) + call mem_deallocate(this%ik33) + call mem_deallocate(this%iperched) + call mem_deallocate(this%ivarcv) + call mem_deallocate(this%idewatcv) + call mem_deallocate(this%ithickstrt) + call mem_deallocate(this%iusgnrhc) + call mem_deallocate(this%inwtupw) + call mem_deallocate(this%isavspdis) + call mem_deallocate(this%isavsat) + call mem_deallocate(this%icalcspdis) + call mem_deallocate(this%irewet) + call mem_deallocate(this%wetfct) + call mem_deallocate(this%iwetit) + call mem_deallocate(this%ihdwet) + call mem_deallocate(this%satmin) + call mem_deallocate(this%ibotnode) + call mem_deallocate(this%iwetdry) + call mem_deallocate(this%iangle1) + call mem_deallocate(this%iangle2) + call mem_deallocate(this%iangle3) + call mem_deallocate(this%nedges) + call mem_deallocate(this%lastedge) + call mem_deallocate(this%ik22overk) + call mem_deallocate(this%ik33overk) + ! + ! -- Deallocate arrays + call mem_deallocate(this%icelltype) + call mem_deallocate(this%k11) + call mem_deallocate(this%k22, 'K22', this%origin) + call mem_deallocate(this%k33, 'K33', this%origin) + call mem_deallocate(this%sat) + call mem_deallocate(this%condsat) + call mem_deallocate(this%wetdry) + call mem_deallocate(this%angle1) + call mem_deallocate(this%angle2) + call mem_deallocate(this%angle3) + call mem_deallocate(this%nodedge) + call mem_deallocate(this%ihcedge) + call mem_deallocate(this%propsedge) + call mem_deallocate(this%spdis) + ! + ! -- deallocate parent + call this%NumericalPackageType%da() + ! + ! -- Return + return + end subroutine npf_da + + subroutine allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars -- Allocate scalar pointer variables +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate, mem_setptr + ! -- dummy + class(GwfNpftype) :: this +! ------------------------------------------------------------------------------ + ! + ! -- allocate scalars in NumericalPackageType + call this%NumericalPackageType%allocate_scalars() + ! + ! -- Allocate scalars + call mem_allocate(this%iname, 'INAME', this%origin) + call mem_allocate(this%ixt3d, 'IXT3D', this%origin) + call mem_allocate(this%satomega, 'SATOMEGA', this%origin) + call mem_allocate(this%hnoflo, 'HNOFLO', this%origin) + call mem_allocate(this%hdry, 'HDRY', this%origin) + call mem_allocate(this%icellavg, 'ICELLAVG', this%origin) + call mem_allocate(this%ik22, 'IK22', this%origin) + call mem_allocate(this%ik33, 'IK33', this%origin) + call mem_allocate(this%ik22overk, 'IK22OVERK', this%origin) + call mem_allocate(this%ik33overk, 'IK33OVERK', this%origin) + call mem_allocate(this%iperched, 'IPERCHED', this%origin) + call mem_allocate(this%ivarcv, 'IVARCV', this%origin) + call mem_allocate(this%idewatcv, 'IDEWATCV', this%origin) + call mem_allocate(this%ithickstrt, 'ITHICKSTRT', this%origin) + call mem_allocate(this%iusgnrhc, 'IUSGNRHC', this%origin) + call mem_allocate(this%inwtupw, 'INWTUPW', this%origin) + call mem_allocate(this%icalcspdis, 'ICALCSPDIS', this%origin) + call mem_allocate(this%isavspdis, 'ISAVSPDIS', this%origin) + call mem_allocate(this%isavsat, 'ISAVSAT', this%origin) + call mem_allocate(this%irewet, 'IREWET', this%origin) + call mem_allocate(this%wetfct, 'WETFCT', this%origin) + call mem_allocate(this%iwetit, 'IWETIT', this%origin) + call mem_allocate(this%ihdwet, 'IHDWET', this%origin) + call mem_allocate(this%satmin, 'SATMIN', this%origin) + call mem_allocate(this%iangle1, 'IANGLE1', this%origin) + call mem_allocate(this%iangle2, 'IANGLE2', this%origin) + call mem_allocate(this%iangle3, 'IANGLE3', this%origin) + call mem_allocate(this%iwetdry, 'IWETDRY', this%origin) + call mem_allocate(this%nedges, 'NEDGES', this%origin) + call mem_allocate(this%lastedge, 'LASTEDGE', this%origin) + ! + ! -- set pointer to inewtonur + call mem_setptr(this%igwfnewtonur, 'INEWTONUR', trim(this%name_model)) + ! + ! -- Initialize value + this%iname = 8 + this%ixt3d = 0 + this%satomega = DZERO + this%hnoflo = DHNOFLO !1.d30 + this%hdry = DHDRY !-1.d30 + this%icellavg = 0 + this%ik22 = 0 + this%ik33 = 0 + this%ik22overk = 0 + this%ik33overk = 0 + this%iperched = 0 + this%ivarcv = 0 + this%idewatcv = 0 + this%ithickstrt = 0 + this%iusgnrhc = 0 + this%inwtupw = 0 + this%icalcspdis = 0 + this%isavspdis = 0 + this%isavsat = 0 + this%irewet = 0 + this%wetfct = DONE + this%iwetit = 1 + this%ihdwet = 0 + this%satmin = DZERO ! DEM7 + this%iangle1 = 0 + this%iangle2 = 0 + this%iangle3 = 0 + this%iwetdry = 0 + this%nedges = 0 + this%lastedge = 0 + ! + ! -- If newton is on, then NPF creates asymmetric matrix + this%iasym = this%inewton + ! + ! -- Return + return + end subroutine allocate_scalars + + subroutine allocate_arrays(this, ncells, njas) +! ****************************************************************************** +! allocate_arrays -- Allocate npf arrays +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GwfNpftype) :: this + integer(I4B), intent(in) :: ncells + integer(I4B), intent(in) :: njas + ! -- local + integer(I4B) :: n +! ------------------------------------------------------------------------------ + ! + call mem_allocate(this%icelltype, ncells, 'ICELLTYPE', trim(this%origin)) + call mem_allocate(this%k11, ncells, 'K11', trim(this%origin)) + call mem_allocate(this%sat, ncells, 'SAT', trim(this%origin)) + call mem_allocate(this%condsat, njas, 'CONDSAT', trim(this%origin)) + ! + ! -- Optional arrays dimensioned to full size initially + call mem_allocate(this%k22, ncells, 'K22', trim(this%origin)) + call mem_allocate(this%k33, ncells, 'K33', trim(this%origin)) + call mem_allocate(this%wetdry, ncells, 'WETDRY', trim(this%origin)) + call mem_allocate(this%angle1, ncells, 'ANGLE1', trim(this%origin)) + call mem_allocate(this%angle2, ncells, 'ANGLE2', trim(this%origin)) + call mem_allocate(this%angle3, ncells, 'ANGLE3', trim(this%origin)) + ! + ! -- Optional arrays + call mem_allocate(this%ibotnode, 0, 'IBOTNODE', trim(this%origin)) + ! + ! -- Specific discharge + if (this%icalcspdis == 1) then + call mem_allocate(this%spdis, 3, ncells, 'SPDIS', trim(this%origin)) + call mem_allocate(this%nodedge, this%nedges, 'NODEDGE', trim(this%origin)) + call mem_allocate(this%ihcedge, this%nedges, 'IHCEDGE', trim(this%origin)) + call mem_allocate(this%propsedge, 5, this%nedges, 'PROPSEDGE', & + trim(this%origin)) + else + call mem_allocate(this%spdis, 3, 0, 'SPDIS', trim(this%origin)) + call mem_allocate(this%nodedge, 0, 'NODEDGE', trim(this%origin)) + call mem_allocate(this%ihcedge, 0, 'IHCEDGE', trim(this%origin)) + call mem_allocate(this%propsedge, 0, 0, 'PROPSEDGE', trim(this%origin)) + endif + ! + ! -- initialize iangle1, iangle2, iangle3, and wetdry + do n = 1, ncells + this%angle1(n) = DZERO + this%angle2(n) = DZERO + this%angle3(n) = DZERO + this%wetdry(n) = DZERO + end do + ! + ! -- allocate variable names + allocate(this%aname(this%iname)) + this%aname = [' ICELLTYPE', ' K', & + ' K33', ' K22', & + ' WETDRY', ' ANGLE1', & + ' ANGLE2', ' ANGLE3'] + ! + ! -- return + return + end subroutine allocate_arrays + + subroutine read_options(this) +! ****************************************************************************** +! read_options -- Read the options +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors + implicit none + ! -- dummy + class(GwfNpftype) :: this + ! -- local + character(len=LINELENGTH) :: errmsg, keyword + 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 +! ------------------------------------------------------------------------------ + ! + ! -- 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() + call ustop() + 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.' + endif + 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 + endif + 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.' + ! + ! -- 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)')'****ERROR. UNKNOWN NPF OPTION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + 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 + this%iusgnrhc = 0 + write(this%iout, '(4x,a,3(1x,a))') & + '****WARNING. MODFLOW-USG saturation calculation not needed', & + 'for a model that is using the standard conductance formulation.', & + 'Resetting DEV_MODFLOWUSG_UPSTREAM_WEIGHTED_SATURATION OPTION from', & + '1 to 0.' + end if + ! + ! -- check that the this%inwtupw option is not specified for non-newton + ! models + if (this%inwtupw /= 0 .and. this%inewton == 0) then + this%inwtupw = 0 + write(this%iout,'(4x,a,3(1x,a))') & + '****WARNING. The DEV_MODFLOWNWT_UPSTREAM_WEIGHTING option has', & + 'been specified for a model that is using the standard conductance', & + 'formulation. Resetting DEV_MODFLOWNWT_UPSTREAM_WEIGHTING OPTION from', & + '1 to 0.' + end if + ! + ! -- check that the transmissivity weighting functions are not specified with + ! with the this%inwtupw option + if (this%inwtupw /= 0 .and. this%icellavg < 2) then + write(errmsg,'(4x,a,2(1x,a))') & + '****ERROR. THE DEV_MODFLOWNWT_UPSTREAM_WEIGHTING OPTION CAN', & + 'ONLY BE SPECIFIED WITH THE AMT-LMK AND AMT-HMK', & + 'ALTERNATIVE_CELL_AVERAGING OPTIONS IN THE NPF PACKAGE.' + call store_error(errmsg) + end if + ! + ! -- check that this%iusgnrhc and this%inwtupw have not both been enabled + if (this%iusgnrhc /= 0 .and. this%inwtupw /= 0) then + write(errmsg,'(4x,a,2(1x,a))') & + '****ERROR. THE DEV_MODFLOWUSG_UPSTREAM_WEIGHTED_SATURATION', & + 'AND DEV_MODFLOWNWT_UPSTREAM_WEIGHTING OPTIONS CANNOT BE', & + 'SPECIFIED IN THE SAME NPF PACKAGE.' + call store_error(errmsg) + end if + ! + ! -- set omega value used for saturation calculations + 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() + call ustop() + end if + ! + ! -- Return + return + end subroutine read_options + + subroutine rewet_options(this) +! ****************************************************************************** +! rewet_options -- Set rewet options +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: store_error, ustop + 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() + call ustop() + endif + 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)') & + '****ERROR. NPF REWETTING FLAGS MUST BE SPECIFIED IN ORDER. ' // & + 'FOUND IWETIT BUT WETFCT NOT SPECIFIED.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + 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)') & + '****ERROR. NPF REWETTING FLAGS MUST BE SPECIFIED IN ORDER. ' // & + 'FOUND IHDWET BUT IWETIT NOT SPECIFIED.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + 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)')'****ERROR. UNKNOWN NPF REWET OPTION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + enddo + ! + 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() + call ustop() + endif + ! + ! -- 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, ustop + use ConstantsModule, only: LINELENGTH + ! -- dummy + class(GwfNpftype) :: this + ! -- local + character(len=LINELENGTH) :: errmsg +! ------------------------------------------------------------------------------ + ! + if(this%inewton > 0) then + if(this%iperched > 0) then + write(errmsg, '(a)') 'ERROR IN NPF OPTIONS. NEWTON OPTION CANNOT ' // & + 'BE USED WITH PERCHED OPTION.' + call store_error(errmsg) + endif + if(this%ivarcv > 0) then + write(errmsg, '(a)') 'ERROR IN NPF OPTIONS. NEWTON OPTION CANNOT ' // & + 'BE USED WITH VARIABLECV OPTION.' + call store_error(errmsg) + endif + if(this%irewet > 0) then + write(errmsg, '(a)') 'ERROR IN NPF OPTIONS. NEWTON OPTION CANNOT ' // & + 'BE USED WITH REWET OPTION.' + call store_error(errmsg) + endif + endif + ! + if (this%ixt3d /= 0) then + if(this%icellavg > 0) then + write(errmsg, '(a)') 'ERROR IN NPF OPTIONS. ' // & + 'ALTERNATIVE_CELL_AVERAGING OPTION ' // & + 'CANNOT BE USED WITH XT3D OPTION.' + call store_error(errmsg) + endif + if(this%ithickstrt > 0) then + write(errmsg, '(a)') 'ERROR IN NPF OPTIONS. THICKSTRT OPTION ' // & + 'CANNOT BE USED WITH XT3D OPTION.' + call store_error(errmsg) + endif + if(this%iperched > 0) then + write(errmsg, '(a)') 'ERROR IN NPF OPTIONS. PERCHED OPTION ' // & + 'CANNOT BE USED WITH XT3D OPTION.' + call store_error(errmsg) + endif + if(this%ivarcv > 0) then + write(errmsg, '(a)') 'ERROR IN NPF OPTIONS. VARIABLECV OPTION ' // & + 'CANNOT BE USED WITH XT3D OPTION.' + call store_error(errmsg) + endif + end if + ! + ! -- Terminate if errors + if(count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Return + return + end subroutine check_options + + subroutine read_data(this) +! ****************************************************************************** +! read_data -- read the npf data block +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH, DONE, DPIO180 + use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_deallocate, & + mem_reassignptr + use SimModule, only: ustop, store_error, count_errors + ! -- dummy + class(GwfNpftype) :: this + ! -- local + 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 + ! -- 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)')'ERROR. REQUIRED GRIDDATA BLOCK NOT FOUND.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- Check for ICELLTYPE + if(.not. lname(1)) then + write(errmsg, '(a, a, a)') 'Error in GRIDDATA block: ', & + trim(adjustl(aname(1))), ' not found.' + call store_error(errmsg) + endif + ! + ! -- Check for K + if(.not. lname(2)) then + write(errmsg, '(a, a, a)') 'Error in GRIDDATA block: ', & + trim(adjustl(aname(2))), ' not found.' + call store_error(errmsg) + endif + ! + ! -- 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) + endif + write(this%iout, '(1x, a)') 'K33 not provided. Assuming K33 = K.' + call mem_reassignptr(this%k33, 'K33', trim(this%origin), & + 'K11', trim(this%origin)) + endif + ! + ! -- 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) + endif + write(this%iout, '(1x, a)') 'K22 not provided. Assuming K22 = K.' + call mem_reassignptr(this%k22, 'K22', trim(this%origin), & + 'K11', trim(this%origin)) + endif + ! + ! -- Set WETDRY + if (lname(5)) then + this%iwetdry = 1 + else + call mem_reallocate(this%wetdry, 1, 'WETDRY', trim(this%origin)) + end if + ! + ! -- set angle flags + if (lname(6)) then + this%iangle1 = 1 + else + if (this%ixt3d == 0) then + call mem_reallocate(this%angle1, 1, 'ANGLE1', trim(this%origin)) + end if + endif + if (lname(7)) then + this%iangle2 = 1 + else + if (this%ixt3d == 0) then + call mem_reallocate(this%angle2, 1, 'ANGLE2', trim(this%origin)) + end if + endif + if (lname(8)) then + this%iangle3 = 1 + else + if (this%ixt3d == 0) then + call mem_reallocate(this%angle3, 1, 'ANGLE3', trim(this%origin)) + end if + endif + ! + ! -- terminate if read errors encountered + if(count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Final NPFDATA message + write(this%iout,'(1x,a)')'END PROCESSING GRIDDATA' + ! + ! -- Return + return + end subroutine read_data + + subroutine prepcheck(this) +! ****************************************************************************** +! prepcheck -- Initialize and check NPF data +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH, DONE, DPIO180 + use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_deallocate + use SimModule, only: store_error, ustop, count_errors + ! -- dummy + class(GwfNpfType) :: this + ! -- local + logical :: finished + character(len=24), dimension(:), pointer :: aname + character(len=LINELENGTH) :: cellstr, errmsg + integer(I4B) :: nerr + real(DP) :: csat + real(DP) :: satn, topn, topm, botn + real(DP) :: fawidth + real(DP) :: hn, hm + real(DP) :: hyn, hym + integer(I4B) :: n, m, ii, nn, ihc + integer(I4B) :: nextn + real(DP) :: minbot, botm + integer(I4B), dimension(:), pointer, contiguous :: ithickstartflag + ! -- format + character(len=*), parameter :: fmtkerr = & + "(1x, 'Hydraulic property ',a,' is <= 0 for cell ',a, ' ', 1pg15.6)" + character(len=*), parameter :: fmtkerr2 = & + "(1x, '... ', i0,' additional errors not shown for ',a)" + character(len=*),parameter :: fmtcnv = & + "(1X,'CELL ', A, & + &' ELIMINATED BECAUSE ALL HYDRAULIC CONDUCTIVITIES TO NODE ARE 0.')" + character(len=*),parameter :: fmtnct = & + "(1X,'Negative cell thickness at cell ', A)" + character(len=*),parameter :: fmtihbe = & + "(1X,'Initial head, bottom elevation:',1P,2G13.5)" + character(len=*),parameter :: fmttebe = & + "(1X,'Top elevation, bottom elevation:',1P,2G13.5)" +! ------------------------------------------------------------------------------ + ! + ! -- initialize + aname => this%aname + ! + ! -- check k11 + nerr = 0 + do n = 1, size(this%k11) + if(this%k11(n) <= DZERO) then + nerr = nerr + 1 + if(nerr <= 20) then + call this%dis%noder_to_string(n, cellstr) + write(errmsg, fmtkerr) trim(adjustl(aname(2))), trim(cellstr), & + this%k11(n) + call store_error(errmsg) + endif + endif + enddo + if(nerr > 20) then + write(errmsg, fmtkerr2) nerr, trim(adjustl(aname(2))) + call store_error(errmsg) + endif + ! + ! -- check k33 because it was read + if (this%ik33 /= 0) then + ! + ! -- Check to make sure values are greater than or equal to zero + nerr = 0 + do n = 1, size(this%k33) + if (this%ik33overk /= 0) this%k33(n) = this%k33(n) * this%k11(n) + if(this%k33(n) <= DZERO) then + nerr = nerr + 1 + if(nerr <= 20) then + call this%dis%noder_to_string(n, cellstr) + write(errmsg, fmtkerr) trim(adjustl(aname(3))), trim(cellstr), & + this%k33(n) + call store_error(errmsg) + endif + endif + enddo + if(nerr > 20) then + write(errmsg, fmtkerr2) nerr, trim(adjustl(aname(3))) + call store_error(errmsg) + endif + end if + ! + ! -- check k22 because it was read + if (this%ik22 /= 0) then + ! + ! -- Check to make sure that angles are available + if(this%dis%con%ianglex == 0) then + write(errmsg, '(a)') 'Error. ANGLDEGX not provided in ' // & + 'discretization file, but K22 was specified. ' + call store_error(errmsg) + endif + ! + ! -- Check to make sure values are greater than or equal to zero + nerr = 0 + do n = 1, size(this%k22) + if (this%ik22overk /= 0) this%k22(n) = this%k22(n) * this%k11(n) + if(this%k22(n) <= DZERO) then + nerr = nerr + 1 + if(nerr <= 20) then + call this%dis%noder_to_string(n, cellstr) + write(errmsg, fmtkerr) trim(adjustl(aname(4))), trim(cellstr), & + this%k22(n) + call store_error(errmsg) + endif + endif + enddo + if(nerr > 20) then + write(errmsg, fmtkerr2) nerr, trim(adjustl(aname(4))) + call store_error(errmsg) + endif + end if + ! + ! -- check for wetdry conflicts + if(this%irewet == 1) then + if(this%iwetdry == 0) then + write(errmsg, '(a, a, a)') 'Error in GRIDDATA block: ', & + trim(adjustl(aname(5))), ' not found.' + call store_error(errmsg) + end if + endif + ! + ! -- Check for angle conflicts + if (this%iangle1 /= 0) then + do n = 1, size(this%angle1) + this%angle1(n) = this%angle1(n) * DPIO180 + enddo + else + if(this%ixt3d /= 0) then + this%iangle1 = 1 + write(this%iout, '(a)') 'XT3D IN USE, BUT ANGLE1 NOT SPECIFIED. ' // & + 'SETTING ANGLE1 TO ZERO.' + do n = 1, size(this%angle1) + this%angle1(n) = DZERO + enddo + endif + endif + if (this%iangle2 /= 0) then + if (this%iangle1 == 0) then + write(errmsg, '(a)') 'ANGLE2 SPECIFIED BUT NOT ANGLE1. ' // & + 'ANGLE2 REQUIRES ANGLE1. ' + call store_error(errmsg) + endif + if (this%iangle3 == 0) then + write(errmsg, '(a)') 'ANGLE2 SPECIFIED BUT NOT ANGLE3. ' // & + 'SPECIFY BOTH OR NEITHER ONE. ' + call store_error(errmsg) + endif + do n = 1, size(this%angle2) + this%angle2(n) = this%angle2(n) * DPIO180 + enddo + endif + if (this%iangle3 /= 0) then + if (this%iangle1 == 0) then + write(errmsg, '(a)') 'ANGLE3 SPECIFIED BUT NOT ANGLE1. ' // & + 'ANGLE3 REQUIRES ANGLE1. ' + call store_error(errmsg) + endif + if (this%iangle2 == 0) then + write(errmsg, '(a)') 'ANGLE3 SPECIFIED BUT NOT ANGLE2. ' // & + 'SPECIFY BOTH OR NEITHER ONE. ' + call store_error(errmsg) + endif + do n = 1, size(this%angle3) + this%angle3(n) = this%angle3(n) * DPIO180 + enddo + endif + ! + ! -- terminate if data errors + if(count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- allocate temporary storage to handle thickstart option + call mem_allocate(ithickstartflag, this%dis%nodes, 'ITHICKSTARTFLAG', & + trim(this%origin)) + do n = 1, this%dis%nodes + ithickstartflag(n) = 0 + end do + ! + ! -- Insure that each cell has at least one non-zero transmissive parameter + ! Note that a cell can be deactivated even if it has a valid connection + ! to another model. + nodeloop: do n = 1, this%dis%nodes + ! + ! -- Skip if already inactive + if(this%ibound(n) == 0) then + if(this%irewet /= 0) then + if(this%wetdry(n) == DZERO) cycle nodeloop + else + cycle nodeloop + endif + endif + ! + ! -- Cycle if k11 is not zero + if(this%k11(n) /= DZERO) cycle nodeloop + ! + ! -- Cycle if at least one vertical connection has non-zero k33 + ! for n and m + do ii = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 + m = this%dis%con%ja(ii) + if(this%dis%con%ihc(this%dis%con%jas(ii)) == 0) then + hyn = this%k11(n) + if(this%ik33 /= 0) hyn = this%k33(n) + if(hyn /= DZERO) then + hym = this%k11(m) + if(this%ik33 /= 0) hym = this%k33(m) + if(hym /= DZERO) cycle + endif + endif + enddo + ! + ! -- If this part of the loop is reached, then all connections have + ! zero transmissivity, so convert to noflow. + this%ibound(n) = 0 + this%hnew(n) = this%hnoflo + if(this%irewet /= 0) this%wetdry(n) = DZERO + call this%dis%noder_to_string(n, cellstr) + write(this%iout, fmtcnv) trim(adjustl(cellstr)) + ! + enddo nodeloop + ! + ! -- Preprocess cell status and heads based on initial conditions + if (this%inewton == 0) then + ! + ! -- For standard formulation (non-Newton) call wetdry routine + call this%wd(0, this%hnew) + else + ! + ! -- Newton formulation, so adjust heads to be above bottom + ! (Not used in present formulation because variable cv + ! cannot be used with Newton) + if (this%ivarcv == 1) then + do n = 1, this%dis%nodes + if (this%hnew(n) < this%dis%bot(n)) then + this%hnew(n) = this%dis%bot(n) + DEM6 + end if + end do + end if + end if + ! + ! -- Initialize sat to zero for ibound=0 cells, unless the cell can + ! rewet. Initialize sat to the saturated fraction based on strt + ! if icelltype is negative and the THCKSTRT option is in effect. + ! Initialize sat to 1.0 for all other cells in order to calculate + ! condsat in next section. + do n = 1, this%dis%nodes + if(this%ibound(n) == 0) then + this%sat(n) = DONE + if(this%icelltype(n) < 0 .and. this%ithickstrt /= 0) then + ithickstartflag(n) = 1 + this%icelltype(n) = 0 + endif + else + topn = this%dis%top(n) + botn = this%dis%bot(n) + if(this%icelltype(n) < 0 .and. this%ithickstrt /= 0) then + call this%thksat(n, this%ic%strt(n), satn) + if(botn > this%ic%strt(n)) then + call this%dis%noder_to_string(n, cellstr) + write(errmsg, fmtnct) trim(adjustl(cellstr)) + call store_error(errmsg) + write(errmsg, fmtihbe) this%ic%strt(n), botn + call store_error(errmsg) + endif + ithickstartflag(n) = 1 + this%icelltype(n) = 0 + else + satn = DONE + if(botn > topn) then + call this%dis%noder_to_string(n, cellstr) + write(errmsg, fmtnct) trim(adjustl(cellstr)) + call store_error(errmsg) + write(errmsg, fmttebe) topn, botn + call store_error(errmsg) + endif + endif + this%sat(n) = satn + endif + enddo + if(count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Calculate condsatu, but only if xt3d is not active. If xt3d is + ! active, then condsat is allocated to size of zero. + if (this%ixt3d == 0) then + ! + ! -- Calculate the saturated conductance for all connections assuming + ! that saturation is 1 (except for case where icelltype was entered + ! as a negative value and THCKSTRT option in effect) + do n = 1, this%dis%nodes + ! + topn = this%dis%top(n) + ! + ! -- Go through the connecting cells + do ii = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 + ! + ! -- Set the m cell number and cycle if lower triangle connection + m = this%dis%con%ja(ii) + if (m < n) cycle + ihc = this%dis%con%ihc(this%dis%con%jas(ii)) + topm = this%dis%top(m) + hyn = this%hy_eff(n, m, ihc, ipos=ii) + hym = this%hy_eff(m, n, ihc, ipos=ii) + if (ithickstartflag(n) == 0) then + hn = topn + else + hn = this%ic%strt(n) + end if + if (ithickstartflag(m) == 0) then + hm = topm + else + hm = this%ic%strt(m) + end if + ! + ! -- Calculate conductance depending on whether connection is + ! vertical (0), horizontal (1), or staggered horizontal (2) + if(ihc == 0) then + ! + ! -- Vertical conductance for fully saturated conditions + csat = vcond(1, 1, 1, 1, 0, 1, 1, DONE, & + this%dis%bot(n), this%dis%bot(m), & + hyn, hym, & + this%sat(n), this%sat(m), & + topn, topm, & + this%dis%bot(n), this%dis%bot(m), & + this%dis%con%hwva(this%dis%con%jas(ii))) + else + ! + ! -- Horizontal conductance for fully saturated conditions + fawidth = this%dis%con%hwva(this%dis%con%jas(ii)) + csat = hcond(1, 1, 1, 1, this%inewton, 0, & + this%dis%con%ihc(this%dis%con%jas(ii)), & + this%icellavg, this%iusgnrhc, this%inwtupw, & + DONE, & + hn, hm, this%sat(n), this%sat(m), hyn, hym, & + topn, topm, & + this%dis%bot(n), this%dis%bot(m), & + this%dis%con%cl1(this%dis%con%jas(ii)), & + this%dis%con%cl2(this%dis%con%jas(ii)), & + fawidth, this%satomega, this%satmin) + end if + this%condsat(this%dis%con%jas(ii)) = csat + enddo + enddo + ! + endif + ! + ! -- Determine the lower most node + if (this%igwfnewtonur /= 0) then + call mem_reallocate(this%ibotnode, this%dis%nodes, 'IBOTNODE', & + trim(this%origin)) + do n = 1, this%dis%nodes + ! + minbot = this%dis%bot(n) + nn = n + finished = .false. + do while(.not. finished) + nextn = 0 + ! + ! -- Go through the connecting cells + do ii = this%dis%con%ia(nn) + 1, this%dis%con%ia(nn + 1) - 1 + ! + ! -- Set the m cell number + m = this%dis%con%ja(ii) + botm = this%dis%bot(m) + ! + ! -- Calculate conductance depending on whether connection is + ! vertical (0), horizontal (1), or staggered horizontal (2) + if(this%dis%con%ihc(this%dis%con%jas(ii)) == 0) then + if (m > nn .and. botm < minbot) then + nextn = m + minbot = botm + end if + end if + end do + if (nextn > 0) then + nn = nextn + else + finished = .true. + end if + end do + this%ibotnode(n) = nn + end do + end if + ! + ! -- nullify unneeded gwf pointers + this%igwfnewtonur => null() + ! + ! - clean up local storage + call mem_deallocate(ithickstartflag) + ! + ! -- Return + return + end subroutine prepcheck + + subroutine sgwf_npf_wetdry(this, kiter, hnew) +! ****************************************************************************** +! sgwf_npf_wetdry -- Perform wetting and drying +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: kstp, kper + use SimModule, only: ustop, store_error + use ConstantsModule, only: LINELENGTH + ! -- dummy + class(GwfNpfType) :: this + integer(I4B),intent(in) :: kiter + real(DP),intent(inout),dimension(:) :: hnew + ! -- local + integer(I4B) :: n, m, ii, ihc + real(DP) :: ttop, bbot, thck + integer(I4B) :: ncnvrt,ihdcnv + character(len=30), dimension(5) :: nodcnvrt + character(len=30) :: nodestr + character(len=3),dimension(5) :: acnvrt + character(len=LINELENGTH) :: errmsg + integer(I4B) :: irewet + ! -- formats + character(len=*),parameter :: fmtnct = & + "(1X,/1X,'Negative cell thickness at (layer,row,col)', & + &I4,',',I5,',',I5)" + character(len=*),parameter :: fmttopbot = & + "(1X,'Top elevation, bottom elevation:',1P,2G13.5)" + character(len=*),parameter :: fmttopbotthk = & + "(1X,'Top elevation, bottom elevation, thickness:',1P,3G13.5)" + character(len=*),parameter :: fmtdrychd = & + "(1X,/1X,'CONSTANT-HEAD CELL WENT DRY -- SIMULATION ABORTED')" + character(len=*),parameter :: fmtni = & + "(1X,'CELLID=',a,' ITERATION=',I0,' TIME STEP=',I0,' STRESS PERIOD=',I0)" +! ------------------------------------------------------------------------------ + ! -- Initialize + ncnvrt = 0 + ihdcnv = 0 + ! + ! -- Convert dry cells to wet + do n = 1, this%dis%nodes + do ii = this%dis%con%ia(n)+1,this%dis%con%ia(n+1)-1 + m = this%dis%con%ja(ii) + ihc = this%dis%con%ihc(this%dis%con%jas(ii)) + call this%rewet_check(kiter, n, hnew(m), this%ibound(m), ihc, hnew, & + irewet) + if(irewet == 1) then + call this%wdmsg(2,ncnvrt,nodcnvrt,acnvrt,ihdcnv,kiter,n) + endif + enddo + enddo + ! + ! -- Perform drying + do n=1,this%dis%nodes + ! + ! -- cycle if inactive or confined + if(this%ibound(n) == 0) cycle + if(this%icelltype(n) == 0) cycle + ! + ! -- check for negative cell thickness + bbot=this%dis%bot(n) + ttop=this%dis%top(n) + if(bbot>ttop) then + write(errmsg, fmtnct) n + call store_error(errmsg) + write(errmsg, fmttopbot) ttop,bbot + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Calculate saturated thickness + if(this%icelltype(n)/=0) then + if(hnew(n) 0) then + itflg=mod(kiter, this%iwetit) + if(itflg == 0) then + if(this%ibound(node) == 0 .and. this%wetdry(node) /= DZERO) then + ! + ! -- Calculate wetting elevation + bbot = this%dis%bot(node) + wd = this%wetdry(node) + awd = wd + if(wd < 0) awd=-wd + turnon = bbot + awd + ! + ! -- Check head in adjacent cells to see if wetting elevation has + ! been reached + if(ihc == 0) then + ! + ! -- check cell below + if(ibdm > 0 .and. hm >= turnon) irewet = 1 + else + if(wd > DZERO) then + ! + ! -- check horizontally adjacent cells + if(ibdm > 0 .and. hm >= turnon) irewet = 1 + end if + endif + ! + if(irewet == 1) then + ! -- rewet cell; use equation 3a if ihdwet=0; use equation 3b if + ! ihdwet is not 0. + if(this%ihdwet==0) then + hnew(node) = bbot + this%wetfct * (hm - bbot) + else + hnew(node) = bbot + this%wetfct * awd !(hm - bbot) + endif + this%ibound(node) = 30000 + endif + endif + endif + endif + ! + ! -- Return + return + end subroutine rewet_check + + subroutine sgwf_npf_wdmsg(this,icode,ncnvrt,nodcnvrt,acnvrt,ihdcnv,kiter,n) +! ****************************************************************************** +! sgwf_npf_wdmsg -- Print wet/dry message +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: kstp, kper + ! -- dummy + class(GwfNpfType) :: this + integer(I4B),intent(in) :: icode + integer(I4B),intent(inout) :: ncnvrt + character(len=30), dimension(5), intent(inout) :: nodcnvrt + character(len=3),dimension(5),intent(inout) :: acnvrt + integer(I4B),intent(inout) :: ihdcnv + integer(I4B),intent(in) :: kiter + integer(I4B),intent(in) :: n + ! -- local + integer(I4B) :: l + ! -- formats + character(len=*),parameter :: fmtcnvtn = & + "(1X,/1X,'CELL CONVERSIONS FOR ITER.=',I0, & + &' STEP=',I0,' PERIOD=',I0,' (NODE or LRC)')" + character(len=*),parameter :: fmtnode = "(1X,3X,5(A4, A20))" +! ------------------------------------------------------------------------------ + ! -- Keep track of cell conversions + if(icode>0) then + ncnvrt=ncnvrt+1 + call this%dis%noder_to_string(n, nodcnvrt(ncnvrt)) + if(icode==1) then + acnvrt(ncnvrt)='DRY' + else + acnvrt(ncnvrt)='WET' + end if + end if + ! + ! -- Print a line if 5 conversions have occurred or if icode indicates that a + ! partial line should be printed + if(ncnvrt==5 .or. (icode==0 .and. ncnvrt>0)) then + if(ihdcnv==0) write(this%iout,fmtcnvtn) kiter,kstp,kper + ihdcnv=1 + write(this%iout,fmtnode) (acnvrt(l), trim(adjustl(nodcnvrt(l))),l=1,ncnvrt) + ncnvrt=0 + endif + ! + ! -- Return + return + end subroutine sgwf_npf_wdmsg + + function hy_eff(this, n, m, ihc, ipos, vg) result(hy) +! ****************************************************************************** +! hy_eff -- Calculate the effective hydraulic conductivity for the n-m +! connection. +! n is primary node node number +! m is connected node (not used if vg is provided) +! ihc is horizontal indicator (0 vertical, 1 horizontal, 2 vertically +! staggered) +! ipos_opt is position of connection in ja array +! vg is the global unit vector that expresses the direction from which to +! calculate an effective hydraulic conductivity. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + real(DP) :: hy + ! -- dummy + class(GwfNpfType) :: this + integer(I4B), intent(in) :: n + integer(I4B), intent(in) :: m + integer(I4B), intent(in) :: ihc + integer(I4B), intent(in), optional :: ipos + real(DP), dimension(3), intent(in), optional :: vg + ! -- local + integer(I4B) :: iipos + real(DP) :: hy11, hy22, hy33 + real(DP) :: ang1, ang2, ang3 + real(DP) :: vg1, vg2, vg3 + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- Initialize + iipos = 0 + if(present(ipos)) iipos = ipos + hy11 = this%k11(n) + hy22 = this%k11(n) + hy33 = this%k11(n) + if(this%ik22 /= 0) hy22 = this%k22(n) + if(this%ik33 /= 0) hy33 = this%k33(n) + ! + ! -- Calculate effective K based on whether connection is vertical + ! or horizontal + if(ihc == 0) then + ! + ! -- Handle rotated anisotropy case that would affect the effective + ! vertical hydraulic conductivity + hy = hy33 + if(this%iangle2 > 0) then + if(present(vg)) then + vg1 = vg(1) + vg2 = vg(2) + vg3 = vg(3) + else + call this%dis%connection_normal(n, m, ihc, vg1, vg2, vg3, iipos) + endif + ang1 = this%angle1(n) + ang2 = this%angle2(n) + ang3 = DZERO + if(this%iangle3 > 0) ang3 = this%angle3(n) + hy = hyeff_calc(hy11, hy22, hy33, ang1, ang2, ang3, vg1, vg2, vg3) + endif + ! + else + ! + ! -- Handle horizontal case + hy = hy11 + if(this%ik22 > 0) then + if(present(vg)) then + vg1 = vg(1) + vg2 = vg(2) + vg3 = vg(3) + else + call this%dis%connection_normal(n, m, ihc, vg1, vg2, vg3, iipos) + endif + ang1 = DZERO + ang2 = DZERO + ang3 = DZERO + if(this%iangle1 > 0) then + ang1 = this%angle1(n) + if(this%iangle2 > 0) then + ang2 = this%angle2(n) + if(this%iangle3 > 0) ang3 = this%angle3(n) + endif + endif + hy = hyeff_calc(hy11, hy22, hy33, ang1, ang2, ang3, vg1, vg2, vg3) + endif + ! + endif + ! + ! -- Return + return + end function hy_eff + + function hcond(ibdn, ibdm, ictn, ictm, inewton, inwtup, ihc, icellavg, iusg, & + iupw, condsat, hn, hm, satn, satm, hkn, hkm, topn, topm, & + botn, botm, cln, clm, fawidth, satomega, satminopt) & + result(condnm) +! ****************************************************************************** +! hcond -- Horizontal conductance between two cells +! inwtup: if 1, then upstream-weight condsat, otherwise recalculate +! +! hcond function uses a weighted transmissivity in the harmonic mean +! conductance calculations. This differs from the MODFLOW-NWT and MODFLOW-USG +! conductance calculations for the Newton-Raphson formulation which use a +! weighted hydraulic conductivity. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + real(DP) :: condnm + ! -- dummy + integer(I4B), intent(in) :: ibdn + integer(I4B), intent(in) :: ibdm + integer(I4B), intent(in) :: ictn + integer(I4B), intent(in) :: ictm + integer(I4B), intent(in) :: inewton + integer(I4B), intent(in) :: inwtup + integer(I4B), intent(in) :: ihc + integer(I4B), intent(in) :: icellavg + integer(I4B), intent(in) :: iusg + integer(I4B), intent(in) :: iupw + real(DP), intent(in) :: condsat + real(DP), intent(in) :: hn + real(DP), intent(in) :: hm + real(DP), intent(in) :: satn + real(DP), intent(in) :: satm + real(DP), intent(in) :: hkn + real(DP), intent(in) :: hkm + real(DP), intent(in) :: topn + real(DP), intent(in) :: topm + real(DP), intent(in) :: botn + real(DP), intent(in) :: botm + real(DP), intent(in) :: cln + real(DP), intent(in) :: clm + real(DP), intent(in) :: fawidth + real(DP), intent(in) :: satomega + real(DP), optional, intent(in) :: satminopt + ! -- local + integer(I4B) :: indk + real(DP) :: satmin + real(DP) :: sn + real(DP) :: sm + real(DP) :: thksatn + real(DP) :: thksatm + real(DP) :: sill_top, sill_bot + real(DP) :: tpn, tpm + real(DP) :: top, bot + real(DP) :: athk + real(DP) :: afac +! ------------------------------------------------------------------------------ + if (present(satminopt)) then + satmin = satminopt + else + satmin = DZERO + end if + ! + ! -- If either n or m is inactive then conductance is zero + if(ibdn == 0 .or. ibdm == 0) then + condnm = DZERO + ! + ! -- if both cells are non-convertible then use condsat + elseif(ictn == 0 .and. ictm == 0) then + if (icellavg /= 4) then + condnm = condsat + else + if (hn > hm) then + condnm = satn * (topn - botn) + else + condnm = satm * (topm - botm) + end if + condnm = condnm * condsat + end if + ! + ! -- At least one of the cells is convertible, so calculate average saturated + ! thickness and multiply with saturated conductance + else + if (inwtup == 1) then + ! -- set flag use to determine if bottom of cells n and m are + ! significantly different + indk = 0 + if (abs(botm-botn) < DEM2) indk = 1 + ! -- recalculate saturation if using MODFLOW-USG saturation + ! calculation approach + if (iusg == 1 .and. indk == 0) then + if (botm > botn) then + top = topm + bot = botm + else + top = topn + bot = botn + end if + sn = sQuadraticSaturation(top, bot, hn, satomega, satmin) + sm = sQuadraticSaturation(top, bot, hm, satomega, satmin) + else + sn = sQuadraticSaturation(topn, botn, hn, satomega, satmin) + sm = sQuadraticSaturation(topm, botm, hm, satomega, satmin) + end if + + if (hn > hm) then + condnm = sn + else + condnm = sm + end if + ! + ! -- if using MODFLOW-NWT upstream weighting option apply + ! factor to remove average thickness + if (iupw /= 0) then + if (hn > hm) then + afac = DTWO / (DONE + (topm - botm) / (topn - botn)) + condnm = condnm * afac + else + afac = DTWO / (DONE + (topn - botn) / (topm - botm)) + condnm = condnm * afac + end if + end if + ! + ! -- multiply condsat by condnm factor + condnm = condnm * condsat + else + thksatn = satn * (topn - botn) + thksatm = satm * (topm - botm) + ! + ! -- If staggered connection, subtract parts of cell that are above and + ! below the sill top and bottom elevations + if(ihc == 2) then + ! + ! -- Calculate sill_top and sill_bot + sill_top = min(topn, topm) + sill_bot = max(botn, botm) + ! + ! -- Calculate tpn and tpm + tpn = botn + thksatn + tpm = botm + thksatm + ! + ! -- Calculate saturated thickness for cells n and m + thksatn = max(min(tpn, sill_top) - sill_bot, DZERO) + thksatm = max(min(tpm, sill_top) - sill_bot, DZERO) + endif + + athk = DONE + if (iusg == 1) then + if (ihc == 2) then + athk = min(thksatn, thksatm) + else + athk = DHALF * (thksatn + thksatm) + end if + thksatn = DONE + thksatm = DONE + end if + ! + condnm = condmean(hkn, hkm, thksatn, thksatm, cln, clm, & + fawidth, icellavg) * athk + end if + endif + ! + ! -- Return + return + end function hcond + + function vcond(ibdn, ibdm, ictn, ictm, inewton, ivarcv, idewatcv, & + condsat, hn, hm, vkn, vkm, satn, satm, topn, topm, botn, & + botm, flowarea) result(condnm) +! ****************************************************************************** +! vcond -- Vertical conductance between two cells +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + real(DP) :: condnm + ! -- dummy + integer(I4B),intent(in) :: ibdn + integer(I4B),intent(in) :: ibdm + integer(I4B), intent(in) :: ictn + integer(I4B), intent(in) :: ictm + integer(I4B), intent(in) :: inewton + integer(I4B), intent(in) :: ivarcv + integer(I4B), intent(in) :: idewatcv + real(DP),intent(in) :: condsat + real(DP),intent(in) :: hn + real(DP),intent(in) :: hm + real(DP), intent(in) :: vkn + real(DP), intent(in) :: vkm + real(DP), intent(in) :: satn + real(DP), intent(in) :: satm + real(DP), intent(in) :: topn + real(DP), intent(in) :: topm + real(DP), intent(in) :: botn + real(DP), intent(in) :: botm + real(DP), intent(in) :: flowarea + ! -- local + real(DP) :: satntmp, satmtmp + real(DP) :: bovk1 + real(DP) :: bovk2 + real(DP) :: denom +! ------------------------------------------------------------------------------ + ! + ! -- If either n or m is inactive then conductance is zero + if(ibdn == 0 .or. ibdm == 0) then + condnm = DZERO + ! + ! -- if constantcv then use condsat + elseif(ivarcv == 0) then + condnm = condsat + ! + ! -- if both cells are non-convertible then use condsat + elseif(ictn == 0 .and. ictm == 0) then + condnm = condsat + ! + ! -- if both cells are fully saturated then use condsat + elseif(hn >= topn .and. hm >= topm) then + condnm = condsat + ! + ! -- At least one cell is partially saturated, so recalculate vertical + ! -- conductance for this connection + ! -- todo: upstream weighting? + else + ! + ! -- Default is for CV correction (dewatered option); use underlying + ! saturation of 1. + satntmp = satn + satmtmp = satm + if(idewatcv == 0) then + if(botn > botm) then + ! -- n is above m + satmtmp = DONE + else + ! -- m is above n + satntmp = DONE + endif + endif + bovk1 = satntmp * (topn - botn) * DHALF / vkn + bovk2 = satmtmp * (topm - botm) * DHALF / vkm + denom = (bovk1 + bovk2) + if(denom /= DZERO) then + condnm = flowarea / denom + else + condnm = DZERO + endif + endif + ! + ! -- Return + return + end function vcond + + function condmean(k1, k2, thick1, thick2, cl1, cl2, width, iavgmeth) +! ****************************************************************************** +! condmean -- Calculate the conductance between two cells +! +! k1 is hydraulic conductivity for cell 1 (in the direction of cell2) +! k2 is hydraulic conductivity for cell 2 (in the direction of cell1) +! thick1 is the saturated thickness for cell 1 +! thick2 is the saturated thickness for cell 2 +! cl1 is the distance from the center of cell1 to the shared face with cell2 +! cl2 is the distance from the center of cell2 to the shared face with cell1 +! h1 is the head for cell1 +! h2 is the head for cell2 +! width is the width perpendicular to flow +! iavgmeth is the averaging method: +! 0 is harmonic averaging +! 1 is logarithmic averaging +! 2 is arithmetic averaging of sat thickness and logarithmic averaging of +! hydraulic conductivity +! 3 is arithmetic averaging of sat thickness and harmonic averaging of +! hydraulic conductivity +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + real(DP) :: condmean + ! -- dummy + real(DP), intent(in) :: k1 + real(DP), intent(in) :: k2 + real(DP), intent(in) :: thick1 + real(DP), intent(in) :: thick2 + real(DP), intent(in) :: cl1 + real(DP), intent(in) :: cl2 + real(DP), intent(in) :: width + integer(I4B), intent(in) :: iavgmeth + ! -- local + real(DP) :: t1 + real(DP) :: t2 + real(DP) :: tmean, kmean, denom +! ------------------------------------------------------------------------------ + ! + ! -- Initialize + t1 = k1 * thick1 + t2 = k2 * thick2 + ! + ! -- Averaging + select case (iavgmeth) + ! + ! -- Harmonic-mean method + case(0) + ! + if (t1*t2 > DZERO) then + condmean = width * t1 * t2 / (t1 * cl2 + t2 * cl1) + else + condmean = DZERO + end if + ! + ! -- Logarithmic-mean method + case(1) + if (t1*t2 > DZERO) then + tmean = logmean(t1, t2) + else + tmean = DZERO + endif + condmean = tmean * width / (cl1 + cl2) + ! + ! -- Arithmetic-mean thickness and logarithmic-mean hydraulic conductivity + case(2) + if (k1*k2 > DZERO) then + kmean = logmean(k1, k2) + else + kmean = DZERO + endif + condmean = kmean * DHALF * (thick1 + thick2) * width / (cl1 + cl2) + ! + ! -- Arithmetic-mean thickness and harmonic-mean hydraulic conductivity + case(3) + denom = (k1 * cl2 + k2 * cl1) + if (denom > DZERO) then + kmean = k1 * k2 / denom + else + kmean = DZERO + end if + condmean = kmean * DHALF * (thick1 + thick2) * width + end select + ! + ! -- Return + return + end function condmean + + function logmean(d1, d2) +! ****************************************************************************** +! logmean -- Calculate the the logarithmic mean of two double precision +! numbers. Use an approximation if the ratio is near 1. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + real(DP) :: logmean + ! -- dummy + real(DP), intent(in) :: d1 + real(DP), intent(in) :: d2 + ! -- local + real(DP) :: drat +! ------------------------------------------------------------------------------ + ! + drat = d2 / d1 + if(drat <= DLNLOW .or. drat >= DLNHIGH) then + logmean = (d2 - d1) / log(drat) + else + logmean = DHALF * (d1 + d2) + endif + ! + ! -- Return + return + end function logmean + + function hyeff_calc(k11, k22, k33, ang1, ang2, ang3, vg1, vg2, vg3) & + result(hyeff) +! ****************************************************************************** +! hyeff_calc -- Calculate the effective horizontal hydraulic conductivity from +! an ellipse using a specified direction (unit vector vg1, vg2, vg3). +! k11 is the hydraulic conductivity of the major ellipse axis +! k22 is the hydraulic conductivity of first minor axis +! k33 is the hydraulic conductivity of the second minor axis +! vg1, vg2, and vg3 are the components of a unit vector in the +! direction of the connection between cell n and m +! a1 is the counter-clockwise rotation (radians) of the ellipse in +! the (x, y) plane +! a2 is the rotation of the conductivity ellipsoid upward or +! downward from the (x, y) plane +! a3 is the rotation of the conductivity ellipsoid about the major +! axis +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DONE + ! -- result + real(DP) :: hyeff + ! -- dummy + real(DP), intent(in) :: k11 + real(DP), intent(in) :: k22 + real(DP), intent(in) :: k33 + real(DP), intent(in) :: ang1 + real(DP), intent(in) :: ang2 + real(DP), intent(in) :: ang3 + real(DP), intent(in) :: vg1 + real(DP), intent(in) :: vg2 + real(DP), intent(in) :: vg3 + ! -- local + real(DP) :: s1, s2, s3, c1, c2, c3 + real(DP), dimension(3,3) :: r + real(DP) :: ve1, ve2, ve3 +! ------------------------------------------------------------------------------ + ! + ! -- Sin and cos of angles + s1 = sin(ang1) + c1 = cos(ang1) + s2 = sin(ang2) + c2 = cos(ang2) + s3 = sin(ang3) + c3 = cos(ang3) + ! + ! -- Rotation matrix + r(1,1) = c1*c2 + r(1,2) = c1*s2*s3 - s1*c3 + r(1,3) = -c1*s2*c3 - s1*s3 + r(2,1) = s1*c2 + r(2,2) = s1*s2*s3 + c1*c3 + r(2,3) = -s1*s2*c3 + c1*s3 + r(3,1) = s2 + r(3,2) = -c2*s3 + r(3,3) = c2*c3 + ! + ! -- Unit vector in direction of n-m connection + ve1 = r(1, 1) * vg1 + r(2, 1) * vg2 + r(3, 1) * vg3 + ve2 = r(1, 2) * vg1 + r(2, 2) * vg2 + r(3, 2) * vg3 + ve3 = r(1, 3) * vg1 + r(2, 3) * vg2 + r(3, 3) * vg3 + ! + ! -- Effective hydraulic conductivity + !hyeff = ve1 ** 2 / k11 + ve2 ** 2 / k22 + ve3 ** 2 / k33 + hyeff = DZERO + if (k11 /= DZERO) hyeff = hyeff + ve1 ** 2 / k11 + if (k22 /= DZERO) hyeff = hyeff + ve2 ** 2 / k22 + if (k33 /= DZERO) hyeff = hyeff + ve3 ** 2 / k33 + if (hyeff /= DZERO) hyeff = DONE / hyeff + ! + ! -- Return + return + end function hyeff_calc + + subroutine calc_spdis(this, flowja) +! ****************************************************************************** +! calc_spdis -- Calculate the 3 conmponents of specific discharge +! at the cell center. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: ustop, store_error + ! -- dummy + class(GwfNpfType) :: this + real(DP), intent(in), dimension(:) :: flowja + ! -- local + integer(I4B) :: n + integer(I4B) :: m + integer(I4B) :: ipos + integer(I4B) :: isympos + integer(I4B) :: ihc + integer(I4B) :: ic + integer(I4B) :: iz + integer(I4B) :: nc + integer(I4B) :: ncz + real(DP) :: qz + real(DP) :: vx + real(DP) :: vy + real(DP) :: vz + real(DP) :: xn + real(DP) :: yn + real(DP) :: zn + real(DP) :: xc + real(DP) :: yc + real(DP) :: zc + real(DP) :: cl1 + real(DP) :: cl2 + real(DP) :: dltot + real(DP) :: ooclsum + real(DP) :: dsumx + real(DP) :: dsumy + real(DP) :: dsumz + real(DP) :: denom + real(DP) :: area + real(DP) :: dz + real(DP) :: axy + real(DP) :: ayx + real(DP), allocatable, dimension(:) :: vi + real(DP), allocatable, dimension(:) :: di + real(DP), allocatable, dimension(:) :: viz + real(DP), allocatable, dimension(:) :: diz + real(DP), allocatable, dimension(:) :: nix + real(DP), allocatable, dimension(:) :: niy + real(DP), allocatable, dimension(:) :: wix + real(DP), allocatable, dimension(:) :: wiy + real(DP), allocatable, dimension(:) :: wiz + real(DP), allocatable, dimension(:) :: bix + real(DP), allocatable, dimension(:) :: biy + logical :: nozee = .true. +! ------------------------------------------------------------------------------ + ! + ! -- Ensure dis has necessary information + if(this%icalcspdis /= 0 .and. this%dis%con%ianglex == 0) then + call store_error('Error. ANGLDEGX not provided in ' // & + 'discretization file. ANGLDEGX required for ' // & + 'calculation of specific discharge.') + call ustop() + endif + ! + ! -- Find max number of connections and allocate weight arrays + nc = 0 + do n = 1, this%dis%nodes + ! + ! -- Count internal model connections + ic = this%dis%con%ia(n + 1) - this%dis%con%ia(n) - 1 + ! + ! -- Count edge connections + do m = 1, this%nedges + if (this%nodedge(m) == n) then + ic = ic + 1 + endif + enddo + ! + ! -- Set max number of connections for any cell + if (ic > nc) nc = ic + end do + ! + ! -- Allocate storage arrays needed for cell-centered spdis calculation + allocate(vi(nc)) + allocate(di(nc)) + allocate(viz(nc)) + allocate(diz(nc)) + allocate(nix(nc)) + allocate(niy(nc)) + allocate(wix(nc)) + allocate(wiy(nc)) + allocate(wiz(nc)) + allocate(bix(nc)) + allocate(biy(nc)) + ! + ! -- Go through each cell and calculate specific discharge + do n = 1, this%dis%nodes + ! + ! -- first calculate geometric properties for x and y directions and + ! the specific discharge at a face (vi) + ic = 0 + iz = 0 + vi(:) = DZERO + di(:) = DZERO + viz(:) = DZERO + diz(:) = DZERO + nix(:) = DZERO + niy(:) = DZERO + do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 + m = this%dis%con%ja(ipos) + isympos = this%dis%con%jas(ipos) + ihc = this%dis%con%ihc(isympos) + area = this%dis%con%hwva(isympos) + if (ihc == 0) then + ! + ! -- vertical connection + iz = iz + 1 + !call this%dis%connection_normal(n, m, ihc, xn, yn, zn, ipos) + call this%dis%connection_vector(n, m, nozee, this%sat(n), this%sat(m), & + ihc, xc, yc, zc, dltot) + cl1 = this%dis%con%cl1(isympos) + cl2 = this%dis%con%cl2(isympos) + ooclsum = DONE / (cl1 + cl2) + diz(iz) = dltot * cl1 * ooclsum + qz = flowja(ipos) + if (n > m) qz = -qz + viz(iz) = qz / area + else + ! + ! -- horizontal connection + ic = ic + 1 + dz = thksatnm(this%ibound(n), this%ibound(m), & + this%icelltype(n), this%icelltype(m), & + this%inewton, ihc, this%iusgnrhc, & + this%hnew(n), this%hnew(m), this%sat(n), this%sat(m), & + this%dis%top(n), this%dis%top(m), this%dis%bot(n), & + this%dis%bot(m), this%satomega, this%satmin) + area = area * dz + call this%dis%connection_normal(n, m, ihc, xn, yn, zn, ipos) + call this%dis%connection_vector(n, m, nozee, this%sat(n), this%sat(m), & + ihc, xc, yc, zc, dltot) + cl1 = this%dis%con%cl1(isympos) + cl2 = this%dis%con%cl2(isympos) + ooclsum = DONE / (cl1 + cl2) + nix(ic) = -xn + niy(ic) = -yn + di(ic) = dltot * cl1 * ooclsum + if (area > DZERO) then + vi(ic) = flowja(ipos) / area + else + vi(ic) = DZERO + endif + endif + end do + ! + ! -- Look through edge flows that may have been provided by an exchange + ! and incorporate them into the averaging arrays + do m = 1, this%nedges + if (this%nodedge(m) == n) then + ! + ! -- propsedge: (Q, area, nx, ny, distance) + ihc = this%ihcedge(m) + area = this%propsedge(2, m) + if (ihc == 0) then + iz = iz + 1 + viz(iz) = this%propsedge(1, m) / area + diz(iz) = this%propsedge(5, m) + else + ic = ic + 1 + nix(ic) = -this%propsedge(3, m) + niy(ic) = -this%propsedge(4, m) + di(ic) = this%propsedge(5, m) + if (area > DZERO) then + vi(ic) = this%propsedge(1, m) / area + else + vi(ic) = DZERO + endif + endif + endif + enddo + ! + ! -- Assign numnber of vertical and horizontal connections + ncz = iz + nc = ic + ! + ! -- calculate z weight (wiz) and z velocity + if (ncz == 1) then + wiz(1) = DONE + else + dsumz = DZERO + do iz = 1, ncz + dsumz = dsumz + diz(iz) + enddo + denom = (ncz - DONE) + if (denom < DZERO) denom = DZERO + dsumz = dsumz + DEM10 * dsumz + do iz = 1, ncz + if (dsumz > DZERO) wiz(iz) = DONE - diz(iz) / dsumz + if (denom > 0) then + wiz(iz) = wiz(iz) / denom + else + wiz(iz) = DZERO + endif + enddo + endif + vz = DZERO + do iz = 1, ncz + vz = vz + wiz(iz) * viz(iz) + enddo + ! + ! -- distance-based weighting + nc = ic + dsumx = DZERO + dsumy = DZERO + dsumz = DZERO + do ic = 1, nc + wix(ic) = di(ic) * abs(nix(ic)) + wiy(ic) = di(ic) * abs(niy(ic)) + dsumx = dsumx + wix(ic) + dsumy = dsumy + wiy(ic) + enddo + ! + ! -- Finish computing omega weights. Add a tiny bit + ! to dsum so that the normalized omega weight later + ! evaluates to (essentially) 1 in the case of a single + ! relevant connection, avoiding 0/0. + dsumx = dsumx + DEM10 * dsumx + dsumy = dsumy + DEM10 * dsumy + do ic = 1, nc + wix(ic) = (dsumx - wix(ic)) * abs(nix(ic)) + wiy(ic) = (dsumy - wiy(ic)) * abs(niy(ic)) + enddo + ! + ! -- compute B weights + dsumx = DZERO + dsumy = DZERO + do ic = 1, nc + bix(ic) = wix(ic) * sign(DONE, nix(ic)) + biy(ic) = wiy(ic) * sign(DONE, niy(ic)) + dsumx = dsumx + wix(ic) * abs(nix(ic)) + dsumy = dsumy + wiy(ic) * abs(niy(ic)) + enddo + if (dsumx > DZERO) dsumx = DONE / dsumx + if (dsumy > DZERO) dsumy = DONE / dsumy + axy = DZERO + ayx = DZERO + do ic = 1, nc + bix(ic) = bix(ic) * dsumx + biy(ic) = biy(ic) * dsumy + axy = axy + bix(ic) * niy(ic) + ayx = ayx + biy(ic) * nix(ic) + enddo + ! + ! -- Calculate specific discharge. The divide by zero checking below + ! is problematic for cells with only one flow, such as can happen + ! with triangular cells in corners. In this case, the resulting + ! cell velocity will be calculated as zero. The method should be + ! improved so that edge flows of zero are included in these + ! calculations. But this needs to be done with consideration for LGR + ! cases in which flows are submitted from an exchange. + vx = DZERO + vy = DZERO + do ic = 1, nc + vx = vx + (bix(ic) - axy * biy(ic)) * vi(ic) + vy = vy + (biy(ic) - ayx * bix(ic)) * vi(ic) + enddo + denom = DONE - axy * ayx + if (denom /= DZERO) then + vx = vx / denom + vy = vy / denom + endif + ! + this%spdis(1, n) = vx + this%spdis(2, n) = vy + this%spdis(3, n) = vz + ! + end do + ! + ! -- cleanup + deallocate(vi) + deallocate(di) + deallocate(nix) + deallocate(niy) + deallocate(wix) + deallocate(wiy) + deallocate(wiz) + deallocate(bix) + deallocate(biy) + ! + ! -- return + return + end subroutine calc_spdis + + subroutine sav_spdis(this, ibinun) +! ****************************************************************************** +! sav_spdis -- save specific discharge in binary format to ibinun +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfNpfType) :: this + integer(I4B), intent(in) :: ibinun + ! -- local + character(len=16) :: text + character(len=16), dimension(3) :: auxtxt + integer(I4B) :: n + integer(I4B) :: naux +! ------------------------------------------------------------------------------ + ! + ! -- Write the header + text = ' DATA-SPDIS' + naux = 3 + auxtxt(:) = [' qx', ' qy', ' qz'] + call this%dis%record_srcdst_list_header(text, this%name_model, this%name, & + this%name_model, this%name, naux, auxtxt, ibinun, this%dis%nodes, & + this%iout) + ! + ! -- Write a zero for Q, and then write qx, qy, qz as aux variables + do n = 1, this%dis%nodes + call this%dis%record_mf6_list_entry(ibinun, n, n, DZERO, naux, & + this%spdis(:, n)) + end do + ! + ! -- return + return + end subroutine sav_spdis + + subroutine sav_sat(this, ibinun) +! ****************************************************************************** +! sav_sat -- save saturation in binary format to ibinun +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfNpfType) :: this + integer(I4B), intent(in) :: ibinun + ! -- local + character(len=16) :: text + character(len=16), dimension(1) :: auxtxt + real(DP), dimension(1) :: a + integer(I4B) :: n + integer(I4B) :: naux +! ------------------------------------------------------------------------------ + ! + ! -- Write the header + text = ' DATA-SAT' + naux = 1 + auxtxt(:) = [' sat'] + call this%dis%record_srcdst_list_header(text, this%name_model, this%name, & + this%name_model, this%name, naux, auxtxt, ibinun, this%dis%nodes, & + this%iout) + ! + ! -- Write a zero for Q, and then write saturation as an aux variables + do n = 1, this%dis%nodes + a(1) = this%sat(n) + call this%dis%record_mf6_list_entry(ibinun, n, n, DZERO, naux, a) + end do + ! + ! -- return + return + end subroutine sav_sat + + subroutine increase_edge_count(this, nedges) +! ****************************************************************************** +! increase_edge_count -- reserve space for nedges cells that have an edge on them. +! This must be called before the npf%allocate_arrays routine, which is called +! from npf%ar. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfNpfType) :: this + integer(I4B), intent(in) :: nedges + ! -- local +! ------------------------------------------------------------------------------ + ! + this%nedges = this%nedges + nedges + ! + ! -- return + return + end subroutine increase_edge_count + + subroutine set_edge_properties(this, nodedge, ihcedge, q, area, nx, ny, & + distance) +! ****************************************************************************** +! edge_count -- provide the npf package with edge properties. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfNpfType) :: this + integer(I4B), intent(in) :: nodedge + integer(I4B), intent(in) :: ihcedge + real(DP), intent(in) :: q + real(DP), intent(in) :: area + real(DP), intent(in) :: nx + real(DP), intent(in) :: ny + real(DP), intent(in) :: distance + ! -- local + integer(I4B) :: lastedge +! ------------------------------------------------------------------------------ + ! + this%lastedge = this%lastedge + 1 + lastedge = this%lastedge + this%nodedge(lastedge) = nodedge + this%ihcedge(lastedge) = ihcedge + this%propsedge(1, lastedge) = q + this%propsedge(2, lastedge) = area + this%propsedge(3, lastedge) = nx + this%propsedge(4, lastedge) = ny + this%propsedge(5, lastedge) = distance + ! + ! -- If this is the last edge, then the next call must be starting a new + ! edge properties assignment loop, so need to reset lastedge to 0 + if (this%lastedge == this%nedges) this%lastedge = 0 + ! + ! -- return + return + end subroutine set_edge_properties + + function thksatnm(ibdn, ibdm, ictn, ictm, inwtup, ihc, iusg, & + hn, hm, satn, satm, topn, topm, botn, botm, & + satomega, satminopt) result(res) +! ****************************************************************************** +! thksatnm -- calculate saturated thickness at interface between two cells +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + real(DP) :: res + ! -- dummy + integer(I4B), intent(in) :: ibdn + integer(I4B), intent(in) :: ibdm + integer(I4B), intent(in) :: ictn + integer(I4B), intent(in) :: ictm + integer(I4B), intent(in) :: inwtup + integer(I4B), intent(in) :: ihc + integer(I4B), intent(in) :: iusg + real(DP), intent(in) :: hn + real(DP), intent(in) :: hm + real(DP), intent(in) :: satn + real(DP), intent(in) :: satm + real(DP), intent(in) :: topn + real(DP), intent(in) :: topm + real(DP), intent(in) :: botn + real(DP), intent(in) :: botm + real(DP), intent(in) :: satomega + real(DP), optional, intent(in) :: satminopt + ! -- local + integer(I4B) :: indk + real(DP) :: satmin + real(DP) :: sn + real(DP) :: sm + real(DP) :: thksatn + real(DP) :: thksatm + real(DP) :: sill_top, sill_bot + real(DP) :: tpn, tpm + real(DP) :: top, bot +! ------------------------------------------------------------------------------ + if (present(satminopt)) then + satmin = satminopt + else + satmin = DZERO + end if + ! + ! -- If either n or m is inactive then saturated thickness is zero + if(ibdn == 0 .or. ibdm == 0) then + res = DZERO + ! + ! -- if both cells are non-convertible then use average cell thickness + elseif(ictn == 0 .and. ictm == 0) then + res = DHALF * (topn - botn + topm - botm) + ! + ! -- At least one of the cells is convertible, so calculate average saturated + ! thickness + else + if (inwtup == 1) then + ! -- set flag used to determine if bottom of cells n and m are + ! significantly different + indk = 0 + if (abs(botm-botn) < DEM2) indk = 1 + ! -- recalculate saturation if using MODFLOW-USG saturation + ! calculation approach + if (iusg == 1 .and. indk == 0) then + if (botm > botn) then + top = topm + bot = botm + else + top = topn + bot = botn + end if + sn = sQuadraticSaturation(top, bot, hn, satomega, satmin) + sm = sQuadraticSaturation(top, bot, hm, satomega, satmin) + else + sn = sQuadraticSaturation(topn, botn, hn, satomega, satmin) + sm = sQuadraticSaturation(topm, botm, hm, satomega, satmin) + end if + ! + ! -- upstream weight the thickness + if (hn > hm) then + res = sn * (topn - botn) + else + res = sm * (topm - botm) + end if + ! + else + thksatn = satn * (topn - botn) + thksatm = satm * (topm - botm) + ! + ! -- If staggered connection, subtract parts of cell that are above and + ! below the sill top and bottom elevations + if(ihc == 2) then + ! + ! -- Calculate sill_top and sill_bot + sill_top = min(topn, topm) + sill_bot = max(botn, botm) + ! + ! -- Calculate tpn and tpm + tpn = botn + thksatn + tpm = botm + thksatm + ! + ! -- Calculate saturated thickness for cells n and m + thksatn = max(min(tpn, sill_top) - sill_bot, DZERO) + thksatm = max(min(tpm, sill_top) - sill_bot, DZERO) + endif + ! + res = DHALF * (thksatn + thksatm) + end if + endif + ! + ! -- Return + return + end function thksatnm + +end module GwfNpfModule diff --git a/src/Model/GroundWaterFlow/gwf3oc8.f90 b/src/Model/GroundWaterFlow/gwf3oc8.f90 index 14c677c9ae3..c8ceb046e42 100644 --- a/src/Model/GroundWaterFlow/gwf3oc8.f90 +++ b/src/Model/GroundWaterFlow/gwf3oc8.f90 @@ -1,98 +1,98 @@ -module GwfOcModule - - use BaseDisModule, only: DisBaseType - use KindModule, only: DP, I4B - use ConstantsModule, only: LENMODELNAME, LENORIGIN - use OutputControlModule, only: OutputControlType - use OutputControlData, only: OutputControlDataType, ocd_cr - - implicit none - private - public GwfOcType, oc_cr - - type, extends(OutputControlType) :: GwfOcType - contains - procedure :: oc_ar - end type GwfOcType - - contains - - subroutine oc_cr(ocobj, name_model, inunit, iout) -! ****************************************************************************** -! oc_cr -- Create a new oc object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - type(GwfOcType), pointer :: ocobj - character(len=*), intent(in) :: name_model - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout -! ------------------------------------------------------------------------------ - ! - ! -- Create the object - allocate(ocobj) - ! - ! -- Allocate scalars - call ocobj%allocate_scalars(name_model) - ! - ! -- Save unit numbers - ocobj%inunit = inunit - ocobj%iout = iout - ! - ! -- Initialize block parser - call ocobj%parser%Initialize(inunit, iout) - ! - ! -- Return - return - end subroutine oc_cr - - subroutine oc_ar(this, head, dis, dnodata) -! ****************************************************************************** -! oc_ar -- allocate and read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfOcType) :: this - real(DP), dimension(:), pointer, contiguous, intent(in) :: head - class(DisBaseType), pointer, intent(in) :: dis - real(DP), intent(in) :: dnodata - ! -- local - integer(I4B) :: i, nocdobj, inodata - type(OutputControlDataType), pointer :: ocdobjptr - real(DP), dimension(:), pointer, contiguous :: nullvec => null() -! ------------------------------------------------------------------------------ - ! - ! -- Initialize variables - inodata = 0 - nocdobj = 2 - allocate(this%ocdobj(nocdobj)) - do i = 1, nocdobj - call ocd_cr(ocdobjptr) - select case (i) - case (1) - call ocdobjptr%init_dbl('BUDGET', nullvec, dis, 'PRINT LAST ', & - 'COLUMNS 10 WIDTH 11 DIGITS 4 GENERAL ', & - this%iout, dnodata) - case (2) - call ocdobjptr%init_dbl('HEAD', head, dis, 'PRINT LAST ', & - 'COLUMNS 10 WIDTH 11 DIGITS 4 GENERAL ', & - this%iout, dnodata) - end select - this%ocdobj(i) = ocdobjptr - deallocate(ocdobjptr) - enddo - ! - ! -- Read options or set defaults if this package not on - if(this%inunit > 0) then - call this%read_options() - endif - ! - ! -- Return - return - end subroutine oc_ar - -end module GwfOcModule +module GwfOcModule + + use BaseDisModule, only: DisBaseType + use KindModule, only: DP, I4B + use ConstantsModule, only: LENMODELNAME, LENORIGIN + use OutputControlModule, only: OutputControlType + use OutputControlData, only: OutputControlDataType, ocd_cr + + implicit none + private + public GwfOcType, oc_cr + + type, extends(OutputControlType) :: GwfOcType + contains + procedure :: oc_ar + end type GwfOcType + + contains + + subroutine oc_cr(ocobj, name_model, inunit, iout) +! ****************************************************************************** +! oc_cr -- Create a new oc object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + type(GwfOcType), pointer :: ocobj + character(len=*), intent(in) :: name_model + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout +! ------------------------------------------------------------------------------ + ! + ! -- Create the object + allocate(ocobj) + ! + ! -- Allocate scalars + call ocobj%allocate_scalars(name_model) + ! + ! -- Save unit numbers + ocobj%inunit = inunit + ocobj%iout = iout + ! + ! -- Initialize block parser + call ocobj%parser%Initialize(inunit, iout) + ! + ! -- Return + return + end subroutine oc_cr + + subroutine oc_ar(this, head, dis, dnodata) +! ****************************************************************************** +! oc_ar -- allocate and read +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfOcType) :: this + real(DP), dimension(:), pointer, contiguous, intent(in) :: head + class(DisBaseType), pointer, intent(in) :: dis + real(DP), intent(in) :: dnodata + ! -- local + integer(I4B) :: i, nocdobj, inodata + type(OutputControlDataType), pointer :: ocdobjptr + real(DP), dimension(:), pointer, contiguous :: nullvec => null() +! ------------------------------------------------------------------------------ + ! + ! -- Initialize variables + inodata = 0 + nocdobj = 2 + allocate(this%ocdobj(nocdobj)) + do i = 1, nocdobj + call ocd_cr(ocdobjptr) + select case (i) + case (1) + call ocdobjptr%init_dbl('BUDGET', nullvec, dis, 'PRINT LAST ', & + 'COLUMNS 10 WIDTH 11 DIGITS 4 GENERAL ', & + this%iout, dnodata) + case (2) + call ocdobjptr%init_dbl('HEAD', head, dis, 'PRINT LAST ', & + 'COLUMNS 10 WIDTH 11 DIGITS 4 GENERAL ', & + this%iout, dnodata) + end select + this%ocdobj(i) = ocdobjptr + deallocate(ocdobjptr) + enddo + ! + ! -- Read options or set defaults if this package not on + if(this%inunit > 0) then + call this%read_options() + endif + ! + ! -- Return + return + end subroutine oc_ar + +end module GwfOcModule diff --git a/src/Model/GroundWaterFlow/gwf3rch8.f90 b/src/Model/GroundWaterFlow/gwf3rch8.f90 index 03781fb7f7e..023c7c9d46a 100644 --- a/src/Model/GroundWaterFlow/gwf3rch8.f90 +++ b/src/Model/GroundWaterFlow/gwf3rch8.f90 @@ -1,905 +1,905 @@ -module RchModule - ! - use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, LENFTYPE, LENPACKAGENAME, MAXCHARLEN - use BndModule, only: BndType - use SimModule, only: store_error, store_error_unit, ustop - use ObsModule, only: DefaultObsIdProcessor - use TimeArraySeriesLinkModule, only: TimeArraySeriesLinkType - use TimeSeriesLinkModule, only: TimeSeriesLinkType, & - GetTimeSeriesLinkFromList - use BlockParserModule, only: BlockParserType - ! - implicit none - ! - private - public :: rch_create - ! - character(len=LENFTYPE) :: ftype = 'RCH' - character(len=LENPACKAGENAME) :: text = ' RCH' - ! - type, extends(BndType) :: RchType - integer(I4B), pointer :: inirch => NULL() - integer(I4B), dimension(:), pointer, contiguous :: nodesontop => NULL() ! User provided cell numbers; nodelist is cells where recharge is applied) - logical, private :: fixed_cell = .false. - logical, private :: read_as_arrays = .false. - contains - procedure :: rch_allocate_scalars - procedure :: bnd_options => rch_options - procedure :: read_dimensions => rch_read_dimensions - procedure :: read_initial_attr => rch_read_initial_attr - procedure :: bnd_rp => rch_rp - procedure :: set_nodesontop - procedure :: bnd_cf => rch_cf - procedure :: bnd_fc => rch_fc - procedure :: bnd_da => rch_da - procedure :: define_listlabel => rch_define_listlabel - procedure, public :: bnd_rp_ts => rch_rp_ts - procedure, private :: rch_rp_array - procedure, private :: rch_rp_list - procedure, private :: default_nodelist - ! -- for observations - procedure, public :: bnd_obs_supported => rch_obs_supported - procedure, public :: bnd_df_obs => rch_df_obs - end type RchType - - contains - - subroutine rch_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) -! ****************************************************************************** -! rch_create -- Create a New Recharge Package -! Subroutine: (1) create new-style package -! (2) point packobj to the new package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout - character(len=*), intent(in) :: namemodel - character(len=*), intent(in) :: pakname - ! -- local - type(rchtype), pointer :: rchobj -! ------------------------------------------------------------------------------ - ! - ! -- allocate recharge object and scalar variables - allocate(rchobj) - packobj => rchobj - ! - ! -- create name and origin - call packobj%set_names(ibcnum, namemodel, pakname, ftype) - packobj%text = text - ! - ! -- allocate scalars - call rchobj%rch_allocate_scalars() - ! - ! -- initialize package - call packobj%pack_initialize() - - packobj%inunit = inunit - packobj%iout = iout - packobj%id = id - packobj%ibcnum = ibcnum - packobj%ncolbnd = 1 - packobj%iscloc = 1 ! sfac applies to recharge rate - packobj%ictorigin = 'NPF' - ! indxconvertflux is Column index of bound that will be multiplied by - ! cell area to convert flux rates to flow rates - packobj%indxconvertflux = 1 - packobj%AllowTimeArraySeries = .true. - ! - ! -- return - return - end subroutine rch_create - - subroutine rch_allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -- allocate scalar members -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(RchType), intent(inout) :: this -! ------------------------------------------------------------------------------ - ! - ! -- call standard BndType allocate scalars - call this%BndType%allocate_scalars() - ! - ! -- allocate the object and assign values to object variables - call mem_allocate(this%inirch, 'INIRCH', this%origin) - ! - ! -- Set values - this%inirch = 0 - this%fixed_cell = .false. - ! - ! -- return - return - end subroutine rch_allocate_scalars - - subroutine rch_options(this, option, found) -! ****************************************************************************** -! rch_options -- set options specific to RchType -! -! rch_options overrides BndType%bnd_options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: DZERO - use SimModule, only: ustop, store_error - implicit none - ! -- dummy - class(RchType), intent(inout) :: this - character(len=*), intent(inout) :: option - logical, intent(inout) :: found - ! -- local - character(len=MAXCHARLEN) :: ermsg - ! -- formats - character(len=*),parameter :: fmtihact = & - "(4x, 'RECHARGE WILL BE APPLIED TO HIGHEST ACTIVE CELL.')" - character(len=*),parameter :: fmtfixedcell = & - "(4x, 'RECHARGE WILL BE APPLIED TO SPECIFIED CELL.')" - character(len=*), parameter :: fmtreadasarrays = & - "(4x, 'RECHARGE INPUT WILL BE READ AS ARRAY(S).')" -! ------------------------------------------------------------------------------ - ! - ! -- Check for FIXED_CELL and READASARRAYS - select case (option) - case ('FIXED_CELL') - this%fixed_cell = .true. - write(this%iout, fmtfixedcell) - found = .true. - case ('READASARRAYS') - if (this%dis%supports_layers()) then - this%read_as_arrays = .true. - else - ermsg = 'READASARRAYS option is not compatible with selected' // & - ' discretization type.' - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Write option - write(this%iout, fmtreadasarrays) - ! - found = .true. - case default - ! - ! -- No options found - found = .false. - end select - ! - ! -- return - return - end subroutine rch_options - - subroutine rch_read_dimensions(this) -! ****************************************************************************** -! bnd_read_dimensions -- Read the dimensions for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, store_error_unit - ! -- dummy - class(RchType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock - ! -- format -! ------------------------------------------------------------------------------ - ! - ! Dimensions block is not required if: - ! (1) discretization is DIS or DISV, and - ! (2) READASARRAYS option has been specified. - if (this%read_as_arrays) then - this%maxbound = this%dis%get_ncpl() - else - ! -- 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 '//trim(adjustl(this%text))// & - ' DIMENSIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('MAXBOUND') - this%maxbound = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)') 'MAXBOUND = ', this%maxbound - case default - write(errmsg,'(4x,a,a)') & - '****ERROR. UNKNOWN '//trim(this%text)//' DIMENSION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - end do - ! - write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' DIMENSIONS' - else - call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') - call this%parser%StoreErrorUnit() - call ustop() - endif - endif - ! - ! -- verify dimensions were set - if(this%maxbound <= 0) then - write(errmsg, '(1x,a)') & - 'ERROR. MAXBOUND MUST BE AN INTEGER GREATER THAN ZERO.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Call define_listlabel to construct the list label that is written - ! when PRINT_INPUT option is used. - call this%define_listlabel() - ! - ! -- return - return - end subroutine rch_read_dimensions - - subroutine rch_read_initial_attr(this) -! ****************************************************************************** -! rch_read_initial_attr -- Part of allocate and read -! If READASARRAYS has been specified, assign default IRCH = 1 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(RchType),intent(inout) :: this -! ------------------------------------------------------------------------------ - ! - if (this%read_as_arrays) then - call this%default_nodelist() - endif - ! - return - end subroutine rch_read_initial_attr - - subroutine rch_rp(this) -! ****************************************************************************** -! rch_rp -- Read and Prepare -! Subroutine: (1) read itmp -! (2) read new boundaries if itmp>0 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use TdisModule, only: kper, nper - use SimModule, only: store_error, ustop - implicit none - ! -- dummy - class(RchType),intent(inout) :: this - ! -- local - integer(I4B) :: ierr - integer(I4B) :: node, n - integer(I4B) :: inirch, inrech - logical :: isfound - logical :: supportopenclose - character(len=LINELENGTH) :: line, errmsg - ! -- formats - character(len=*),parameter :: fmtblkerr = & - "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - character(len=*),parameter :: fmtlsp = & - "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" - character(len=*), parameter :: fmtnbd = & - "(1X,/1X,'THE NUMBER OF ACTIVE ',A,'S (',I6, & - &') IS GREATER THAN MAXIMUM(',I6,')')" - character(len=*), parameter :: fmtdimlayered = & - "('When READASARRAYS is specified for the selected discretization" // & - " package, DIMENSIONS block must be omitted.')" -! ------------------------------------------------------------------------------ - ! - if(this%inunit == 0) return - ! - ! -- Set ionper to the stress period number for which a new block of data - ! will be read. - if (this%ionper < kper) then - ! - ! -- get period block - supportopenclose = .not. this%read_as_arrays - ! When reading a list, OPEN/CLOSE is handled by list reader, - ! so supportOpenClose needs to be false in call the GetBlock. - ! When reading as arrays, set supportOpenClose as desired. - call this%parser%GetBlock('PERIOD', isfound, ierr) - if(isfound) then - ! - ! -- read ionper and check for increasing period numbers - call this%read_check_ionper() - else - ! - ! -- PERIOD block not found - if (ierr < 0) then - ! -- End of file found; data applies for remainder of simulation. - this%ionper = nper + 1 - else - ! -- Found invalid block - call this%parser%GetCurrentLine(line) - write(errmsg, fmtblkerr) adjustl(trim(line)) - call store_error(errmsg) - if (this%read_as_arrays) then - write(errmsg, fmtdimlayered) - call store_error(errmsg) - endif - call this%parser%StoreErrorUnit() - call ustop() - end if - endif - end if - ! - ! -- Read data if ionper == kper - inrech = 0 - inirch = 0 - if(this%ionper == kper) then - ! - ! -- Remove all time-series links associated with this package - call this%TsManager%Reset(this%name) - call this%TasManager%Reset(this%name) - ! - if (.not. this%read_as_arrays) then - ! -- Read RECHARGE and other input as a list - call this%rch_rp_list(inrech) - call this%bnd_rp_ts() - else - ! -- Read RECHARGE, IRCH, and AUX variables as arrays - call this%rch_rp_array(line, inrech) - endif - ! - else - write(this%iout,fmtlsp) trim(this%filtyp) - endif - ! - ! -- If recharge was read, then multiply by cell area. If inrech = 2, then - ! recharge is begin managed as a time series, and the time series object - ! will multiply the recharge rate by the cell area. - if(inrech == 1) then - do n = 1, this%nbound - node = this%nodelist(n) - this%bound(1, n) = this%bound(1, n) * this%dis%get_area(node) - enddo - endif - ! - ! -- return - return - end subroutine rch_rp - - subroutine rch_rp_array(this, line, inrech) -! ****************************************************************************** -! rch_rp_array -- Read and Prepare Recharge as arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LENTIMESERIESNAME, LINELENGTH - use SimModule, only: ustop, store_error - use ArrayHandlersModule, only: ifind - implicit none - ! -- dummy - class(RchType), intent(inout) :: this - character(len=LINELENGTH), intent(inout) :: line - integer(I4B), intent(inout) :: inrech - ! -- local - integer(I4B) :: n - integer(I4B) :: ipos - integer(I4B) :: jcol, jauxcol, lpos, ivarsread - character(len=LENTIMESERIESNAME) :: tasName - character(len=24), dimension(2) :: aname - character(len=LINELENGTH) :: keyword, atemp - logical :: found, endOfBlock - logical :: convertFlux - ! - ! -- these time array series pointers need to be non-contiguous - ! beacuse a slice of bound is passed - real(DP), dimension(:), pointer :: bndArrayPtr => null() - real(DP), dimension(:), pointer :: auxArrayPtr => null() - real(DP), dimension(:), pointer :: auxMultArray => null() - type(TimeArraySeriesLinkType), pointer :: tasLink => null() - ! -- formats - character(len=*),parameter :: fmtrchauxmult = & - "(4x, 'THE RECHARGE ARRAY IS BEING MULTIPLED BY THE AUXILIARY ARRAY WITH & - &THE NAME: ', A)" - ! -- data - data aname(1) /' LAYER OR NODE INDEX'/ - data aname(2) /' RECHARGE'/ - ! -! ------------------------------------------------------------------------------ - ! - ! -- Initialize - jauxcol = 0 - ivarsread = 0 - ! - ! -- Read RECHARGE, IRCH, and AUX variables as arrays - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - ! - ! -- Parse the keywords - select case (keyword) - case ('RECHARGE') - ! - ! -- Look for keyword TIMEARRAYSERIES and time-array series - ! name on line, following RECHARGE - call this%parser%GetStringCaps(keyword) - if (keyword == 'TIMEARRAYSERIES') then - ! -- Get time-array series name - call this%parser%GetStringCaps(tasName) - jcol = 1 ! for recharge rate - bndArrayPtr => this%bound(jcol,:) - ! Make a time-array-series link and add it to the list of links - ! contained in the TimeArraySeriesManagerType object. - convertflux = .true. - call this%TasManager%MakeTasLink(this%name, bndArrayPtr, & - this%iprpak, tasName, 'RECHARGE', & - convertFlux, this%nodelist, & - this%parser%iuactive) - lpos = this%TasManager%CountLinks() - tasLink => this%TasManager%GetLink(lpos) - inrech = 2 - else - ! - ! -- Read the recharge array, then indicate - ! that recharge was read by setting inrech - call this%dis%read_layer_array(this%nodelist, this%bound, & - this%ncolbnd, this%maxbound, 1, aname(2), this%parser%iuactive, & - this%iout) - inrech = 1 - endif - ! - case ('IRCH') - ! - ! -- Check to see if other variables have already been read. If so, - ! then terminate with an error that IRCH must be read first. - if (ivarsread > 0) then - call store_error('****ERROR. IRCH IS NOT FIRST VARIABLE IN & - &PERIOD BLOCK OR IT IS SPECIFIED MORE THAN ONCE.') - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Read the IRCH array - call this%dis%nlarray_to_nodelist(this%nodelist, this%maxbound, & - this%nbound, aname(1), this%parser%iuactive, this%iout) - ! - ! -- set flag to indicate that irch array has been read - this%inirch = 1 - ! - ! -- if fixed_cell option not set, then need to store nodelist - ! in the nodesontop array - if(.not. this%fixed_cell) call this%set_nodesontop() - ! - case default - ! - ! -- Check for auxname, and if found, then read into auxvar array - found = .false. - ipos = ifind(this%auxname, keyword) - if(ipos > 0) then - found = .true. - atemp = keyword - ! - ! -- Look for keyword TIMEARRAYSERIES and time-array series - ! name on line, following auxname - call this%parser%GetStringCaps(keyword) - if (keyword == 'TIMEARRAYSERIES') then - ! -- Get time-array series name - call this%parser%GetStringCaps(tasName) - jauxcol = jauxcol + 1 - auxArrayPtr => this%auxvar(jauxcol,:) - ! Make a time-array-series link and add it to the list of links - ! contained in the TimeArraySeriesManagerType object. - convertflux = .false. - call this%TasManager%MakeTasLink(this%name, auxArrayPtr, & - this%iprpak, tasName, & - this%auxname(ipos), convertFlux, & - this%nodelist, & - this%parser%iuactive) - else - ! - ! -- Read the aux variable array - call this%dis%read_layer_array(this%nodelist, this%auxvar, & - this%naux, this%maxbound, ipos, atemp, this%parser%iuactive, & - this%iout) - endif - endif - ! - ! -- Nothing found - if(.not. found) then - call this%parser%GetCurrentLine(line) - call store_error('****ERROR. LOOKING FOR VALID VARIABLE NAME. FOUND: ') - call store_error(trim(line)) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- If this aux variable has been designated as a multiplier array - ! by presence of AUXMULTNAME, set local pointer appropriately. - if (this%iauxmultcol > 0 .and. this%iauxmultcol == ipos) then - auxMultArray => this%auxvar(this%iauxmultcol,:) - endif - end select - ! - ! -- Increment the number of variables read - ivarsread = ivarsread + 1 - ! - end do - ! - ! -- If the multiplier-array pointer has been assigned and - ! stress is controlled by a time-array series, assign - ! multiplier-array pointer in time-array series link. - if (associated(auxMultArray)) then - if (associated(tasLink)) then - tasLink%RMultArray => auxMultArray - endif - endif - ! - ! -- If recharge was read and auxmultcol was specified, then multiply - ! the recharge rate by the multplier column - if(inrech == 1 .and. this%iauxmultcol > 0) then - write(this%iout, fmtrchauxmult) this%auxname(this%iauxmultcol) - do n = 1, this%nbound - this%bound(this%iscloc, n) = this%bound(this%iscloc, n) * & - this%auxvar(this%iauxmultcol, n) - enddo - endif - ! - return - end subroutine rch_rp_array - - subroutine rch_rp_list(this, inrech) -! ****************************************************************************** -! rch_rp_list -- Read and Prepare Recharge as a list -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - class(RchType), intent(inout) :: this - integer(I4B), intent(inout) :: inrech - ! -- local - integer(I4B) :: maxboundorig, nlist - ! -! ------------------------------------------------------------------------------ - ! - ! -- initialize - nlist = -1 - maxboundorig = this%maxbound - ! - ! -- read the list of recharge values; scale the recharge by auxmultcol - ! if it is specified. - call this%dis%read_list(this%parser%iuactive, this%iout, this%iprpak, & - nlist, this%inamedbound, this%iauxmultcol, & - this%nodelist, this%bound, this%auxvar, & - this%auxname, this%boundname, this%listlabel, & - this%name, this%tsManager, this%iscloc, & - this%indxconvertflux) - this%nbound = nlist - if (this%maxbound > maxboundorig) then - ! -- The arrays that belong to BndType have been extended. - ! Now, RCH array nodesontop needs to be recreated. - if (associated(this%nodesontop)) then - deallocate(this%nodesontop) - endif - endif - if (.not. this%fixed_cell) call this%set_nodesontop() - inrech = 1 - ! - ! -- terminate the period block - call this%parser%terminateblock() - ! - return - end subroutine rch_rp_list - - subroutine set_nodesontop(this) -! ****************************************************************************** -! set_nodesontop -- store nodelist in nodesontop -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - class(RchType),intent(inout) :: this - ! -- local - integer(I4B) :: n - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- allocate if necessary - if(.not. associated(this%nodesontop)) then - allocate(this%nodesontop(this%maxbound)) - endif - ! - ! -- copy nodelist into nodesontop - do n = 1, this%nbound - this%nodesontop(n) = this%nodelist(n) - enddo - ! - ! -- return - return - end subroutine set_nodesontop - - subroutine rch_cf(this, reset_mover) -! ****************************************************************************** -! rch_cf -- Formulate the HCOF and RHS terms -! Subroutine: (1) skip if no recharge -! (2) calculate hcof and rhs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(rchtype) :: this - logical, intent(in), optional :: reset_mover - ! -- local - integer(I4B) :: i, node -! ------------------------------------------------------------------------------ - ! - ! -- Return if no recharge - if(this%nbound == 0) return - ! - ! -- Calculate hcof and rhs for each recharge entry - do i = 1, this%nbound - ! - ! -- Find the node number - if (this%fixed_cell) then - node = this%nodelist(i) - else - node = this%nodesontop(i) - if(this%ibound(node) == 0) & - call this%dis%highest_active(node, this%ibound) - this%nodelist(i) = node - endif - ! - ! -- Set rhs and hcof - this%hcof(i) = DZERO - if(this%ibound(node) <= 0) then - this%rhs(i) = DZERO - cycle - endif - this%rhs(i) = -this%bound(1,i) - enddo - ! - ! -- return - return - end subroutine rch_cf - - subroutine rch_fc(this, rhs, ia, idxglo, amatsln) -! ************************************************************************** -! rch_fc -- Copy rhs and hcof into solution rhs and amat -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - ! -- dummy - class(RchType) :: this - real(DP), dimension(:), intent(inout) :: rhs - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln - ! -- local - integer(I4B) :: i, n, ipos -! -------------------------------------------------------------------------- - ! - ! -- Copy package rhs and hcof into solution rhs and amat - do i = 1, this%nbound - n = this%nodelist(i) - ! -- reset hcof and rhs for excluded cells - if (this%ibound(n) == 10000) then - this%hcof(i) = DZERO - this%rhs(i) = DZERO - cycle - end if - rhs(n) = rhs(n) + this%rhs(i) - ipos = ia(n) - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) - enddo - ! - ! -- return - return - end subroutine rch_fc - - subroutine rch_da(this) -! ****************************************************************************** -! rch_da -- deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(RchType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Deallocate parent package - call this%BndType%bnd_da() - ! - ! -- scalars - call mem_deallocate(this%inirch) - ! - ! -- arrays - if(associated(this%nodesontop)) deallocate(this%nodesontop) - ! - ! -- return - return - end subroutine rch_da - - subroutine rch_define_listlabel(this) -! ****************************************************************************** -! define_listlabel -- Define the list heading that is written to iout when -! PRINT_INPUT option is used. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(RchType), intent(inout) :: this -! ------------------------------------------------------------------------------ - ! - ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' - else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'RECHARGE' -! if(this%multindex > 0) & -! write(this%listlabel, '(a, a16)') trim(this%listlabel), 'MULTIPLIER' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif - ! - ! -- return - return - end subroutine rch_define_listlabel - - subroutine default_nodelist(this) -! ****************************************************************************** -! default_nodelist -- Assign default nodelist when READASARRAYS is specified. -! Equivalent to reading IRCH as CONSTANT 1 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: get_node - use SimModule, only: ustop, store_error - use ConstantsModule, only: LINELENGTH - ! -- dummy - class(RchType) :: this - ! -- local - integer(I4B) :: il, ir, ic, ncol, nrow, nlay, nodeu, noder, ipos -! ------------------------------------------------------------------------------ - ! - ! -- set variables - if(this%dis%ndim == 3) then - nlay = this%dis%mshape(1) - nrow = this%dis%mshape(2) - ncol = this%dis%mshape(3) - elseif(this%dis%ndim == 2) then - nlay = this%dis%mshape(1) - nrow = 1 - ncol = this%dis%mshape(2) - endif - ! - ! -- Populate nodelist - ipos = 1 - il = 1 - do ir = 1, nrow - do ic = 1, ncol - nodeu = get_node(il, ir, ic, nlay, nrow, ncol) - noder = this%dis%get_nodenumber(nodeu, 0) - if(noder > 0) then - this%nodelist(ipos) = noder - ipos = ipos + 1 - endif - enddo - enddo - ! - ! Set flag that indicates IRCH has been assigned, and assign nbound. - this%inirch = 1 - this%nbound = ipos - 1 - ! - ! -- if fixed_cell option not set, then need to store nodelist - ! in the nodesontop array - if(.not. this%fixed_cell) call this%set_nodesontop() - ! - ! -- return - end subroutine default_nodelist - - ! -- Procedures related to observations - logical function rch_obs_supported(this) - ! ****************************************************************************** - ! rch_obs_supported - ! -- Return true because RCH package supports observations. - ! -- Overrides BndType%bnd_obs_supported() - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - implicit none - class(RchType) :: this - ! ------------------------------------------------------------------------------ - rch_obs_supported = .true. - ! - ! -- return - return - end function rch_obs_supported - - subroutine rch_df_obs(this) - ! ****************************************************************************** - ! rch_df_obs (implements bnd_df_obs) - ! -- Store observation type supported by RCH package. - ! -- Overrides BndType%bnd_df_obs - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - class(RchType) :: this - ! -- local - integer(I4B) :: indx - ! ------------------------------------------------------------------------------ - call this%obs%StoreObsType('rch', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor - ! - ! -- return - return - end subroutine rch_df_obs - - ! - ! -- Procedure related to time series - subroutine rch_rp_ts(this) - ! -- Assign tsLink%Text appropriately for - ! all time series in use by package. - ! In RCH package only the RECHARGE variable - ! can be controlled by time series. - ! -- dummy - class(RchType), intent(inout) :: this - ! -- local - integer(I4B) :: i, nlinks - type(TimeSeriesLinkType), pointer :: tslink => null() - ! - nlinks = this%TsManager%boundtslinks%Count() - do i=1,nlinks - tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) - if (associated(tslink)) then - select case (tslink%JCol) - case (1) - tslink%Text = 'RECHARGE' - end select - endif - enddo - ! - return - end subroutine rch_rp_ts - -end module RchModule - +module RchModule + ! + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, LENFTYPE, LENPACKAGENAME, MAXCHARLEN + use BndModule, only: BndType + use SimModule, only: store_error, store_error_unit, ustop + use ObsModule, only: DefaultObsIdProcessor + use TimeArraySeriesLinkModule, only: TimeArraySeriesLinkType + use TimeSeriesLinkModule, only: TimeSeriesLinkType, & + GetTimeSeriesLinkFromList + use BlockParserModule, only: BlockParserType + ! + implicit none + ! + private + public :: rch_create + ! + character(len=LENFTYPE) :: ftype = 'RCH' + character(len=LENPACKAGENAME) :: text = ' RCH' + ! + type, extends(BndType) :: RchType + integer(I4B), pointer :: inirch => NULL() + integer(I4B), dimension(:), pointer, contiguous :: nodesontop => NULL() ! User provided cell numbers; nodelist is cells where recharge is applied) + logical, private :: fixed_cell = .false. + logical, private :: read_as_arrays = .false. + contains + procedure :: rch_allocate_scalars + procedure :: bnd_options => rch_options + procedure :: read_dimensions => rch_read_dimensions + procedure :: read_initial_attr => rch_read_initial_attr + procedure :: bnd_rp => rch_rp + procedure :: set_nodesontop + procedure :: bnd_cf => rch_cf + procedure :: bnd_fc => rch_fc + procedure :: bnd_da => rch_da + procedure :: define_listlabel => rch_define_listlabel + procedure, public :: bnd_rp_ts => rch_rp_ts + procedure, private :: rch_rp_array + procedure, private :: rch_rp_list + procedure, private :: default_nodelist + ! -- for observations + procedure, public :: bnd_obs_supported => rch_obs_supported + procedure, public :: bnd_df_obs => rch_df_obs + end type RchType + + contains + + subroutine rch_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) +! ****************************************************************************** +! rch_create -- Create a New Recharge Package +! Subroutine: (1) create new-style package +! (2) point packobj to the new package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BndType), pointer :: packobj + integer(I4B),intent(in) :: id + integer(I4B),intent(in) :: ibcnum + integer(I4B),intent(in) :: inunit + integer(I4B),intent(in) :: iout + character(len=*), intent(in) :: namemodel + character(len=*), intent(in) :: pakname + ! -- local + type(rchtype), pointer :: rchobj +! ------------------------------------------------------------------------------ + ! + ! -- allocate recharge object and scalar variables + allocate(rchobj) + packobj => rchobj + ! + ! -- create name and origin + call packobj%set_names(ibcnum, namemodel, pakname, ftype) + packobj%text = text + ! + ! -- allocate scalars + call rchobj%rch_allocate_scalars() + ! + ! -- initialize package + call packobj%pack_initialize() + + packobj%inunit = inunit + packobj%iout = iout + packobj%id = id + packobj%ibcnum = ibcnum + packobj%ncolbnd = 1 + packobj%iscloc = 1 ! sfac applies to recharge rate + packobj%ictorigin = 'NPF' + ! indxconvertflux is Column index of bound that will be multiplied by + ! cell area to convert flux rates to flow rates + packobj%indxconvertflux = 1 + packobj%AllowTimeArraySeries = .true. + ! + ! -- return + return + end subroutine rch_create + + subroutine rch_allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars -- allocate scalar members +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(RchType), intent(inout) :: this +! ------------------------------------------------------------------------------ + ! + ! -- call standard BndType allocate scalars + call this%BndType%allocate_scalars() + ! + ! -- allocate the object and assign values to object variables + call mem_allocate(this%inirch, 'INIRCH', this%origin) + ! + ! -- Set values + this%inirch = 0 + this%fixed_cell = .false. + ! + ! -- return + return + end subroutine rch_allocate_scalars + + subroutine rch_options(this, option, found) +! ****************************************************************************** +! rch_options -- set options specific to RchType +! +! rch_options overrides BndType%bnd_options +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: DZERO + use SimModule, only: ustop, store_error + implicit none + ! -- dummy + class(RchType), intent(inout) :: this + character(len=*), intent(inout) :: option + logical, intent(inout) :: found + ! -- local + character(len=MAXCHARLEN) :: ermsg + ! -- formats + character(len=*),parameter :: fmtihact = & + "(4x, 'RECHARGE WILL BE APPLIED TO HIGHEST ACTIVE CELL.')" + character(len=*),parameter :: fmtfixedcell = & + "(4x, 'RECHARGE WILL BE APPLIED TO SPECIFIED CELL.')" + character(len=*), parameter :: fmtreadasarrays = & + "(4x, 'RECHARGE INPUT WILL BE READ AS ARRAY(S).')" +! ------------------------------------------------------------------------------ + ! + ! -- Check for FIXED_CELL and READASARRAYS + select case (option) + case ('FIXED_CELL') + this%fixed_cell = .true. + write(this%iout, fmtfixedcell) + found = .true. + case ('READASARRAYS') + if (this%dis%supports_layers()) then + this%read_as_arrays = .true. + else + ermsg = 'READASARRAYS option is not compatible with selected' // & + ' discretization type.' + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Write option + write(this%iout, fmtreadasarrays) + ! + found = .true. + case default + ! + ! -- No options found + found = .false. + end select + ! + ! -- return + return + end subroutine rch_options + + subroutine rch_read_dimensions(this) +! ****************************************************************************** +! bnd_read_dimensions -- Read the dimensions for this package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, store_error_unit + ! -- dummy + class(RchType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: errmsg, keyword + integer(I4B) :: ierr + logical :: isfound, endOfBlock + ! -- format +! ------------------------------------------------------------------------------ + ! + ! Dimensions block is not required if: + ! (1) discretization is DIS or DISV, and + ! (2) READASARRAYS option has been specified. + if (this%read_as_arrays) then + this%maxbound = this%dis%get_ncpl() + else + ! -- 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 '//trim(adjustl(this%text))// & + ' DIMENSIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('MAXBOUND') + this%maxbound = this%parser%GetInteger() + write(this%iout,'(4x,a,i7)') 'MAXBOUND = ', this%maxbound + case default + write(errmsg,'(4x,a,a)') & + '****ERROR. UNKNOWN '//trim(this%text)//' DIMENSION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + end do + ! + write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' DIMENSIONS' + else + call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') + call this%parser%StoreErrorUnit() + call ustop() + endif + endif + ! + ! -- verify dimensions were set + if(this%maxbound <= 0) then + write(errmsg, '(1x,a)') & + 'ERROR. MAXBOUND MUST BE AN INTEGER GREATER THAN ZERO.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Call define_listlabel to construct the list label that is written + ! when PRINT_INPUT option is used. + call this%define_listlabel() + ! + ! -- return + return + end subroutine rch_read_dimensions + + subroutine rch_read_initial_attr(this) +! ****************************************************************************** +! rch_read_initial_attr -- Part of allocate and read +! If READASARRAYS has been specified, assign default IRCH = 1 +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(RchType),intent(inout) :: this +! ------------------------------------------------------------------------------ + ! + if (this%read_as_arrays) then + call this%default_nodelist() + endif + ! + return + end subroutine rch_read_initial_attr + + subroutine rch_rp(this) +! ****************************************************************************** +! rch_rp -- Read and Prepare +! Subroutine: (1) read itmp +! (2) read new boundaries if itmp>0 +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use TdisModule, only: kper, nper + use SimModule, only: store_error, ustop + implicit none + ! -- dummy + class(RchType),intent(inout) :: this + ! -- local + integer(I4B) :: ierr + integer(I4B) :: node, n + integer(I4B) :: inirch, inrech + logical :: isfound + logical :: supportopenclose + character(len=LINELENGTH) :: line, errmsg + ! -- formats + character(len=*),parameter :: fmtblkerr = & + "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + character(len=*),parameter :: fmtlsp = & + "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" + character(len=*), parameter :: fmtnbd = & + "(1X,/1X,'THE NUMBER OF ACTIVE ',A,'S (',I6, & + &') IS GREATER THAN MAXIMUM(',I6,')')" + character(len=*), parameter :: fmtdimlayered = & + "('When READASARRAYS is specified for the selected discretization" // & + " package, DIMENSIONS block must be omitted.')" +! ------------------------------------------------------------------------------ + ! + if(this%inunit == 0) return + ! + ! -- Set ionper to the stress period number for which a new block of data + ! will be read. + if (this%ionper < kper) then + ! + ! -- get period block + supportopenclose = .not. this%read_as_arrays + ! When reading a list, OPEN/CLOSE is handled by list reader, + ! so supportOpenClose needs to be false in call the GetBlock. + ! When reading as arrays, set supportOpenClose as desired. + call this%parser%GetBlock('PERIOD', isfound, ierr) + if(isfound) then + ! + ! -- read ionper and check for increasing period numbers + call this%read_check_ionper() + else + ! + ! -- PERIOD block not found + if (ierr < 0) then + ! -- End of file found; data applies for remainder of simulation. + this%ionper = nper + 1 + else + ! -- Found invalid block + call this%parser%GetCurrentLine(line) + write(errmsg, fmtblkerr) adjustl(trim(line)) + call store_error(errmsg) + if (this%read_as_arrays) then + write(errmsg, fmtdimlayered) + call store_error(errmsg) + endif + call this%parser%StoreErrorUnit() + call ustop() + end if + endif + end if + ! + ! -- Read data if ionper == kper + inrech = 0 + inirch = 0 + if(this%ionper == kper) then + ! + ! -- Remove all time-series links associated with this package + call this%TsManager%Reset(this%name) + call this%TasManager%Reset(this%name) + ! + if (.not. this%read_as_arrays) then + ! -- Read RECHARGE and other input as a list + call this%rch_rp_list(inrech) + call this%bnd_rp_ts() + else + ! -- Read RECHARGE, IRCH, and AUX variables as arrays + call this%rch_rp_array(line, inrech) + endif + ! + else + write(this%iout,fmtlsp) trim(this%filtyp) + endif + ! + ! -- If recharge was read, then multiply by cell area. If inrech = 2, then + ! recharge is begin managed as a time series, and the time series object + ! will multiply the recharge rate by the cell area. + if(inrech == 1) then + do n = 1, this%nbound + node = this%nodelist(n) + this%bound(1, n) = this%bound(1, n) * this%dis%get_area(node) + enddo + endif + ! + ! -- return + return + end subroutine rch_rp + + subroutine rch_rp_array(this, line, inrech) +! ****************************************************************************** +! rch_rp_array -- Read and Prepare Recharge as arrays +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LENTIMESERIESNAME, LINELENGTH + use SimModule, only: ustop, store_error + use ArrayHandlersModule, only: ifind + implicit none + ! -- dummy + class(RchType), intent(inout) :: this + character(len=LINELENGTH), intent(inout) :: line + integer(I4B), intent(inout) :: inrech + ! -- local + integer(I4B) :: n + integer(I4B) :: ipos + integer(I4B) :: jcol, jauxcol, lpos, ivarsread + character(len=LENTIMESERIESNAME) :: tasName + character(len=24), dimension(2) :: aname + character(len=LINELENGTH) :: keyword, atemp + logical :: found, endOfBlock + logical :: convertFlux + ! + ! -- these time array series pointers need to be non-contiguous + ! beacuse a slice of bound is passed + real(DP), dimension(:), pointer :: bndArrayPtr => null() + real(DP), dimension(:), pointer :: auxArrayPtr => null() + real(DP), dimension(:), pointer :: auxMultArray => null() + type(TimeArraySeriesLinkType), pointer :: tasLink => null() + ! -- formats + character(len=*),parameter :: fmtrchauxmult = & + "(4x, 'THE RECHARGE ARRAY IS BEING MULTIPLED BY THE AUXILIARY ARRAY WITH & + &THE NAME: ', A)" + ! -- data + data aname(1) /' LAYER OR NODE INDEX'/ + data aname(2) /' RECHARGE'/ + ! +! ------------------------------------------------------------------------------ + ! + ! -- Initialize + jauxcol = 0 + ivarsread = 0 + ! + ! -- Read RECHARGE, IRCH, and AUX variables as arrays + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + ! + ! -- Parse the keywords + select case (keyword) + case ('RECHARGE') + ! + ! -- Look for keyword TIMEARRAYSERIES and time-array series + ! name on line, following RECHARGE + call this%parser%GetStringCaps(keyword) + if (keyword == 'TIMEARRAYSERIES') then + ! -- Get time-array series name + call this%parser%GetStringCaps(tasName) + jcol = 1 ! for recharge rate + bndArrayPtr => this%bound(jcol,:) + ! Make a time-array-series link and add it to the list of links + ! contained in the TimeArraySeriesManagerType object. + convertflux = .true. + call this%TasManager%MakeTasLink(this%name, bndArrayPtr, & + this%iprpak, tasName, 'RECHARGE', & + convertFlux, this%nodelist, & + this%parser%iuactive) + lpos = this%TasManager%CountLinks() + tasLink => this%TasManager%GetLink(lpos) + inrech = 2 + else + ! + ! -- Read the recharge array, then indicate + ! that recharge was read by setting inrech + call this%dis%read_layer_array(this%nodelist, this%bound, & + this%ncolbnd, this%maxbound, 1, aname(2), this%parser%iuactive, & + this%iout) + inrech = 1 + endif + ! + case ('IRCH') + ! + ! -- Check to see if other variables have already been read. If so, + ! then terminate with an error that IRCH must be read first. + if (ivarsread > 0) then + call store_error('****ERROR. IRCH IS NOT FIRST VARIABLE IN & + &PERIOD BLOCK OR IT IS SPECIFIED MORE THAN ONCE.') + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Read the IRCH array + call this%dis%nlarray_to_nodelist(this%nodelist, this%maxbound, & + this%nbound, aname(1), this%parser%iuactive, this%iout) + ! + ! -- set flag to indicate that irch array has been read + this%inirch = 1 + ! + ! -- if fixed_cell option not set, then need to store nodelist + ! in the nodesontop array + if(.not. this%fixed_cell) call this%set_nodesontop() + ! + case default + ! + ! -- Check for auxname, and if found, then read into auxvar array + found = .false. + ipos = ifind(this%auxname, keyword) + if(ipos > 0) then + found = .true. + atemp = keyword + ! + ! -- Look for keyword TIMEARRAYSERIES and time-array series + ! name on line, following auxname + call this%parser%GetStringCaps(keyword) + if (keyword == 'TIMEARRAYSERIES') then + ! -- Get time-array series name + call this%parser%GetStringCaps(tasName) + jauxcol = jauxcol + 1 + auxArrayPtr => this%auxvar(jauxcol,:) + ! Make a time-array-series link and add it to the list of links + ! contained in the TimeArraySeriesManagerType object. + convertflux = .false. + call this%TasManager%MakeTasLink(this%name, auxArrayPtr, & + this%iprpak, tasName, & + this%auxname(ipos), convertFlux, & + this%nodelist, & + this%parser%iuactive) + else + ! + ! -- Read the aux variable array + call this%dis%read_layer_array(this%nodelist, this%auxvar, & + this%naux, this%maxbound, ipos, atemp, this%parser%iuactive, & + this%iout) + endif + endif + ! + ! -- Nothing found + if(.not. found) then + call this%parser%GetCurrentLine(line) + call store_error('****ERROR. LOOKING FOR VALID VARIABLE NAME. FOUND: ') + call store_error(trim(line)) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- If this aux variable has been designated as a multiplier array + ! by presence of AUXMULTNAME, set local pointer appropriately. + if (this%iauxmultcol > 0 .and. this%iauxmultcol == ipos) then + auxMultArray => this%auxvar(this%iauxmultcol,:) + endif + end select + ! + ! -- Increment the number of variables read + ivarsread = ivarsread + 1 + ! + end do + ! + ! -- If the multiplier-array pointer has been assigned and + ! stress is controlled by a time-array series, assign + ! multiplier-array pointer in time-array series link. + if (associated(auxMultArray)) then + if (associated(tasLink)) then + tasLink%RMultArray => auxMultArray + endif + endif + ! + ! -- If recharge was read and auxmultcol was specified, then multiply + ! the recharge rate by the multplier column + if(inrech == 1 .and. this%iauxmultcol > 0) then + write(this%iout, fmtrchauxmult) this%auxname(this%iauxmultcol) + do n = 1, this%nbound + this%bound(this%iscloc, n) = this%bound(this%iscloc, n) * & + this%auxvar(this%iauxmultcol, n) + enddo + endif + ! + return + end subroutine rch_rp_array + + subroutine rch_rp_list(this, inrech) +! ****************************************************************************** +! rch_rp_list -- Read and Prepare Recharge as a list +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + ! -- dummy + class(RchType), intent(inout) :: this + integer(I4B), intent(inout) :: inrech + ! -- local + integer(I4B) :: maxboundorig, nlist + ! +! ------------------------------------------------------------------------------ + ! + ! -- initialize + nlist = -1 + maxboundorig = this%maxbound + ! + ! -- read the list of recharge values; scale the recharge by auxmultcol + ! if it is specified. + call this%dis%read_list(this%parser%iuactive, this%iout, this%iprpak, & + nlist, this%inamedbound, this%iauxmultcol, & + this%nodelist, this%bound, this%auxvar, & + this%auxname, this%boundname, this%listlabel, & + this%name, this%tsManager, this%iscloc, & + this%indxconvertflux) + this%nbound = nlist + if (this%maxbound > maxboundorig) then + ! -- The arrays that belong to BndType have been extended. + ! Now, RCH array nodesontop needs to be recreated. + if (associated(this%nodesontop)) then + deallocate(this%nodesontop) + endif + endif + if (.not. this%fixed_cell) call this%set_nodesontop() + inrech = 1 + ! + ! -- terminate the period block + call this%parser%terminateblock() + ! + return + end subroutine rch_rp_list + + subroutine set_nodesontop(this) +! ****************************************************************************** +! set_nodesontop -- store nodelist in nodesontop +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + ! -- dummy + class(RchType),intent(inout) :: this + ! -- local + integer(I4B) :: n + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- allocate if necessary + if(.not. associated(this%nodesontop)) then + allocate(this%nodesontop(this%maxbound)) + endif + ! + ! -- copy nodelist into nodesontop + do n = 1, this%nbound + this%nodesontop(n) = this%nodelist(n) + enddo + ! + ! -- return + return + end subroutine set_nodesontop + + subroutine rch_cf(this, reset_mover) +! ****************************************************************************** +! rch_cf -- Formulate the HCOF and RHS terms +! Subroutine: (1) skip if no recharge +! (2) calculate hcof and rhs +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(rchtype) :: this + logical, intent(in), optional :: reset_mover + ! -- local + integer(I4B) :: i, node +! ------------------------------------------------------------------------------ + ! + ! -- Return if no recharge + if(this%nbound == 0) return + ! + ! -- Calculate hcof and rhs for each recharge entry + do i = 1, this%nbound + ! + ! -- Find the node number + if (this%fixed_cell) then + node = this%nodelist(i) + else + node = this%nodesontop(i) + if(this%ibound(node) == 0) & + call this%dis%highest_active(node, this%ibound) + this%nodelist(i) = node + endif + ! + ! -- Set rhs and hcof + this%hcof(i) = DZERO + if(this%ibound(node) <= 0) then + this%rhs(i) = DZERO + cycle + endif + this%rhs(i) = -this%bound(1,i) + enddo + ! + ! -- return + return + end subroutine rch_cf + + subroutine rch_fc(this, rhs, ia, idxglo, amatsln) +! ************************************************************************** +! rch_fc -- Copy rhs and hcof into solution rhs and amat +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + ! -- dummy + class(RchType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + real(DP), dimension(:), intent(inout) :: amatsln + ! -- local + integer(I4B) :: i, n, ipos +! -------------------------------------------------------------------------- + ! + ! -- Copy package rhs and hcof into solution rhs and amat + do i = 1, this%nbound + n = this%nodelist(i) + ! -- reset hcof and rhs for excluded cells + if (this%ibound(n) == 10000) then + this%hcof(i) = DZERO + this%rhs(i) = DZERO + cycle + end if + rhs(n) = rhs(n) + this%rhs(i) + ipos = ia(n) + amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) + enddo + ! + ! -- return + return + end subroutine rch_fc + + subroutine rch_da(this) +! ****************************************************************************** +! rch_da -- deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(RchType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Deallocate parent package + call this%BndType%bnd_da() + ! + ! -- scalars + call mem_deallocate(this%inirch) + ! + ! -- arrays + if(associated(this%nodesontop)) deallocate(this%nodesontop) + ! + ! -- return + return + end subroutine rch_da + + subroutine rch_define_listlabel(this) +! ****************************************************************************** +! define_listlabel -- Define the list heading that is written to iout when +! PRINT_INPUT option is used. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(RchType), intent(inout) :: this +! ------------------------------------------------------------------------------ + ! + ! -- create the header list label + this%listlabel = trim(this%filtyp) // ' NO.' + if(this%dis%ndim == 3) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif(this%dis%ndim == 2) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + else + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + endif + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'RECHARGE' +! if(this%multindex > 0) & +! write(this%listlabel, '(a, a16)') trim(this%listlabel), 'MULTIPLIER' + if(this%inamedbound == 1) then + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + endif + ! + ! -- return + return + end subroutine rch_define_listlabel + + subroutine default_nodelist(this) +! ****************************************************************************** +! default_nodelist -- Assign default nodelist when READASARRAYS is specified. +! Equivalent to reading IRCH as CONSTANT 1 +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: get_node + use SimModule, only: ustop, store_error + use ConstantsModule, only: LINELENGTH + ! -- dummy + class(RchType) :: this + ! -- local + integer(I4B) :: il, ir, ic, ncol, nrow, nlay, nodeu, noder, ipos +! ------------------------------------------------------------------------------ + ! + ! -- set variables + if(this%dis%ndim == 3) then + nlay = this%dis%mshape(1) + nrow = this%dis%mshape(2) + ncol = this%dis%mshape(3) + elseif(this%dis%ndim == 2) then + nlay = this%dis%mshape(1) + nrow = 1 + ncol = this%dis%mshape(2) + endif + ! + ! -- Populate nodelist + ipos = 1 + il = 1 + do ir = 1, nrow + do ic = 1, ncol + nodeu = get_node(il, ir, ic, nlay, nrow, ncol) + noder = this%dis%get_nodenumber(nodeu, 0) + if(noder > 0) then + this%nodelist(ipos) = noder + ipos = ipos + 1 + endif + enddo + enddo + ! + ! Set flag that indicates IRCH has been assigned, and assign nbound. + this%inirch = 1 + this%nbound = ipos - 1 + ! + ! -- if fixed_cell option not set, then need to store nodelist + ! in the nodesontop array + if(.not. this%fixed_cell) call this%set_nodesontop() + ! + ! -- return + end subroutine default_nodelist + + ! -- Procedures related to observations + logical function rch_obs_supported(this) + ! ****************************************************************************** + ! rch_obs_supported + ! -- Return true because RCH package supports observations. + ! -- Overrides BndType%bnd_obs_supported() + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + implicit none + class(RchType) :: this + ! ------------------------------------------------------------------------------ + rch_obs_supported = .true. + ! + ! -- return + return + end function rch_obs_supported + + subroutine rch_df_obs(this) + ! ****************************************************************************** + ! rch_df_obs (implements bnd_df_obs) + ! -- Store observation type supported by RCH package. + ! -- Overrides BndType%bnd_df_obs + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + implicit none + ! -- dummy + class(RchType) :: this + ! -- local + integer(I4B) :: indx + ! ------------------------------------------------------------------------------ + call this%obs%StoreObsType('rch', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor + ! + ! -- return + return + end subroutine rch_df_obs + + ! + ! -- Procedure related to time series + subroutine rch_rp_ts(this) + ! -- Assign tsLink%Text appropriately for + ! all time series in use by package. + ! In RCH package only the RECHARGE variable + ! can be controlled by time series. + ! -- dummy + class(RchType), intent(inout) :: this + ! -- local + integer(I4B) :: i, nlinks + type(TimeSeriesLinkType), pointer :: tslink => null() + ! + nlinks = this%TsManager%boundtslinks%Count() + do i=1,nlinks + tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) + if (associated(tslink)) then + select case (tslink%JCol) + case (1) + tslink%Text = 'RECHARGE' + end select + endif + enddo + ! + return + end subroutine rch_rp_ts + +end module RchModule + diff --git a/src/Model/GroundWaterFlow/gwf3riv8.f90 b/src/Model/GroundWaterFlow/gwf3riv8.f90 index 3e7514df11c..3cbff60e8b9 100644 --- a/src/Model/GroundWaterFlow/gwf3riv8.f90 +++ b/src/Model/GroundWaterFlow/gwf3riv8.f90 @@ -1,381 +1,381 @@ -module rivmodule - use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, LENFTYPE, LENPACKAGENAME - use BndModule, only: BndType - use ObsModule, only: DefaultObsIdProcessor - use TimeSeriesLinkModule, only: TimeSeriesLinkType, & - GetTimeSeriesLinkFromList - ! - implicit none - ! - private - public :: riv_create - public :: RivType - ! - character(len=LENFTYPE) :: ftype = 'RIV' - character(len=LENPACKAGENAME) :: text = ' RIV' - ! - type, extends(BndType) :: RivType - contains - procedure :: bnd_options => riv_options - procedure :: bnd_ck => riv_ck - procedure :: bnd_cf => riv_cf - procedure :: bnd_fc => riv_fc - procedure :: define_listlabel - ! -- methods for observations - procedure, public :: bnd_obs_supported => riv_obs_supported - procedure, public :: bnd_df_obs => riv_df_obs - ! -- method for time series - procedure, public :: bnd_rp_ts => riv_rp_ts - end type RivType - -contains - - subroutine riv_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) -! ****************************************************************************** -! riv_create -- Create a New Riv Package -! Subroutine: (1) create new-style package -! (2) point packobj to the new package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout - character(len=*), intent(in) :: namemodel - character(len=*), intent(in) :: pakname - ! -- local - type(RivType), pointer :: rivobj -! ------------------------------------------------------------------------------ - ! - ! -- allocate the object and assign values to object variables - allocate(rivobj) - packobj => rivobj - ! - ! -- create name and origin - call packobj%set_names(ibcnum, namemodel, pakname, ftype) - packobj%text = text - ! - ! -- allocate scalars - call rivobj%allocate_scalars() - ! - ! -- initialize package - call packobj%pack_initialize() - - packobj%inunit=inunit - packobj%iout=iout - packobj%id=id - packobj%ibcnum = ibcnum - packobj%ncolbnd=3 ! stage, conductance, rbot - packobj%iscloc=2 !sfac applies to conductance - packobj%ictorigin = 'NPF' - ! - ! -- return - return -end subroutine riv_create - - subroutine riv_options(this, option, found) -! ****************************************************************************** -! riv_options -- set options specific to RivType -! -! riv_options overrides BndType%bnd_options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use InputOutputModule, only: urword - ! -- dummy - class(RivType), intent(inout) :: this - character(len=*), intent(inout) :: option - logical, intent(inout) :: found - ! -- local -! ------------------------------------------------------------------------------ - ! - select case (option) - case('MOVER') - this%imover = 1 - write(this%iout, '(4x,A)') 'MOVER OPTION ENABLED' - found = .true. - case default - ! - ! -- No options found - found = .false. - end select - ! - ! -- return - return - end subroutine riv_options - - subroutine riv_ck(this) -! ****************************************************************************** -! riv_ck -- Check river boundary condition data -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors, store_error_unit - ! -- dummy - class(RivType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: errmsg - integer(I4B) :: i - integer(I4B) :: node - real(DP) :: bt - real(DP) :: stage - real(DP) :: rbot - ! -- formats - character(len=*), parameter :: fmtriverr = & - "('RIV BOUNDARY (',i0,') RIVER BOTTOM (',f10.4,') IS LESS " // & - "THAN CELL BOTTOM (',f10.4,')')" - character(len=*), parameter :: fmtriverr2 = & - "('RIV BOUNDARY (',i0,') RIVER STAGE (',f10.4,') IS LESS " // & - "THAN RIVER BOTTOM (',f10.4,')')" - character(len=*), parameter :: fmtriverr3 = & - "('RIV BOUNDARY (',i0,') RIVER STAGE (',f10.4,') IS LESS " // & - "THAN CELL BOTTOM (',f10.4,')')" -! ------------------------------------------------------------------------------ - ! - ! -- check stress period data - do i = 1, this%nbound - node = this%nodelist(i) - bt = this%dis%bot(node) - stage = this%bound(1,i) - rbot = this%bound(3,i) - ! -- accumulate errors - if (rbot < bt .and. this%icelltype(node) /= 0) then - write(errmsg, fmt=fmtriverr) i, rbot, bt - call store_error(errmsg) - end if - if (stage < rbot) then - write(errmsg, fmt=fmtriverr2) i, stage, rbot - call store_error(errmsg) - end if - if (stage < bt .and. this%icelltype(node) /= 0) then - write(errmsg, fmt=fmtriverr3) i, stage, bt - call store_error(errmsg) - end if - end do - ! - ! -- write summary of river package error messages - if (count_errors() > 0) then - call store_error_unit(this%inunit) - call ustop() - end if - ! - ! -- return - return - end subroutine riv_ck - -subroutine riv_cf(this, reset_mover) -! ****************************************************************************** -! riv_cf -- Formulate the HCOF and RHS terms -! Subroutine: (1) skip in no rivs -! (2) calculate hcof and rhs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(RivType) :: this - logical, intent(in), optional :: reset_mover - ! -- local - integer(I4B) :: i, node - real(DP) :: hriv, criv, rbot - logical :: lrm -! ------------------------------------------------------------------------------ - ! - ! -- Return if no rivs - if(this%nbound.eq.0) return - ! - ! -- pakmvrobj cf - lrm = .true. - if (present(reset_mover)) lrm = reset_mover - if(this%imover == 1 .and. lrm) then - call this%pakmvrobj%cf() - endif - ! - ! -- Calculate hcof and rhs for each riv entry - do i=1,this%nbound - node=this%nodelist(i) - if(this%ibound(node)<=0) then - this%hcof(i)=DZERO - this%rhs(i)=DZERO - cycle - endif - hriv=this%bound(1,i) - criv=this%bound(2,i) - rbot=this%bound(3,i) - if(this%xnew(node)<=rbot) then - this%rhs(i)=-criv*(hriv-rbot) - this%hcof(i) = DZERO - else - this%rhs(i) = -criv*hriv - this%hcof(i) = -criv - endif - enddo - ! - ! -- return - return -end subroutine riv_cf - - subroutine riv_fc(this, rhs, ia, idxglo, amatsln) -! ************************************************************************** -! riv_fc -- Copy rhs and hcof into solution rhs and amat -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - ! -- dummy - class(RivType) :: this - real(DP), dimension(:), intent(inout) :: rhs - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln - ! -- local - integer(I4B) :: i, n, ipos - real(DP) :: cond, stage, qriv !, rbot -! -------------------------------------------------------------------------- - ! - ! -- pakmvrobj fc - if(this%imover == 1) then - call this%pakmvrobj%fc() - endif - ! - ! -- Copy package rhs and hcof into solution rhs and amat - do i = 1, this%nbound - n = this%nodelist(i) - rhs(n) = rhs(n) + this%rhs(i) - ipos = ia(n) - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) - ! - ! -- If mover is active and this river cell is discharging, - ! store available water (as positive value). - stage = this%bound(1,i) - if(this%imover == 1 .and. this%xnew(n) > stage) then - cond = this%bound(2,i) - qriv = cond * (this%xnew(n) - stage) - call this%pakmvrobj%accumulate_qformvr(i, qriv) - endif - enddo - ! - ! -- return - return - end subroutine riv_fc - - subroutine define_listlabel(this) -! ****************************************************************************** -! define_listlabel -- Define the list heading that is written to iout when -! PRINT_INPUT option is used. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(RivType), intent(inout) :: this -! ------------------------------------------------------------------------------ - ! - ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' - else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STAGE' - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'CONDUCTANCE' - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOTTOM EL.' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif - ! - ! -- return - return - end subroutine define_listlabel - - ! -- Procedures related to observations - -logical function riv_obs_supported(this) -! ****************************************************************************** -! riv_obs_supported -! -- Return true because RIV package supports observations. -! -- Overrides BndType%bnd_obs_supported() -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - class(RivType) :: this -! ------------------------------------------------------------------------------ - riv_obs_supported = .true. - return -end function riv_obs_supported - - subroutine riv_df_obs(this) - ! ****************************************************************************** - ! riv_df_obs (implements bnd_df_obs) - ! -- Store observation type supported by RIV package. - ! -- Overrides BndType%bnd_df_obs - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - class(RivType) :: this - ! -- local - integer(I4B) :: indx - ! ------------------------------------------------------------------------------ - call this%obs%StoreObsType('riv', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor - ! - ! -- Store obs type and assign procedure pointer - ! for to-mvr observation type. - call this%obs%StoreObsType('to-mvr', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor - ! - ! -- return - return - end subroutine riv_df_obs - - ! -- Procedure related to time series - - subroutine riv_rp_ts(this) - ! -- Assign tsLink%Text appropriately for - ! all time series in use by package. - ! In RIV package variables STAGE, COND, and RBOT - ! can be controlled by time series. - ! -- dummy - class(RivType), intent(inout) :: this - ! -- local - integer(I4B) :: i, nlinks - type(TimeSeriesLinkType), pointer :: tslink => null() - ! - nlinks = this%TsManager%boundtslinks%Count() - do i=1,nlinks - tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) - if (associated(tslink)) then - select case (tslink%JCol) - case (1) - tslink%Text = 'STAGE' - case (2) - tslink%Text = 'COND' - case (3) - tslink%Text = 'RBOT' - end select - endif - enddo - ! - return - end subroutine riv_rp_ts - -end module rivmodule +module rivmodule + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, LENFTYPE, LENPACKAGENAME + use BndModule, only: BndType + use ObsModule, only: DefaultObsIdProcessor + use TimeSeriesLinkModule, only: TimeSeriesLinkType, & + GetTimeSeriesLinkFromList + ! + implicit none + ! + private + public :: riv_create + public :: RivType + ! + character(len=LENFTYPE) :: ftype = 'RIV' + character(len=LENPACKAGENAME) :: text = ' RIV' + ! + type, extends(BndType) :: RivType + contains + procedure :: bnd_options => riv_options + procedure :: bnd_ck => riv_ck + procedure :: bnd_cf => riv_cf + procedure :: bnd_fc => riv_fc + procedure :: define_listlabel + ! -- methods for observations + procedure, public :: bnd_obs_supported => riv_obs_supported + procedure, public :: bnd_df_obs => riv_df_obs + ! -- method for time series + procedure, public :: bnd_rp_ts => riv_rp_ts + end type RivType + +contains + + subroutine riv_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) +! ****************************************************************************** +! riv_create -- Create a New Riv Package +! Subroutine: (1) create new-style package +! (2) point packobj to the new package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BndType), pointer :: packobj + integer(I4B),intent(in) :: id + integer(I4B),intent(in) :: ibcnum + integer(I4B),intent(in) :: inunit + integer(I4B),intent(in) :: iout + character(len=*), intent(in) :: namemodel + character(len=*), intent(in) :: pakname + ! -- local + type(RivType), pointer :: rivobj +! ------------------------------------------------------------------------------ + ! + ! -- allocate the object and assign values to object variables + allocate(rivobj) + packobj => rivobj + ! + ! -- create name and origin + call packobj%set_names(ibcnum, namemodel, pakname, ftype) + packobj%text = text + ! + ! -- allocate scalars + call rivobj%allocate_scalars() + ! + ! -- initialize package + call packobj%pack_initialize() + + packobj%inunit=inunit + packobj%iout=iout + packobj%id=id + packobj%ibcnum = ibcnum + packobj%ncolbnd=3 ! stage, conductance, rbot + packobj%iscloc=2 !sfac applies to conductance + packobj%ictorigin = 'NPF' + ! + ! -- return + return +end subroutine riv_create + + subroutine riv_options(this, option, found) +! ****************************************************************************** +! riv_options -- set options specific to RivType +! +! riv_options overrides BndType%bnd_options +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use InputOutputModule, only: urword + ! -- dummy + class(RivType), intent(inout) :: this + character(len=*), intent(inout) :: option + logical, intent(inout) :: found + ! -- local +! ------------------------------------------------------------------------------ + ! + select case (option) + case('MOVER') + this%imover = 1 + write(this%iout, '(4x,A)') 'MOVER OPTION ENABLED' + found = .true. + case default + ! + ! -- No options found + found = .false. + end select + ! + ! -- return + return + end subroutine riv_options + + subroutine riv_ck(this) +! ****************************************************************************** +! riv_ck -- Check river boundary condition data +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors, store_error_unit + ! -- dummy + class(RivType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + integer(I4B) :: i + integer(I4B) :: node + real(DP) :: bt + real(DP) :: stage + real(DP) :: rbot + ! -- formats + character(len=*), parameter :: fmtriverr = & + "('RIV BOUNDARY (',i0,') RIVER BOTTOM (',f10.4,') IS LESS " // & + "THAN CELL BOTTOM (',f10.4,')')" + character(len=*), parameter :: fmtriverr2 = & + "('RIV BOUNDARY (',i0,') RIVER STAGE (',f10.4,') IS LESS " // & + "THAN RIVER BOTTOM (',f10.4,')')" + character(len=*), parameter :: fmtriverr3 = & + "('RIV BOUNDARY (',i0,') RIVER STAGE (',f10.4,') IS LESS " // & + "THAN CELL BOTTOM (',f10.4,')')" +! ------------------------------------------------------------------------------ + ! + ! -- check stress period data + do i = 1, this%nbound + node = this%nodelist(i) + bt = this%dis%bot(node) + stage = this%bound(1,i) + rbot = this%bound(3,i) + ! -- accumulate errors + if (rbot < bt .and. this%icelltype(node) /= 0) then + write(errmsg, fmt=fmtriverr) i, rbot, bt + call store_error(errmsg) + end if + if (stage < rbot) then + write(errmsg, fmt=fmtriverr2) i, stage, rbot + call store_error(errmsg) + end if + if (stage < bt .and. this%icelltype(node) /= 0) then + write(errmsg, fmt=fmtriverr3) i, stage, bt + call store_error(errmsg) + end if + end do + ! + ! -- write summary of river package error messages + if (count_errors() > 0) then + call store_error_unit(this%inunit) + call ustop() + end if + ! + ! -- return + return + end subroutine riv_ck + +subroutine riv_cf(this, reset_mover) +! ****************************************************************************** +! riv_cf -- Formulate the HCOF and RHS terms +! Subroutine: (1) skip in no rivs +! (2) calculate hcof and rhs +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(RivType) :: this + logical, intent(in), optional :: reset_mover + ! -- local + integer(I4B) :: i, node + real(DP) :: hriv, criv, rbot + logical :: lrm +! ------------------------------------------------------------------------------ + ! + ! -- Return if no rivs + if(this%nbound.eq.0) return + ! + ! -- pakmvrobj cf + lrm = .true. + if (present(reset_mover)) lrm = reset_mover + if(this%imover == 1 .and. lrm) then + call this%pakmvrobj%cf() + endif + ! + ! -- Calculate hcof and rhs for each riv entry + do i=1,this%nbound + node=this%nodelist(i) + if(this%ibound(node)<=0) then + this%hcof(i)=DZERO + this%rhs(i)=DZERO + cycle + endif + hriv=this%bound(1,i) + criv=this%bound(2,i) + rbot=this%bound(3,i) + if(this%xnew(node)<=rbot) then + this%rhs(i)=-criv*(hriv-rbot) + this%hcof(i) = DZERO + else + this%rhs(i) = -criv*hriv + this%hcof(i) = -criv + endif + enddo + ! + ! -- return + return +end subroutine riv_cf + + subroutine riv_fc(this, rhs, ia, idxglo, amatsln) +! ************************************************************************** +! riv_fc -- Copy rhs and hcof into solution rhs and amat +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + ! -- dummy + class(RivType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + real(DP), dimension(:), intent(inout) :: amatsln + ! -- local + integer(I4B) :: i, n, ipos + real(DP) :: cond, stage, qriv !, rbot +! -------------------------------------------------------------------------- + ! + ! -- pakmvrobj fc + if(this%imover == 1) then + call this%pakmvrobj%fc() + endif + ! + ! -- Copy package rhs and hcof into solution rhs and amat + do i = 1, this%nbound + n = this%nodelist(i) + rhs(n) = rhs(n) + this%rhs(i) + ipos = ia(n) + amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) + ! + ! -- If mover is active and this river cell is discharging, + ! store available water (as positive value). + stage = this%bound(1,i) + if(this%imover == 1 .and. this%xnew(n) > stage) then + cond = this%bound(2,i) + qriv = cond * (this%xnew(n) - stage) + call this%pakmvrobj%accumulate_qformvr(i, qriv) + endif + enddo + ! + ! -- return + return + end subroutine riv_fc + + subroutine define_listlabel(this) +! ****************************************************************************** +! define_listlabel -- Define the list heading that is written to iout when +! PRINT_INPUT option is used. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(RivType), intent(inout) :: this +! ------------------------------------------------------------------------------ + ! + ! -- create the header list label + this%listlabel = trim(this%filtyp) // ' NO.' + if(this%dis%ndim == 3) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif(this%dis%ndim == 2) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + else + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + endif + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STAGE' + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'CONDUCTANCE' + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOTTOM EL.' + if(this%inamedbound == 1) then + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + endif + ! + ! -- return + return + end subroutine define_listlabel + + ! -- Procedures related to observations + +logical function riv_obs_supported(this) +! ****************************************************************************** +! riv_obs_supported +! -- Return true because RIV package supports observations. +! -- Overrides BndType%bnd_obs_supported() +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + class(RivType) :: this +! ------------------------------------------------------------------------------ + riv_obs_supported = .true. + return +end function riv_obs_supported + + subroutine riv_df_obs(this) + ! ****************************************************************************** + ! riv_df_obs (implements bnd_df_obs) + ! -- Store observation type supported by RIV package. + ! -- Overrides BndType%bnd_df_obs + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + implicit none + ! -- dummy + class(RivType) :: this + ! -- local + integer(I4B) :: indx + ! ------------------------------------------------------------------------------ + call this%obs%StoreObsType('riv', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor + ! + ! -- Store obs type and assign procedure pointer + ! for to-mvr observation type. + call this%obs%StoreObsType('to-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor + ! + ! -- return + return + end subroutine riv_df_obs + + ! -- Procedure related to time series + + subroutine riv_rp_ts(this) + ! -- Assign tsLink%Text appropriately for + ! all time series in use by package. + ! In RIV package variables STAGE, COND, and RBOT + ! can be controlled by time series. + ! -- dummy + class(RivType), intent(inout) :: this + ! -- local + integer(I4B) :: i, nlinks + type(TimeSeriesLinkType), pointer :: tslink => null() + ! + nlinks = this%TsManager%boundtslinks%Count() + do i=1,nlinks + tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) + if (associated(tslink)) then + select case (tslink%JCol) + case (1) + tslink%Text = 'STAGE' + case (2) + tslink%Text = 'COND' + case (3) + tslink%Text = 'RBOT' + end select + endif + enddo + ! + return + end subroutine riv_rp_ts + +end module rivmodule diff --git a/src/Model/GroundWaterFlow/gwf3sfr8.f90 b/src/Model/GroundWaterFlow/gwf3sfr8.f90 index bc1a9468d27..1bb42c0d882 100644 --- a/src/Model/GroundWaterFlow/gwf3sfr8.f90 +++ b/src/Model/GroundWaterFlow/gwf3sfr8.f90 @@ -1,4844 +1,4844 @@ -module SfrModule - ! - use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, LENTIMESERIESNAME, & - DZERO, DPREC, DEM30, DEM6, DEM5, DEM4, DEM2, & - DHALF, DP6, DTWOTHIRDS, DP7, DP9, DP99, DP999, & - DONE, D1P1, DFIVETHIRDS, DTWO, DPI, DEIGHT, & - DHUNDRED, DEP20, & - NAMEDBOUNDFLAG, LENBOUNDNAME, LENFTYPE, & - LENPACKAGENAME, LENPAKLOC, MAXCHARLEN, & - DHNOFLO, DHDRY, DNODATA, & - TABLEFT, TABCENTER, TABRIGHT - use SmoothingModule, only: sQuadraticSaturation, sQSaturation, & - sQuadraticSaturationDerivative, & - sQSaturationDerivative, & - sCubicSaturation, sChSmooth - use BndModule, only: BndType - use BudgetObjectModule, only: BudgetObjectType, budgetobject_cr - use TableModule, only: TableType, table_cr - use ObserveModule, only: ObserveType - use ObsModule, only: ObsType - use InputOutputModule, only: get_node, URWORD, extract_idnum_or_bndname - use BaseDisModule, only: DisBaseType - use SimModule, only: count_errors, store_error, store_error_unit, ustop - use GenericUtilitiesModule, only: sim_message - use SparseModule, only: sparsematrix - use ArrayHandlersModule, only: ExpandArray - use BlockParserModule, only: BlockParserType - ! - implicit none - ! - character(len=LENFTYPE) :: ftype = 'SFR' - character(len=LENPACKAGENAME) :: text = ' SFR' - ! - ! -- timeseries type for - type :: SfrTSType - character (len=LENTIMESERIESNAME), pointer :: name => null() - real(DP), pointer :: value => null() - end type SfrTSType - ! - type :: SfrDivType - integer(I4B), pointer :: reach => null() - integer(I4B), pointer :: iprior => null() - character (len=10), pointer :: cprior => null() - type (SfrTSType), pointer :: rate => null() - end type SfrDivType - ! - ! -- Streamflow Routing derived data type - type :: SfrDataType - ! -- diversion data - type (SfrDivType), dimension(:), pointer, contiguous :: diversion => null() - ! -- aux data - type (SfrTSType), dimension(:), pointer, contiguous :: auxvar => null() - ! -- boundary data - type (SfrTSType), pointer :: rough => null() - type (SfrTSType), pointer :: rain => null() - type (SfrTSType), pointer :: evap => null() - type (SfrTSType), pointer :: inflow => null() - type (SfrTSType), pointer :: runoff => null() - type (SfrTSType), pointer :: sstage => null() - ! -- arrays of data for reach - integer(I4B), dimension(:), pointer, contiguous :: iconn => null() - integer(I4B), dimension(:), pointer, contiguous :: idir => null() - integer(I4B), dimension(:), pointer, contiguous :: idiv => null() - ! -- double precision arrays for reach - real(DP), dimension(:), pointer, contiguous :: qconn => null() - end type SfrDataType - ! - private - public :: sfr_create - public :: SfrType - ! - type, extends(BndType) :: SfrType - ! -- scalars - ! -- for budgets - ! -- characters - character(len=16), dimension(:), pointer, contiguous :: csfrbudget => NULL() - character(len=16), dimension(:), pointer, contiguous :: cauxcbc => NULL() - character(len=LENBOUNDNAME), dimension(:), pointer, & - contiguous :: sfrname => null() - ! -- integers - integer(I4B), pointer :: iprhed => null() - integer(I4B), pointer :: istageout => null() - integer(I4B), pointer :: ibudgetout => null() - integer(I4B), pointer :: ipakcsv => null() - integer(I4B), pointer :: idiversions => null() - integer(I4B), pointer :: nconn => NULL() - integer(I4B), pointer :: maxsfrit => NULL() - integer(I4B), pointer :: bditems => NULL() - integer(I4B), pointer :: cbcauxitems => NULL() - integer(I4B), pointer :: icheck => NULL() - integer(I4B), pointer :: iconvchk => NULL() - integer(I4B), pointer :: gwfiss => NULL() - ! -- double precision - real(DP), pointer :: unitconv => NULL() - real(DP), pointer :: dmaxchg => NULL() - real(DP), pointer :: deps => NULL() - ! -- integer vectors - integer(I4B), dimension(:), pointer, contiguous :: ia => null() - integer(I4B), dimension(:), pointer, contiguous :: ja => null() - ! -- double precision output vectors - real(DP), dimension(:), pointer, contiguous :: qoutflow => null() - real(DP), dimension(:), pointer, contiguous :: qextoutflow => null() - real(DP), dimension(:), pointer, contiguous :: qauxcbc => null() - real(DP), dimension(:), pointer, contiguous :: dbuff => null() - ! - ! -- sfr budget object - type(BudgetObjectType), pointer :: budobj => null() - type(SfrDataType), dimension(:), pointer, contiguous :: reaches => NULL() - type(sparsematrix), pointer :: sparse => null() - ! - ! -- sfr table objects - type(TableType), pointer :: stagetab => null() - type(TableType), pointer :: pakcsvtab => null() - ! - ! -- moved from SfrDataType - integer(I4B), dimension(:), pointer, contiguous :: iboundpak => null() - integer(I4B), dimension(:), pointer, contiguous :: igwfnode => null() - integer(I4B), dimension(:), pointer, contiguous :: igwftopnode => null() - real(DP), dimension(:), pointer, contiguous :: length => null() - real(DP), dimension(:), pointer, contiguous :: width => null() - real(DP), dimension(:), pointer, contiguous :: strtop => null() - real(DP), dimension(:), pointer, contiguous :: bthick => null() - real(DP), dimension(:), pointer, contiguous :: hk => null() - real(DP), dimension(:), pointer, contiguous :: slope => null() - integer(I4B), dimension(:), pointer, contiguous :: nconnreach => null() - real(DP), dimension(:), pointer, contiguous :: ustrf => null() - real(DP), dimension(:), pointer, contiguous :: ftotnd => null() - integer(I4B), dimension(:), pointer, contiguous :: ndiv => null() - real(DP), dimension(:), pointer, contiguous :: usflow => null() - real(DP), dimension(:), pointer, contiguous :: dsflow => null() - real(DP), dimension(:), pointer, contiguous :: depth => null() - real(DP), dimension(:), pointer, contiguous :: stage => null() - real(DP), dimension(:), pointer, contiguous :: gwflow => null() - real(DP), dimension(:), pointer, contiguous :: simevap => null() - real(DP), dimension(:), pointer, contiguous :: simrunoff => null() - real(DP), dimension(:), pointer, contiguous :: stage0 => null() - real(DP), dimension(:), pointer, contiguous :: usflow0 => null() - ! -- type bound procedures - contains - procedure :: sfr_allocate_scalars - procedure :: sfr_allocate_arrays - procedure :: bnd_options => sfr_options - procedure :: read_dimensions => sfr_read_dimensions - procedure :: set_pointers => sfr_set_pointers - procedure :: bnd_ar => sfr_ar - procedure :: bnd_rp => sfr_rp - procedure :: bnd_ad => sfr_ad - procedure :: bnd_cf => sfr_cf - procedure :: bnd_fc => sfr_fc - procedure :: bnd_fn => sfr_fn - procedure :: bnd_cc => sfr_cc - procedure :: bnd_bd => sfr_bd - procedure :: bnd_ot => sfr_ot - procedure :: bnd_da => sfr_da - procedure :: define_listlabel - ! -- methods for observations - procedure, public :: bnd_obs_supported => sfr_obs_supported - procedure, public :: bnd_df_obs => sfr_df_obs - procedure, public :: bnd_rp_obs => sfr_rp_obs - procedure, private :: sfr_bd_obs - ! -- private procedures - procedure, private :: allocate_reach - procedure, private :: deallocate_reach - procedure, private :: allocate_diversion - procedure, private :: deallocate_diversion - procedure, private :: sfr_set_stressperiod - procedure, private :: sfr_solve - procedure, private :: sfr_update_flows - procedure, private :: sfr_calc_qgwf - procedure, private :: sfr_calc_cond - procedure, private :: sfr_calc_qman - procedure, private :: sfr_calc_qd - procedure, private :: sfr_calc_qsource - procedure, private :: sfr_calc_div - ! -- geometry - procedure, private :: area_wet - procedure, private :: perimeter_wet - procedure, private :: surface_area - procedure, private :: surface_area_wet - procedure, private :: top_width_wet - ! -- reading - procedure, private :: sfr_read_packagedata - procedure, private :: sfr_read_connectiondata - procedure, private :: sfr_read_diversions - ! -- calculations - procedure, private :: sfr_rectch_depth - ! -- error checking - procedure, private :: sfr_check_reaches - procedure, private :: sfr_check_connections - procedure, private :: sfr_check_diversions - procedure, private :: sfr_check_ustrf - ! -- budget - procedure, private :: sfr_setup_budobj - procedure, private :: sfr_fill_budobj - ! -- table - procedure, private :: sfr_setup_tableobj - end type SfrType - -contains - - subroutine sfr_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) -! ****************************************************************************** -! sfr_create -- Create a New Streamflow Routing Package -! Subroutine: (1) create new-style package -! (2) point bndobj to the new package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout - character(len=*), intent(in) :: namemodel - character(len=*), intent(in) :: pakname - ! -- local - type(SfrType), pointer :: sfrobj -! ------------------------------------------------------------------------------ - ! - ! -- allocate the object and assign values to object variables - allocate(sfrobj) - packobj => sfrobj - ! - ! -- create name and origin - call packobj%set_names(ibcnum, namemodel, pakname, ftype) - packobj%text = text - ! - ! -- allocate scalars - call sfrobj%sfr_allocate_scalars() - ! - ! -- initialize package - call packobj%pack_initialize() - - packobj%inunit = inunit - packobj%iout = iout - packobj%id = id - packobj%ibcnum = ibcnum - packobj%ncolbnd = 4 - packobj%iscloc = 0 ! not supported - packobj%ictorigin = 'NPF' - ! - ! -- return - return - end subroutine sfr_create - - subroutine sfr_allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -- allocate scalar members -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use MemoryManagerModule, only: mem_allocate, mem_setptr - ! -- dummy - class(SfrType), intent(inout) :: this -! ------------------------------------------------------------------------------ - ! - ! -- call standard BndType allocate scalars - call this%BndType%allocate_scalars() - ! - ! -- allocate the object and assign values to object variables - call mem_allocate(this%iprhed, 'IPRHED', this%origin) - call mem_allocate(this%istageout, 'ISTAGEOUT', this%origin) - call mem_allocate(this%ibudgetout, 'IBUDGETOUT', this%origin) - call mem_allocate(this%ipakcsv, 'IPAKCSV', this%origin) - call mem_allocate(this%idiversions, 'IDIVERSIONS', this%origin) - call mem_allocate(this%maxsfrit, 'MAXSFRIT', this%origin) - call mem_allocate(this%bditems, 'BDITEMS', this%origin) - call mem_allocate(this%cbcauxitems, 'CBCAUXITEMS', this%origin) - call mem_allocate(this%unitconv, 'UNITCONV', this%origin) - call mem_allocate(this%dmaxchg, 'DMAXCHG', this%origin) - call mem_allocate(this%deps, 'DEPS', this%origin) - call mem_allocate(this%nconn, 'NCONN', this%origin) - call mem_allocate(this%icheck, 'ICHECK', this%origin) - call mem_allocate(this%iconvchk, 'ICONVCHK', this%origin) - ! - ! -- set pointer to gwf iss - call mem_setptr(this%gwfiss, 'ISS', trim(this%name_model)) - ! - ! -- Set values - this%iprhed = 0 - this%istageout = 0 - this%ibudgetout = 0 - this%ipakcsv = 0 - this%idiversions = 0 - this%maxsfrit = 100 - this%bditems = 8 - this%cbcauxitems = 1 - this%unitconv = DONE - this%dmaxchg = DEM5 - this%deps = DP999 * this%dmaxchg - !this%imover = 0 - this%nconn = 0 - this%icheck = 1 - this%iconvchk = 1 - ! - ! -- return - return - end subroutine sfr_allocate_scalars - - subroutine sfr_allocate_arrays(this) -! ****************************************************************************** -! allocate_scalars -- allocate scalar members -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(SfrType), intent(inout) :: this - ! -- local - integer(I4B) :: i -! ------------------------------------------------------------------------------ - ! - ! -- call standard BndType allocate scalars - !call this%BndType%allocate_arrays() - ! - ! -- allocate character array for budget text - allocate(this%csfrbudget(this%bditems)) - allocate(this%sfrname(this%maxbound)) - ! - ! -- variables originally in SfrDataType - call mem_allocate(this%iboundpak, this%maxbound, 'IBOUNDPAK', this%origin) - call mem_allocate(this%igwfnode, this%maxbound, 'IGWFNODE', this%origin) - call mem_allocate(this%igwftopnode, this%maxbound, 'IGWFTOPNODE', this%origin) - call mem_allocate(this%length, this%maxbound, 'LENGTH', this%origin) - call mem_allocate(this%width, this%maxbound, 'WIDTH', this%origin) - call mem_allocate(this%strtop, this%maxbound, 'STRTOP', this%origin) - call mem_allocate(this%bthick, this%maxbound, 'BTHICK', this%origin) - call mem_allocate(this%hk, this%maxbound, 'HK', this%origin) - call mem_allocate(this%slope, this%maxbound, 'SLOPE', this%origin) - call mem_allocate(this%nconnreach, this%maxbound, 'NCONNREACH', this%origin) - call mem_allocate(this%ustrf, this%maxbound, 'USTRF', this%origin) - call mem_allocate(this%ftotnd, this%maxbound, 'FTOTND', this%origin) - call mem_allocate(this%ndiv, this%maxbound, 'NDIV', this%origin) - call mem_allocate(this%usflow, this%maxbound, 'USFLOW', this%origin) - call mem_allocate(this%dsflow, this%maxbound, 'DSFLOW', this%origin) - call mem_allocate(this%depth, this%maxbound, 'DEPTH', this%origin) - call mem_allocate(this%stage, this%maxbound, 'STAGE', this%origin) - call mem_allocate(this%gwflow, this%maxbound, 'GWFLOW', this%origin) - call mem_allocate(this%simevap, this%maxbound, 'SIMEVAP', this%origin) - call mem_allocate(this%simrunoff, this%maxbound, 'SIMRUNOFF', this%origin) - call mem_allocate(this%stage0, this%maxbound, 'STAGE0', this%origin) - call mem_allocate(this%usflow0, this%maxbound, 'USFLOW0', this%origin) - do i = 1, this%maxbound - this%iboundpak(i) = 1 - this%igwfnode(i) = 0 - this%igwftopnode(i) = 0 - this%length(i) = DZERO - this%width(i) = DZERO - this%strtop(i) = DZERO - this%bthick(i) = DZERO - this%hk(i) = DZERO - this%slope(i) = DZERO - this%nconnreach(i) = 0 - this%ustrf(i) = DZERO - this%ftotnd(i) = DZERO - this%ndiv(i) = 0 - this%usflow(i) = DZERO - this%dsflow(i) = DZERO - this%depth(i) = DZERO - this%stage(i) = DZERO - this%gwflow(i) = DZERO - this%simevap(i) = DZERO - this%simrunoff(i) = DZERO - this%stage0(i) = DZERO - this%usflow0(i) = DZERO - end do - - ! - ! - !-- fill csfrbudget - this%csfrbudget(1) = ' RAINFALL' - this%csfrbudget(2) = ' EVAPORATION' - this%csfrbudget(3) = ' RUNOFF' - this%csfrbudget(4) = ' EXT-INFLOW' - this%csfrbudget(5) = ' GWF' - this%csfrbudget(6) = ' EXT-OUTFLOW' - this%csfrbudget(7) = ' FROM-MVR' - this%csfrbudget(8) = ' TO-MVR' - ! - ! -- allocate and initialize budget output data - call mem_allocate(this%qoutflow, this%maxbound, 'QOUTFLOW', this%origin) - call mem_allocate(this%qextoutflow, this%maxbound, 'QEXTOUTFLOW', this%origin) - do i = 1, this%maxbound - this%qoutflow(i) = DZERO - this%qextoutflow(i) = DZERO - end do - ! - ! -- allocate and initialize dbuff - if (this%istageout > 0) then - call mem_allocate(this%dbuff, this%maxbound, 'DBUFF', this%origin) - do i = 1, this%maxbound - this%dbuff(i) = DZERO - end do - else - call mem_allocate(this%dbuff, 0, 'DBUFF', this%origin) - end if - ! - ! -- allocate character array for budget text - allocate(this%cauxcbc(this%cbcauxitems)) - ! - ! -- allocate and initialize qauxcbc - call mem_allocate(this%qauxcbc, this%cbcauxitems, 'QAUXCBC', this%origin) - do i = 1, this%cbcauxitems - this%qauxcbc(i) = DZERO - end do - ! - !-- fill cauxcbc - this%cauxcbc(1) = 'FLOW-AREA ' - ! - ! -- return - return - end subroutine sfr_allocate_arrays - - subroutine sfr_read_dimensions(this) -! ****************************************************************************** -! pak1read_dimensions -- Read the dimensions for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use InputOutputModule, only: urword - use SimModule, only: ustop, store_error, count_errors - ! -- dummy - class(SfrType),intent(inout) :: this - ! -- local - character (len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock - ! -- format -! ------------------------------------------------------------------------------ - ! - ! -- initialize dimensions to 0 - this%maxbound = 0 - ! - ! -- 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 '//trim(adjustl(this%text))// & - ' DIMENSIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('NREACHES') - this%maxbound = this%parser%GetInteger() - write(this%iout,'(4x,a,i0)')'NREACHES = ', this%maxbound - case default - write(errmsg,'(4x,a,a)') & - '****ERROR. UNKNOWN '//trim(this%text)//' DIMENSION: ', & - trim(keyword) - call store_error(errmsg) - end select - end do - write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' DIMENSIONS' - else - call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') - end if - ! - ! -- verify dimensions were set - if(this%maxbound < 1) then - write(errmsg, '(1x,a)') & - 'ERROR. NREACHES WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.' - call store_error(errmsg) - endif - ! - ! -- write summary of error messages for block - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- Call define_listlabel to construct the list label that is written - ! when PRINT_INPUT option is used. - call this%define_listlabel() - - - - - ! - ! -- Allocate arrays in package superclass - call this%sfr_allocate_arrays() - ! - ! -- read package data - call this%sfr_read_packagedata() - ! - ! -- read connection data - call this%sfr_read_connectiondata() - ! - ! -- read diversion data - call this%sfr_read_diversions() - ! - ! -- setup the budget object - call this%sfr_setup_budobj() - ! - ! -- setup the stage table object - call this%sfr_setup_tableobj() - ! - ! -- return - return - end subroutine sfr_read_dimensions - - subroutine sfr_options(this, option, found) -! ****************************************************************************** -! rch_options -- set options specific to RchType -! -! rch_options overrides BndType%bnd_options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: DZERO - use OpenSpecModule, only: access, form - use SimModule, only: ustop, store_error - use InputOutputModule, only: urword, getunit, openfile - ! -- dummy - class(SfrType), intent(inout) :: this - character(len=*), intent(inout) :: option - logical, intent(inout) :: found - ! -- local - real(DP) :: r - character(len=MAXCHARLEN) :: fname, keyword - ! -- formats - character(len=*),parameter :: fmtunitconv = & - "(4x, 'UNIT CONVERSION VALUE (',g15.7,') SPECIFIED.')" - character(len=*),parameter :: fmtiter = & - "(4x, 'MAXIMUM SFR ITERATION VALUE (',i15,') SPECIFIED.')" - character(len=*),parameter :: fmtdmaxchg = & - "(4x, 'MAXIMUM DEPTH CHANGE VALUE (',g15.7,') SPECIFIED.')" - character(len=*),parameter :: fmtsfrbin = & - "(4x, 'SFR ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" -! ------------------------------------------------------------------------------ - ! - ! -- Check for SFR options - select case (option) - case ('PRINT_STAGE') - this%iprhed = 1 - write(this%iout,'(4x,a)') trim(adjustl(this%text))// & - ' STAGES WILL BE PRINTED TO LISTING FILE.' - found = .true. - case('STAGE') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%istageout = getunit() - call openfile(this%istageout, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE') - write(this%iout,fmtsfrbin) 'STAGE', fname, this%istageout - found = .true. - else - call store_error('OPTIONAL STAGE KEYWORD MUST BE FOLLOWED BY FILEOUT') - end if - case('BUDGET') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ibudgetout = getunit() - call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE') - write(this%iout,fmtsfrbin) 'BUDGET', fname, this%ibudgetout - found = .true. - else - call store_error('OPTIONAL BUDGET KEYWORD MUST BE FOLLOWED BY FILEOUT') - end if - case('PACKAGE_CONVERGENCE') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ipakcsv = getunit() - call openfile(this%ipakcsv, this%iout, fname, 'CSV', & - filstat_opt='REPLACE') - write(this%iout,fmtsfrbin) 'PACKAGE_CONVERGENCE', fname, this%ipakcsv - found = .true. - else - call store_error('OPTIONAL PACKAGE_CONVERGENCE KEYWORD MUST BE ' // & - 'FOLLOWED BY FILEOUT') - end if - case('UNIT_CONVERSION') - this%unitconv = this%parser%GetDouble() - write(this%iout, fmtunitconv) this%unitconv - found = .true. - case('MAXIMUM_ITERATIONS') - this%maxsfrit = this%parser%GetInteger() - write(this%iout, fmtiter) this%maxsfrit - found = .true. - case('MAXIMUM_DEPTH_CHANGE') - r = this%parser%GetDouble() - this%dmaxchg = r - this%deps = DP999 * r - write(this%iout, fmtdmaxchg) this%dmaxchg - found = .true. - case('MOVER') - this%imover = 1 - write(this%iout, '(4x,A)') 'MOVER OPTION ENABLED' - found = .true. - ! - ! -- right now these 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_CHECK') - call this%parser%DevOpt() - this%icheck = 0 - write(this%iout, '(4x,A)') 'SFR CHECKS OF REACH GEOMETRY ' // & - 'RELATIVE TO MODEL GRID AND ' // & - 'REASONABLE PARAMETERS WILL NOT ' // & - 'BE PERFORMED.' - found = .true. - case('DEV_NO_FINAL_CHECK') - call this%parser%DevOpt() - this%iconvchk = 0 - write(this%iout, '(4x,a)') & - & 'A FINAL CONVERGENCE CHECK OF THE CHANGE IN STREAM FLOW ROUTING ' // & - & 'STAGES AND FLOWS WILL NOT BE MADE' - found = .true. - ! - ! -- no valid options found - case default - ! - ! -- No options found - found = .false. - end select - ! - ! -- return - return - end subroutine sfr_options - - subroutine sfr_ar(this) - ! ****************************************************************************** - ! sfr_ar -- Allocate and Read - ! Subroutine: (1) create new-style package - ! (2) point bndobj to the new package - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - use SimModule, only: ustop, count_errors - ! -- dummy - class(SfrType),intent(inout) :: this - ! -- local - integer(I4B) :: n, ierr - ! -- format - ! ------------------------------------------------------------------------------ - ! - call this%obs%obs_ar() - ! - ! -- call standard BndType allocate scalars - call this%BndType%allocate_arrays() - ! - ! -- set boundname for each connection - if (this%inamedbound /= 0) then - do n = 1, this%maxbound - this%boundname(n) = this%sfrname(n) - end do - endif - ! - ! -- copy igwfnode into nodelist - do n = 1, this%maxbound - this%nodelist(n) = this%igwfnode(n) - end do - ! - ! -- check the sfr data - call this%sfr_check_reaches() - - ! -- check the connection data - call this%sfr_check_connections() - - ! -- check the diversion data - if (this%idiversions /= 0) then - call this%sfr_check_diversions() - end if - ! - ! -- terminate if errors were detected in any of the static sfr data - ierr = count_errors() - if (ierr > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- setup pakmvrobj - if (this%imover /= 0) then - allocate(this%pakmvrobj) - call this%pakmvrobj%ar(this%maxbound, this%maxbound, this%origin) - endif - ! - ! -- return - return - end subroutine sfr_ar - - subroutine sfr_read_packagedata(this) - ! ****************************************************************************** - ! sfr_read_packagedata -- read package data - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors - use TimeSeriesManagerModule, only: read_single_value_or_time_series - ! -- dummy - class(SfrType),intent(inout) :: this - ! -- local - character (len=LINELENGTH) :: errmsg - character(len=LINELENGTH) :: text, cellid, keyword - character (len=10) :: cnum - character(len=LENBOUNDNAME) :: bndName, bndNameTemp, manningname - character(len=50), dimension(:), allocatable :: caux - integer(I4B) :: n, ierr, ival - logical :: isfound, endOfBlock - integer(I4B) :: i - integer(I4B) :: jj - integer(I4B) :: iaux - integer, allocatable, dimension(:) :: nboundchk - ! -- format - ! ------------------------------------------------------------------------------ - ! - ! -- allocate space for sfr reach data - allocate(this%reaches(this%maxbound)) - allocate(nboundchk(this%maxbound)) - do i = 1, this%maxbound - nboundchk(i) = 0 - enddo - ! - ! -- allocate local storage for aux variables - if (this%naux > 0) then - allocate(caux(this%naux)) - end if - ! - ! -- read reach data - call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & - supportOpenClose=.true.) - ! - ! -- parse reaches block if detected - if (isfound) then - write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & - ' PACKAGEDATA' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - ! -- read reach number - n = this%parser%GetInteger() - - if (n < 1 .or. n > this%maxbound) then - write(errmsg,'(4x,a,1x,i6)') & - '****ERROR. REACH NUMBER (rno) MUST BE > 0 and <= ', this%maxbound - call store_error(errmsg) - cycle - end if - - ! -- increment nboundchk - nboundchk(n) = nboundchk(n) + 1 - - ! -- allocate data for this reach - call this%allocate_reach(n, nboundchk(n)) - ! -- get model node number - call this%parser%GetCellid(this%dis%ndim, cellid, flag_string=.true.) - this%igwfnode(n) = this%dis%noder_from_cellid(cellid, & - this%inunit, this%iout, flag_string=.true.) - this%igwftopnode(n) = this%igwfnode(n) - !cdl this%nodelist(n) = this%igwfnode(n) - ! -- read the cellid string and determine if 'none' is specified - if (this%igwfnode(n) < 1) then - call this%parser%GetStringCaps(keyword) - if (keyword .ne. 'NONE') then - write(cnum, '(i0)') n - errmsg = 'ERROR: cellid (' // trim(cellid) // & - ') for unconnected reach ' // trim(cnum) // & - ' must be NONE' - call store_error(errmsg) - end if - end if - ! -- get reach length - this%length(n) = this%parser%GetDouble() - ! -- get reach width - this%width(n) = this%parser%GetDouble() - ! -- get reach slope - this%slope(n) = this%parser%GetDouble() - ! -- get reach stream bottom - this%strtop(n) = this%parser%GetDouble() - ! -- get reach bed thickness - this%bthick(n) = this%parser%GetDouble() - ! -- get reach bed hk - this%hk(n) = this%parser%GetDouble() - ! -- get reach roughness - !this%reaches(n)%rough = this%parser%GetDouble() - call this%parser%GetStringCaps(manningname) - ! -- get number of connections for reach - ival = this%parser%GetInteger() - this%nconnreach(n) = ival - this%nconn = this%nconn + ival - if (ival > 0) then - allocate(this%reaches(n)%iconn(ival)) - allocate(this%reaches(n)%idir(ival)) - allocate(this%reaches(n)%idiv(ival)) - allocate(this%reaches(n)%qconn(ival)) - else if (ival < 0) then - ival = 0 - end if - ! -- get upstream fraction for reach - this%ustrf(n) = this%parser%GetDouble() - ! -- get number of diversions for reach - ival = this%parser%GetInteger() - this%ndiv(n) = ival - if (ival > 0) then - this%idiversions = 1 - call this%allocate_diversion(n, ival) - else if (ival < 0) then - ival = 0 - end if - - ! -- get aux data - do iaux = 1, this%naux - call this%parser%GetString(caux(iaux)) - end do - - ! -- set default bndName - write(cnum,'(i10.10)') n - bndName = 'Reach' // cnum - - ! -- get reach name - if (this%inamedbound /= 0) then - call this%parser%GetStringCaps(bndNameTemp) - if (bndNameTemp /= '') then - bndName = bndNameTemp(1:16) - endif - !this%boundname(n) = bndName - end if - this%sfrname(n) = bndName - - ! -- set Mannings - text = manningname - jj = 1 !iaux - call read_single_value_or_time_series(text, & - this%reaches(n)%rough%value, & - this%reaches(n)%rough%name, & - DZERO, & - this%Name, 'BND', this%TsManager, & - this%iprpak, n, jj, & - 'MANNING', bndName, & - this%parser%iuactive) - - - ! -- get aux data - do iaux = 1, this%naux - text = caux(iaux) - jj = 1 !iaux - call read_single_value_or_time_series(text, & - this%reaches(n)%auxvar(iaux)%value, & - this%reaches(n)%auxvar(iaux)%name, & - DZERO, & - this%Name, 'AUX', this%TsManager, & - this%iprpak, n, jj, & - this%auxname(iaux), bndName, & - this%parser%iuactive) - end do - - ! -- initialize sstage to the top of the reach - ! this value would be used by simple routing reaches - ! on kper = 1 and kstp = 1 if a stage is not specified - ! on the status line for the reach - this%reaches(n)%sstage%name = '' - this%reaches(n)%sstage%value = this%strtop(n) - - end do - write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' PACKAGEDATA' - else - call store_error('ERROR. REQUIRED PACKAGEDATA BLOCK NOT FOUND.') - end if - ! - ! -- Check to make sure that every reach is specified and that no reach - ! is specified more than once. - do i = 1, this%maxbound - if (nboundchk(i) == 0) then - write(errmsg, '(a, i0, a)') 'ERROR: INFORMATION FOR REACH ', i, & - ' NOT SPECIFIED IN PACKAGEDATA BLOCK.' - call store_error(errmsg) - else if (nboundchk(i) > 1) then - write(errmsg, '(a, i0, i0)') 'ERROR: INFORMATION SPECIFIED ', & - nboundchk(i), ' TIMES FOR REACH ', i - call store_error(errmsg) - endif - end do - deallocate(nboundchk) - ! - ! -- terminate if errors encountered in reach block - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- deallocate local storage for aux variables - if (this%naux > 0) then - deallocate(caux) - end if - ! - ! -- return - return - end subroutine sfr_read_packagedata - - subroutine sfr_read_connectiondata(this) - ! ****************************************************************************** - ! sfr_read_connectiondata -- - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors - ! -- dummy - class(SfrType),intent(inout) :: this - ! -- local - character (len=LINELENGTH) :: line, errmsg - integer(I4B) :: n, ierr, ival - logical :: isfound, endOfBlock - integer(I4B) :: i - integer(I4B) :: nja - integer(I4B), dimension(:), pointer, contiguous :: rowmaxnnz => null() - integer, allocatable, dimension(:) :: nboundchk - ! -- format - ! ------------------------------------------------------------------------------ - ! - ! -- allocate and initialize local variables for reach connections - allocate(nboundchk(this%maxbound)) - do n = 1, this%maxbound - nboundchk(n) = 0 - end do - ! - ! -- - nja = 0 - allocate(rowmaxnnz(this%maxbound)) - do n = 1, this%maxbound - ival = this%nconnreach(n) - if (ival < 0) ival = 0 - rowmaxnnz(n) = ival + 1 - nja = nja + ival + 1 - enddo - ! - ! -- allocate space for connectivity - allocate(this%sparse) - ! - ! -- set up sparse - - call this%sparse%init(this%maxbound, this%maxbound, rowmaxnnz) - ! - ! -- read connection data - call this%parser%GetBlock('CONNECTIONDATA', isfound, ierr, & - supportOpenClose=.true.) - ! - ! -- parse reach connectivity block if detected - if (isfound) then - write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & - ' CONNECTIONDATA' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - ! - ! -- get reach number - n = this%parser%GetInteger() - ! - ! -- check for error - if(n < 1 .or. n > this%maxbound) then - write(errmsg, '(a, i0)') 'SFR REACH LESS THAN ONE OR > NREACHES: ', n - call store_error(errmsg) - cycle - endif - ! - ! -- increment nboundchk - if (this%nconnreach(n) > 0) then - nboundchk(n) = nboundchk(n) + 1 - end if - ! - ! -- add diagonal connection for reach - call this%sparse%addconnection(n, n, 1) - ! - ! -- fill off diagonals - do i = 1, this%nconnreach(n) - ival = this%parser%GetInteger() - if (ival < 0) then - this%reaches(n)%idir(i) = -1 - ival = abs(ival) - elseif (ival == 0) then - call store_error('Missing or zero connection reach in line:') - call store_error(line) - else - this%reaches(n)%idir(i) = 1 - end if - if (ival > this%maxbound) then - call store_error('Reach number exceeds NREACHES in line:') - call store_error(line) - endif - this%reaches(n)%iconn(i) = ival - this%reaches(n)%idiv(i) = 0 - call this%sparse%addconnection(n, ival, 1) - end do - end do - - write(this%iout,'(1x,a)') 'END OF '//trim(adjustl(this%text))// & - ' CONNECTIONDATA' - - do n = 1, this%maxbound - if (this%nconnreach(n) > 0) then - ! - ! -- check for missing or duplicate sfr connections - if (nboundchk(n) == 0) then - write(errmsg,'(a,1x,i0)') & - 'ERROR. NO CONNECTION DATA SPECIFIED FOR REACH', n - call store_error(errmsg) - else if (nboundchk(n) > 1) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & - 'ERROR. CONNECTION DATA FOR REACH', n, & - 'SPECIFIED', nboundchk(n), 'TIMES' - call store_error(errmsg) - end if - end if - end do - - else - call store_error('ERROR. REQUIRED CONNECTIONDATA BLOCK NOT FOUND.') - end if - ! - ! -- deallocate local storage for reach connections - deallocate(nboundchk) - ! - ! -- terminate if errors encountered in connectiondata block - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- allocate ia and ja for package - allocate(this%ia(this%maxbound+1)) - allocate(this%ja(nja)) - ! - ! -- create ia and ja from sparse - call this%sparse%filliaja(this%ia,this%ja,ierr) - ! - ! -- deallocate temporary storage - deallocate(rowmaxnnz) - ! - ! -- destroy sparse - call this%sparse%destroy() - deallocate(this%sparse) - ! - ! -- return - return - end subroutine sfr_read_connectiondata - - - subroutine sfr_read_diversions(this) - ! ****************************************************************************** - ! sfr_read_diversions -- - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors - ! -- dummy - class(SfrType),intent(inout) :: this - ! -- local - character (len=LINELENGTH) :: errmsg - character (len=10) :: cnum - character (len=10) :: cval - integer(I4B) :: j, n, ierr, ival - integer(I4B) :: ipos - integer(I4B) :: ndiv - logical :: isfound, endOfBlock - integer(I4B) :: idiv - integer, allocatable, dimension(:) :: iachk - integer, allocatable, dimension(:) :: nboundchk - ! -- format - ! ------------------------------------------------------------------------------ - ! - ! -- read diversions - call this%parser%GetBlock('DIVERSIONS', isfound, ierr, & - supportOpenClose=.true., & - blockRequired=.false.) - ! - ! -- parse reach connectivity block if detected - if (isfound) then - if (this%idiversions /= 0) then - write(this%iout,'(/1x,a)') 'PROCESSING ' // trim(adjustl(this%text)) // & - ' DIVERSIONS' - ! - ! -- allocate and initialize local variables for diversions - ndiv = 0 - do n = 1, this%maxbound - ndiv = ndiv + this%ndiv(n) - end do - allocate(iachk(this%maxbound+1)) - allocate(nboundchk(ndiv)) - iachk(1) = 1 - do n = 1, this%maxbound - iachk(n+1) = iachk(n) + this%ndiv(n) - end do - do n = 1, ndiv - nboundchk(n) = 0 - end do - ! - ! -- read diversion data - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - ! - ! -- get reach number - n = this%parser%GetInteger() - if (n < 1 .or. n > this%maxbound) then - write(cnum, '(i0)') n - errmsg = 'ERROR: reach number should be between 1 and ' // & - trim(cnum) // '.' - call store_error(errmsg) - cycle - end if - ! - ! -- make sure reach has at least one diversion - if (this%ndiv(n) < 1) then - write(cnum, '(i0)') n - errmsg = 'ERROR: diversions cannot be specified ' // & - 'for reach ' // trim(cnum) - call store_error(errmsg) - cycle - end if - ! - ! -- read diversion number - ival = this%parser%GetInteger() - if (ival < 1 .or. ival > this%ndiv(n)) then - write(cnum, '(i0)') n - errmsg = 'ERROR: reach ' // trim(cnum) - write(cnum, '(i0)') this%ndiv(n) - errmsg = trim(errmsg) // ' diversion number should be between ' // & - '1 and ' // trim(cnum) // '.' - call store_error(errmsg) - cycle - end if - - ! -- increment nboundchk - ipos = iachk(n) + ival - 1 - nboundchk(ipos) = nboundchk(ipos) + 1 - - idiv = ival - ! - ! -- get target reach for diversion - ival = this%parser%GetInteger() - if (ival < 1 .or. ival > this%maxbound) then - write(cnum, '(i0)') ival - errmsg = 'ERROR: diversion target reach number should be ' // & - 'between 1 and ' // trim(cnum) // '.' - call store_error(errmsg) - cycle - end if - this%reaches(n)%diversion(idiv)%reach = ival - ! - ! -- get cprior - call this%parser%GetStringCaps(cval) - ival = -1 - select case (cval) - case('UPTO') - ival = 0 - case('THRESHOLD') - ival = -1 - case('FRACTION') - ival = -2 - case('EXCESS') - ival = -3 - case default - errmsg = 'ERROR: INVALID CPRIOR TYPE ' // trim(cval) - call store_error(errmsg) - end select - this%reaches(n)%diversion(idiv)%cprior = cval - this%reaches(n)%diversion(idiv)%iprior = ival - - end do - - write(this%iout,'(1x,a)') 'END OF ' // trim(adjustl(this%text)) // & - ' DIVERSIONS' - - do n = 1, this%maxbound - do j = 1, this%ndiv(n) - ipos = iachk(n) + j - 1 - ! - ! -- check for missing or duplicate reach diversions - if (nboundchk(ipos) == 0) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0)') & - 'ERROR. NO DATA SPECIFIED FOR REACH', n, 'DIVERSION', j - call store_error(errmsg) - else if (nboundchk(ipos) > 1) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & - 'ERROR. DATA FOR REACH', n, 'DIVERSION', j, & - 'SPECIFIED', nboundchk(ipos), 'TIMES' - call store_error(errmsg) - end if - end do - end do - ! - ! -- deallocate local variables - deallocate(iachk) - deallocate(nboundchk) - else - ! - ! -- error condition - write(errmsg,'(a,1x,a)') 'ERROR. A DIVERSIONS BLOCK SHOULD NOT BE', & - 'SPECIFIED IF DIVERSIONS ARE NOT SPECIFIED.' - call store_error(errmsg) - end if - else - if (this%idiversions /= 0) then - call store_error('ERROR. REQUIRED DIVERSIONS BLOCK NOT FOUND.') - end if - end if - ! - ! -- write summary of diversion error messages - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- return - return - end subroutine sfr_read_diversions - - - subroutine sfr_rp(this) -! ****************************************************************************** -! sfr_rp -- Read and Prepare -! Subroutine: (1) read itmp -! (2) read new boundaries if itmp>0 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use TdisModule, only: kper, nper - use InputOutputModule, only: urword - use SimModule, only: ustop, store_error, count_errors - ! -- dummy - class(SfrType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: title - character(len=LINELENGTH) :: line - character(len=LINELENGTH) :: errmsg - integer(I4B) :: ierr - integer(I4B) :: n - integer(I4B) :: ichkustrm - logical :: isfound, endOfBlock - ! -- formats - character(len=*),parameter :: fmtblkerr = & - "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - character(len=*),parameter :: fmtlsp = & - & "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" - character(len=*), parameter :: fmtnbd = & - "(1X,/1X,'THE NUMBER OF ACTIVE ',A,'S (',I6, & - & ') IS GREATER THAN MAXIMUM(',I6,')')" -! ------------------------------------------------------------------------------ - ! - ! -- initialize flags - ichkustrm = 0 - if (kper == 1) then - ichkustrm = 1 - end if - ! - ! -- set nbound to maxbound - this%nbound = this%maxbound - ! - ! -- Set ionper to the stress period number for which a new block of data - ! will be read. - if (this%ionper < kper) then - ! - ! -- get period block - call this%parser%GetBlock('PERIOD', isfound, ierr, & - supportOpenClose=.true.) - if(isfound) then - ! - ! -- read ionper and check for increasing period numbers - call this%read_check_ionper() - else - ! - ! -- PERIOD block not found - if (ierr < 0) then - ! -- End of file found; data applies for remainder of simulation. - this%ionper = nper + 1 - else - ! -- Found invalid block - write(errmsg, fmtblkerr) adjustl(trim(line)) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - endif - end if - ! - ! -- Read data if ionper == kper - if(this%ionper==kper) then - ! - ! -- setup table for period data - if (this%iprpak /= 0) then - ! - ! -- reset the input table object - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%name)) //') DATA FOR PERIOD' - write(title, '(a,1x,i6)') trim(adjustl(title)), kper - call table_cr(this%inputtab, this%name, title) - call this%inputtab%table_df(1, 4, this%iout, finalize=.FALSE.) - text = 'NUMBER' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'KEYWORD' - call this%inputtab%initialize_column(text, 20, alignment=TABLEFT) - do n = 1, 2 - write(text, '(a,1x,i6)') 'VALUE', n - call this%inputtab%initialize_column(text, 15, alignment=TABCENTER) - end do - end if - ! - ! -- read data - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - n = this%parser%GetInteger() - if (n < 1 .or. n > this%maxbound) then - write(errmsg,'(4x,a,1x,i6)') & - '****ERROR. RNO MUST BE > 0 and <= ', this%maxbound - call store_error(errmsg) - cycle - end if - ! - ! -- read data from the rest of the line - call this%parser%GetRemainingLine(line) - call this%sfr_set_stressperiod(n, line, ichkustrm) - ! - ! -- write line to table - if (this%iprpak /= 0) then - call this%inputtab%add_term(n) - call this%inputtab%line_to_columns(line) - end if - end do - if (this%iprpak /= 0) then - call this%inputtab%finalize_table() - end if - - ! -- Reuse data from last stress period - else - write(this%iout,fmtlsp) trim(this%filtyp) - endif - ! - ! -- check upstream fraction values - if (ichkustrm /= 0) then - call this%sfr_check_ustrf() - end if - ! - ! -- write summary of package block error messages - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- return - return - end subroutine sfr_rp - - subroutine sfr_ad(this) -! ****************************************************************************** -! sfr_ad -- Add package connection to matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(SfrType) :: this - ! -- local - integer(I4B) :: n - integer(I4B) :: iaux -! ------------------------------------------------------------------------------ - ! - ! -- Advance the time series manager - call this%TsManager%ad() - ! - ! -- update auxiliary variables by copying from the derived-type time - ! series variable into the bndpackage auxvar variable so that this - ! information is properly written to the GWF budget file - if (this%naux > 0) then - do n = 1, this%maxbound - do iaux = 1, this%naux - this%auxvar(iaux, n) = this%reaches(n)%auxvar(iaux)%value - end do - end do - end if - ! - ! -- reset upstream flow to zero and set specified stage - do n = 1, this%maxbound - this%usflow(n) = DZERO - if (this%iboundpak(n) < 0) then - this%stage(n) = this%reaches(n)%sstage%value - end if - end do - ! - ! -- pakmvrobj ad - if(this%imover == 1) then - call this%pakmvrobj%ad() - endif - ! - ! -- For each observation, push simulated value and corresponding - ! simulation time from "current" to "preceding" and reset - ! "current" value. - call this%obs%obs_ad() - ! - ! -- return - return - end subroutine sfr_ad - - subroutine sfr_cf(this, reset_mover) - ! ****************************************************************************** - ! sfr_cf -- Formulate the HCOF and RHS terms - ! Subroutine: (1) skip in no wells - ! (2) calculate hcof and rhs - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - ! -- dummy - class(SfrType) :: this - logical, intent(in), optional :: reset_mover - ! -- local variables - integer(I4B) :: n - integer(I4B) :: igwfnode - logical :: lrm - ! ------------------------------------------------------------------------------ - ! - ! -- Return if no sfr reaches - if(this%nbound == 0) return - ! - ! -- find highest active cell - do n = 1, this%nbound - igwfnode = this%igwftopnode(n) - if (igwfnode > 0) then - if (this%ibound(igwfnode) == 0) then - call this%dis%highest_active(igwfnode, this%ibound) - end if - end if - this%igwfnode(n) = igwfnode - this%nodelist(n) = igwfnode - end do - ! - ! -- pakmvrobj cf - lrm = .true. - if (present(reset_mover)) lrm = reset_mover - if(this%imover == 1 .and. lrm) then - call this%pakmvrobj%cf() - endif - ! - ! -- return - return - end subroutine sfr_cf - - subroutine sfr_fc(this, rhs, ia, idxglo, amatsln) - ! ************************************************************************** - ! sfr_fc -- Copy rhs and hcof into solution rhs and amat - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - ! -- dummy - class(SfrType) :: this - real(DP), dimension(:), intent(inout) :: rhs - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln - ! -- local - integer(I4B) :: i, n - integer(I4B) :: ipos - integer(I4B) :: node - real(DP) :: hgwf - real(DP) :: v - real(DP) :: hhcof - real(DP) :: rrhs -! -------------------------------------------------------------------------- - ! - ! -- pakmvrobj fc - if(this%imover == 1) then - call this%pakmvrobj%fc() - endif - ! - ! -- solve for each sfr reach - do n = 1, this%nbound - node = this%igwfnode(n) - if (node > 0) then - hgwf = this%xnew(node) - else - hgwf = DEP20 - end if - ! - ! -- save previous stage and upstream flow - this%stage0(n) = this%stage(n) - this%usflow0(n) = this%usflow(n) - ! - ! -- solve for flow in swr - if (this%iboundpak(n) /= 0) then - call this%sfr_solve(n, hgwf, hhcof, rrhs) - else - this%depth(n) = DZERO - this%stage(n) = this%strtop(n) - v = DZERO - call this%sfr_update_flows(n, v, v) - hhcof = DZERO - rrhs = DZERO - end if - this%hcof(n) = hhcof - this%rhs(n) = rrhs - end do - ! - ! -- Copy package rhs and hcof into solution rhs and amat - do i = 1, this%nbound - n = this%nodelist(i) - if (n < 1) cycle - rhs(n) = rhs(n) + this%rhs(i) - ipos = ia(n) - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) - enddo - ! - ! -- return - return - end subroutine sfr_fc - - subroutine sfr_fn(this, rhs, ia, idxglo, amatsln) -! ************************************************************************** -! pak1fn -- Fill newton terms -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - ! -- dummy - class(SfrType) :: this - real(DP), dimension(:), intent(inout) :: rhs - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln - ! -- local - integer(I4B) :: i, n - integer(I4B) :: ipos - real(DP) :: rterm, drterm - real(DP) :: rhs1, hcof1, q1 - real(DP) :: q2 - real(DP) :: hgwf -! -------------------------------------------------------------------------- - ! - ! -- Copy package rhs and hcof into solution rhs and amat - do i = 1, this%nbound - ! -- skip inactive reaches - if (this%iboundpak(i) < 1) cycle - ! -- skip if reach is not connected to gwf - n = this%nodelist(i) - if (n < 1) cycle - ipos = ia(n) - !rterm = this%hcof(i) * this%xnew(n) - this%rhs(i) - rterm = this%hcof(i) * this%xnew(n) - ! -- calculate perturbed head - hgwf = this%xnew(n) + DEM4 - call this%sfr_solve(i, hgwf, hcof1, rhs1, update=.false.) - q1 = rhs1 - hcof1 * hgwf - ! -- calculate unperturbed head - !hgwf = this%xnew(n) - !call this%sfr_solve(i, hgwf, hcof2, rhs2) - !q2 = rhs2 - hcof2 * hgwf - q2 = this%rhs(i) - this%hcof(i) * this%xnew(n) - ! -- calculate derivative - drterm = (q2 - q1) / DEM4 - ! -- add terms to convert conductance formulation into - ! newton-raphson formulation - !amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + drterm - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + drterm - this%hcof(i) - rhs(n) = rhs(n) - rterm + drterm * this%xnew(n) - end do - ! - ! -- return - return - end subroutine sfr_fn - - subroutine sfr_cc(this, kiter, iend, icnvgmod, cpak, dpak) -! ************************************************************************** -! sfr_cc -- Final convergence check for package -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - use TdisModule, only: totim, kstp, kper, delt - ! -- dummy - class(SfrType), intent(inout) :: this - integer(I4B), intent(in) :: kiter - integer(I4B), intent(in) :: iend - integer(I4B), intent(in) :: icnvgmod - character(len=LENPAKLOC), intent(inout) :: cpak - real(DP), intent(inout) :: dpak - ! -- local - character(len=LENPAKLOC) :: cloc - character(len=LINELENGTH) :: tag - integer(I4B) :: icheck - integer(I4B) :: ipakfail - integer(I4B) :: locdhmax - integer(I4B) :: locrmax - integer(I4B) :: ntabrows - integer(I4B) :: ntabcols - integer(I4B) :: n - real(DP) :: dh - real(DP) :: r - real(DP) :: dhmax - real(DP) :: rmax - ! format -! -------------------------------------------------------------------------- - ! - ! -- initialize local variables - icheck = this%iconvchk - ipakfail = 0 - locdhmax = 0 - locrmax = 0 - dhmax = DZERO - rmax = DZERO - ! - ! -- if not saving package convergence data on check convergence if - ! the model is considered converged - if (this%ipakcsv == 0) then - if (icnvgmod == 0) then - icheck = 0 - end if - ! - ! -- saving package convergence data - else - ! - ! -- header for package csv - if (.not. associated(this%pakcsvtab)) then - ! - ! -- determine the number of columns and rows - ntabrows = 1 - ntabcols = 8 - ! - ! -- setup table - call table_cr(this%pakcsvtab, this%name, '') - call this%pakcsvtab%table_df(ntabrows, ntabcols, this%ipakcsv, & - lineseparator=.FALSE., separator=',', & - finalize=.FALSE.) - ! - ! -- add columns to package csv - tag = 'totim' - call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'kper' - call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'kstp' - call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'nouter' - call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'dvmax' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - tag = 'dvmax_loc' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - tag = 'dinflowmax' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - tag = 'dinflowmax_loc' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - end if - end if - ! - ! -- perform package convergence check - if (icheck /= 0) then - final_check: do n = 1, this%maxbound - if (this%iboundpak(n) == 0) cycle - dh = this%stage0(n) - this%stage(n) - r = this%usflow0(n) - this%usflow(n) - ! - ! -- normalize flow difference and convert to a depth - r = r * delt / this%surface_area(n) - ! - ! -- evaluate magnitude of differences - if (n == 1) then - locdhmax = n - dhmax = dh - locrmax = n - rmax = r - else - if (abs(dh) > abs(dhmax)) then - locdhmax = n - dhmax = dh - end if - if (abs(r) > abs(rmax)) then - locrmax = n - rmax = r - end if - end if - end do final_check - ! - ! -- set dpak and cpak - if (ABS(dhmax) > abs(dpak)) then - dpak = dhmax - write(cloc, "(a,'-(',i0,')-',a)") & - trim(this%name), locdhmax, 'stage' - cpak = trim(cloc) - end if - if (ABS(rmax) > abs(dpak)) then - dpak = rmax - write(cloc, "(a,'-(',i0,')-',a)") & - trim(this%name), locrmax, 'inflow' - cpak = trim(cloc) - end if - ! - ! -- write convergence data to package csv - if (this%ipakcsv /= 0) then - ! - ! -- write the data - call this%pakcsvtab%add_term(totim) - call this%pakcsvtab%add_term(kper) - call this%pakcsvtab%add_term(kstp) - call this%pakcsvtab%add_term(kiter) - call this%pakcsvtab%add_term(dhmax) - call this%pakcsvtab%add_term(locdhmax) - call this%pakcsvtab%add_term(rmax) - call this%pakcsvtab%add_term(locrmax) - ! - ! -- finalize the package csv - if (iend == 1) then - call this%pakcsvtab%finalize_table() - end if - end if - end if - ! - ! -- return - return - end subroutine sfr_cc - - - subroutine sfr_bd(this, x, idvfl, icbcfl, ibudfl, icbcun, iprobs, & - isuppress_output, model_budget, imap, iadv) -! ************************************************************************** -! bnd_bd -- Calculate Volumetric Budget -! Note that the compact budget will always be used. -! Subroutine: (1) Process each package entry -! (2) Write output -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - ! -- modules - use TdisModule, only: kstp, kper, delt, pertim, totim - use ConstantsModule, only: LENBOUNDNAME - use InputOutputModule, only: ulasav, ubdsv06 - use BudgetModule, only: BudgetType - ! -- dummy - class(SfrType) :: this - real(DP),dimension(:),intent(in) :: x - integer(I4B), intent(in) :: idvfl - integer(I4B), intent(in) :: icbcfl - integer(I4B), intent(in) :: ibudfl - integer(I4B), intent(in) :: icbcun - integer(I4B), intent(in) :: iprobs - integer(I4B), intent(in) :: isuppress_output - type(BudgetType), intent(inout) :: model_budget - integer(I4B), dimension(:), optional, intent(in) :: imap - integer(I4B), optional, intent(in) :: iadv - ! -- local - integer(I4B) :: i - integer(I4B) :: ibinun - real(DP) :: qext - ! -- for budget - integer(I4B) :: n - real(DP) :: d - real(DP) :: v - real(DP) :: qoutflow - real(DP) :: qfrommvr - real(DP) :: qtomvr - ! -- for observations - integer(I4B) :: iprobslocal - ! -- formats -! -------------------------------------------------------------------------- - ! - ! -- Suppress saving of simulated values; they - ! will be saved at end of this procedure. - iprobslocal = 0 - ! - ! -- call base functionality in bnd_bd - call this%BndType%bnd_bd(x, idvfl, icbcfl, ibudfl, icbcun, iprobslocal, & - isuppress_output, model_budget, iadv=1) - ! - ! -- Calculate qextoutflow and qoutflow for subsequent budgets - do n = 1, this%maxbound - ! - ! -- mover - qfrommvr = DZERO - qtomvr = DZERO - if (this%imover == 1) then - qfrommvr = this%pakmvrobj%get_qfrommvr(n) - qtomvr = this%pakmvrobj%get_qtomvr(n) - if (qtomvr > DZERO) then - qtomvr = -qtomvr - end if - endif - ! - ! -- external downstream stream flow - qext = this%dsflow(n) - qoutflow = DZERO - if (qext > DZERO) then - qext = -qext - end if - do i = 1, this%nconnreach(n) - if (this%reaches(n)%idir(i) > 0) cycle - qext = DZERO - exit - end do - ! - ! -- adjust external downstream stream flow using qtomvr - if (qext < DZERO) then - if (qtomvr < DZERO) then - qext = qext - qtomvr - end if - else - qoutflow = this%dsflow(n) - if (qoutflow > DZERO) then - qoutflow = -qoutflow - end if - end if - ! - ! -- set qextoutflow and qoutflow for cell by cell budget - ! output and observations - this%qextoutflow(n) = qext - this%qoutflow(n) = qoutflow - ! - end do - ! - ! -- For continuous observations, save simulated values. - if (this%obs%npakobs > 0 .and. iprobs > 0) then - call this%sfr_bd_obs() - end if - ! - ! -- set unit number for binary dependent variable output - ibinun = 0 - if(this%istageout /= 0) then - ibinun = this%istageout - end if - if(idvfl == 0) ibinun = 0 - if (isuppress_output /= 0) ibinun = 0 - ! - ! -- write sfr binary output - if (ibinun > 0) then - do n = 1, this%maxbound - d = this%depth(n) - v = this%stage(n) - if (this%iboundpak(n) == 0) then - v = DHNOFLO - else if (d == DZERO) then - v = DHDRY - end if - this%dbuff(n) = v - end do - call ulasav(this%dbuff, ' STAGE', kstp, kper, pertim, totim, & - this%maxbound, 1, 1, ibinun) - end if - ! - ! -- fill the budget object - call this%sfr_fill_budobj() - ! - ! -- write the flows from the budobj - ibinun = 0 - if(this%ibudgetout /= 0) then - ibinun = this%ibudgetout - end if - if(icbcfl == 0) ibinun = 0 - if (isuppress_output /= 0) ibinun = 0 - if (ibinun > 0) then - call this%budobj%save_flows(this%dis, ibinun, kstp, kper, delt, & - pertim, totim, this%iout) - end if - ! - ! - ! -- return - return - end subroutine sfr_bd - - subroutine sfr_ot(this, kstp, kper, iout, ihedfl, ibudfl) - ! ************************************************************************** - ! pak1t -- Output package budget - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - ! -- dummy - class(SfrType) :: this - integer(I4B),intent(in) :: kstp - integer(I4B),intent(in) :: kper - integer(I4B),intent(in) :: iout - integer(I4B),intent(in) :: ihedfl - integer(I4B),intent(in) :: ibudfl - ! -- locals - character (len=20) :: cellid - integer(I4B) :: n - integer(I4B) :: node - real(DP) :: hgwf - real(DP) :: sbot - real(DP) :: depth, stage - real(DP) :: w, cond, grad - ! format - ! -------------------------------------------------------------------------- - ! - ! -- write sfr stage and depth table - if (ihedfl /= 0 .and. this%iprhed /= 0) then - ! - ! -- fill stage data - do n = 1, this%maxbound - node = this%igwfnode(n) - if (node > 0) then - call this%dis%noder_to_string(node, cellid) - hgwf = this%xnew(node) - else - cellid = 'none' - end if - if(this%inamedbound==1) then - call this%stagetab%add_term(this%boundname(n)) - end if - call this%stagetab%add_term(n) - call this%stagetab%add_term(cellid) - depth = this%depth(n) - stage = this%stage(n) - w = this%top_width_wet(n, depth) - call this%stagetab%add_term(stage) - call this%stagetab%add_term(depth) - call this%stagetab%add_term(w) - call this%sfr_calc_cond(n, cond) - if (node > 0) then - sbot = this%strtop(n) - this%bthick(n) - if (hgwf < sbot) then - grad = stage - sbot - else - grad = stage - hgwf - end if - grad = grad / this%bthick(n) - call this%stagetab%add_term(hgwf) - call this%stagetab%add_term(cond) - call this%stagetab%add_term(grad) - else - call this%stagetab%add_term('--') - call this%stagetab%add_term('--') - call this%stagetab%add_term('--') - end if - end do - end if - ! - ! -- Output sfr flow table - if (ibudfl /= 0 .and. this%iprflow /= 0) then - call this%budobj%write_flowtable(this%dis) - end if - ! - ! -- Output sfr budget - call this%budobj%write_budtable(kstp, kper, iout) - ! - ! -- return - return - end subroutine sfr_ot - - subroutine sfr_da(this) -! ****************************************************************************** -! sfr_da -- deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(SfrType) :: this - ! -- local - integer(I4B) :: n -! ------------------------------------------------------------------------------ - ! - ! -- arrays - call mem_deallocate(this%qoutflow) - call mem_deallocate(this%qextoutflow) - deallocate(this%csfrbudget) - deallocate(this%sfrname) - call mem_deallocate(this%dbuff) - deallocate(this%cauxcbc) - call mem_deallocate(this%qauxcbc) - call mem_deallocate(this%iboundpak) - call mem_deallocate(this%igwfnode) - call mem_deallocate(this%igwftopnode) - call mem_deallocate(this%length) - call mem_deallocate(this%width) - call mem_deallocate(this%strtop) - call mem_deallocate(this%bthick) - call mem_deallocate(this%hk) - call mem_deallocate(this%slope) - call mem_deallocate(this%ustrf) - call mem_deallocate(this%ftotnd) - call mem_deallocate(this%usflow) - call mem_deallocate(this%dsflow) - call mem_deallocate(this%depth) - call mem_deallocate(this%stage) - call mem_deallocate(this%gwflow) - call mem_deallocate(this%simevap) - call mem_deallocate(this%simrunoff) - call mem_deallocate(this%stage0) - call mem_deallocate(this%usflow0) - ! - ! -- deallocation diversions - do n = 1, this%maxbound - if (this%ndiv(n) > 0) then - call this%deallocate_diversion(n) - endif - enddo - call mem_deallocate(this%ndiv) - ! - ! -- deallocate reaches - do n = 1, this%maxbound - call this%deallocate_reach(n) - enddo - deallocate(this%reaches) - call mem_deallocate(this%nconnreach) - ! - ! -- ia ja - deallocate(this%ia) - deallocate(this%ja) - ! - ! -- budobj - call this%budobj%budgetobject_da() - deallocate(this%budobj) - nullify(this%budobj) - ! - ! -- stage table - if (this%iprhed > 0) then - call this%stagetab%table_da() - deallocate(this%stagetab) - nullify(this%stagetab) - end if - ! - ! -- package csv table - if (this%ipakcsv > 0) then - call this%pakcsvtab%table_da() - deallocate(this%pakcsvtab) - nullify(this%pakcsvtab) - end if - ! - ! -- scalars - call mem_deallocate(this%iprhed) - call mem_deallocate(this%istageout) - call mem_deallocate(this%ibudgetout) - call mem_deallocate(this%ipakcsv) - call mem_deallocate(this%idiversions) - call mem_deallocate(this%maxsfrit) - call mem_deallocate(this%bditems) - call mem_deallocate(this%cbcauxitems) - call mem_deallocate(this%unitconv) - call mem_deallocate(this%dmaxchg) - call mem_deallocate(this%deps) - call mem_deallocate(this%nconn) - call mem_deallocate(this%icheck) - call mem_deallocate(this%iconvchk) - nullify(this%gwfiss) - ! - ! -- call BndType deallocate - call this%BndType%bnd_da() - ! - ! -- return - end subroutine sfr_da - - subroutine define_listlabel(this) -! ****************************************************************************** -! define_listlabel -- Define the list heading that is written to iout when -! PRINT_INPUT option is used. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(SfrType), intent(inout) :: this -! ------------------------------------------------------------------------------ - ! - ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' - else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif - ! - ! -- return - return - end subroutine define_listlabel - - - subroutine sfr_set_pointers(this, neq, ibound, xnew, xold, flowja) -! ****************************************************************************** -! set_pointers -- Set pointers to model arrays and variables so that a package -! has access to these things. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(SfrType) :: this - integer(I4B), pointer :: neq - integer(I4B), dimension(:), pointer, contiguous :: ibound - real(DP), dimension(:), pointer, contiguous :: xnew - real(DP), dimension(:), pointer, contiguous :: xold - real(DP), dimension(:), pointer, contiguous :: flowja - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- call base BndType set_pointers - call this%BndType%set_pointers(neq, ibound, xnew, xold, flowja) - ! - ! -- return - end subroutine sfr_set_pointers - - ! - ! -- Procedures related to observations (type-bound) - logical function sfr_obs_supported(this) - ! ****************************************************************************** - ! sfr_obs_supported - ! -- Return true because sfr package supports observations. - ! -- Overrides BndType%bnd_obs_supported() - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - class(SfrType) :: this - ! ------------------------------------------------------------------------------ - sfr_obs_supported = .true. - return - end function sfr_obs_supported - - - subroutine sfr_df_obs(this) - ! ****************************************************************************** - ! sfr_df_obs (implements bnd_df_obs) - ! -- Store observation type supported by sfr package. - ! -- Overrides BndType%bnd_df_obs - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - ! -- dummy - class(SfrType) :: this - ! -- local - integer(I4B) :: indx - ! ------------------------------------------------------------------------------ - ! - ! -- Store obs type and assign procedure pointer - ! for stage observation type. - call this%obs%StoreObsType('stage', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for inflow observation type. - call this%obs%StoreObsType('inflow', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for inflow observation type. - call this%obs%StoreObsType('ext-inflow', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for rainfall observation type. - call this%obs%StoreObsType('rainfall', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for runoff observation type. - call this%obs%StoreObsType('runoff', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for evaporation observation type. - call this%obs%StoreObsType('evaporation', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for outflow observation type. - call this%obs%StoreObsType('outflow', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for ext-outflow observation type. - call this%obs%StoreObsType('ext-outflow', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for to-mvr observation type. - call this%obs%StoreObsType('to-mvr', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for sfr-frommvr observation type. - call this%obs%StoreObsType('from-mvr', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for sfr observation type. - call this%obs%StoreObsType('sfr', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for upstream flow observation type. - call this%obs%StoreObsType('upstream-flow', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for downstream flow observation type. - call this%obs%StoreObsType('downstream-flow', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - return - end subroutine sfr_df_obs - - - subroutine sfr_bd_obs(this) - ! ************************************************************************** - ! sfr_bd_obs - ! -- Calculate observations this time step and call - ! ObsType%SaveOneSimval for each SfrType observation. - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - ! -- dummy - class(SfrType), intent(inout) :: this - ! -- local - integer(I4B) :: i, j, n, nn - real(DP) :: v - character(len=100) :: msg - type(ObserveType), pointer :: obsrv => null() - !--------------------------------------------------------------------------- - ! - ! Write simulated values for all sfr observations - if (this%obs%npakobs>0) then - call this%obs%obs_bd_clear() - do i=1 ,this%obs%npakobs - obsrv => this%obs%pakobs(i)%obsrv - nn = size(obsrv%indxbnds) - do j = 1,nn - n = obsrv%indxbnds(j) - v = DZERO - select case (obsrv%ObsTypeId) - case ('STAGE') - v = this%stage(n) - case ('TO-MVR') - v = DNODATA - if (this%imover == 1) then - v = this%pakmvrobj%get_qtomvr(n) - if (v > DZERO) then - v = -v - end if - end if - case ('FROM-MVR') - v = DNODATA - if (this%imover == 1) then - v = this%pakmvrobj%get_qfrommvr(n) - end if - case ('EXT-INFLOW') - v = this%reaches(n)%inflow%value - case ('INFLOW') - v = this%usflow(n) - case ('OUTFLOW') - v = this%qoutflow(n) - case ('EXT-OUTFLOW') - v = this%qextoutflow(n) - case ('RAINFALL') - v = this%reaches(n)%rain%value - case ('RUNOFF') - v = this%simrunoff(n) - case ('EVAPORATION') - v = this%simevap(n) - case ('SFR') - v = this%gwflow(n) - case ('UPSTREAM-FLOW') - v = this%usflow(n) - if (this%imover == 1) then - v = v + this%pakmvrobj%get_qfrommvr(n) - end if - case ('DOWNSTREAM-FLOW') - v = this%dsflow(n) - if (v > DZERO) then - v = -v - end if - case default - msg = 'Error: Unrecognized observation type: ' // trim(obsrv%ObsTypeId) - call store_error(msg) - end select - call this%obs%SaveOneSimval(obsrv, v) - end do - end do - end if - ! - ! -- write summary of package block error messages - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - return - end subroutine sfr_bd_obs - - - subroutine sfr_rp_obs(this) - ! -- dummy - class(SfrType), intent(inout) :: this - ! -- local - integer(I4B) :: i, j, n, nn1 - character(len=200) :: errmsg - character(len=LENBOUNDNAME) :: bname - logical :: jfound - class(ObserveType), pointer :: obsrv => null() - ! -------------------------------------------------------------------------- - ! -- formats -10 format('Error: Boundary "',a,'" for observation "',a, & - '" is invalid in package "',a,'"') -30 format('Error: Boundary name not provided for observation "',a, & - '" in package "',a,'"') - do i = 1, this%obs%npakobs - obsrv => this%obs%pakobs(i)%obsrv - ! - ! -- indxbnds needs to be deallocated and reallocated (using - ! ExpandArray) each stress period because list of boundaries - ! can change each stress period. - if (allocated(obsrv%indxbnds)) then - deallocate(obsrv%indxbnds) - end if - ! - ! -- get node number 1 - nn1 = obsrv%NodeNumber - if (nn1 == NAMEDBOUNDFLAG) then - bname = obsrv%FeatureName - if (bname /= '') then - ! -- Observation location(s) is(are) based on a boundary name. - ! Iterate through all boundaries to identify and store - ! corresponding index(indices) in bound array. - jfound = .false. - do j = 1, this%maxbound - if (this%boundname(j) == bname) then - jfound = .true. - call ExpandArray(obsrv%indxbnds) - n = size(obsrv%indxbnds) - obsrv%indxbnds(n) = j - endif - enddo - if (.not. jfound) then - write(errmsg,10)trim(bname), trim(obsrv%name), trim(this%name) - call store_error(errmsg) - endif - else - write(errmsg,30) trim(obsrv%name), trim(this%name) - call store_error(errmsg) - endif - elseif (nn1 < 1 .or. nn1 > this%maxbound) then - write(errmsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & - 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & - ' reach must be > 0 and <=', this%maxbound, & - '(specified value is ', nn1, ')' - call store_error(errmsg) - else - call ExpandArray(obsrv%indxbnds) - n = size(obsrv%indxbnds) - if (n == 1) then - obsrv%indxbnds(1) = nn1 - else - errmsg = 'Programming error in sfr_rp_obs' - call store_error(errmsg) - endif - end if - ! - ! -- catch non-cumulative observation assigned to observation defined - ! by a boundname that is assigned to more than one element - if (obsrv%ObsTypeId == 'STAGE') then - nn1 = obsrv%NodeNumber - if (nn1 == NAMEDBOUNDFLAG) then - n = size(obsrv%indxbnds) - if (n > 1) then - write(errmsg, '(4x,a,4(1x,a))') & - 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & - 'for observation', trim(adjustl(obsrv%Name)), & - ' must be assigned to a reach with a unique boundname.' - call store_error(errmsg) - end if - end if - end if - ! - ! -- check that node number 1 is valid; call store_error if not - n = size(obsrv%indxbnds) - do j = 1, n - nn1 = obsrv%indxbnds(j) - if (nn1 < 1 .or. nn1 > this%maxbound) then - write(errmsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & - 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & - ' reach must be > 0 and <=', this%maxbound, & - '(specified value is ', nn1, ')' - call store_error(errmsg) - end if - end do - end do - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - return - end subroutine sfr_rp_obs - - - ! - ! -- Procedures related to observations (NOT type-bound) - subroutine sfr_process_obsID(obsrv, dis, inunitobs, iout) - ! -- This procedure is pointed to by ObsDataType%ProcesssIdPtr. It processes - ! the ID string of an observation definition for sfr-package observations. - ! -- dummy - type(ObserveType), intent(inout) :: obsrv - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: inunitobs - integer(I4B), intent(in) :: iout - ! -- local - integer(I4B) :: nn1 - integer(I4B) :: icol, istart, istop - character(len=LINELENGTH) :: strng - character(len=LENBOUNDNAME) :: bndname - ! formats - ! - strng = obsrv%IDstring - ! -- Extract reach number from strng and store it. - ! If 1st item is not an integer(I4B), it should be a - ! boundary name--deal with it. - icol = 1 - ! -- get reach number or boundary name - call extract_idnum_or_bndname(strng, icol, istart, istop, nn1, bndname) - if (nn1 == NAMEDBOUNDFLAG) then - obsrv%FeatureName = bndname - endif - ! -- store reach number (NodeNumber) - obsrv%NodeNumber = nn1 - ! - return - end subroutine sfr_process_obsID - - ! - ! -- private sfr methods - ! - - - subroutine sfr_set_stressperiod(this, n, line, ichkustrm) -! ****************************************************************************** -! sfr_set_stressperiod -- Set a stress period attribute for sfr reach n -! using keywords. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - !use ConstantsModule, only: LINELENGTH, DTWO - use TdisModule, only: kper, perlen, totimsav - use TimeSeriesManagerModule, only: read_single_value_or_time_series - use InputOutputModule, only: urword - use SimModule, only: ustop, store_error - ! -- dummy - class(SfrType),intent(inout) :: this - integer(I4B), intent(in) :: n - character (len=*), intent(in) :: line - integer(I4B), intent(inout) :: ichkustrm - ! -- local - character(len=10) :: cnum - character(len=LINELENGTH) :: text - character(len=LINELENGTH) :: caux - character(len=LINELENGTH) :: keyword - character(len=LINELENGTH) :: errmsg - character(len=LENBOUNDNAME) :: bndName - integer(I4B) :: ival, istart, istop, jj - integer(I4B) :: i0 - integer(I4B) :: lloc - integer(I4B) :: idiv - integer(I4B) :: iaux - real(DP) :: rval - real(DP) :: endtim - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- Find time interval of current stress period. - endtim = totimsav + perlen(kper) - ! - ! -- Assign boundary name - if (this%inamedbound==1) then - bndName = this%boundname(n) - else - bndName = '' - end if - ! - ! -- read line - lloc = 1 - call urword(line, lloc, istart, istop, 1, ival, rval, this%iout, this%inunit) - i0 = istart - keyword = line(istart:istop) - select case (line(istart:istop)) - case ('STATUS') - ichkustrm = 1 - call urword(line, lloc, istart, istop, 1, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - if (text == 'INACTIVE') then - this%iboundpak(n) = 0 - else if (text == 'ACTIVE') then - this%iboundpak(n) = 1 - else if (text == 'SIMPLE') then - this%iboundpak(n) = -1 - else - write(errmsg,'(4x,a,a)') & - '****ERROR. UNKNOWN '//trim(this%text)//' SFR STATUS KEYWORD: ', & - text - call store_error(errmsg) - end if - case ('MANNING') - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 1 ! For 'MANNING' - call read_single_value_or_time_series(text, & - this%reaches(n)%rough%value, & - this%reaches(n)%rough%name, & - endtim, & - this%Name, 'BND', this%TsManager, & - this%iprpak, n, jj, 'MANNING', & - bndName, this%inunit) - case ('STAGE') - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 1 ! For 'STAGE' - call read_single_value_or_time_series(text, & - this%reaches(n)%sstage%value, & - this%reaches(n)%sstage%name, & - endtim, & - this%Name, 'BND', this%TsManager, & - this%iprpak, n, jj, 'STAGE', & - bndName, this%inunit) - case ('RAINFALL') - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 1 ! For 'RAIN' - call read_single_value_or_time_series(text, & - this%reaches(n)%rain%value, & - this%reaches(n)%rain%name, & - endtim, & - this%Name, 'BND', this%TsManager, & - this%iprpak, n, jj, 'RAINFALL', & - bndName, this%inunit) - case ('EVAPORATION') - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 2 ! For 'EVAP' - call read_single_value_or_time_series(text, & - this%reaches(n)%evap%value, & - this%reaches(n)%evap%name, & - endtim, & - this%Name, 'BND', this%TsManager, & - this%iprpak, n, jj, & - 'EVAPORATION', bndName, & - this%inunit) - case ('RUNOFF') - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 3 ! For 'RUNOFF' - call read_single_value_or_time_series(text, & - this%reaches(n)%runoff%value, & - this%reaches(n)%runoff%name, & - endtim, & - this%Name, 'BND', this%TsManager, & - this%iprpak, n, jj, 'RUNOFF', & - bndName, this%inunit) - case ('INFLOW') - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 4 ! For 'INFLOW' - call read_single_value_or_time_series(text, & - this%reaches(n)%inflow%value, & - this%reaches(n)%inflow%name, & - endtim, & - this%Name, 'BND', this%TsManager, & - this%iprpak, n, jj, 'INFLOW', & - bndName, this%inunit) - case ('DIVERSION') - ! - ! -- make sure reach has at least one diversion - if (this%ndiv(n) < 1) then - write(cnum, '(i0)') n - errmsg = 'ERROR: diversions cannot be specified for reach ' // trim(cnum) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- read diversion number - call urword(line, lloc, istart, istop, 2, ival, rval, this%iout, this%inunit) - if (ival < 1 .or. ival > this%ndiv(n)) then - write(cnum, '(i0)') n - errmsg = 'ERROR: reach ' // trim(cnum) - write(cnum, '(i0)') this%ndiv(n) - errmsg = trim(errmsg) // ' diversion number should be between 1 ' // & - 'and ' // trim(cnum) // '.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - idiv = ival - ! - ! -- read value - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 5 ! for 'DIVERSION' - call read_single_value_or_time_series(text, & - this%reaches(n)%diversion(idiv)%rate%value, & - this%reaches(n)%diversion(idiv)%rate%name, & - endtim, & - this%Name, 'BND', this%TsManager, & - this%iprpak, n, jj, 'DIVERSION', & - bndName, this%inunit) - - case ('UPSTREAM_FRACTION') - ichkustrm = 1 - call urword(line, lloc, istart, istop, 3, ival, rval, this%iout, this%inunit) - this%ustrf(n) = rval - - case ('AUXILIARY') - call urword(line, lloc, istart, istop, 1, ival, rval, this%iout, this%inunit) - caux = line(istart:istop) - do iaux = 1, this%naux - if (trim(adjustl(caux)) /= trim(adjustl(this%auxname(iaux)))) cycle - call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) - text = line(istart:istop) - jj = 1 !iaux - call read_single_value_or_time_series(text, & - this%reaches(n)%auxvar(iaux)%value, & - this%reaches(n)%auxvar(iaux)%name, & - endtim, & - this%Name, 'BND', this%TsManager, & - this%iprpak, n, jj, & - this%auxname(iaux), bndName, & - this%inunit) - exit - end do - - case default - write(errmsg,'(4x,a,a)') & - '****ERROR. UNKNOWN '//trim(this%text)//' SFR DATA KEYWORD: ', & - line(istart:istop) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - ! - ! -- return - return - end subroutine sfr_set_stressperiod - - subroutine allocate_reach(this, n, nboundchk) -! ****************************************************************************** -! allocate_reach -- Allocate pointers for reach(n). -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(SfrType) :: this - integer(I4B), intent(in) :: n - integer(I4B), intent(in) :: nboundchk - ! -- local - character(len=LINELENGTH) :: errmsg - character(len=10) :: crch - integer(I4B) :: iaux -! ------------------------------------------------------------------------------ - ! - ! -- make sure reach has not been allocated - if (nboundchk > 1) then - write(crch, '(i10)') n - errmsg = 'reach ' // trim(crch) // ' is already allocated' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - ! -- allocate pointers - allocate(this%reaches(n)%rough) - allocate(this%reaches(n)%rough%name) - allocate(this%reaches(n)%rough%value) - allocate(this%reaches(n)%rain) - allocate(this%reaches(n)%rain%name) - allocate(this%reaches(n)%rain%value) - allocate(this%reaches(n)%evap) - allocate(this%reaches(n)%evap%name) - allocate(this%reaches(n)%evap%value) - allocate(this%reaches(n)%inflow) - allocate(this%reaches(n)%inflow%name) - allocate(this%reaches(n)%inflow%value) - allocate(this%reaches(n)%runoff) - allocate(this%reaches(n)%runoff%name) - allocate(this%reaches(n)%runoff%value) - allocate(this%reaches(n)%sstage) - allocate(this%reaches(n)%sstage%name) - allocate(this%reaches(n)%sstage%value) - if (this%naux > 0) then - allocate(this%reaches(n)%auxvar(this%naux)) - do iaux = 1, this%naux - allocate(this%reaches(n)%auxvar(iaux)%name) - allocate(this%reaches(n)%auxvar(iaux)%value) - end do - end if - ! - ! -- initialize a few items - this%reaches(n)%rough%name = '' - this%reaches(n)%rain%name = '' - this%reaches(n)%evap%name = '' - this%reaches(n)%inflow%name = '' - this%reaches(n)%runoff%name = '' - this%reaches(n)%sstage%name = '' - this%reaches(n)%rough%value = DZERO - this%reaches(n)%rain%value = DZERO - this%reaches(n)%evap%value = DZERO - this%reaches(n)%inflow%value = DZERO - this%reaches(n)%runoff%value = DZERO - this%reaches(n)%sstage%value = DZERO - do iaux = 1, this%naux - this%reaches(n)%auxvar(iaux)%value = DZERO - end do - ! - ! -- return - return - end subroutine allocate_reach - - subroutine deallocate_reach(this, n) -! ****************************************************************************** -! deallocate_reach -- Deallocate pointers for reach(n). -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(SfrType) :: this - integer(I4B), intent(in) :: n - ! -- local - integer(I4B) :: iaux -! ------------------------------------------------------------------------------ - ! - ! -- connections - if (this%nconnreach(n) > 0) then - deallocate(this%reaches(n)%iconn) - deallocate(this%reaches(n)%idir) - deallocate(this%reaches(n)%idiv) - deallocate(this%reaches(n)%qconn) - endif - ! - ! -- deallocate pointers - deallocate(this%reaches(n)%rough%name) - deallocate(this%reaches(n)%rough%value) - deallocate(this%reaches(n)%rough) - deallocate(this%reaches(n)%rain%name) - deallocate(this%reaches(n)%rain%value) - deallocate(this%reaches(n)%rain) - deallocate(this%reaches(n)%evap%name) - deallocate(this%reaches(n)%evap%value) - deallocate(this%reaches(n)%evap) - deallocate(this%reaches(n)%inflow%name) - deallocate(this%reaches(n)%inflow%value) - deallocate(this%reaches(n)%inflow) - deallocate(this%reaches(n)%runoff%name) - deallocate(this%reaches(n)%runoff%value) - deallocate(this%reaches(n)%runoff) - deallocate(this%reaches(n)%sstage%name) - deallocate(this%reaches(n)%sstage%value) - deallocate(this%reaches(n)%sstage) - if (this%naux > 0) then - do iaux = 1, this%naux - deallocate(this%reaches(n)%auxvar(iaux)%name) - deallocate(this%reaches(n)%auxvar(iaux)%value) - end do - deallocate(this%reaches(n)%auxvar) - end if - ! - ! -- return - return - end subroutine deallocate_reach - - subroutine allocate_diversion(this, n, ndiv) -! ****************************************************************************** -! allocate_diversion -- Allocate diversion pointers for reach(n). -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(SfrType) :: this - integer(I4B), intent(in) :: n - integer(I4B), intent(in) :: ndiv - ! -- local - character(len=LINELENGTH) :: errmsg - character(len=10) :: crch - integer(I4B) :: j -! ------------------------------------------------------------------------------ - ! - ! -- make sure reach has not been allocated - if (associated(this%reaches(n)%diversion)) then - write(crch, '(i10)') n - errmsg = 'ERROR: reach ' // trim(adjustl(crch)) // & - ' diversions are already allocated' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - ! -- allocate pointers - allocate(this%reaches(n)%diversion(ndiv)) - do j = 1, ndiv - allocate(this%reaches(n)%diversion(j)%reach) - allocate(this%reaches(n)%diversion(j)%cprior) - allocate(this%reaches(n)%diversion(j)%iprior) - allocate(this%reaches(n)%diversion(j)%rate) - allocate(this%reaches(n)%diversion(j)%rate%name) - allocate(this%reaches(n)%diversion(j)%rate%value) - ! -- initialize a few variables - this%reaches(n)%diversion(j)%reach = 0 - this%reaches(n)%diversion(j)%cprior = '' - this%reaches(n)%diversion(j)%iprior = 0 - this%reaches(n)%diversion(j)%rate%name = '' - this%reaches(n)%diversion(j)%rate%value = DZERO - end do - ! - ! -- return - return - end subroutine allocate_diversion - - subroutine deallocate_diversion(this, n) -! ****************************************************************************** -! deallocate_diversion -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(SfrType) :: this - integer(I4B), intent(in) :: n - ! -- local - integer(I4B) :: j -! ------------------------------------------------------------------------------ - ! - ! -- make sure reach has not been allocated - ! -- allocate pointers - do j = 1, this%ndiv(n) - deallocate(this%reaches(n)%diversion(j)%reach) - deallocate(this%reaches(n)%diversion(j)%cprior) - deallocate(this%reaches(n)%diversion(j)%iprior) - deallocate(this%reaches(n)%diversion(j)%rate%name) - deallocate(this%reaches(n)%diversion(j)%rate%value) - deallocate(this%reaches(n)%diversion(j)%rate) - end do - deallocate(this%reaches(n)%diversion) - ! - ! -- return - return - end subroutine deallocate_diversion - - subroutine sfr_solve(this, n, h, hcof, rhs, update) - ! ****************************************************************************** - ! sfr_solve -- Solve continuity equation - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - class(SfrType) :: this - integer(I4B), intent(in) :: n - real(DP), intent(in) :: h - real(DP), intent(inout) :: hcof - real(DP), intent(inout) :: rhs - logical, intent(in), optional :: update - ! -- local - logical :: lupdate - integer(I4B) :: i, ii - integer(I4B) :: n2 - integer(I4B) :: isolve - integer(I4B) :: iic, iic2, iic3, iic4 - integer(I4B) :: ibflg - real(DP) :: hgwf - real(DP) :: qu, qi, qr, qe, qro, qmp, qsrc - real(DP) :: qfrommvr - real(DP) :: qgwf - real(DP) :: qmpsrc - real(DP) :: qc - real(DP) :: qt - real(DP) :: tp - real(DP) :: bt - real(DP) :: hsfr - real(DP) :: cstr - real(DP) :: qd - real(DP) :: en1, en2 - real(DP) :: qen1 - real(DP) :: f1, f2 - real(DP) :: qgwf1, qgwf2, qgwfp, qgwfold - real(DP) :: fhstr1, fhstr2 - real(DP) :: d1, d2, dpp, dx - real(DP) :: q1, q2 - real(DP) :: derv - real(DP) :: dlh, dlhold - real(DP) :: fp - real(DP) :: sat, sat1, sat2 - real(DP) :: err, errold - real(DP) :: sumleak, sumrch - ! ------------------------------------------------------------------------------ - ! - ! -- - if (present(update)) then - lupdate = update - else - lupdate = .true. - end if - ! - ! -- calculate hgwf - hgwf = h - ! - ! - hcof = DZERO - rhs = DZERO - ! - ! -- initialize q1, q2, and qgwf - q1 = DZERO - q2 = DZERO - qgwf = DZERO - qgwfold = DZERO - ! - ! -- calculate initial depth assuming a wide cross-section and ignore - ! groundwater leakage - ! -- calculate upstream flow - qu = DZERO - do i = 1, this%nconnreach(n) - if (this%reaches(n)%idir(i) < 0) cycle - n2 = this%reaches(n)%iconn(i) - do ii = 1, this%nconnreach(n2) - if (this%reaches(n2)%idir(ii) > 0) cycle - if (this%reaches(n2)%iconn(ii) /= n) cycle - qu = qu + this%reaches(n2)%qconn(ii) - end do - end do - this%usflow(n) = qu - ! -- calculate remaining terms - qi = this%reaches(n)%inflow%value - qr = this%reaches(n)%rain%value * this%width(n) * this%length(n) - qe = this%reaches(n)%evap%value * this%width(n) * this%length(n) - qro = this%reaches(n)%runoff%value - ! - ! -- Water mover term; assume that it goes in at the upstream end of the reach - qfrommvr = DZERO - if(this%imover == 1) then - qfrommvr = this%pakmvrobj%get_qfrommvr(n) - endif - ! - ! -- calculate sum of sources to the reach excluding groundwater leakage - qc = qu + qi + qr - qe + qro + qfrommvr - ! - ! -- adjust runoff or evaporation if sum of sources is negative - if (qc < DZERO) then - ! - ! -- calculate sources without et - qt = qu + qi + qr + qro + qfrommvr - ! - ! -- runoff exceeds sources of water for reach - if (qt < DZERO) then - qro = -(qu + qi + qr + qfrommvr) - qe = DZERO - ! - ! -- evaporation exceeds sources of water for reach - else - qe = qu + qi + qr + qro + qfrommvr - end if - qc = qu + qi + qr - qe + qro + qfrommvr - end if - ! - ! -- set simulated evaporation and runoff - this%simevap(n) = qe - this%simrunoff(n) = qro - ! - ! -- calculate flow at the middle of the reach and excluding groundwater leakage - qmp = qu + qi + qfrommvr + DHALF * (qr - qe + qro) - qmpsrc = qmp - ! - ! -- calculate stream depth at the midpoint - if (this%iboundpak(n) > 0) then - call this%sfr_rectch_depth(n, qmp, d1) - else - this%stage(n) = this%reaches(n)%sstage%value - d1 = max(DZERO, this%stage(n) - this%strtop(n)) - end if - ! - ! -- calculate sources/sinks for reach excluding groundwater leakage - call this%sfr_calc_qsource(n, d1, qsrc) - ! - ! -- calculate initial reach stage, downstream flow, and groundwater leakage - tp = this%strtop(n) - bt = tp - this%bthick(n) - hsfr = d1 + tp - qd = MAX(qsrc, DZERO) - qgwf = DZERO - ! - ! -- calculate reach conductance for a unit depth of water - ! if equal to zero will skip iterations - call this%sfr_calc_cond(n, cstr) - ! - ! -- set flag to skip iterations - isolve = 1 - if (hsfr <= tp .and. hgwf <= tp) isolve = 0 - if (hgwf <= tp .and. qc < DEM30) isolve = 0 - if (cstr < DEM30) isolve = 0 - if (this%iboundpak(n) < 0) isolve = 0 - ! - ! -- iterate to achieve solution - itersol: if (isolve /= 0) then - ! - ! -- estimate initial end points - en1 = DZERO - if (d1 > DEM30) then - if ((tp - hgwf) > DEM30) then - en2 = DP9 * d1 - else - en2 = D1P1 * d1 - (tp - hgwf) - end if - else if ((tp - hgwf) > DEM30) then - en2 = DONE - else - en2 = DP99 * (hgwf - tp) - end if - ! - ! -- estimate flow at end points - ! -- end point 1 - if (hgwf > tp) then - qgwf1 = cstr * (tp - hgwf) - qen1 = qmp - DHALF * qgwf1 - else - qgwf1 = DZERO - qen1 = qmpsrc - end if - if (hgwf > bt) then - qgwf2 = cstr * (tp + en2 - hgwf) - else - qgwf2 = cstr * (tp + en2 - bt) - end if - if (qgwf2 > qsrc) qgwf2 = qsrc - ! -- calculate two depths - call this%sfr_rectch_depth(n, (qmpsrc-DHALF*qgwf1), d1) - call this%sfr_rectch_depth(n, (qmpsrc-DHALF*qgwf2), d2) - ! -- determine roots - if (d1 > DEM30) then - f1 = en1 - d1 - else - en1 = DZERO - f1 = en1 - DZERO - end if - if (d2 > DEM30) then - f2 = en2 - d2 - if (f2 < DEM30) en2 = d2 - else - d2 = DZERO - f2 = en2 - DZERO - end if - ! - ! -- iterate to find a solution - dpp = DHALF * (en1 + en2) - dx = dpp - iic = 0 - iic2 = 0 - iic3 = 0 - fhstr1 = DZERO - fhstr2 = DZERO - qgwfp = DZERO - dlhold = DZERO - do i = 1, this%maxsfrit - ibflg = 0 - d1 = dpp - d2 = d1 + DTWO * this%deps - ! -- calculate q at midpoint at both end points - call this%sfr_calc_qman(n, d1, q1) - call this%sfr_calc_qman(n, d2, q2) - ! -- calculate groundwater leakage at both end points - call sChSmooth(d1, sat1, derv) - call sChSmooth(d2, sat2, derv) - if (hgwf > bt) then - qgwf1 = sat1 * cstr * (d1 + tp - hgwf) - qgwf2 = sat2 * cstr * (d2 + tp - hgwf) - else - qgwf1 = sat1 * cstr * (d1 + tp - bt) - qgwf2 = sat2 * cstr * (d2 + tp - bt) - end if - ! - if (qgwf1 >= qsrc) then - en2 = dpp - dpp = DHALF * (en1 + en2) - call sChSmooth(dpp, sat, derv) - if (hgwf > bt) then - qgwfp = sat * cstr * (dpp + tp - hgwf) - else - qgwfp = sat * cstr * (dpp + tp - bt) - end if - if (qgwfp > qsrc) qgwfp = qsrc - call this%sfr_rectch_depth(n, (qmpsrc-DHALF*qgwfp), dx) - ibflg = 1 - else - fhstr1 = (qmpsrc-DHALF*qgwf1) - q1 - fhstr2 = (qmpsrc-DHALF*qgwf2) - q2 - end if - ! - if (ibflg == 0) then - derv = DZERO - if (abs(d1-d2) > DZERO) then - derv = (fhstr1-fhstr2) / (d1 - d2) - end if - if (abs(derv) > DEM30) then - dlh = -fhstr1 / derv - else - dlh = DZERO - end if - dpp = d1 + dlh - ! - ! -- updated depth outside of endpoints - use bisection instead - if ((dpp >= en2) .or. (dpp <= en1)) then - if (abs(dlh) > abs(dlhold) .or. dpp < DEM30) then - ibflg = 1 - dpp = DHALF * (en1 + en2) - end if - end if - ! - ! -- check for slow convergence - ! -- set flags to determine if the Newton-Raphson method oscillates - ! or if convergence is slow - if (qgwf1*qgwfold < DEM30) then - iic2 = iic2 + 1 - else - iic2 = 0 - end if - if (qgwf1 < DEM30) then - iic3 = iic3 + 1 - else - iic3 = 0 - end if - if (dlh*dlhold < DEM30 .or. ABS(dlh) > ABS(dlhold)) then - iic = iic + 1 - end if - iic4 = 0 - if (iic3 > 7 .and. iic > 12) then - iic4 = 1 - end if - ! - ! -- switch to bisection when the Newton-Raphson method oscillates - ! or when convergence is slow - if (iic2 > 7 .or. iic > 12 .or. iic4 == 1) then - ibflg = 1 - dpp = DHALF * (en1 + en2) - end if - ! - ! -- - call sChSmooth(dpp, sat, derv) - if (hgwf > bt) then - qgwfp = sat * cstr * (dpp + tp - hgwf) - else - qgwfp = sat * cstr * (dpp + tp - bt) - end if - if (qgwfp > qsrc) then - qgwfp = qsrc - if (abs(en1-en2) < this%dmaxchg*DEM6) then - call this%sfr_rectch_depth(n, (qmpsrc-DHALF*qgwfp), dpp) - end if - end if - call this%sfr_rectch_depth(n, (qmpsrc-DHALF*qgwfp), dx) - end if - ! - ! -- - fp = dpp - dx - if (ibflg == 1) then - dlh = fp - ! -- change end points - ! -- root is between f1 and fp - if (f1*fp < DZERO) then - en2 = dpp - f2 = fp - ! -- root is between fp and f2 - else - en1 = dpp - f1 = fp - end if - err = min(abs(fp), abs(en2-en1)) - else - err = abs(dlh) - end if - if (err < this%dmaxchg) then - d1 = dpp - qgwf = qgwfp - qd = qsrc - qgwf - exit - end if - ! - ! -- save iterates - errold = err - dlhold = dlh - if (ibflg == 1) then - qgwfold = qgwfp - else - qgwfold = qgwf1 - end if - ! - ! -- end of iteration - end do - end if itersol - - ! -- simple routing option or where depth = 0 and hgwf < bt - if (isolve == 0) then - call sChSmooth(d1, sat, derv) - if (hgwf > bt) then - qgwf = sat * cstr * (d1 + tp - hgwf) - else - qgwf = sat * cstr * (d1 + tp - bt) - end if - ! -- leakage exceeds inflow - if (qgwf > qsrc) then - d1 = DZERO - call this%sfr_calc_qsource(n, d1, qsrc) - qgwf = qsrc - end if - ! -- set qd - qd = qsrc - qgwf - end if - - ! -- update sfr stage - hsfr = tp + d1 - - ! -- update stored values - if (lupdate) then - ! - ! -- save depth and calculate stage - this%depth(n) = d1 - this%stage(n) = hsfr - ! - call this%sfr_update_flows(n, qd, qgwf) - end if - ! - ! -- calculate sumleak and sumrch - sumleak = DZERO - sumrch = DZERO - if (this%gwfiss == 0) then - sumleak = qgwf - else - sumleak = qgwf - end if - if (hgwf < bt) then - sumrch = qgwf - end if - ! - ! -- calculate hcof and rhs for MODFLOW - call sChSmooth(d1, sat, derv) - if (abs(sumleak) > DZERO) then - ! -- stream leakage is not head dependent - if (hgwf < bt) then - rhs = rhs - sumrch - ! -- stream leakage is head dependent - else if ((sumleak-qsrc) < -DEM30) then - if (this%gwfiss == 0) then - rhs = rhs - sat * cstr * hsfr - sumrch - else - rhs = rhs - sat * cstr * hsfr - end if - hcof = -cstr - ! -- place holder for UZF - else - if (this%gwfiss == 0) then - rhs = rhs - sumleak - sumrch - else - rhs = rhs - sumleak - end if - end if - ! -- add groundwater leakage - else if (hgwf < bt) then - rhs = rhs - sumrch - end if - ! - ! -- return - return - end subroutine sfr_solve - - subroutine sfr_update_flows(this, n, qd, qgwf) - ! ****************************************************************************** - ! sfr_update_flows -- Update downstream and groundwater leakage terms for reach - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - class(SfrType), intent(inout) :: this - integer(I4B), intent(in) :: n - real(DP), intent(inout) :: qd - real(DP), intent(in) :: qgwf - ! -- local - integer(I4B) :: i - integer(I4B) :: n2 - real(DP) :: q2 - real(DP) :: f - ! ------------------------------------------------------------------------------ - ! - ! -- update reach terms - ! - ! -- save final downstream stream flow - this%dsflow(n) = qd - ! - ! -- save groundwater leakage - this%gwflow(n) = qgwf - ! - ! -- route downstream flow - if (qd > DZERO) then - ! - ! -- route water to diversions - do i = 1, this%nconnreach(n) - if (this%reaches(n)%idir(i) > 0) cycle - if (this%reaches(n)%idiv(i) == 0) cycle - call this%sfr_calc_div(n, this%reaches(n)%idiv(i), qd, q2) - this%reaches(n)%qconn(i) = q2 - end do - ! - ! -- Mover terms: store outflow after diversion loss - ! as qformvr and reduce outflow (qd) - ! by how much was actually sent to the mover - if (this%imover == 1) then - call this%pakmvrobj%accumulate_qformvr(n, qd) - qd = MAX(qd - this%pakmvrobj%get_qtomvr(n), DZERO) - endif - ! - ! -- route remaining water to downstream reaches - do i = 1, this%nconnreach(n) - if (this%reaches(n)%idir(i) > 0) cycle - if (this%reaches(n)%idiv(i) > 0) cycle - n2 = this%reaches(n)%iconn(i) - f = this%ustrf(n2) / this%ftotnd(n) - this%reaches(n)%qconn(i) = qd * f - end do - else - do i = 1, this%nconnreach(n) - if (this%reaches(n)%idir(i) > 0) cycle - this%reaches(n)%qconn(i) = DZERO - end do - end if - ! - ! -- return - return - end subroutine sfr_update_flows - - subroutine sfr_calc_qd(this, n, depth, hgwf, qgwf, qd) - ! ****************************************************************************** - ! sfr_calc_dq -- Calculate downstream flow for reach - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - class(SfrType) :: this - integer(I4B), intent(in) :: n - real(DP), intent(in) :: depth - real(DP), intent(in) :: hgwf - real(DP), intent(inout) :: qgwf - real(DP), intent(inout) :: qd - ! -- local - real(DP) :: qsrc - ! ------------------------------------------------------------------------------ - ! - ! -- initialize residual - qd = DZERO - ! - ! -- calculate total water sources excluding groundwater leakage - call this%sfr_calc_qsource(n, depth, qsrc) - ! - ! -- estimate groundwater leakage - call this%sfr_calc_qgwf(n, depth, hgwf, qgwf) - if (-qgwf > qsrc) qgwf = -qsrc - ! - ! -- calculate down stream flow - qd = qsrc + qgwf - ! - ! -- limit downstream flow to a positive value - if (qd < DEM30) qd = DZERO - ! - ! -- return - return - end subroutine sfr_calc_qd - - subroutine sfr_calc_qsource(this, n, depth, qsrc) - ! ****************************************************************************** - ! sfr_calc_qsource -- Calculate sum of sources for reach - excluding - ! reach leakage - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - class(SfrType) :: this - integer(I4B), intent(in) :: n - real(DP), intent(in) :: depth - real(DP), intent(inout) :: qsrc - ! -- local - real(DP) :: qu, qi, qr, qe, qro, qfrommvr - real(DP) :: qt - real(DP) :: a, ae - ! ------------------------------------------------------------------------------ - ! - ! -- initialize residual - qsrc = DZERO - ! - ! -- calculate flow terms - qu = this%usflow(n) - qi = this%reaches(n)%inflow%value - qro = this%reaches(n)%runoff%value - ! - ! -- calculate rainfall and evap - a = this%surface_area(n) - ae = this%surface_area_wet(n, depth) - qr = this%reaches(n)%rain%value * a - !qe = this%reaches(n)%evap%value * ae - qe = this%reaches(n)%evap%value * a - ! - ! -- calculate mover term - qfrommvr = DZERO - if (this%imover == 1) then - qfrommvr = this%pakmvrobj%get_qfrommvr(n) - endif - ! - ! -- calculate down stream flow - qsrc = qu + qi + qr - qe + qro + qfrommvr - ! - ! -- adjust runoff or evaporation if sum of sources is negative - if (qsrc < DZERO) then - ! - ! -- calculate sources without et - qt = qu + qi + qr + qro + qfrommvr - ! - ! -- runoff exceeds sources of water for reach - if (qt < DZERO) then - qro = -(qu + qi + qr + qfrommvr) - qe = DZERO - ! - ! -- evaporation exceeds sources of water for reach - else - qe = qu + qi + qr + qro + qfrommvr - end if - qsrc = qu + qi + qr - qe + qro + qfrommvr - end if - ! - ! -- return - return - end subroutine sfr_calc_qsource - - - subroutine sfr_calc_qman(this, n, depth, qman) - ! ****************************************************************************** - ! sfr_calc_qman -- Calculate stream flow using Manning's equation - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - class(SfrType) :: this - integer(I4B), intent(in) :: n - real(DP), intent(in) :: depth - real(DP), intent(inout) :: qman - ! -- local - real(DP) :: sat - real(DP) :: derv - real(DP) :: s, r, aw, wp, rh - ! ------------------------------------------------------------------------------ - ! - ! -- initialize qman - qman = DZERO - ! - ! -- calculate terms for Manning's equation - call sChSmooth(depth, sat, derv) - s = this%slope(n) - r = this%reaches(n)%rough%value - aw = this%area_wet(n, depth) - wp = this%perimeter_wet(n) - rh = DZERO - if (wp > DZERO) then - rh = aw / wp - end if - ! - ! -- calculate flow - qman = sat * this%unitconv * aw * (rh**DTWOTHIRDS) * sqrt(s) / r - ! - ! -- return - return - end subroutine sfr_calc_qman - - - subroutine sfr_calc_qgwf(this, n, depth, hgwf, qgwf) - ! ****************************************************************************** - ! sfr_calc_qgwf -- Calculate sfr-aquifer exchange (relative to sfr reach) - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - class(SfrType) :: this - integer(I4B), intent(in) :: n - real(DP), intent(in) :: depth - real(DP), intent(in) :: hgwf - real(DP), intent(inout) :: qgwf - ! -- local - integer(I4B) :: node - real(DP) :: tp - real(DP) :: bt - real(DP) :: hsfr - real(DP) :: htmp - real(DP) :: cond - real(DP) :: sat - real(DP) :: derv - ! ------------------------------------------------------------------------------ - ! - ! -- initialize qgwf - qgwf = DZERO - ! - ! -- skip sfr-aquifer exchange in external cells - node = this%igwfnode(n) - if (node < 1) return - ! - ! -- skip sfr-aquifer exchange in inactive cells - if (this%ibound(node) == 0) return - ! - ! -- calculate saturation - call sChSmooth(depth, sat, derv) - ! - ! -- calculate conductance - call this%sfr_calc_cond(n, cond) - ! - ! -- calculate groundwater leakage - tp = this%strtop(n) - bt = tp - this%bthick(n) - hsfr = tp + depth - htmp = hgwf - if (htmp < bt) then - htmp = bt - end if - qgwf = sat * cond * (htmp - hsfr) - ! - ! -- return - return - end subroutine sfr_calc_qgwf - - subroutine sfr_calc_cond(this, n, cond) - ! ****************************************************************************** - ! sfr_calc_qgwf -- Calculate sfr-aquifer exchange - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - class(SfrType) :: this - integer(I4B), intent(in) :: n - real(DP), intent(inout) :: cond - ! -- local - integer(I4B) :: node - real(DP) :: wp - ! ------------------------------------------------------------------------------ - ! - ! -- initialize a few variables - cond = DZERO - node = this%igwfnode(n) - if (node > 0) then - if (this%ibound(node) > 0) then - wp = this%perimeter_wet(n) - cond = this%hk(n) * this%length(n) * wp / this%bthick(n) - end if - end if - ! - ! -- return - return - end subroutine sfr_calc_cond - - - subroutine sfr_calc_div(this, n, i, q, qd) - ! ****************************************************************************** - ! sfr_calc_resid -- Calculate residual for reach - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - class(SfrType) :: this - integer(I4B), intent(in) :: n - integer(I4B), intent(in) :: i - real(DP), intent(inout) :: q - real(DP), intent(inout) :: qd - ! -- local - character (len=10) :: cp - integer(I4B) :: n2 - !integer(I4B) :: ip - real(DP) :: v - ! ------------------------------------------------------------------------------ - ! - ! -- set local variables - n2 = this%reaches(n)%diversion(i)%reach - cp = this%reaches(n)%diversion(i)%cprior - !ip = this%reaches(n)%diversion(i)%iprior - v = this%reaches(n)%diversion(i)%rate%value - ! - ! -- calculate diversion - select case(cp) - ! -- flood diversion - !case (-3) - case ('EXCESS') - if (q < v) then - v = DZERO - else - v = q - v - end if - ! -- diversion percentage - !case (-2) - case ('FRACTION') - v = q * v - ! -- STR priority algorithm - !case (-1) - case ('THRESHOLD') - if (q < v) then - v = DZERO - end if - ! -- specified diversion - !case (0) - case ('UPTO') - if (v > q) then - v = q - end if - case default - v = DZERO - end select - ! - ! -- update upstream from for downstream reaches - q = q - v - qd = v - ! - ! -- return - return - end subroutine sfr_calc_div - - subroutine sfr_rectch_depth(this, n, q1, d1) - class(SfrType) :: this - integer(I4B), intent(in) :: n - real(DP), intent(in) :: q1 - real(DP), intent(inout) :: d1 - ! -- local - real(DP) :: w - real(DP) :: s - real(DP) :: r - real(DP) :: qconst - ! -- code - ! -- calculate stream depth at the midpoint - w = this%width(n) - s = this%slope(n) - r = this%reaches(n)%rough%value - qconst = this%unitconv * w * sqrt(s) / r - d1 = (q1 / qconst)**DP6 - if (d1 < DEM30) d1 = DZERO - ! -- return - return - end subroutine sfr_rectch_depth - - - subroutine sfr_check_reaches(this) - class(SfrType) :: this - ! -- local - character (len= 5) :: crch - character (len=10) :: cval - character (len=30) :: nodestr - character (len=LINELENGTH) :: title - character (len=LINELENGTH) :: text - character (len=LINELENGTH) :: errmsg - integer(I4B) :: n, nn - real(DP) :: btgwf, bt - ! -- code - ! - ! -- setup inputtab tableobj - if (this%iprpak /= 0) then - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%name)) //') STATIC REACH DATA' - call table_cr(this%inputtab, this%name, title) - call this%inputtab%table_df(this%maxbound, 10, this%iout) - text = 'NUMBER' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'CELLID' - call this%inputtab%initialize_column(text, 20, alignment=TABLEFT) - text = 'LENGTH' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'WIDTH' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'SLOPE' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'TOP' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'THICKNESS' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'HK' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'ROUGHNESS' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'UPSTREAM FRACTION' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - end if - ! - ! -- check the reach data for simple errors - do n = 1, this%maxbound - write(crch, '(i5)') n - nn = this%igwfnode(n) - if (nn > 0) then - btgwf = this%dis%bot(nn) - call this%dis%noder_to_string(nn, nodestr) - else - nodestr = 'none' - end if - ! -- check reach length - if (this%length(n) <= DZERO) then - errmsg = 'ERROR: Reach ' // crch // ' length must be > 0.0' - call store_error(errmsg) - end if - ! -- check reach width - if (this%width(n) <= DZERO) then - errmsg = 'ERROR: Reach ' // crch // ' width must be > 0.0' - call store_error(errmsg) - end if - ! -- check reach slope - if (this%slope(n) <= DZERO) then - errmsg = 'ERROR: Reach ' // crch // ' slope must be > 0.0' - call store_error(errmsg) - end if - ! -- check bed thickness and bed hk for reaches connected to GWF - if (nn > 0) then - bt = this%strtop(n) - this%bthick(n) - if (bt <= btgwf .and. this%icheck /= 0) then - write(cval,'(f10.4)') bt - errmsg = 'ERROR: Reach ' // crch // ' bed bottom (rtp-rbth =' // & - cval // ') must be > the bottom of cell (' // nodestr - write(cval,'(f10.4)') btgwf - errmsg = trim(adjustl(errmsg)) // '=' // cval // ').' - call store_error(errmsg) - end if - if (this%hk(n) < DZERO) then - errmsg = 'ERROR: Reach ' // crch // ' hk must be >= 0.0' - call store_error(errmsg) - end if - end if - ! -- check reach roughness - if (this%reaches(n)%rough%value <= DZERO) then - errmsg = 'ERROR: Reach ' // crch // " Manning's roughness " // & - 'coefficient must be > 0.0' - call store_error(errmsg) - end if - ! -- check reach upstream fraction - if (this%ustrf(n) < DZERO) then - errmsg = 'ERROR: Reach ' // crch // " upstream fraction must be >= 0.0" - call store_error(errmsg) - end if - ! -- write summary of reach information - if (this%iprpak /= 0) then - call this%inputtab%add_term(n) - call this%inputtab%add_term(nodestr) - call this%inputtab%add_term(this%length(n)) - call this%inputtab%add_term(this%width(n)) - call this%inputtab%add_term(this%slope(n)) - call this%inputtab%add_term(this%strtop(n)) - call this%inputtab%add_term(this%bthick(n)) - call this%inputtab%add_term(this%hk(n)) - call this%inputtab%add_term(this%reaches(n)%rough%value) - call this%inputtab%add_term(this%ustrf(n)) - end if - end do - - ! -- return - return - end subroutine sfr_check_reaches - - - subroutine sfr_check_connections(this) - class(SfrType) :: this - ! -- local - character (len= 5) :: crch - character (len= 5) :: crch2 - character (len=LINELENGTH) :: text - character (len=LINELENGTH) :: title - character (len=LINELENGTH) :: errmsg - integer(I4B) :: n, nn, nc - integer(I4B) :: i, ii - integer(I4B) :: ifound - integer(I4B) :: ierr - integer(I4B) :: maxconn - integer(I4B) :: ntabcol - ! -- code - ! - ! -- create input table for reach connections data - if (this%iprpak /= 0) then - ! - ! -- calculate the maximum number of connections - maxconn = 0 - do n = 1, this%maxbound - maxconn = max(maxconn, this%nconnreach(n)) - end do - ntabcol = 1 + maxconn - ! - ! -- reset the input table object - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%name)) //') STATIC REACH CONNECTION DATA' - call table_cr(this%inputtab, this%name, title) - call this%inputtab%table_df(this%maxbound, ntabcol, this%iout) - text = 'REACH' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - do n = 1, maxconn - write(text, '(a,1x,i6)') 'CONN', n - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - end do - end if - ! - ! -- check the reach connections for simple errors - ! -- connection check - do n = 1, this%maxbound - write(crch, '(i5)') n - eachconn: do i = 1, this%nconnreach(n) - nn = this%reaches(n)%iconn(i) - write(crch2, '(i5)') nn - ifound = 0 - connreach: do ii = 1, this%nconnreach(nn) - nc = this%reaches(nn)%iconn(ii) - if (nc == n) then - ifound = 1 - exit connreach - end if - end do connreach - if (ifound /= 1) then - errmsg = 'ERROR: Reach ' // crch // ' is connected to ' // & - 'reach ' // crch2 // ' but reach ' // crch2 // & - ' is not connected to reach ' // crch // '.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - end do eachconn - ! - ! -- write connection data to the table - if (this%iprpak /= 0) then - call this%inputtab%add_term(n) - do i = 1, this%nconnreach(n) - call this%inputtab%add_term(this%reaches(n)%iconn(i)) - end do - nn = maxconn - this%nconnreach(n) - do i = 1, nn - call this%inputtab%add_term(' ') - end do - end if - end do - ! - ! -- check for incorrect connections between upstream connections - ! - ! -- check upstream connections for each reach - ierr = 0 - do n = 1, this%maxbound - write(crch, '(i5)') n - eachconnv: do i = 1, this%nconnreach(n) - ! - ! -- skip downstream connections - if (this%reaches(n)%idir(i) < 0) cycle eachconnv - nn = this%reaches(n)%iconn(i) - write(crch2, '(i5)') nn - connreachv: do ii = 1, this%nconnreach(nn) - ! -- skip downstream connections - if (this%reaches(nn)%idir(ii) < 0) cycle connreachv - nc = this%reaches(nn)%iconn(ii) - ! - ! -- if n == n then that means reach n is an upstream connection for - ! reach nn and reach nn is an upstream connection for reach n - if (nc == n) then - ierr = ierr + 1 - errmsg = 'ERROR: Reach ' // crch // ' is connected to ' // & - 'reach ' // crch2 // ' but streamflow from reach ' // & - crch // ' to reach ' // crch2 // ' is not permitted.' - call store_error(errmsg) - exit connreachv - end if - end do connreachv - end do eachconnv - end do - if (ierr > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- check that downstream reaches for a reach are - ! the upstream reaches for the reach - do n = 1, this%maxbound - write(crch, '(i5)') n - eachconnds: do i = 1, this%nconnreach(n) - nn = this%reaches(n)%iconn(i) - if (this%reaches(n)%idir(i) > 0) cycle eachconnds - write(crch2, '(i5)') nn - ifound = 0 - connreachds: do ii = 1, this%nconnreach(nn) - nc = this%reaches(nn)%iconn(ii) - if (nc == n) then - if (this%reaches(n)%idir(i) /= this%reaches(nn)%idir(ii)) then - ifound = 1 - end if - exit connreachds - end if - end do connreachds - if (ifound /= 1) then - errmsg = 'ERROR: Reach ' // crch // ' downstream connected reach ' // & - 'is reach ' // crch2 // ' but reach ' // crch // ' is not' // & - ' the upstream connected reach for reach ' // crch2 // '.' - call store_error(errmsg) - end if - end do eachconnds - end do - ! - ! -- create input table for upstream and downstream connections - if (this%iprpak /= 0) then - ! - ! -- calculate the maximum number of upstream connections - maxconn = 0 - do n = 1, this%maxbound - ii = 0 - do i = 1, this%nconnreach(n) - if (this%reaches(n)%idir(i) > 0) then - ii = ii + 1 - end if - end do - maxconn = max(maxconn, ii) - end do - ntabcol = 1 + maxconn - ! - ! -- reset the input table object - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%name)) //') STATIC UPSTREAM REACH ' // & - 'CONNECTION DATA' - call table_cr(this%inputtab, this%name, title) - call this%inputtab%table_df(this%maxbound, ntabcol, this%iout) - text = 'REACH' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - do n = 1, maxconn - write(text, '(a,1x,i6)') 'UPSTREAM CONN', n - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - end do - ! - ! -- upstream connection data - do n = 1, this%maxbound - call this%inputtab%add_term(n) - ii = 0 - do i = 1, this%nconnreach(n) - if (this%reaches(n)%idir(i) > 0) then - call this%inputtab%add_term(this%reaches(n)%iconn(i)) - ii = ii + 1 - end if - end do - nn = maxconn - ii - do i = 1, nn - call this%inputtab%add_term(' ') - end do - end do - ! - ! -- calculate the maximum number of downstream connections - maxconn = 0 - do n = 1, this%maxbound - ii = 0 - do i = 1, this%nconnreach(n) - if (this%reaches(n)%idir(i) < 0) then - ii = ii + 1 - end if - end do - maxconn = max(maxconn, ii) - end do - ntabcol = 1 + maxconn - ! - ! -- reset the input table object - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%name)) //') STATIC DOWNSTREAM ' // & - 'REACH CONNECTION DATA' - call table_cr(this%inputtab, this%name, title) - call this%inputtab%table_df(this%maxbound, ntabcol, this%iout) - text = 'REACH' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - do n = 1, maxconn - write(text, '(a,1x,i6)') 'DOWNSTREAM CONN', n - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - end do - ! - ! -- downstream connection data - do n = 1, this%maxbound - call this%inputtab%add_term(n) - ii = 0 - do i = 1, this%nconnreach(n) - if (this%reaches(n)%idir(i) < 0) then - call this%inputtab%add_term(this%reaches(n)%iconn(i)) - ii = ii + 1 - end if - end do - nn = maxconn - ii - do i = 1, nn - call this%inputtab%add_term(' ') - end do - end do - end if - ! - ! -- return - return - end subroutine sfr_check_connections - - - subroutine sfr_check_diversions(this) - class(SfrType) :: this - ! -- local - character (len=LINELENGTH) :: title - character (len=LINELENGTH) :: text - character (len= 5) :: crch - character (len= 5) :: cdiv - character (len= 5) :: crch2 - character (len=10) :: cprior - character (len=LINELENGTH) :: errmsg - integer(I4B) :: maxdiv - integer(I4B) :: n, nn, nc - integer(I4B) :: ii - integer(I4B) :: idiv - integer(I4B) :: ifound - ! -- format -10 format('Diversion ',i0,' of reach ',i0, & - ' is invalid or has not been defined.') - ! -- code - ! - ! -- write header - if (this%iprpak /= 0) then - ! - ! -- determine the maximum number of diversions - maxdiv = 0 - do n = 1, this%maxbound - maxdiv = maxdiv + this%ndiv(n) - end do - ! - ! -- reset the input table object - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%name)) //') REACH DIVERSION DATA' - call table_cr(this%inputtab, this%name, title) - call this%inputtab%table_df(maxdiv, 4, this%iout) - text = 'REACH' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'DIVERSION' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'REACH 2' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'CPRIOR' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - end if - ! - ! -- check that diversion data are correct - do n = 1, this%maxbound - if (this%ndiv(n) < 1) cycle - write(crch, '(i5)') n - !line = ' ' // crch - - do idiv = 1, this%ndiv(n) - write(cdiv, '(i5)') idiv - ! - ! - nn = this%reaches(n)%diversion(idiv)%reach - write(crch2, '(i5)') nn - ! - ! -- make sure diversion reach is connected to current reach - ifound = 0 - if (nn < 1 .or. nn > this%maxbound) then - write(errmsg,10)idiv, n - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - connreach: do ii = 1, this%nconnreach(nn) - nc = this%reaches(nn)%iconn(ii) - if (nc == n) then - if (this%reaches(nn)%idir(ii) > 0) then - ifound = 1 - end if - exit connreach - end if - end do connreach - if (ifound /= 1) then - errmsg = 'ERROR: Reach ' // crch // ' is not a upstream reach for ' // & - 'reach ' // crch2 // ' as a result diversion ' // cdiv // & - ' from reach ' // crch //' to reach ' // crch2 // & - ' is not possible. Check reach connectivity.' - call store_error(errmsg) - end if - ! -- iprior - cprior = this%reaches(n)%diversion(idiv)%cprior - ! - ! -- add terms to the table - if (this%iprpak /= 0) then - call this%inputtab%add_term(n) - call this%inputtab%add_term(idiv) - call this%inputtab%add_term(nn) - call this%inputtab%add_term(this%reaches(n)%diversion(idiv)%cprior) - end if - end do - end do - ! - ! -- return - return - end subroutine sfr_check_diversions - - - subroutine sfr_check_ustrf(this) - class(SfrType) :: this - ! -- local - character (len=LINELENGTH) :: title - character (len=LINELENGTH) :: text - logical :: lcycle - logical :: ladd - character (len=5) :: crch, crch2 - character (len=10) :: cval - character (len=LINELENGTH) :: errmsg - integer(I4B) :: maxcols - integer(I4B) :: npairs - integer(I4B) :: ipair - integer(I4B) :: i, n - integer(I4B) :: n2 - integer(I4B) :: idiv - integer(I4B) :: ids - real(DP) :: f - real(DP) :: rval - ! -- code - ! - ! -- write table header - if (this%iprpak /= 0) then - ! - ! -- determine the maximum number of columns - npairs = 0 - do n = 1, this%maxbound - ipair = 0 - ec: do i = 1, this%nconnreach(n) - ! - ! -- skip upstream connections - if (this%reaches(n)%idir(i) > 0) cycle ec - n2 = this%reaches(n)%iconn(i) - ! - ! -- skip inactive downstream reaches - if (this%iboundpak(n2) == 0) cycle ec - ! - ! -- increment ipair and see if it exceeds npairs - ipair = ipair + 1 - npairs = max(npairs, ipair) - end do ec - end do - maxcols = 1 + npairs * 2 - ! - ! -- reset the input table object - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%name)) //') CONNECTED REACH UPSTREAM ' // & - 'FRACTION DATA' - call table_cr(this%inputtab, this%name, title) - call this%inputtab%table_df(this%maxbound, maxcols, this%iout) - text = 'REACH' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - do i = 1, npairs - write(cval, '(i10)') i - text = 'DOWNSTREAM REACH ' // trim(adjustl(cval)) - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'FRACTION ' // trim(adjustl(cval)) - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - end do - end if - ! - ! -- calculate the total fraction of connected reaches that are - ! not diversions and check that the sum of upstream fractions - ! is equal to 1 for each reach - do n = 1, this%maxbound - ids = 0 - rval = DZERO - f = DZERO - write(crch, '(i5)') n - if (this%iprpak /= 0) then - call this%inputtab%add_term(n) - end if - ipair = 0 - eachconn: do i = 1, this%nconnreach(n) - lcycle = .FALSE. - ! - ! -- initialize downstream connection q - this%reaches(n)%qconn(i) = DZERO - ! - ! -- skip upstream connections - if (this%reaches(n)%idir(i) > 0) then - lcycle = .TRUE. - end if - n2 = this%reaches(n)%iconn(i) - ! - ! -- skip inactive downstream reaches - if (this%iboundpak(n2) == 0) then - lcycle = .TRUE. - end if - if (lcycle) then - cycle eachconn - end if - ipair = ipair + 1 - write(crch2, '(i5)') n2 - ids = ids + 1 - ladd = .true. - f = f + this%ustrf(n2) - write(cval, '(f10.4)') this%ustrf(n2) - ! - ! -- write upstream fractions - if (this%iprpak /= 0) then - call this%inputtab%add_term(n2) - call this%inputtab%add_term(this%ustrf(n2)) - end if - eachdiv: do idiv = 1, this%ndiv(n) - if (this%reaches(n)%diversion(idiv)%reach == n2) then - this%reaches(n)%idiv(i) = idiv - ladd = .false. - exit eachconn - end if - end do eachdiv - if (ladd) then - rval = rval + this%ustrf(n2) - end if - end do eachconn - this%ftotnd(n) = rval - ! - ! -- write remaining table columns - if (this%iprpak /= 0) then - ipair = ipair + 1 - do i = ipair, npairs - call this%inputtab%add_term(' ') - call this%inputtab%add_term(' ') - end do - end if - ! - ! -- evaluate if an error condition has occured - ! the sum of fractions is not equal to 1 - if (ids /= 0) then - if (abs(f-DONE) > DEM6) then - write(cval, '(f10.4)') f - errmsg = 'ERROR: upstream fractions for reach ' // crch // ' not ' // & - 'equal to one (' // cval // '). Check reach connectivity.' - call store_error(errmsg) - end if - end if - end do - ! - ! -- return - return - end subroutine sfr_check_ustrf - - subroutine sfr_setup_budobj(this) -! ****************************************************************************** -! sfr_setup_budobj -- Set up the budget object that stores all the sfr flows -! The terms listed here must correspond in number and order to the ones -! listed in the sfr_fill_budobj routine. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LENBUDTXT - ! -- dummy - class(SfrType) :: this - ! -- local - integer(I4B) :: nbudterm - integer(I4B) :: i, n, n1, n2 - integer(I4B) :: maxlist, naux - integer(I4B) :: idx - real(DP) :: q - character(len=LENBUDTXT) :: text - character(len=LENBUDTXT), dimension(1) :: auxtxt -! ------------------------------------------------------------------------------ - ! - ! -- Determine the number of sfr budget terms. These are fixed for - ! the simulation and cannot change. This includes FLOW-JA-FACE - ! so they can be written to the binary budget files, but these internal - ! flows are not included as part of the budget table. - nbudterm = 8 - if (this%imover == 1) nbudterm = nbudterm + 2 - if (this%naux > 0) nbudterm = nbudterm + 1 - ! - ! -- set up budobj - call budgetobject_cr(this%budobj, this%name) - call this%budobj%budgetobject_df(this%maxbound, nbudterm, 0, 0) - idx = 0 - ! - ! -- Go through and set up each budget term - text = ' FLOW-JA-FACE' - idx = idx + 1 - maxlist = this%nconn - naux = 1 - auxtxt(1) = ' FLOW-AREA' - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux, auxtxt) - ! - ! -- store connectivity - call this%budobj%budterm(idx)%reset(this%nconn) - q = DZERO - do n = 1, this%maxbound - n1 = n - do i = 1, this%nconnreach(n) - n2 = this%reaches(n)%iconn(i) - call this%budobj%budterm(idx)%update_term(n1, n2, q) - end do - end do - ! - ! -- - text = ' GWF' - idx = idx + 1 - maxlist = this%maxbound - naux = 1 - auxtxt(1) = ' FLOW-AREA' - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name_model, & - maxlist, .false., .true., & - naux, auxtxt) - call this%budobj%budterm(idx)%reset(this%maxbound) - q = DZERO - do n = 1, this%maxbound - n2 = this%igwfnode(n) - call this%budobj%budterm(idx)%update_term(n, n2, q) - end do - ! - ! -- - text = ' RAINFALL' - idx = idx + 1 - maxlist = this%maxbound - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- - text = ' EVAPORATION' - idx = idx + 1 - maxlist = this%maxbound - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- - text = ' RUNOFF' - idx = idx + 1 - maxlist = this%maxbound - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- - text = ' EXT-INFLOW' - idx = idx + 1 - maxlist = this%maxbound - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- - text = ' EXT-OUTFLOW' - idx = idx + 1 - maxlist = this%maxbound - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- - text = ' STORAGE' - idx = idx + 1 - maxlist = this%maxbound - naux = 1 - auxtxt(1) = ' VOLUME' - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux, auxtxt) - ! - ! -- - if (this%imover == 1) then - ! - ! -- - text = ' FROM-MVR' - idx = idx + 1 - maxlist = this%maxbound - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- - text = ' TO-MVR' - idx = idx + 1 - maxlist = this%maxbound - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - end if - ! - ! -- - naux = this%naux - if (naux > 0) then - ! - ! -- - text = ' AUXILIARY' - idx = idx + 1 - maxlist = this%maxbound - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux, this%auxname) - end if - ! - ! -- if sfr flow for each reach are written to the listing file - if (this%iprflow /= 0) then - call this%budobj%flowtable_df(this%iout, cellids='GWF') - end if - ! - ! -- return - return - end subroutine sfr_setup_budobj - - subroutine sfr_fill_budobj(this) -! ****************************************************************************** -! sfr_fill_budobj -- copy flow terms into this%budobj -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(SfrType) :: this - ! -- local - integer(I4B) :: naux - integer(I4B) :: i, n, n1, n2 - integer(I4B) :: ii - integer(I4B) :: idx - real(DP) :: q - real(DP) :: qt - real(DP) :: d - real(DP) :: a - ! -- formats -! ----------------------------------------------------------------------------- - ! - ! -- initialize counter - idx = 0 - - - ! -- FLOW JA FACE - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nconn) - do n = 1, this%maxbound - n1 = n - do i = 1, this%nconnreach(n) - n2 = this%reaches(n)%iconn(i) - ! flow to downstream reaches - if (this%reaches(n)%idir(i) < 0) then - qt = this%dsflow(n) - q = -this%reaches(n)%qconn(i) - ! flow from upstream reaches - else - qt = this%usflow(n) - do ii = 1, this%nconnreach(n2) - if (this%reaches(n2)%idir(ii) > 0) cycle - if (this%reaches(n2)%iconn(ii) /= n) cycle - q = this%reaches(n2)%qconn(ii) - exit - end do - end if - ! calculate flow area - call this%sfr_rectch_depth(n, qt, d) - this%qauxcbc(1) = d * this%width(n) - call this%budobj%budterm(idx)%update_term(n1, n2, q, this%qauxcbc) - end do - end do - - - ! -- GWF (LEAKAGE) - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%maxbound) - do n = 1, this%maxbound - this%qauxcbc(1) = this%width(n) * this%length(n) - n2 = this%igwfnode(n) - q = -this%gwflow(n) - call this%budobj%budterm(idx)%update_term(n, n2, q, this%qauxcbc) - end do - - - ! -- RAIN - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%maxbound) - do n = 1, this%maxbound - a = this%surface_area(n) - q = this%reaches(n)%rain%value * a - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - - - ! -- EVAPORATION - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%maxbound) - do n = 1, this%maxbound - q = -this%simevap(n) - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - - - ! -- RUNOFF - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%maxbound) - do n = 1, this%maxbound - q = this%simrunoff(n) - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - - - ! -- INFLOW - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%maxbound) - do n = 1, this%maxbound - q = this%reaches(n)%inflow%value - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - - - ! -- EXTERNAL OUTFLOW - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%maxbound) - do n = 1, this%maxbound - q = this%dsflow(n) - if (q > DZERO) q = -q - do i = 1, this%nconnreach(n) - if (this%reaches(n)%idir(i) > 0) cycle - q = DZERO - exit - end do - if (this%imover == 1) then - q = q + this%pakmvrobj%get_qtomvr(n) - end if - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - - ! -- STORAGE - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%maxbound) - do n = 1, this%maxbound - q = DZERO - d = this%depth(n) - a = this%width(n) * this%length(n) - this%qauxcbc(1) = a * d - call this%budobj%budterm(idx)%update_term(n, n, q, this%qauxcbc) - end do - - ! -- MOVER - if (this%imover == 1) then - - ! -- FROM MOVER - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%maxbound) - do n = 1, this%maxbound - q = this%pakmvrobj%get_qfrommvr(n) - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - - - ! -- TO MOVER - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%maxbound) - do n = 1, this%maxbound - q = this%pakmvrobj%get_qtomvr(n) - if (q > DZERO) then - q = -q - end if - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - - end if - - - ! -- AUXILIARY VARIABLES - naux = this%naux - if (naux > 0) then - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%maxbound) - do n = 1, this%maxbound - q = DZERO - call this%budobj%budterm(idx)%update_term(n, n, q, this%auxvar(:, n)) - end do - end if - ! - ! --Terms are filled, now accumulate them for this time step - call this%budobj%accumulate_terms() - ! - ! -- return - return - end subroutine sfr_fill_budobj - - subroutine sfr_setup_tableobj(this) -! ****************************************************************************** -! sfr_setup_tableobj -- Set up the table object that is used to write the sfr -! stage data. The terms listed here must correspond in -! number and order to the ones written to the stage table -! in the sfr_ot method. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH, LENBUDTXT - ! -- dummy - class(SfrType) :: this - ! -- local - integer(I4B) :: nterms - character(len=LINELENGTH) :: title - character(len=LINELENGTH) :: text -! ------------------------------------------------------------------------------ - ! - ! -- setup stage table - if (this%iprhed > 0) then - ! - ! -- Determine the number of sfr budget terms. These are fixed for - ! the simulation and cannot change. This includes FLOW-JA-FACE - ! so they can be written to the binary budget files, but these internal - ! flows are not included as part of the budget table. - nterms = 8 - if (this%inamedbound == 1) nterms = nterms + 1 - ! - ! -- set up table title - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%name)) //') STAGES FOR EACH CONTROL VOLUME' - ! - ! -- set up stage tableobj - call table_cr(this%stagetab, this%name, title) - call this%stagetab%table_df(this%maxbound, nterms, this%iout, & - transient=.TRUE.) - ! - ! -- Go through and set up table budget term - if (this%inamedbound == 1) then - text = 'NAME' - call this%stagetab%initialize_column(text, 20, alignment=TABLEFT) - end if - ! - ! -- reach number - text = 'NUMBER' - call this%stagetab%initialize_column(text, 10, alignment=TABCENTER) - ! - ! -- cellids - text = 'CELLID' - call this%stagetab%initialize_column(text, 20, alignment=TABLEFT) - ! - ! -- reach stage - text = 'STAGE' - call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) - ! - ! -- reach depth - text = 'DEPTH' - call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) - ! - ! -- reach width - text = 'WIDTH' - call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) - ! - ! -- gwf head - text = 'GWF HEAD' - call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) - ! - ! -- streambed conductance - text = 'STREAMBED CONDUCTANCE' - call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) - ! - ! -- streambed gradient - text = 'STREAMBED GRADIENT' - call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) - end if - ! - ! -- return - return - end subroutine sfr_setup_tableobj - - - - ! -- geometry functions - function area_wet(this, n, depth) -! ****************************************************************************** -! area_wet -- return wetted area -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - real(DP) :: area_wet - ! -- dummy - class(SfrType) :: this - integer(I4B), intent(in) :: n - real(DP), intent(in) :: depth -! ------------------------------------------------------------------------------ - ! - ! -- Calculate area - area_wet = depth * this%width(n) - ! - ! -- Return - return - end function area_wet - - - function perimeter_wet(this, n) -! ****************************************************************************** -! perimeter_wet -- return wetted perimeter -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - real(DP) :: perimeter_wet - ! -- dummy - class(SfrType) :: this - integer(I4B), intent(in) :: n -! ------------------------------------------------------------------------------ - ! - ! -- Calculate wetted perimeter - perimeter_wet = this%width(n) - ! - ! -- return - return - end function perimeter_wet - - function surface_area(this, n) -! ****************************************************************************** -! surface_area -- return surface area -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return variable - real(DP) :: surface_area - ! -- dummy - class(SfrType) :: this - integer(I4B), intent(in) :: n -! ------------------------------------------------------------------------------ - ! - ! -- Calculate surface area - surface_area = this%width(n) * this%length(n) - ! - ! -- Return - return - end function surface_area - - function surface_area_wet(this, n, depth) -! ****************************************************************************** -! area_wet -- return wetted surface area -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - real(DP) :: surface_area_wet - ! -- dummy - class(SfrType) :: this - integer(I4B), intent(in) :: n - real(DP), intent(in) :: depth - ! -- local - real(DP) :: top_width -! ------------------------------------------------------------------------------ - ! - ! -- Calculate surface area - top_width = this%top_width_wet(n, depth) - surface_area_wet = top_width * this%length(n) - ! - ! -- Return - return - end function surface_area_wet - - function top_width_wet(this, n, depth) -! ****************************************************************************** -! area_wet -- return wetted surface area -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DEM5, DZERO - ! -- return - real(DP) :: top_width_wet - ! -- dummy - class(SfrType) :: this - integer(I4B), intent(in) :: n - real(DP), intent(in) :: depth - ! -- local - real(DP) :: sat -! ------------------------------------------------------------------------------ - ! - ! -- Calculate surface area - sat = sCubicSaturation(DEM5, DZERO, depth, DEM5) - top_width_wet = this%width(n) * sat - ! - ! -- Return - return - end function top_width_wet - -end module SfrModule +module SfrModule + ! + use KindModule, only: DP, I4B + use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, LENTIMESERIESNAME, & + DZERO, DPREC, DEM30, DEM6, DEM5, DEM4, DEM2, & + DHALF, DP6, DTWOTHIRDS, DP7, DP9, DP99, DP999, & + DONE, D1P1, DFIVETHIRDS, DTWO, DPI, DEIGHT, & + DHUNDRED, DEP20, & + NAMEDBOUNDFLAG, LENBOUNDNAME, LENFTYPE, & + LENPACKAGENAME, LENPAKLOC, MAXCHARLEN, & + DHNOFLO, DHDRY, DNODATA, & + TABLEFT, TABCENTER, TABRIGHT + use SmoothingModule, only: sQuadraticSaturation, sQSaturation, & + sQuadraticSaturationDerivative, & + sQSaturationDerivative, & + sCubicSaturation, sChSmooth + use BndModule, only: BndType + use BudgetObjectModule, only: BudgetObjectType, budgetobject_cr + use TableModule, only: TableType, table_cr + use ObserveModule, only: ObserveType + use ObsModule, only: ObsType + use InputOutputModule, only: get_node, URWORD, extract_idnum_or_bndname + use BaseDisModule, only: DisBaseType + use SimModule, only: count_errors, store_error, store_error_unit, ustop + use GenericUtilitiesModule, only: sim_message + use SparseModule, only: sparsematrix + use ArrayHandlersModule, only: ExpandArray + use BlockParserModule, only: BlockParserType + ! + implicit none + ! + character(len=LENFTYPE) :: ftype = 'SFR' + character(len=LENPACKAGENAME) :: text = ' SFR' + ! + ! -- timeseries type for + type :: SfrTSType + character (len=LENTIMESERIESNAME), pointer :: name => null() + real(DP), pointer :: value => null() + end type SfrTSType + ! + type :: SfrDivType + integer(I4B), pointer :: reach => null() + integer(I4B), pointer :: iprior => null() + character (len=10), pointer :: cprior => null() + type (SfrTSType), pointer :: rate => null() + end type SfrDivType + ! + ! -- Streamflow Routing derived data type + type :: SfrDataType + ! -- diversion data + type (SfrDivType), dimension(:), pointer, contiguous :: diversion => null() + ! -- aux data + type (SfrTSType), dimension(:), pointer, contiguous :: auxvar => null() + ! -- boundary data + type (SfrTSType), pointer :: rough => null() + type (SfrTSType), pointer :: rain => null() + type (SfrTSType), pointer :: evap => null() + type (SfrTSType), pointer :: inflow => null() + type (SfrTSType), pointer :: runoff => null() + type (SfrTSType), pointer :: sstage => null() + ! -- arrays of data for reach + integer(I4B), dimension(:), pointer, contiguous :: iconn => null() + integer(I4B), dimension(:), pointer, contiguous :: idir => null() + integer(I4B), dimension(:), pointer, contiguous :: idiv => null() + ! -- double precision arrays for reach + real(DP), dimension(:), pointer, contiguous :: qconn => null() + end type SfrDataType + ! + private + public :: sfr_create + public :: SfrType + ! + type, extends(BndType) :: SfrType + ! -- scalars + ! -- for budgets + ! -- characters + character(len=16), dimension(:), pointer, contiguous :: csfrbudget => NULL() + character(len=16), dimension(:), pointer, contiguous :: cauxcbc => NULL() + character(len=LENBOUNDNAME), dimension(:), pointer, & + contiguous :: sfrname => null() + ! -- integers + integer(I4B), pointer :: iprhed => null() + integer(I4B), pointer :: istageout => null() + integer(I4B), pointer :: ibudgetout => null() + integer(I4B), pointer :: ipakcsv => null() + integer(I4B), pointer :: idiversions => null() + integer(I4B), pointer :: nconn => NULL() + integer(I4B), pointer :: maxsfrit => NULL() + integer(I4B), pointer :: bditems => NULL() + integer(I4B), pointer :: cbcauxitems => NULL() + integer(I4B), pointer :: icheck => NULL() + integer(I4B), pointer :: iconvchk => NULL() + integer(I4B), pointer :: gwfiss => NULL() + ! -- double precision + real(DP), pointer :: unitconv => NULL() + real(DP), pointer :: dmaxchg => NULL() + real(DP), pointer :: deps => NULL() + ! -- integer vectors + integer(I4B), dimension(:), pointer, contiguous :: ia => null() + integer(I4B), dimension(:), pointer, contiguous :: ja => null() + ! -- double precision output vectors + real(DP), dimension(:), pointer, contiguous :: qoutflow => null() + real(DP), dimension(:), pointer, contiguous :: qextoutflow => null() + real(DP), dimension(:), pointer, contiguous :: qauxcbc => null() + real(DP), dimension(:), pointer, contiguous :: dbuff => null() + ! + ! -- sfr budget object + type(BudgetObjectType), pointer :: budobj => null() + type(SfrDataType), dimension(:), pointer, contiguous :: reaches => NULL() + type(sparsematrix), pointer :: sparse => null() + ! + ! -- sfr table objects + type(TableType), pointer :: stagetab => null() + type(TableType), pointer :: pakcsvtab => null() + ! + ! -- moved from SfrDataType + integer(I4B), dimension(:), pointer, contiguous :: iboundpak => null() + integer(I4B), dimension(:), pointer, contiguous :: igwfnode => null() + integer(I4B), dimension(:), pointer, contiguous :: igwftopnode => null() + real(DP), dimension(:), pointer, contiguous :: length => null() + real(DP), dimension(:), pointer, contiguous :: width => null() + real(DP), dimension(:), pointer, contiguous :: strtop => null() + real(DP), dimension(:), pointer, contiguous :: bthick => null() + real(DP), dimension(:), pointer, contiguous :: hk => null() + real(DP), dimension(:), pointer, contiguous :: slope => null() + integer(I4B), dimension(:), pointer, contiguous :: nconnreach => null() + real(DP), dimension(:), pointer, contiguous :: ustrf => null() + real(DP), dimension(:), pointer, contiguous :: ftotnd => null() + integer(I4B), dimension(:), pointer, contiguous :: ndiv => null() + real(DP), dimension(:), pointer, contiguous :: usflow => null() + real(DP), dimension(:), pointer, contiguous :: dsflow => null() + real(DP), dimension(:), pointer, contiguous :: depth => null() + real(DP), dimension(:), pointer, contiguous :: stage => null() + real(DP), dimension(:), pointer, contiguous :: gwflow => null() + real(DP), dimension(:), pointer, contiguous :: simevap => null() + real(DP), dimension(:), pointer, contiguous :: simrunoff => null() + real(DP), dimension(:), pointer, contiguous :: stage0 => null() + real(DP), dimension(:), pointer, contiguous :: usflow0 => null() + ! -- type bound procedures + contains + procedure :: sfr_allocate_scalars + procedure :: sfr_allocate_arrays + procedure :: bnd_options => sfr_options + procedure :: read_dimensions => sfr_read_dimensions + procedure :: set_pointers => sfr_set_pointers + procedure :: bnd_ar => sfr_ar + procedure :: bnd_rp => sfr_rp + procedure :: bnd_ad => sfr_ad + procedure :: bnd_cf => sfr_cf + procedure :: bnd_fc => sfr_fc + procedure :: bnd_fn => sfr_fn + procedure :: bnd_cc => sfr_cc + procedure :: bnd_bd => sfr_bd + procedure :: bnd_ot => sfr_ot + procedure :: bnd_da => sfr_da + procedure :: define_listlabel + ! -- methods for observations + procedure, public :: bnd_obs_supported => sfr_obs_supported + procedure, public :: bnd_df_obs => sfr_df_obs + procedure, public :: bnd_rp_obs => sfr_rp_obs + procedure, private :: sfr_bd_obs + ! -- private procedures + procedure, private :: allocate_reach + procedure, private :: deallocate_reach + procedure, private :: allocate_diversion + procedure, private :: deallocate_diversion + procedure, private :: sfr_set_stressperiod + procedure, private :: sfr_solve + procedure, private :: sfr_update_flows + procedure, private :: sfr_calc_qgwf + procedure, private :: sfr_calc_cond + procedure, private :: sfr_calc_qman + procedure, private :: sfr_calc_qd + procedure, private :: sfr_calc_qsource + procedure, private :: sfr_calc_div + ! -- geometry + procedure, private :: area_wet + procedure, private :: perimeter_wet + procedure, private :: surface_area + procedure, private :: surface_area_wet + procedure, private :: top_width_wet + ! -- reading + procedure, private :: sfr_read_packagedata + procedure, private :: sfr_read_connectiondata + procedure, private :: sfr_read_diversions + ! -- calculations + procedure, private :: sfr_rectch_depth + ! -- error checking + procedure, private :: sfr_check_reaches + procedure, private :: sfr_check_connections + procedure, private :: sfr_check_diversions + procedure, private :: sfr_check_ustrf + ! -- budget + procedure, private :: sfr_setup_budobj + procedure, private :: sfr_fill_budobj + ! -- table + procedure, private :: sfr_setup_tableobj + end type SfrType + +contains + + subroutine sfr_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) +! ****************************************************************************** +! sfr_create -- Create a New Streamflow Routing Package +! Subroutine: (1) create new-style package +! (2) point bndobj to the new package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BndType), pointer :: packobj + integer(I4B),intent(in) :: id + integer(I4B),intent(in) :: ibcnum + integer(I4B),intent(in) :: inunit + integer(I4B),intent(in) :: iout + character(len=*), intent(in) :: namemodel + character(len=*), intent(in) :: pakname + ! -- local + type(SfrType), pointer :: sfrobj +! ------------------------------------------------------------------------------ + ! + ! -- allocate the object and assign values to object variables + allocate(sfrobj) + packobj => sfrobj + ! + ! -- create name and origin + call packobj%set_names(ibcnum, namemodel, pakname, ftype) + packobj%text = text + ! + ! -- allocate scalars + call sfrobj%sfr_allocate_scalars() + ! + ! -- initialize package + call packobj%pack_initialize() + + packobj%inunit = inunit + packobj%iout = iout + packobj%id = id + packobj%ibcnum = ibcnum + packobj%ncolbnd = 4 + packobj%iscloc = 0 ! not supported + packobj%ictorigin = 'NPF' + ! + ! -- return + return + end subroutine sfr_create + + subroutine sfr_allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars -- allocate scalar members +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use MemoryManagerModule, only: mem_allocate, mem_setptr + ! -- dummy + class(SfrType), intent(inout) :: this +! ------------------------------------------------------------------------------ + ! + ! -- call standard BndType allocate scalars + call this%BndType%allocate_scalars() + ! + ! -- allocate the object and assign values to object variables + call mem_allocate(this%iprhed, 'IPRHED', this%origin) + call mem_allocate(this%istageout, 'ISTAGEOUT', this%origin) + call mem_allocate(this%ibudgetout, 'IBUDGETOUT', this%origin) + call mem_allocate(this%ipakcsv, 'IPAKCSV', this%origin) + call mem_allocate(this%idiversions, 'IDIVERSIONS', this%origin) + call mem_allocate(this%maxsfrit, 'MAXSFRIT', this%origin) + call mem_allocate(this%bditems, 'BDITEMS', this%origin) + call mem_allocate(this%cbcauxitems, 'CBCAUXITEMS', this%origin) + call mem_allocate(this%unitconv, 'UNITCONV', this%origin) + call mem_allocate(this%dmaxchg, 'DMAXCHG', this%origin) + call mem_allocate(this%deps, 'DEPS', this%origin) + call mem_allocate(this%nconn, 'NCONN', this%origin) + call mem_allocate(this%icheck, 'ICHECK', this%origin) + call mem_allocate(this%iconvchk, 'ICONVCHK', this%origin) + ! + ! -- set pointer to gwf iss + call mem_setptr(this%gwfiss, 'ISS', trim(this%name_model)) + ! + ! -- Set values + this%iprhed = 0 + this%istageout = 0 + this%ibudgetout = 0 + this%ipakcsv = 0 + this%idiversions = 0 + this%maxsfrit = 100 + this%bditems = 8 + this%cbcauxitems = 1 + this%unitconv = DONE + this%dmaxchg = DEM5 + this%deps = DP999 * this%dmaxchg + !this%imover = 0 + this%nconn = 0 + this%icheck = 1 + this%iconvchk = 1 + ! + ! -- return + return + end subroutine sfr_allocate_scalars + + subroutine sfr_allocate_arrays(this) +! ****************************************************************************** +! allocate_scalars -- allocate scalar members +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(SfrType), intent(inout) :: this + ! -- local + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + ! -- call standard BndType allocate scalars + !call this%BndType%allocate_arrays() + ! + ! -- allocate character array for budget text + allocate(this%csfrbudget(this%bditems)) + allocate(this%sfrname(this%maxbound)) + ! + ! -- variables originally in SfrDataType + call mem_allocate(this%iboundpak, this%maxbound, 'IBOUNDPAK', this%origin) + call mem_allocate(this%igwfnode, this%maxbound, 'IGWFNODE', this%origin) + call mem_allocate(this%igwftopnode, this%maxbound, 'IGWFTOPNODE', this%origin) + call mem_allocate(this%length, this%maxbound, 'LENGTH', this%origin) + call mem_allocate(this%width, this%maxbound, 'WIDTH', this%origin) + call mem_allocate(this%strtop, this%maxbound, 'STRTOP', this%origin) + call mem_allocate(this%bthick, this%maxbound, 'BTHICK', this%origin) + call mem_allocate(this%hk, this%maxbound, 'HK', this%origin) + call mem_allocate(this%slope, this%maxbound, 'SLOPE', this%origin) + call mem_allocate(this%nconnreach, this%maxbound, 'NCONNREACH', this%origin) + call mem_allocate(this%ustrf, this%maxbound, 'USTRF', this%origin) + call mem_allocate(this%ftotnd, this%maxbound, 'FTOTND', this%origin) + call mem_allocate(this%ndiv, this%maxbound, 'NDIV', this%origin) + call mem_allocate(this%usflow, this%maxbound, 'USFLOW', this%origin) + call mem_allocate(this%dsflow, this%maxbound, 'DSFLOW', this%origin) + call mem_allocate(this%depth, this%maxbound, 'DEPTH', this%origin) + call mem_allocate(this%stage, this%maxbound, 'STAGE', this%origin) + call mem_allocate(this%gwflow, this%maxbound, 'GWFLOW', this%origin) + call mem_allocate(this%simevap, this%maxbound, 'SIMEVAP', this%origin) + call mem_allocate(this%simrunoff, this%maxbound, 'SIMRUNOFF', this%origin) + call mem_allocate(this%stage0, this%maxbound, 'STAGE0', this%origin) + call mem_allocate(this%usflow0, this%maxbound, 'USFLOW0', this%origin) + do i = 1, this%maxbound + this%iboundpak(i) = 1 + this%igwfnode(i) = 0 + this%igwftopnode(i) = 0 + this%length(i) = DZERO + this%width(i) = DZERO + this%strtop(i) = DZERO + this%bthick(i) = DZERO + this%hk(i) = DZERO + this%slope(i) = DZERO + this%nconnreach(i) = 0 + this%ustrf(i) = DZERO + this%ftotnd(i) = DZERO + this%ndiv(i) = 0 + this%usflow(i) = DZERO + this%dsflow(i) = DZERO + this%depth(i) = DZERO + this%stage(i) = DZERO + this%gwflow(i) = DZERO + this%simevap(i) = DZERO + this%simrunoff(i) = DZERO + this%stage0(i) = DZERO + this%usflow0(i) = DZERO + end do + + ! + ! + !-- fill csfrbudget + this%csfrbudget(1) = ' RAINFALL' + this%csfrbudget(2) = ' EVAPORATION' + this%csfrbudget(3) = ' RUNOFF' + this%csfrbudget(4) = ' EXT-INFLOW' + this%csfrbudget(5) = ' GWF' + this%csfrbudget(6) = ' EXT-OUTFLOW' + this%csfrbudget(7) = ' FROM-MVR' + this%csfrbudget(8) = ' TO-MVR' + ! + ! -- allocate and initialize budget output data + call mem_allocate(this%qoutflow, this%maxbound, 'QOUTFLOW', this%origin) + call mem_allocate(this%qextoutflow, this%maxbound, 'QEXTOUTFLOW', this%origin) + do i = 1, this%maxbound + this%qoutflow(i) = DZERO + this%qextoutflow(i) = DZERO + end do + ! + ! -- allocate and initialize dbuff + if (this%istageout > 0) then + call mem_allocate(this%dbuff, this%maxbound, 'DBUFF', this%origin) + do i = 1, this%maxbound + this%dbuff(i) = DZERO + end do + else + call mem_allocate(this%dbuff, 0, 'DBUFF', this%origin) + end if + ! + ! -- allocate character array for budget text + allocate(this%cauxcbc(this%cbcauxitems)) + ! + ! -- allocate and initialize qauxcbc + call mem_allocate(this%qauxcbc, this%cbcauxitems, 'QAUXCBC', this%origin) + do i = 1, this%cbcauxitems + this%qauxcbc(i) = DZERO + end do + ! + !-- fill cauxcbc + this%cauxcbc(1) = 'FLOW-AREA ' + ! + ! -- return + return + end subroutine sfr_allocate_arrays + + subroutine sfr_read_dimensions(this) +! ****************************************************************************** +! pak1read_dimensions -- Read the dimensions for this package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use InputOutputModule, only: urword + use SimModule, only: ustop, store_error, count_errors + ! -- dummy + class(SfrType),intent(inout) :: this + ! -- local + character (len=LINELENGTH) :: errmsg, keyword + integer(I4B) :: ierr + logical :: isfound, endOfBlock + ! -- format +! ------------------------------------------------------------------------------ + ! + ! -- initialize dimensions to 0 + this%maxbound = 0 + ! + ! -- 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 '//trim(adjustl(this%text))// & + ' DIMENSIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('NREACHES') + this%maxbound = this%parser%GetInteger() + write(this%iout,'(4x,a,i0)')'NREACHES = ', this%maxbound + case default + write(errmsg,'(4x,a,a)') & + '****ERROR. UNKNOWN '//trim(this%text)//' DIMENSION: ', & + trim(keyword) + call store_error(errmsg) + end select + end do + write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' DIMENSIONS' + else + call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') + end if + ! + ! -- verify dimensions were set + if(this%maxbound < 1) then + write(errmsg, '(1x,a)') & + 'ERROR. NREACHES WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.' + call store_error(errmsg) + endif + ! + ! -- write summary of error messages for block + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- Call define_listlabel to construct the list label that is written + ! when PRINT_INPUT option is used. + call this%define_listlabel() + + + + + ! + ! -- Allocate arrays in package superclass + call this%sfr_allocate_arrays() + ! + ! -- read package data + call this%sfr_read_packagedata() + ! + ! -- read connection data + call this%sfr_read_connectiondata() + ! + ! -- read diversion data + call this%sfr_read_diversions() + ! + ! -- setup the budget object + call this%sfr_setup_budobj() + ! + ! -- setup the stage table object + call this%sfr_setup_tableobj() + ! + ! -- return + return + end subroutine sfr_read_dimensions + + subroutine sfr_options(this, option, found) +! ****************************************************************************** +! rch_options -- set options specific to RchType +! +! rch_options overrides BndType%bnd_options +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: DZERO + use OpenSpecModule, only: access, form + use SimModule, only: ustop, store_error + use InputOutputModule, only: urword, getunit, openfile + ! -- dummy + class(SfrType), intent(inout) :: this + character(len=*), intent(inout) :: option + logical, intent(inout) :: found + ! -- local + real(DP) :: r + character(len=MAXCHARLEN) :: fname, keyword + ! -- formats + character(len=*),parameter :: fmtunitconv = & + "(4x, 'UNIT CONVERSION VALUE (',g15.7,') SPECIFIED.')" + character(len=*),parameter :: fmtiter = & + "(4x, 'MAXIMUM SFR ITERATION VALUE (',i15,') SPECIFIED.')" + character(len=*),parameter :: fmtdmaxchg = & + "(4x, 'MAXIMUM DEPTH CHANGE VALUE (',g15.7,') SPECIFIED.')" + character(len=*),parameter :: fmtsfrbin = & + "(4x, 'SFR ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" +! ------------------------------------------------------------------------------ + ! + ! -- Check for SFR options + select case (option) + case ('PRINT_STAGE') + this%iprhed = 1 + write(this%iout,'(4x,a)') trim(adjustl(this%text))// & + ' STAGES WILL BE PRINTED TO LISTING FILE.' + found = .true. + case('STAGE') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%istageout = getunit() + call openfile(this%istageout, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE') + write(this%iout,fmtsfrbin) 'STAGE', fname, this%istageout + found = .true. + else + call store_error('OPTIONAL STAGE KEYWORD MUST BE FOLLOWED BY FILEOUT') + end if + case('BUDGET') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ibudgetout = getunit() + call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE') + write(this%iout,fmtsfrbin) 'BUDGET', fname, this%ibudgetout + found = .true. + else + call store_error('OPTIONAL BUDGET KEYWORD MUST BE FOLLOWED BY FILEOUT') + end if + case('PACKAGE_CONVERGENCE') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ipakcsv = getunit() + call openfile(this%ipakcsv, this%iout, fname, 'CSV', & + filstat_opt='REPLACE') + write(this%iout,fmtsfrbin) 'PACKAGE_CONVERGENCE', fname, this%ipakcsv + found = .true. + else + call store_error('OPTIONAL PACKAGE_CONVERGENCE KEYWORD MUST BE ' // & + 'FOLLOWED BY FILEOUT') + end if + case('UNIT_CONVERSION') + this%unitconv = this%parser%GetDouble() + write(this%iout, fmtunitconv) this%unitconv + found = .true. + case('MAXIMUM_ITERATIONS') + this%maxsfrit = this%parser%GetInteger() + write(this%iout, fmtiter) this%maxsfrit + found = .true. + case('MAXIMUM_DEPTH_CHANGE') + r = this%parser%GetDouble() + this%dmaxchg = r + this%deps = DP999 * r + write(this%iout, fmtdmaxchg) this%dmaxchg + found = .true. + case('MOVER') + this%imover = 1 + write(this%iout, '(4x,A)') 'MOVER OPTION ENABLED' + found = .true. + ! + ! -- right now these 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_CHECK') + call this%parser%DevOpt() + this%icheck = 0 + write(this%iout, '(4x,A)') 'SFR CHECKS OF REACH GEOMETRY ' // & + 'RELATIVE TO MODEL GRID AND ' // & + 'REASONABLE PARAMETERS WILL NOT ' // & + 'BE PERFORMED.' + found = .true. + case('DEV_NO_FINAL_CHECK') + call this%parser%DevOpt() + this%iconvchk = 0 + write(this%iout, '(4x,a)') & + & 'A FINAL CONVERGENCE CHECK OF THE CHANGE IN STREAM FLOW ROUTING ' // & + & 'STAGES AND FLOWS WILL NOT BE MADE' + found = .true. + ! + ! -- no valid options found + case default + ! + ! -- No options found + found = .false. + end select + ! + ! -- return + return + end subroutine sfr_options + + subroutine sfr_ar(this) + ! ****************************************************************************** + ! sfr_ar -- Allocate and Read + ! Subroutine: (1) create new-style package + ! (2) point bndobj to the new package + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + use SimModule, only: ustop, count_errors + ! -- dummy + class(SfrType),intent(inout) :: this + ! -- local + integer(I4B) :: n, ierr + ! -- format + ! ------------------------------------------------------------------------------ + ! + call this%obs%obs_ar() + ! + ! -- call standard BndType allocate scalars + call this%BndType%allocate_arrays() + ! + ! -- set boundname for each connection + if (this%inamedbound /= 0) then + do n = 1, this%maxbound + this%boundname(n) = this%sfrname(n) + end do + endif + ! + ! -- copy igwfnode into nodelist + do n = 1, this%maxbound + this%nodelist(n) = this%igwfnode(n) + end do + ! + ! -- check the sfr data + call this%sfr_check_reaches() + + ! -- check the connection data + call this%sfr_check_connections() + + ! -- check the diversion data + if (this%idiversions /= 0) then + call this%sfr_check_diversions() + end if + ! + ! -- terminate if errors were detected in any of the static sfr data + ierr = count_errors() + if (ierr > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- setup pakmvrobj + if (this%imover /= 0) then + allocate(this%pakmvrobj) + call this%pakmvrobj%ar(this%maxbound, this%maxbound, this%origin) + endif + ! + ! -- return + return + end subroutine sfr_ar + + subroutine sfr_read_packagedata(this) + ! ****************************************************************************** + ! sfr_read_packagedata -- read package data + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors + use TimeSeriesManagerModule, only: read_single_value_or_time_series + ! -- dummy + class(SfrType),intent(inout) :: this + ! -- local + character (len=LINELENGTH) :: errmsg + character(len=LINELENGTH) :: text, cellid, keyword + character (len=10) :: cnum + character(len=LENBOUNDNAME) :: bndName, bndNameTemp, manningname + character(len=50), dimension(:), allocatable :: caux + integer(I4B) :: n, ierr, ival + logical :: isfound, endOfBlock + integer(I4B) :: i + integer(I4B) :: jj + integer(I4B) :: iaux + integer, allocatable, dimension(:) :: nboundchk + ! -- format + ! ------------------------------------------------------------------------------ + ! + ! -- allocate space for sfr reach data + allocate(this%reaches(this%maxbound)) + allocate(nboundchk(this%maxbound)) + do i = 1, this%maxbound + nboundchk(i) = 0 + enddo + ! + ! -- allocate local storage for aux variables + if (this%naux > 0) then + allocate(caux(this%naux)) + end if + ! + ! -- read reach data + call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & + supportOpenClose=.true.) + ! + ! -- parse reaches block if detected + if (isfound) then + write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & + ' PACKAGEDATA' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + ! -- read reach number + n = this%parser%GetInteger() + + if (n < 1 .or. n > this%maxbound) then + write(errmsg,'(4x,a,1x,i6)') & + '****ERROR. REACH NUMBER (rno) MUST BE > 0 and <= ', this%maxbound + call store_error(errmsg) + cycle + end if + + ! -- increment nboundchk + nboundchk(n) = nboundchk(n) + 1 + + ! -- allocate data for this reach + call this%allocate_reach(n, nboundchk(n)) + ! -- get model node number + call this%parser%GetCellid(this%dis%ndim, cellid, flag_string=.true.) + this%igwfnode(n) = this%dis%noder_from_cellid(cellid, & + this%inunit, this%iout, flag_string=.true.) + this%igwftopnode(n) = this%igwfnode(n) + !cdl this%nodelist(n) = this%igwfnode(n) + ! -- read the cellid string and determine if 'none' is specified + if (this%igwfnode(n) < 1) then + call this%parser%GetStringCaps(keyword) + if (keyword .ne. 'NONE') then + write(cnum, '(i0)') n + errmsg = 'ERROR: cellid (' // trim(cellid) // & + ') for unconnected reach ' // trim(cnum) // & + ' must be NONE' + call store_error(errmsg) + end if + end if + ! -- get reach length + this%length(n) = this%parser%GetDouble() + ! -- get reach width + this%width(n) = this%parser%GetDouble() + ! -- get reach slope + this%slope(n) = this%parser%GetDouble() + ! -- get reach stream bottom + this%strtop(n) = this%parser%GetDouble() + ! -- get reach bed thickness + this%bthick(n) = this%parser%GetDouble() + ! -- get reach bed hk + this%hk(n) = this%parser%GetDouble() + ! -- get reach roughness + !this%reaches(n)%rough = this%parser%GetDouble() + call this%parser%GetStringCaps(manningname) + ! -- get number of connections for reach + ival = this%parser%GetInteger() + this%nconnreach(n) = ival + this%nconn = this%nconn + ival + if (ival > 0) then + allocate(this%reaches(n)%iconn(ival)) + allocate(this%reaches(n)%idir(ival)) + allocate(this%reaches(n)%idiv(ival)) + allocate(this%reaches(n)%qconn(ival)) + else if (ival < 0) then + ival = 0 + end if + ! -- get upstream fraction for reach + this%ustrf(n) = this%parser%GetDouble() + ! -- get number of diversions for reach + ival = this%parser%GetInteger() + this%ndiv(n) = ival + if (ival > 0) then + this%idiversions = 1 + call this%allocate_diversion(n, ival) + else if (ival < 0) then + ival = 0 + end if + + ! -- get aux data + do iaux = 1, this%naux + call this%parser%GetString(caux(iaux)) + end do + + ! -- set default bndName + write(cnum,'(i10.10)') n + bndName = 'Reach' // cnum + + ! -- get reach name + if (this%inamedbound /= 0) then + call this%parser%GetStringCaps(bndNameTemp) + if (bndNameTemp /= '') then + bndName = bndNameTemp(1:16) + endif + !this%boundname(n) = bndName + end if + this%sfrname(n) = bndName + + ! -- set Mannings + text = manningname + jj = 1 !iaux + call read_single_value_or_time_series(text, & + this%reaches(n)%rough%value, & + this%reaches(n)%rough%name, & + DZERO, & + this%Name, 'BND', this%TsManager, & + this%iprpak, n, jj, & + 'MANNING', bndName, & + this%parser%iuactive) + + + ! -- get aux data + do iaux = 1, this%naux + text = caux(iaux) + jj = 1 !iaux + call read_single_value_or_time_series(text, & + this%reaches(n)%auxvar(iaux)%value, & + this%reaches(n)%auxvar(iaux)%name, & + DZERO, & + this%Name, 'AUX', this%TsManager, & + this%iprpak, n, jj, & + this%auxname(iaux), bndName, & + this%parser%iuactive) + end do + + ! -- initialize sstage to the top of the reach + ! this value would be used by simple routing reaches + ! on kper = 1 and kstp = 1 if a stage is not specified + ! on the status line for the reach + this%reaches(n)%sstage%name = '' + this%reaches(n)%sstage%value = this%strtop(n) + + end do + write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' PACKAGEDATA' + else + call store_error('ERROR. REQUIRED PACKAGEDATA BLOCK NOT FOUND.') + end if + ! + ! -- Check to make sure that every reach is specified and that no reach + ! is specified more than once. + do i = 1, this%maxbound + if (nboundchk(i) == 0) then + write(errmsg, '(a, i0, a)') 'ERROR: INFORMATION FOR REACH ', i, & + ' NOT SPECIFIED IN PACKAGEDATA BLOCK.' + call store_error(errmsg) + else if (nboundchk(i) > 1) then + write(errmsg, '(a, i0, i0)') 'ERROR: INFORMATION SPECIFIED ', & + nboundchk(i), ' TIMES FOR REACH ', i + call store_error(errmsg) + endif + end do + deallocate(nboundchk) + ! + ! -- terminate if errors encountered in reach block + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- deallocate local storage for aux variables + if (this%naux > 0) then + deallocate(caux) + end if + ! + ! -- return + return + end subroutine sfr_read_packagedata + + subroutine sfr_read_connectiondata(this) + ! ****************************************************************************** + ! sfr_read_connectiondata -- + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors + ! -- dummy + class(SfrType),intent(inout) :: this + ! -- local + character (len=LINELENGTH) :: line, errmsg + integer(I4B) :: n, ierr, ival + logical :: isfound, endOfBlock + integer(I4B) :: i + integer(I4B) :: nja + integer(I4B), dimension(:), pointer, contiguous :: rowmaxnnz => null() + integer, allocatable, dimension(:) :: nboundchk + ! -- format + ! ------------------------------------------------------------------------------ + ! + ! -- allocate and initialize local variables for reach connections + allocate(nboundchk(this%maxbound)) + do n = 1, this%maxbound + nboundchk(n) = 0 + end do + ! + ! -- + nja = 0 + allocate(rowmaxnnz(this%maxbound)) + do n = 1, this%maxbound + ival = this%nconnreach(n) + if (ival < 0) ival = 0 + rowmaxnnz(n) = ival + 1 + nja = nja + ival + 1 + enddo + ! + ! -- allocate space for connectivity + allocate(this%sparse) + ! + ! -- set up sparse + + call this%sparse%init(this%maxbound, this%maxbound, rowmaxnnz) + ! + ! -- read connection data + call this%parser%GetBlock('CONNECTIONDATA', isfound, ierr, & + supportOpenClose=.true.) + ! + ! -- parse reach connectivity block if detected + if (isfound) then + write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & + ' CONNECTIONDATA' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + ! + ! -- get reach number + n = this%parser%GetInteger() + ! + ! -- check for error + if(n < 1 .or. n > this%maxbound) then + write(errmsg, '(a, i0)') 'SFR REACH LESS THAN ONE OR > NREACHES: ', n + call store_error(errmsg) + cycle + endif + ! + ! -- increment nboundchk + if (this%nconnreach(n) > 0) then + nboundchk(n) = nboundchk(n) + 1 + end if + ! + ! -- add diagonal connection for reach + call this%sparse%addconnection(n, n, 1) + ! + ! -- fill off diagonals + do i = 1, this%nconnreach(n) + ival = this%parser%GetInteger() + if (ival < 0) then + this%reaches(n)%idir(i) = -1 + ival = abs(ival) + elseif (ival == 0) then + call store_error('Missing or zero connection reach in line:') + call store_error(line) + else + this%reaches(n)%idir(i) = 1 + end if + if (ival > this%maxbound) then + call store_error('Reach number exceeds NREACHES in line:') + call store_error(line) + endif + this%reaches(n)%iconn(i) = ival + this%reaches(n)%idiv(i) = 0 + call this%sparse%addconnection(n, ival, 1) + end do + end do + + write(this%iout,'(1x,a)') 'END OF '//trim(adjustl(this%text))// & + ' CONNECTIONDATA' + + do n = 1, this%maxbound + if (this%nconnreach(n) > 0) then + ! + ! -- check for missing or duplicate sfr connections + if (nboundchk(n) == 0) then + write(errmsg,'(a,1x,i0)') & + 'ERROR. NO CONNECTION DATA SPECIFIED FOR REACH', n + call store_error(errmsg) + else if (nboundchk(n) > 1) then + write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & + 'ERROR. CONNECTION DATA FOR REACH', n, & + 'SPECIFIED', nboundchk(n), 'TIMES' + call store_error(errmsg) + end if + end if + end do + + else + call store_error('ERROR. REQUIRED CONNECTIONDATA BLOCK NOT FOUND.') + end if + ! + ! -- deallocate local storage for reach connections + deallocate(nboundchk) + ! + ! -- terminate if errors encountered in connectiondata block + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- allocate ia and ja for package + allocate(this%ia(this%maxbound+1)) + allocate(this%ja(nja)) + ! + ! -- create ia and ja from sparse + call this%sparse%filliaja(this%ia,this%ja,ierr) + ! + ! -- deallocate temporary storage + deallocate(rowmaxnnz) + ! + ! -- destroy sparse + call this%sparse%destroy() + deallocate(this%sparse) + ! + ! -- return + return + end subroutine sfr_read_connectiondata + + + subroutine sfr_read_diversions(this) + ! ****************************************************************************** + ! sfr_read_diversions -- + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors + ! -- dummy + class(SfrType),intent(inout) :: this + ! -- local + character (len=LINELENGTH) :: errmsg + character (len=10) :: cnum + character (len=10) :: cval + integer(I4B) :: j, n, ierr, ival + integer(I4B) :: ipos + integer(I4B) :: ndiv + logical :: isfound, endOfBlock + integer(I4B) :: idiv + integer, allocatable, dimension(:) :: iachk + integer, allocatable, dimension(:) :: nboundchk + ! -- format + ! ------------------------------------------------------------------------------ + ! + ! -- read diversions + call this%parser%GetBlock('DIVERSIONS', isfound, ierr, & + supportOpenClose=.true., & + blockRequired=.false.) + ! + ! -- parse reach connectivity block if detected + if (isfound) then + if (this%idiversions /= 0) then + write(this%iout,'(/1x,a)') 'PROCESSING ' // trim(adjustl(this%text)) // & + ' DIVERSIONS' + ! + ! -- allocate and initialize local variables for diversions + ndiv = 0 + do n = 1, this%maxbound + ndiv = ndiv + this%ndiv(n) + end do + allocate(iachk(this%maxbound+1)) + allocate(nboundchk(ndiv)) + iachk(1) = 1 + do n = 1, this%maxbound + iachk(n+1) = iachk(n) + this%ndiv(n) + end do + do n = 1, ndiv + nboundchk(n) = 0 + end do + ! + ! -- read diversion data + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + ! + ! -- get reach number + n = this%parser%GetInteger() + if (n < 1 .or. n > this%maxbound) then + write(cnum, '(i0)') n + errmsg = 'ERROR: reach number should be between 1 and ' // & + trim(cnum) // '.' + call store_error(errmsg) + cycle + end if + ! + ! -- make sure reach has at least one diversion + if (this%ndiv(n) < 1) then + write(cnum, '(i0)') n + errmsg = 'ERROR: diversions cannot be specified ' // & + 'for reach ' // trim(cnum) + call store_error(errmsg) + cycle + end if + ! + ! -- read diversion number + ival = this%parser%GetInteger() + if (ival < 1 .or. ival > this%ndiv(n)) then + write(cnum, '(i0)') n + errmsg = 'ERROR: reach ' // trim(cnum) + write(cnum, '(i0)') this%ndiv(n) + errmsg = trim(errmsg) // ' diversion number should be between ' // & + '1 and ' // trim(cnum) // '.' + call store_error(errmsg) + cycle + end if + + ! -- increment nboundchk + ipos = iachk(n) + ival - 1 + nboundchk(ipos) = nboundchk(ipos) + 1 + + idiv = ival + ! + ! -- get target reach for diversion + ival = this%parser%GetInteger() + if (ival < 1 .or. ival > this%maxbound) then + write(cnum, '(i0)') ival + errmsg = 'ERROR: diversion target reach number should be ' // & + 'between 1 and ' // trim(cnum) // '.' + call store_error(errmsg) + cycle + end if + this%reaches(n)%diversion(idiv)%reach = ival + ! + ! -- get cprior + call this%parser%GetStringCaps(cval) + ival = -1 + select case (cval) + case('UPTO') + ival = 0 + case('THRESHOLD') + ival = -1 + case('FRACTION') + ival = -2 + case('EXCESS') + ival = -3 + case default + errmsg = 'ERROR: INVALID CPRIOR TYPE ' // trim(cval) + call store_error(errmsg) + end select + this%reaches(n)%diversion(idiv)%cprior = cval + this%reaches(n)%diversion(idiv)%iprior = ival + + end do + + write(this%iout,'(1x,a)') 'END OF ' // trim(adjustl(this%text)) // & + ' DIVERSIONS' + + do n = 1, this%maxbound + do j = 1, this%ndiv(n) + ipos = iachk(n) + j - 1 + ! + ! -- check for missing or duplicate reach diversions + if (nboundchk(ipos) == 0) then + write(errmsg,'(a,1x,i0,1x,a,1x,i0)') & + 'ERROR. NO DATA SPECIFIED FOR REACH', n, 'DIVERSION', j + call store_error(errmsg) + else if (nboundchk(ipos) > 1) then + write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & + 'ERROR. DATA FOR REACH', n, 'DIVERSION', j, & + 'SPECIFIED', nboundchk(ipos), 'TIMES' + call store_error(errmsg) + end if + end do + end do + ! + ! -- deallocate local variables + deallocate(iachk) + deallocate(nboundchk) + else + ! + ! -- error condition + write(errmsg,'(a,1x,a)') 'ERROR. A DIVERSIONS BLOCK SHOULD NOT BE', & + 'SPECIFIED IF DIVERSIONS ARE NOT SPECIFIED.' + call store_error(errmsg) + end if + else + if (this%idiversions /= 0) then + call store_error('ERROR. REQUIRED DIVERSIONS BLOCK NOT FOUND.') + end if + end if + ! + ! -- write summary of diversion error messages + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- return + return + end subroutine sfr_read_diversions + + + subroutine sfr_rp(this) +! ****************************************************************************** +! sfr_rp -- Read and Prepare +! Subroutine: (1) read itmp +! (2) read new boundaries if itmp>0 +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use TdisModule, only: kper, nper + use InputOutputModule, only: urword + use SimModule, only: ustop, store_error, count_errors + ! -- dummy + class(SfrType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: line + character(len=LINELENGTH) :: errmsg + integer(I4B) :: ierr + integer(I4B) :: n + integer(I4B) :: ichkustrm + logical :: isfound, endOfBlock + ! -- formats + character(len=*),parameter :: fmtblkerr = & + "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + character(len=*),parameter :: fmtlsp = & + & "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" + character(len=*), parameter :: fmtnbd = & + "(1X,/1X,'THE NUMBER OF ACTIVE ',A,'S (',I6, & + & ') IS GREATER THAN MAXIMUM(',I6,')')" +! ------------------------------------------------------------------------------ + ! + ! -- initialize flags + ichkustrm = 0 + if (kper == 1) then + ichkustrm = 1 + end if + ! + ! -- set nbound to maxbound + this%nbound = this%maxbound + ! + ! -- Set ionper to the stress period number for which a new block of data + ! will be read. + if (this%ionper < kper) then + ! + ! -- get period block + call this%parser%GetBlock('PERIOD', isfound, ierr, & + supportOpenClose=.true.) + if(isfound) then + ! + ! -- read ionper and check for increasing period numbers + call this%read_check_ionper() + else + ! + ! -- PERIOD block not found + if (ierr < 0) then + ! -- End of file found; data applies for remainder of simulation. + this%ionper = nper + 1 + else + ! -- Found invalid block + write(errmsg, fmtblkerr) adjustl(trim(line)) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end if + endif + end if + ! + ! -- Read data if ionper == kper + if(this%ionper==kper) then + ! + ! -- setup table for period data + if (this%iprpak /= 0) then + ! + ! -- reset the input table object + title = trim(adjustl(this%text)) // ' PACKAGE (' // & + trim(adjustl(this%name)) //') DATA FOR PERIOD' + write(title, '(a,1x,i6)') trim(adjustl(title)), kper + call table_cr(this%inputtab, this%name, title) + call this%inputtab%table_df(1, 4, this%iout, finalize=.FALSE.) + text = 'NUMBER' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'KEYWORD' + call this%inputtab%initialize_column(text, 20, alignment=TABLEFT) + do n = 1, 2 + write(text, '(a,1x,i6)') 'VALUE', n + call this%inputtab%initialize_column(text, 15, alignment=TABCENTER) + end do + end if + ! + ! -- read data + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + n = this%parser%GetInteger() + if (n < 1 .or. n > this%maxbound) then + write(errmsg,'(4x,a,1x,i6)') & + '****ERROR. RNO MUST BE > 0 and <= ', this%maxbound + call store_error(errmsg) + cycle + end if + ! + ! -- read data from the rest of the line + call this%parser%GetRemainingLine(line) + call this%sfr_set_stressperiod(n, line, ichkustrm) + ! + ! -- write line to table + if (this%iprpak /= 0) then + call this%inputtab%add_term(n) + call this%inputtab%line_to_columns(line) + end if + end do + if (this%iprpak /= 0) then + call this%inputtab%finalize_table() + end if + + ! -- Reuse data from last stress period + else + write(this%iout,fmtlsp) trim(this%filtyp) + endif + ! + ! -- check upstream fraction values + if (ichkustrm /= 0) then + call this%sfr_check_ustrf() + end if + ! + ! -- write summary of package block error messages + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- return + return + end subroutine sfr_rp + + subroutine sfr_ad(this) +! ****************************************************************************** +! sfr_ad -- Add package connection to matrix +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(SfrType) :: this + ! -- local + integer(I4B) :: n + integer(I4B) :: iaux +! ------------------------------------------------------------------------------ + ! + ! -- Advance the time series manager + call this%TsManager%ad() + ! + ! -- update auxiliary variables by copying from the derived-type time + ! series variable into the bndpackage auxvar variable so that this + ! information is properly written to the GWF budget file + if (this%naux > 0) then + do n = 1, this%maxbound + do iaux = 1, this%naux + this%auxvar(iaux, n) = this%reaches(n)%auxvar(iaux)%value + end do + end do + end if + ! + ! -- reset upstream flow to zero and set specified stage + do n = 1, this%maxbound + this%usflow(n) = DZERO + if (this%iboundpak(n) < 0) then + this%stage(n) = this%reaches(n)%sstage%value + end if + end do + ! + ! -- pakmvrobj ad + if(this%imover == 1) then + call this%pakmvrobj%ad() + endif + ! + ! -- For each observation, push simulated value and corresponding + ! simulation time from "current" to "preceding" and reset + ! "current" value. + call this%obs%obs_ad() + ! + ! -- return + return + end subroutine sfr_ad + + subroutine sfr_cf(this, reset_mover) + ! ****************************************************************************** + ! sfr_cf -- Formulate the HCOF and RHS terms + ! Subroutine: (1) skip in no wells + ! (2) calculate hcof and rhs + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + ! -- dummy + class(SfrType) :: this + logical, intent(in), optional :: reset_mover + ! -- local variables + integer(I4B) :: n + integer(I4B) :: igwfnode + logical :: lrm + ! ------------------------------------------------------------------------------ + ! + ! -- Return if no sfr reaches + if(this%nbound == 0) return + ! + ! -- find highest active cell + do n = 1, this%nbound + igwfnode = this%igwftopnode(n) + if (igwfnode > 0) then + if (this%ibound(igwfnode) == 0) then + call this%dis%highest_active(igwfnode, this%ibound) + end if + end if + this%igwfnode(n) = igwfnode + this%nodelist(n) = igwfnode + end do + ! + ! -- pakmvrobj cf + lrm = .true. + if (present(reset_mover)) lrm = reset_mover + if(this%imover == 1 .and. lrm) then + call this%pakmvrobj%cf() + endif + ! + ! -- return + return + end subroutine sfr_cf + + subroutine sfr_fc(this, rhs, ia, idxglo, amatsln) + ! ************************************************************************** + ! sfr_fc -- Copy rhs and hcof into solution rhs and amat + ! ************************************************************************** + ! + ! SPECIFICATIONS: + ! -------------------------------------------------------------------------- + ! -- dummy + class(SfrType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + real(DP), dimension(:), intent(inout) :: amatsln + ! -- local + integer(I4B) :: i, n + integer(I4B) :: ipos + integer(I4B) :: node + real(DP) :: hgwf + real(DP) :: v + real(DP) :: hhcof + real(DP) :: rrhs +! -------------------------------------------------------------------------- + ! + ! -- pakmvrobj fc + if(this%imover == 1) then + call this%pakmvrobj%fc() + endif + ! + ! -- solve for each sfr reach + do n = 1, this%nbound + node = this%igwfnode(n) + if (node > 0) then + hgwf = this%xnew(node) + else + hgwf = DEP20 + end if + ! + ! -- save previous stage and upstream flow + this%stage0(n) = this%stage(n) + this%usflow0(n) = this%usflow(n) + ! + ! -- solve for flow in swr + if (this%iboundpak(n) /= 0) then + call this%sfr_solve(n, hgwf, hhcof, rrhs) + else + this%depth(n) = DZERO + this%stage(n) = this%strtop(n) + v = DZERO + call this%sfr_update_flows(n, v, v) + hhcof = DZERO + rrhs = DZERO + end if + this%hcof(n) = hhcof + this%rhs(n) = rrhs + end do + ! + ! -- Copy package rhs and hcof into solution rhs and amat + do i = 1, this%nbound + n = this%nodelist(i) + if (n < 1) cycle + rhs(n) = rhs(n) + this%rhs(i) + ipos = ia(n) + amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) + enddo + ! + ! -- return + return + end subroutine sfr_fc + + subroutine sfr_fn(this, rhs, ia, idxglo, amatsln) +! ************************************************************************** +! pak1fn -- Fill newton terms +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + ! -- dummy + class(SfrType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + real(DP), dimension(:), intent(inout) :: amatsln + ! -- local + integer(I4B) :: i, n + integer(I4B) :: ipos + real(DP) :: rterm, drterm + real(DP) :: rhs1, hcof1, q1 + real(DP) :: q2 + real(DP) :: hgwf +! -------------------------------------------------------------------------- + ! + ! -- Copy package rhs and hcof into solution rhs and amat + do i = 1, this%nbound + ! -- skip inactive reaches + if (this%iboundpak(i) < 1) cycle + ! -- skip if reach is not connected to gwf + n = this%nodelist(i) + if (n < 1) cycle + ipos = ia(n) + !rterm = this%hcof(i) * this%xnew(n) - this%rhs(i) + rterm = this%hcof(i) * this%xnew(n) + ! -- calculate perturbed head + hgwf = this%xnew(n) + DEM4 + call this%sfr_solve(i, hgwf, hcof1, rhs1, update=.false.) + q1 = rhs1 - hcof1 * hgwf + ! -- calculate unperturbed head + !hgwf = this%xnew(n) + !call this%sfr_solve(i, hgwf, hcof2, rhs2) + !q2 = rhs2 - hcof2 * hgwf + q2 = this%rhs(i) - this%hcof(i) * this%xnew(n) + ! -- calculate derivative + drterm = (q2 - q1) / DEM4 + ! -- add terms to convert conductance formulation into + ! newton-raphson formulation + !amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + drterm + amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + drterm - this%hcof(i) + rhs(n) = rhs(n) - rterm + drterm * this%xnew(n) + end do + ! + ! -- return + return + end subroutine sfr_fn + + subroutine sfr_cc(this, kiter, iend, icnvgmod, cpak, dpak) +! ************************************************************************** +! sfr_cc -- Final convergence check for package +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + use TdisModule, only: totim, kstp, kper, delt + ! -- dummy + class(SfrType), intent(inout) :: this + integer(I4B), intent(in) :: kiter + integer(I4B), intent(in) :: iend + integer(I4B), intent(in) :: icnvgmod + character(len=LENPAKLOC), intent(inout) :: cpak + real(DP), intent(inout) :: dpak + ! -- local + character(len=LENPAKLOC) :: cloc + character(len=LINELENGTH) :: tag + integer(I4B) :: icheck + integer(I4B) :: ipakfail + integer(I4B) :: locdhmax + integer(I4B) :: locrmax + integer(I4B) :: ntabrows + integer(I4B) :: ntabcols + integer(I4B) :: n + real(DP) :: dh + real(DP) :: r + real(DP) :: dhmax + real(DP) :: rmax + ! format +! -------------------------------------------------------------------------- + ! + ! -- initialize local variables + icheck = this%iconvchk + ipakfail = 0 + locdhmax = 0 + locrmax = 0 + dhmax = DZERO + rmax = DZERO + ! + ! -- if not saving package convergence data on check convergence if + ! the model is considered converged + if (this%ipakcsv == 0) then + if (icnvgmod == 0) then + icheck = 0 + end if + ! + ! -- saving package convergence data + else + ! + ! -- header for package csv + if (.not. associated(this%pakcsvtab)) then + ! + ! -- determine the number of columns and rows + ntabrows = 1 + ntabcols = 8 + ! + ! -- setup table + call table_cr(this%pakcsvtab, this%name, '') + call this%pakcsvtab%table_df(ntabrows, ntabcols, this%ipakcsv, & + lineseparator=.FALSE., separator=',', & + finalize=.FALSE.) + ! + ! -- add columns to package csv + tag = 'totim' + call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'kper' + call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'kstp' + call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'nouter' + call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'dvmax' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + tag = 'dvmax_loc' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + tag = 'dinflowmax' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + tag = 'dinflowmax_loc' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + end if + end if + ! + ! -- perform package convergence check + if (icheck /= 0) then + final_check: do n = 1, this%maxbound + if (this%iboundpak(n) == 0) cycle + dh = this%stage0(n) - this%stage(n) + r = this%usflow0(n) - this%usflow(n) + ! + ! -- normalize flow difference and convert to a depth + r = r * delt / this%surface_area(n) + ! + ! -- evaluate magnitude of differences + if (n == 1) then + locdhmax = n + dhmax = dh + locrmax = n + rmax = r + else + if (abs(dh) > abs(dhmax)) then + locdhmax = n + dhmax = dh + end if + if (abs(r) > abs(rmax)) then + locrmax = n + rmax = r + end if + end if + end do final_check + ! + ! -- set dpak and cpak + if (ABS(dhmax) > abs(dpak)) then + dpak = dhmax + write(cloc, "(a,'-(',i0,')-',a)") & + trim(this%name), locdhmax, 'stage' + cpak = trim(cloc) + end if + if (ABS(rmax) > abs(dpak)) then + dpak = rmax + write(cloc, "(a,'-(',i0,')-',a)") & + trim(this%name), locrmax, 'inflow' + cpak = trim(cloc) + end if + ! + ! -- write convergence data to package csv + if (this%ipakcsv /= 0) then + ! + ! -- write the data + call this%pakcsvtab%add_term(totim) + call this%pakcsvtab%add_term(kper) + call this%pakcsvtab%add_term(kstp) + call this%pakcsvtab%add_term(kiter) + call this%pakcsvtab%add_term(dhmax) + call this%pakcsvtab%add_term(locdhmax) + call this%pakcsvtab%add_term(rmax) + call this%pakcsvtab%add_term(locrmax) + ! + ! -- finalize the package csv + if (iend == 1) then + call this%pakcsvtab%finalize_table() + end if + end if + end if + ! + ! -- return + return + end subroutine sfr_cc + + + subroutine sfr_bd(this, x, idvfl, icbcfl, ibudfl, icbcun, iprobs, & + isuppress_output, model_budget, imap, iadv) +! ************************************************************************** +! bnd_bd -- Calculate Volumetric Budget +! Note that the compact budget will always be used. +! Subroutine: (1) Process each package entry +! (2) Write output +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + ! -- modules + use TdisModule, only: kstp, kper, delt, pertim, totim + use ConstantsModule, only: LENBOUNDNAME + use InputOutputModule, only: ulasav, ubdsv06 + use BudgetModule, only: BudgetType + ! -- dummy + class(SfrType) :: this + real(DP),dimension(:),intent(in) :: x + integer(I4B), intent(in) :: idvfl + integer(I4B), intent(in) :: icbcfl + integer(I4B), intent(in) :: ibudfl + integer(I4B), intent(in) :: icbcun + integer(I4B), intent(in) :: iprobs + integer(I4B), intent(in) :: isuppress_output + type(BudgetType), intent(inout) :: model_budget + integer(I4B), dimension(:), optional, intent(in) :: imap + integer(I4B), optional, intent(in) :: iadv + ! -- local + integer(I4B) :: i + integer(I4B) :: ibinun + real(DP) :: qext + ! -- for budget + integer(I4B) :: n + real(DP) :: d + real(DP) :: v + real(DP) :: qoutflow + real(DP) :: qfrommvr + real(DP) :: qtomvr + ! -- for observations + integer(I4B) :: iprobslocal + ! -- formats +! -------------------------------------------------------------------------- + ! + ! -- Suppress saving of simulated values; they + ! will be saved at end of this procedure. + iprobslocal = 0 + ! + ! -- call base functionality in bnd_bd + call this%BndType%bnd_bd(x, idvfl, icbcfl, ibudfl, icbcun, iprobslocal, & + isuppress_output, model_budget, iadv=1) + ! + ! -- Calculate qextoutflow and qoutflow for subsequent budgets + do n = 1, this%maxbound + ! + ! -- mover + qfrommvr = DZERO + qtomvr = DZERO + if (this%imover == 1) then + qfrommvr = this%pakmvrobj%get_qfrommvr(n) + qtomvr = this%pakmvrobj%get_qtomvr(n) + if (qtomvr > DZERO) then + qtomvr = -qtomvr + end if + endif + ! + ! -- external downstream stream flow + qext = this%dsflow(n) + qoutflow = DZERO + if (qext > DZERO) then + qext = -qext + end if + do i = 1, this%nconnreach(n) + if (this%reaches(n)%idir(i) > 0) cycle + qext = DZERO + exit + end do + ! + ! -- adjust external downstream stream flow using qtomvr + if (qext < DZERO) then + if (qtomvr < DZERO) then + qext = qext - qtomvr + end if + else + qoutflow = this%dsflow(n) + if (qoutflow > DZERO) then + qoutflow = -qoutflow + end if + end if + ! + ! -- set qextoutflow and qoutflow for cell by cell budget + ! output and observations + this%qextoutflow(n) = qext + this%qoutflow(n) = qoutflow + ! + end do + ! + ! -- For continuous observations, save simulated values. + if (this%obs%npakobs > 0 .and. iprobs > 0) then + call this%sfr_bd_obs() + end if + ! + ! -- set unit number for binary dependent variable output + ibinun = 0 + if(this%istageout /= 0) then + ibinun = this%istageout + end if + if(idvfl == 0) ibinun = 0 + if (isuppress_output /= 0) ibinun = 0 + ! + ! -- write sfr binary output + if (ibinun > 0) then + do n = 1, this%maxbound + d = this%depth(n) + v = this%stage(n) + if (this%iboundpak(n) == 0) then + v = DHNOFLO + else if (d == DZERO) then + v = DHDRY + end if + this%dbuff(n) = v + end do + call ulasav(this%dbuff, ' STAGE', kstp, kper, pertim, totim, & + this%maxbound, 1, 1, ibinun) + end if + ! + ! -- fill the budget object + call this%sfr_fill_budobj() + ! + ! -- write the flows from the budobj + ibinun = 0 + if(this%ibudgetout /= 0) then + ibinun = this%ibudgetout + end if + if(icbcfl == 0) ibinun = 0 + if (isuppress_output /= 0) ibinun = 0 + if (ibinun > 0) then + call this%budobj%save_flows(this%dis, ibinun, kstp, kper, delt, & + pertim, totim, this%iout) + end if + ! + ! + ! -- return + return + end subroutine sfr_bd + + subroutine sfr_ot(this, kstp, kper, iout, ihedfl, ibudfl) + ! ************************************************************************** + ! pak1t -- Output package budget + ! ************************************************************************** + ! + ! SPECIFICATIONS: + ! -------------------------------------------------------------------------- + ! -- dummy + class(SfrType) :: this + integer(I4B),intent(in) :: kstp + integer(I4B),intent(in) :: kper + integer(I4B),intent(in) :: iout + integer(I4B),intent(in) :: ihedfl + integer(I4B),intent(in) :: ibudfl + ! -- locals + character (len=20) :: cellid + integer(I4B) :: n + integer(I4B) :: node + real(DP) :: hgwf + real(DP) :: sbot + real(DP) :: depth, stage + real(DP) :: w, cond, grad + ! format + ! -------------------------------------------------------------------------- + ! + ! -- write sfr stage and depth table + if (ihedfl /= 0 .and. this%iprhed /= 0) then + ! + ! -- fill stage data + do n = 1, this%maxbound + node = this%igwfnode(n) + if (node > 0) then + call this%dis%noder_to_string(node, cellid) + hgwf = this%xnew(node) + else + cellid = 'none' + end if + if(this%inamedbound==1) then + call this%stagetab%add_term(this%boundname(n)) + end if + call this%stagetab%add_term(n) + call this%stagetab%add_term(cellid) + depth = this%depth(n) + stage = this%stage(n) + w = this%top_width_wet(n, depth) + call this%stagetab%add_term(stage) + call this%stagetab%add_term(depth) + call this%stagetab%add_term(w) + call this%sfr_calc_cond(n, cond) + if (node > 0) then + sbot = this%strtop(n) - this%bthick(n) + if (hgwf < sbot) then + grad = stage - sbot + else + grad = stage - hgwf + end if + grad = grad / this%bthick(n) + call this%stagetab%add_term(hgwf) + call this%stagetab%add_term(cond) + call this%stagetab%add_term(grad) + else + call this%stagetab%add_term('--') + call this%stagetab%add_term('--') + call this%stagetab%add_term('--') + end if + end do + end if + ! + ! -- Output sfr flow table + if (ibudfl /= 0 .and. this%iprflow /= 0) then + call this%budobj%write_flowtable(this%dis) + end if + ! + ! -- Output sfr budget + call this%budobj%write_budtable(kstp, kper, iout) + ! + ! -- return + return + end subroutine sfr_ot + + subroutine sfr_da(this) +! ****************************************************************************** +! sfr_da -- deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(SfrType) :: this + ! -- local + integer(I4B) :: n +! ------------------------------------------------------------------------------ + ! + ! -- arrays + call mem_deallocate(this%qoutflow) + call mem_deallocate(this%qextoutflow) + deallocate(this%csfrbudget) + deallocate(this%sfrname) + call mem_deallocate(this%dbuff) + deallocate(this%cauxcbc) + call mem_deallocate(this%qauxcbc) + call mem_deallocate(this%iboundpak) + call mem_deallocate(this%igwfnode) + call mem_deallocate(this%igwftopnode) + call mem_deallocate(this%length) + call mem_deallocate(this%width) + call mem_deallocate(this%strtop) + call mem_deallocate(this%bthick) + call mem_deallocate(this%hk) + call mem_deallocate(this%slope) + call mem_deallocate(this%ustrf) + call mem_deallocate(this%ftotnd) + call mem_deallocate(this%usflow) + call mem_deallocate(this%dsflow) + call mem_deallocate(this%depth) + call mem_deallocate(this%stage) + call mem_deallocate(this%gwflow) + call mem_deallocate(this%simevap) + call mem_deallocate(this%simrunoff) + call mem_deallocate(this%stage0) + call mem_deallocate(this%usflow0) + ! + ! -- deallocation diversions + do n = 1, this%maxbound + if (this%ndiv(n) > 0) then + call this%deallocate_diversion(n) + endif + enddo + call mem_deallocate(this%ndiv) + ! + ! -- deallocate reaches + do n = 1, this%maxbound + call this%deallocate_reach(n) + enddo + deallocate(this%reaches) + call mem_deallocate(this%nconnreach) + ! + ! -- ia ja + deallocate(this%ia) + deallocate(this%ja) + ! + ! -- budobj + call this%budobj%budgetobject_da() + deallocate(this%budobj) + nullify(this%budobj) + ! + ! -- stage table + if (this%iprhed > 0) then + call this%stagetab%table_da() + deallocate(this%stagetab) + nullify(this%stagetab) + end if + ! + ! -- package csv table + if (this%ipakcsv > 0) then + call this%pakcsvtab%table_da() + deallocate(this%pakcsvtab) + nullify(this%pakcsvtab) + end if + ! + ! -- scalars + call mem_deallocate(this%iprhed) + call mem_deallocate(this%istageout) + call mem_deallocate(this%ibudgetout) + call mem_deallocate(this%ipakcsv) + call mem_deallocate(this%idiversions) + call mem_deallocate(this%maxsfrit) + call mem_deallocate(this%bditems) + call mem_deallocate(this%cbcauxitems) + call mem_deallocate(this%unitconv) + call mem_deallocate(this%dmaxchg) + call mem_deallocate(this%deps) + call mem_deallocate(this%nconn) + call mem_deallocate(this%icheck) + call mem_deallocate(this%iconvchk) + nullify(this%gwfiss) + ! + ! -- call BndType deallocate + call this%BndType%bnd_da() + ! + ! -- return + end subroutine sfr_da + + subroutine define_listlabel(this) +! ****************************************************************************** +! define_listlabel -- Define the list heading that is written to iout when +! PRINT_INPUT option is used. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(SfrType), intent(inout) :: this +! ------------------------------------------------------------------------------ + ! + ! -- create the header list label + this%listlabel = trim(this%filtyp) // ' NO.' + if(this%dis%ndim == 3) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif(this%dis%ndim == 2) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + else + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + endif + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' + if(this%inamedbound == 1) then + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + endif + ! + ! -- return + return + end subroutine define_listlabel + + + subroutine sfr_set_pointers(this, neq, ibound, xnew, xold, flowja) +! ****************************************************************************** +! set_pointers -- Set pointers to model arrays and variables so that a package +! has access to these things. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(SfrType) :: this + integer(I4B), pointer :: neq + integer(I4B), dimension(:), pointer, contiguous :: ibound + real(DP), dimension(:), pointer, contiguous :: xnew + real(DP), dimension(:), pointer, contiguous :: xold + real(DP), dimension(:), pointer, contiguous :: flowja + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- call base BndType set_pointers + call this%BndType%set_pointers(neq, ibound, xnew, xold, flowja) + ! + ! -- return + end subroutine sfr_set_pointers + + ! + ! -- Procedures related to observations (type-bound) + logical function sfr_obs_supported(this) + ! ****************************************************************************** + ! sfr_obs_supported + ! -- Return true because sfr package supports observations. + ! -- Overrides BndType%bnd_obs_supported() + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + class(SfrType) :: this + ! ------------------------------------------------------------------------------ + sfr_obs_supported = .true. + return + end function sfr_obs_supported + + + subroutine sfr_df_obs(this) + ! ****************************************************************************** + ! sfr_df_obs (implements bnd_df_obs) + ! -- Store observation type supported by sfr package. + ! -- Overrides BndType%bnd_df_obs + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + ! -- dummy + class(SfrType) :: this + ! -- local + integer(I4B) :: indx + ! ------------------------------------------------------------------------------ + ! + ! -- Store obs type and assign procedure pointer + ! for stage observation type. + call this%obs%StoreObsType('stage', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for inflow observation type. + call this%obs%StoreObsType('inflow', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for inflow observation type. + call this%obs%StoreObsType('ext-inflow', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for rainfall observation type. + call this%obs%StoreObsType('rainfall', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for runoff observation type. + call this%obs%StoreObsType('runoff', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for evaporation observation type. + call this%obs%StoreObsType('evaporation', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for outflow observation type. + call this%obs%StoreObsType('outflow', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for ext-outflow observation type. + call this%obs%StoreObsType('ext-outflow', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for to-mvr observation type. + call this%obs%StoreObsType('to-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for sfr-frommvr observation type. + call this%obs%StoreObsType('from-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for sfr observation type. + call this%obs%StoreObsType('sfr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for upstream flow observation type. + call this%obs%StoreObsType('upstream-flow', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for downstream flow observation type. + call this%obs%StoreObsType('downstream-flow', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + return + end subroutine sfr_df_obs + + + subroutine sfr_bd_obs(this) + ! ************************************************************************** + ! sfr_bd_obs + ! -- Calculate observations this time step and call + ! ObsType%SaveOneSimval for each SfrType observation. + ! ************************************************************************** + ! + ! SPECIFICATIONS: + ! -------------------------------------------------------------------------- + ! -- dummy + class(SfrType), intent(inout) :: this + ! -- local + integer(I4B) :: i, j, n, nn + real(DP) :: v + character(len=100) :: msg + type(ObserveType), pointer :: obsrv => null() + !--------------------------------------------------------------------------- + ! + ! Write simulated values for all sfr observations + if (this%obs%npakobs>0) then + call this%obs%obs_bd_clear() + do i=1 ,this%obs%npakobs + obsrv => this%obs%pakobs(i)%obsrv + nn = size(obsrv%indxbnds) + do j = 1,nn + n = obsrv%indxbnds(j) + v = DZERO + select case (obsrv%ObsTypeId) + case ('STAGE') + v = this%stage(n) + case ('TO-MVR') + v = DNODATA + if (this%imover == 1) then + v = this%pakmvrobj%get_qtomvr(n) + if (v > DZERO) then + v = -v + end if + end if + case ('FROM-MVR') + v = DNODATA + if (this%imover == 1) then + v = this%pakmvrobj%get_qfrommvr(n) + end if + case ('EXT-INFLOW') + v = this%reaches(n)%inflow%value + case ('INFLOW') + v = this%usflow(n) + case ('OUTFLOW') + v = this%qoutflow(n) + case ('EXT-OUTFLOW') + v = this%qextoutflow(n) + case ('RAINFALL') + v = this%reaches(n)%rain%value + case ('RUNOFF') + v = this%simrunoff(n) + case ('EVAPORATION') + v = this%simevap(n) + case ('SFR') + v = this%gwflow(n) + case ('UPSTREAM-FLOW') + v = this%usflow(n) + if (this%imover == 1) then + v = v + this%pakmvrobj%get_qfrommvr(n) + end if + case ('DOWNSTREAM-FLOW') + v = this%dsflow(n) + if (v > DZERO) then + v = -v + end if + case default + msg = 'Error: Unrecognized observation type: ' // trim(obsrv%ObsTypeId) + call store_error(msg) + end select + call this%obs%SaveOneSimval(obsrv, v) + end do + end do + end if + ! + ! -- write summary of package block error messages + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + return + end subroutine sfr_bd_obs + + + subroutine sfr_rp_obs(this) + ! -- dummy + class(SfrType), intent(inout) :: this + ! -- local + integer(I4B) :: i, j, n, nn1 + character(len=200) :: errmsg + character(len=LENBOUNDNAME) :: bname + logical :: jfound + class(ObserveType), pointer :: obsrv => null() + ! -------------------------------------------------------------------------- + ! -- formats +10 format('Error: Boundary "',a,'" for observation "',a, & + '" is invalid in package "',a,'"') +30 format('Error: Boundary name not provided for observation "',a, & + '" in package "',a,'"') + do i = 1, this%obs%npakobs + obsrv => this%obs%pakobs(i)%obsrv + ! + ! -- indxbnds needs to be deallocated and reallocated (using + ! ExpandArray) each stress period because list of boundaries + ! can change each stress period. + if (allocated(obsrv%indxbnds)) then + deallocate(obsrv%indxbnds) + end if + ! + ! -- get node number 1 + nn1 = obsrv%NodeNumber + if (nn1 == NAMEDBOUNDFLAG) then + bname = obsrv%FeatureName + if (bname /= '') then + ! -- Observation location(s) is(are) based on a boundary name. + ! Iterate through all boundaries to identify and store + ! corresponding index(indices) in bound array. + jfound = .false. + do j = 1, this%maxbound + if (this%boundname(j) == bname) then + jfound = .true. + call ExpandArray(obsrv%indxbnds) + n = size(obsrv%indxbnds) + obsrv%indxbnds(n) = j + endif + enddo + if (.not. jfound) then + write(errmsg,10)trim(bname), trim(obsrv%name), trim(this%name) + call store_error(errmsg) + endif + else + write(errmsg,30) trim(obsrv%name), trim(this%name) + call store_error(errmsg) + endif + elseif (nn1 < 1 .or. nn1 > this%maxbound) then + write(errmsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & + 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & + ' reach must be > 0 and <=', this%maxbound, & + '(specified value is ', nn1, ')' + call store_error(errmsg) + else + call ExpandArray(obsrv%indxbnds) + n = size(obsrv%indxbnds) + if (n == 1) then + obsrv%indxbnds(1) = nn1 + else + errmsg = 'Programming error in sfr_rp_obs' + call store_error(errmsg) + endif + end if + ! + ! -- catch non-cumulative observation assigned to observation defined + ! by a boundname that is assigned to more than one element + if (obsrv%ObsTypeId == 'STAGE') then + nn1 = obsrv%NodeNumber + if (nn1 == NAMEDBOUNDFLAG) then + n = size(obsrv%indxbnds) + if (n > 1) then + write(errmsg, '(4x,a,4(1x,a))') & + 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & + 'for observation', trim(adjustl(obsrv%Name)), & + ' must be assigned to a reach with a unique boundname.' + call store_error(errmsg) + end if + end if + end if + ! + ! -- check that node number 1 is valid; call store_error if not + n = size(obsrv%indxbnds) + do j = 1, n + nn1 = obsrv%indxbnds(j) + if (nn1 < 1 .or. nn1 > this%maxbound) then + write(errmsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & + 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & + ' reach must be > 0 and <=', this%maxbound, & + '(specified value is ', nn1, ')' + call store_error(errmsg) + end if + end do + end do + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + return + end subroutine sfr_rp_obs + + + ! + ! -- Procedures related to observations (NOT type-bound) + subroutine sfr_process_obsID(obsrv, dis, inunitobs, iout) + ! -- This procedure is pointed to by ObsDataType%ProcesssIdPtr. It processes + ! the ID string of an observation definition for sfr-package observations. + ! -- dummy + type(ObserveType), intent(inout) :: obsrv + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: inunitobs + integer(I4B), intent(in) :: iout + ! -- local + integer(I4B) :: nn1 + integer(I4B) :: icol, istart, istop + character(len=LINELENGTH) :: strng + character(len=LENBOUNDNAME) :: bndname + ! formats + ! + strng = obsrv%IDstring + ! -- Extract reach number from strng and store it. + ! If 1st item is not an integer(I4B), it should be a + ! boundary name--deal with it. + icol = 1 + ! -- get reach number or boundary name + call extract_idnum_or_bndname(strng, icol, istart, istop, nn1, bndname) + if (nn1 == NAMEDBOUNDFLAG) then + obsrv%FeatureName = bndname + endif + ! -- store reach number (NodeNumber) + obsrv%NodeNumber = nn1 + ! + return + end subroutine sfr_process_obsID + + ! + ! -- private sfr methods + ! + + + subroutine sfr_set_stressperiod(this, n, line, ichkustrm) +! ****************************************************************************** +! sfr_set_stressperiod -- Set a stress period attribute for sfr reach n +! using keywords. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + !use ConstantsModule, only: LINELENGTH, DTWO + use TdisModule, only: kper, perlen, totimsav + use TimeSeriesManagerModule, only: read_single_value_or_time_series + use InputOutputModule, only: urword + use SimModule, only: ustop, store_error + ! -- dummy + class(SfrType),intent(inout) :: this + integer(I4B), intent(in) :: n + character (len=*), intent(in) :: line + integer(I4B), intent(inout) :: ichkustrm + ! -- local + character(len=10) :: cnum + character(len=LINELENGTH) :: text + character(len=LINELENGTH) :: caux + character(len=LINELENGTH) :: keyword + character(len=LINELENGTH) :: errmsg + character(len=LENBOUNDNAME) :: bndName + integer(I4B) :: ival, istart, istop, jj + integer(I4B) :: i0 + integer(I4B) :: lloc + integer(I4B) :: idiv + integer(I4B) :: iaux + real(DP) :: rval + real(DP) :: endtim + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- Find time interval of current stress period. + endtim = totimsav + perlen(kper) + ! + ! -- Assign boundary name + if (this%inamedbound==1) then + bndName = this%boundname(n) + else + bndName = '' + end if + ! + ! -- read line + lloc = 1 + call urword(line, lloc, istart, istop, 1, ival, rval, this%iout, this%inunit) + i0 = istart + keyword = line(istart:istop) + select case (line(istart:istop)) + case ('STATUS') + ichkustrm = 1 + call urword(line, lloc, istart, istop, 1, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + if (text == 'INACTIVE') then + this%iboundpak(n) = 0 + else if (text == 'ACTIVE') then + this%iboundpak(n) = 1 + else if (text == 'SIMPLE') then + this%iboundpak(n) = -1 + else + write(errmsg,'(4x,a,a)') & + '****ERROR. UNKNOWN '//trim(this%text)//' SFR STATUS KEYWORD: ', & + text + call store_error(errmsg) + end if + case ('MANNING') + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 1 ! For 'MANNING' + call read_single_value_or_time_series(text, & + this%reaches(n)%rough%value, & + this%reaches(n)%rough%name, & + endtim, & + this%Name, 'BND', this%TsManager, & + this%iprpak, n, jj, 'MANNING', & + bndName, this%inunit) + case ('STAGE') + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 1 ! For 'STAGE' + call read_single_value_or_time_series(text, & + this%reaches(n)%sstage%value, & + this%reaches(n)%sstage%name, & + endtim, & + this%Name, 'BND', this%TsManager, & + this%iprpak, n, jj, 'STAGE', & + bndName, this%inunit) + case ('RAINFALL') + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 1 ! For 'RAIN' + call read_single_value_or_time_series(text, & + this%reaches(n)%rain%value, & + this%reaches(n)%rain%name, & + endtim, & + this%Name, 'BND', this%TsManager, & + this%iprpak, n, jj, 'RAINFALL', & + bndName, this%inunit) + case ('EVAPORATION') + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 2 ! For 'EVAP' + call read_single_value_or_time_series(text, & + this%reaches(n)%evap%value, & + this%reaches(n)%evap%name, & + endtim, & + this%Name, 'BND', this%TsManager, & + this%iprpak, n, jj, & + 'EVAPORATION', bndName, & + this%inunit) + case ('RUNOFF') + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 3 ! For 'RUNOFF' + call read_single_value_or_time_series(text, & + this%reaches(n)%runoff%value, & + this%reaches(n)%runoff%name, & + endtim, & + this%Name, 'BND', this%TsManager, & + this%iprpak, n, jj, 'RUNOFF', & + bndName, this%inunit) + case ('INFLOW') + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 4 ! For 'INFLOW' + call read_single_value_or_time_series(text, & + this%reaches(n)%inflow%value, & + this%reaches(n)%inflow%name, & + endtim, & + this%Name, 'BND', this%TsManager, & + this%iprpak, n, jj, 'INFLOW', & + bndName, this%inunit) + case ('DIVERSION') + ! + ! -- make sure reach has at least one diversion + if (this%ndiv(n) < 1) then + write(cnum, '(i0)') n + errmsg = 'ERROR: diversions cannot be specified for reach ' // trim(cnum) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- read diversion number + call urword(line, lloc, istart, istop, 2, ival, rval, this%iout, this%inunit) + if (ival < 1 .or. ival > this%ndiv(n)) then + write(cnum, '(i0)') n + errmsg = 'ERROR: reach ' // trim(cnum) + write(cnum, '(i0)') this%ndiv(n) + errmsg = trim(errmsg) // ' diversion number should be between 1 ' // & + 'and ' // trim(cnum) // '.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end if + idiv = ival + ! + ! -- read value + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 5 ! for 'DIVERSION' + call read_single_value_or_time_series(text, & + this%reaches(n)%diversion(idiv)%rate%value, & + this%reaches(n)%diversion(idiv)%rate%name, & + endtim, & + this%Name, 'BND', this%TsManager, & + this%iprpak, n, jj, 'DIVERSION', & + bndName, this%inunit) + + case ('UPSTREAM_FRACTION') + ichkustrm = 1 + call urword(line, lloc, istart, istop, 3, ival, rval, this%iout, this%inunit) + this%ustrf(n) = rval + + case ('AUXILIARY') + call urword(line, lloc, istart, istop, 1, ival, rval, this%iout, this%inunit) + caux = line(istart:istop) + do iaux = 1, this%naux + if (trim(adjustl(caux)) /= trim(adjustl(this%auxname(iaux)))) cycle + call urword(line, lloc, istart, istop, 0, ival, rval, this%iout, this%inunit) + text = line(istart:istop) + jj = 1 !iaux + call read_single_value_or_time_series(text, & + this%reaches(n)%auxvar(iaux)%value, & + this%reaches(n)%auxvar(iaux)%name, & + endtim, & + this%Name, 'BND', this%TsManager, & + this%iprpak, n, jj, & + this%auxname(iaux), bndName, & + this%inunit) + exit + end do + + case default + write(errmsg,'(4x,a,a)') & + '****ERROR. UNKNOWN '//trim(this%text)//' SFR DATA KEYWORD: ', & + line(istart:istop) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + ! + ! -- return + return + end subroutine sfr_set_stressperiod + + subroutine allocate_reach(this, n, nboundchk) +! ****************************************************************************** +! allocate_reach -- Allocate pointers for reach(n). +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(SfrType) :: this + integer(I4B), intent(in) :: n + integer(I4B), intent(in) :: nboundchk + ! -- local + character(len=LINELENGTH) :: errmsg + character(len=10) :: crch + integer(I4B) :: iaux +! ------------------------------------------------------------------------------ + ! + ! -- make sure reach has not been allocated + if (nboundchk > 1) then + write(crch, '(i10)') n + errmsg = 'reach ' // trim(crch) // ' is already allocated' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end if + ! -- allocate pointers + allocate(this%reaches(n)%rough) + allocate(this%reaches(n)%rough%name) + allocate(this%reaches(n)%rough%value) + allocate(this%reaches(n)%rain) + allocate(this%reaches(n)%rain%name) + allocate(this%reaches(n)%rain%value) + allocate(this%reaches(n)%evap) + allocate(this%reaches(n)%evap%name) + allocate(this%reaches(n)%evap%value) + allocate(this%reaches(n)%inflow) + allocate(this%reaches(n)%inflow%name) + allocate(this%reaches(n)%inflow%value) + allocate(this%reaches(n)%runoff) + allocate(this%reaches(n)%runoff%name) + allocate(this%reaches(n)%runoff%value) + allocate(this%reaches(n)%sstage) + allocate(this%reaches(n)%sstage%name) + allocate(this%reaches(n)%sstage%value) + if (this%naux > 0) then + allocate(this%reaches(n)%auxvar(this%naux)) + do iaux = 1, this%naux + allocate(this%reaches(n)%auxvar(iaux)%name) + allocate(this%reaches(n)%auxvar(iaux)%value) + end do + end if + ! + ! -- initialize a few items + this%reaches(n)%rough%name = '' + this%reaches(n)%rain%name = '' + this%reaches(n)%evap%name = '' + this%reaches(n)%inflow%name = '' + this%reaches(n)%runoff%name = '' + this%reaches(n)%sstage%name = '' + this%reaches(n)%rough%value = DZERO + this%reaches(n)%rain%value = DZERO + this%reaches(n)%evap%value = DZERO + this%reaches(n)%inflow%value = DZERO + this%reaches(n)%runoff%value = DZERO + this%reaches(n)%sstage%value = DZERO + do iaux = 1, this%naux + this%reaches(n)%auxvar(iaux)%value = DZERO + end do + ! + ! -- return + return + end subroutine allocate_reach + + subroutine deallocate_reach(this, n) +! ****************************************************************************** +! deallocate_reach -- Deallocate pointers for reach(n). +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(SfrType) :: this + integer(I4B), intent(in) :: n + ! -- local + integer(I4B) :: iaux +! ------------------------------------------------------------------------------ + ! + ! -- connections + if (this%nconnreach(n) > 0) then + deallocate(this%reaches(n)%iconn) + deallocate(this%reaches(n)%idir) + deallocate(this%reaches(n)%idiv) + deallocate(this%reaches(n)%qconn) + endif + ! + ! -- deallocate pointers + deallocate(this%reaches(n)%rough%name) + deallocate(this%reaches(n)%rough%value) + deallocate(this%reaches(n)%rough) + deallocate(this%reaches(n)%rain%name) + deallocate(this%reaches(n)%rain%value) + deallocate(this%reaches(n)%rain) + deallocate(this%reaches(n)%evap%name) + deallocate(this%reaches(n)%evap%value) + deallocate(this%reaches(n)%evap) + deallocate(this%reaches(n)%inflow%name) + deallocate(this%reaches(n)%inflow%value) + deallocate(this%reaches(n)%inflow) + deallocate(this%reaches(n)%runoff%name) + deallocate(this%reaches(n)%runoff%value) + deallocate(this%reaches(n)%runoff) + deallocate(this%reaches(n)%sstage%name) + deallocate(this%reaches(n)%sstage%value) + deallocate(this%reaches(n)%sstage) + if (this%naux > 0) then + do iaux = 1, this%naux + deallocate(this%reaches(n)%auxvar(iaux)%name) + deallocate(this%reaches(n)%auxvar(iaux)%value) + end do + deallocate(this%reaches(n)%auxvar) + end if + ! + ! -- return + return + end subroutine deallocate_reach + + subroutine allocate_diversion(this, n, ndiv) +! ****************************************************************************** +! allocate_diversion -- Allocate diversion pointers for reach(n). +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(SfrType) :: this + integer(I4B), intent(in) :: n + integer(I4B), intent(in) :: ndiv + ! -- local + character(len=LINELENGTH) :: errmsg + character(len=10) :: crch + integer(I4B) :: j +! ------------------------------------------------------------------------------ + ! + ! -- make sure reach has not been allocated + if (associated(this%reaches(n)%diversion)) then + write(crch, '(i10)') n + errmsg = 'ERROR: reach ' // trim(adjustl(crch)) // & + ' diversions are already allocated' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end if + ! -- allocate pointers + allocate(this%reaches(n)%diversion(ndiv)) + do j = 1, ndiv + allocate(this%reaches(n)%diversion(j)%reach) + allocate(this%reaches(n)%diversion(j)%cprior) + allocate(this%reaches(n)%diversion(j)%iprior) + allocate(this%reaches(n)%diversion(j)%rate) + allocate(this%reaches(n)%diversion(j)%rate%name) + allocate(this%reaches(n)%diversion(j)%rate%value) + ! -- initialize a few variables + this%reaches(n)%diversion(j)%reach = 0 + this%reaches(n)%diversion(j)%cprior = '' + this%reaches(n)%diversion(j)%iprior = 0 + this%reaches(n)%diversion(j)%rate%name = '' + this%reaches(n)%diversion(j)%rate%value = DZERO + end do + ! + ! -- return + return + end subroutine allocate_diversion + + subroutine deallocate_diversion(this, n) +! ****************************************************************************** +! deallocate_diversion +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(SfrType) :: this + integer(I4B), intent(in) :: n + ! -- local + integer(I4B) :: j +! ------------------------------------------------------------------------------ + ! + ! -- make sure reach has not been allocated + ! -- allocate pointers + do j = 1, this%ndiv(n) + deallocate(this%reaches(n)%diversion(j)%reach) + deallocate(this%reaches(n)%diversion(j)%cprior) + deallocate(this%reaches(n)%diversion(j)%iprior) + deallocate(this%reaches(n)%diversion(j)%rate%name) + deallocate(this%reaches(n)%diversion(j)%rate%value) + deallocate(this%reaches(n)%diversion(j)%rate) + end do + deallocate(this%reaches(n)%diversion) + ! + ! -- return + return + end subroutine deallocate_diversion + + subroutine sfr_solve(this, n, h, hcof, rhs, update) + ! ****************************************************************************** + ! sfr_solve -- Solve continuity equation + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + class(SfrType) :: this + integer(I4B), intent(in) :: n + real(DP), intent(in) :: h + real(DP), intent(inout) :: hcof + real(DP), intent(inout) :: rhs + logical, intent(in), optional :: update + ! -- local + logical :: lupdate + integer(I4B) :: i, ii + integer(I4B) :: n2 + integer(I4B) :: isolve + integer(I4B) :: iic, iic2, iic3, iic4 + integer(I4B) :: ibflg + real(DP) :: hgwf + real(DP) :: qu, qi, qr, qe, qro, qmp, qsrc + real(DP) :: qfrommvr + real(DP) :: qgwf + real(DP) :: qmpsrc + real(DP) :: qc + real(DP) :: qt + real(DP) :: tp + real(DP) :: bt + real(DP) :: hsfr + real(DP) :: cstr + real(DP) :: qd + real(DP) :: en1, en2 + real(DP) :: qen1 + real(DP) :: f1, f2 + real(DP) :: qgwf1, qgwf2, qgwfp, qgwfold + real(DP) :: fhstr1, fhstr2 + real(DP) :: d1, d2, dpp, dx + real(DP) :: q1, q2 + real(DP) :: derv + real(DP) :: dlh, dlhold + real(DP) :: fp + real(DP) :: sat, sat1, sat2 + real(DP) :: err, errold + real(DP) :: sumleak, sumrch + ! ------------------------------------------------------------------------------ + ! + ! -- + if (present(update)) then + lupdate = update + else + lupdate = .true. + end if + ! + ! -- calculate hgwf + hgwf = h + ! + ! + hcof = DZERO + rhs = DZERO + ! + ! -- initialize q1, q2, and qgwf + q1 = DZERO + q2 = DZERO + qgwf = DZERO + qgwfold = DZERO + ! + ! -- calculate initial depth assuming a wide cross-section and ignore + ! groundwater leakage + ! -- calculate upstream flow + qu = DZERO + do i = 1, this%nconnreach(n) + if (this%reaches(n)%idir(i) < 0) cycle + n2 = this%reaches(n)%iconn(i) + do ii = 1, this%nconnreach(n2) + if (this%reaches(n2)%idir(ii) > 0) cycle + if (this%reaches(n2)%iconn(ii) /= n) cycle + qu = qu + this%reaches(n2)%qconn(ii) + end do + end do + this%usflow(n) = qu + ! -- calculate remaining terms + qi = this%reaches(n)%inflow%value + qr = this%reaches(n)%rain%value * this%width(n) * this%length(n) + qe = this%reaches(n)%evap%value * this%width(n) * this%length(n) + qro = this%reaches(n)%runoff%value + ! + ! -- Water mover term; assume that it goes in at the upstream end of the reach + qfrommvr = DZERO + if(this%imover == 1) then + qfrommvr = this%pakmvrobj%get_qfrommvr(n) + endif + ! + ! -- calculate sum of sources to the reach excluding groundwater leakage + qc = qu + qi + qr - qe + qro + qfrommvr + ! + ! -- adjust runoff or evaporation if sum of sources is negative + if (qc < DZERO) then + ! + ! -- calculate sources without et + qt = qu + qi + qr + qro + qfrommvr + ! + ! -- runoff exceeds sources of water for reach + if (qt < DZERO) then + qro = -(qu + qi + qr + qfrommvr) + qe = DZERO + ! + ! -- evaporation exceeds sources of water for reach + else + qe = qu + qi + qr + qro + qfrommvr + end if + qc = qu + qi + qr - qe + qro + qfrommvr + end if + ! + ! -- set simulated evaporation and runoff + this%simevap(n) = qe + this%simrunoff(n) = qro + ! + ! -- calculate flow at the middle of the reach and excluding groundwater leakage + qmp = qu + qi + qfrommvr + DHALF * (qr - qe + qro) + qmpsrc = qmp + ! + ! -- calculate stream depth at the midpoint + if (this%iboundpak(n) > 0) then + call this%sfr_rectch_depth(n, qmp, d1) + else + this%stage(n) = this%reaches(n)%sstage%value + d1 = max(DZERO, this%stage(n) - this%strtop(n)) + end if + ! + ! -- calculate sources/sinks for reach excluding groundwater leakage + call this%sfr_calc_qsource(n, d1, qsrc) + ! + ! -- calculate initial reach stage, downstream flow, and groundwater leakage + tp = this%strtop(n) + bt = tp - this%bthick(n) + hsfr = d1 + tp + qd = MAX(qsrc, DZERO) + qgwf = DZERO + ! + ! -- calculate reach conductance for a unit depth of water + ! if equal to zero will skip iterations + call this%sfr_calc_cond(n, cstr) + ! + ! -- set flag to skip iterations + isolve = 1 + if (hsfr <= tp .and. hgwf <= tp) isolve = 0 + if (hgwf <= tp .and. qc < DEM30) isolve = 0 + if (cstr < DEM30) isolve = 0 + if (this%iboundpak(n) < 0) isolve = 0 + ! + ! -- iterate to achieve solution + itersol: if (isolve /= 0) then + ! + ! -- estimate initial end points + en1 = DZERO + if (d1 > DEM30) then + if ((tp - hgwf) > DEM30) then + en2 = DP9 * d1 + else + en2 = D1P1 * d1 - (tp - hgwf) + end if + else if ((tp - hgwf) > DEM30) then + en2 = DONE + else + en2 = DP99 * (hgwf - tp) + end if + ! + ! -- estimate flow at end points + ! -- end point 1 + if (hgwf > tp) then + qgwf1 = cstr * (tp - hgwf) + qen1 = qmp - DHALF * qgwf1 + else + qgwf1 = DZERO + qen1 = qmpsrc + end if + if (hgwf > bt) then + qgwf2 = cstr * (tp + en2 - hgwf) + else + qgwf2 = cstr * (tp + en2 - bt) + end if + if (qgwf2 > qsrc) qgwf2 = qsrc + ! -- calculate two depths + call this%sfr_rectch_depth(n, (qmpsrc-DHALF*qgwf1), d1) + call this%sfr_rectch_depth(n, (qmpsrc-DHALF*qgwf2), d2) + ! -- determine roots + if (d1 > DEM30) then + f1 = en1 - d1 + else + en1 = DZERO + f1 = en1 - DZERO + end if + if (d2 > DEM30) then + f2 = en2 - d2 + if (f2 < DEM30) en2 = d2 + else + d2 = DZERO + f2 = en2 - DZERO + end if + ! + ! -- iterate to find a solution + dpp = DHALF * (en1 + en2) + dx = dpp + iic = 0 + iic2 = 0 + iic3 = 0 + fhstr1 = DZERO + fhstr2 = DZERO + qgwfp = DZERO + dlhold = DZERO + do i = 1, this%maxsfrit + ibflg = 0 + d1 = dpp + d2 = d1 + DTWO * this%deps + ! -- calculate q at midpoint at both end points + call this%sfr_calc_qman(n, d1, q1) + call this%sfr_calc_qman(n, d2, q2) + ! -- calculate groundwater leakage at both end points + call sChSmooth(d1, sat1, derv) + call sChSmooth(d2, sat2, derv) + if (hgwf > bt) then + qgwf1 = sat1 * cstr * (d1 + tp - hgwf) + qgwf2 = sat2 * cstr * (d2 + tp - hgwf) + else + qgwf1 = sat1 * cstr * (d1 + tp - bt) + qgwf2 = sat2 * cstr * (d2 + tp - bt) + end if + ! + if (qgwf1 >= qsrc) then + en2 = dpp + dpp = DHALF * (en1 + en2) + call sChSmooth(dpp, sat, derv) + if (hgwf > bt) then + qgwfp = sat * cstr * (dpp + tp - hgwf) + else + qgwfp = sat * cstr * (dpp + tp - bt) + end if + if (qgwfp > qsrc) qgwfp = qsrc + call this%sfr_rectch_depth(n, (qmpsrc-DHALF*qgwfp), dx) + ibflg = 1 + else + fhstr1 = (qmpsrc-DHALF*qgwf1) - q1 + fhstr2 = (qmpsrc-DHALF*qgwf2) - q2 + end if + ! + if (ibflg == 0) then + derv = DZERO + if (abs(d1-d2) > DZERO) then + derv = (fhstr1-fhstr2) / (d1 - d2) + end if + if (abs(derv) > DEM30) then + dlh = -fhstr1 / derv + else + dlh = DZERO + end if + dpp = d1 + dlh + ! + ! -- updated depth outside of endpoints - use bisection instead + if ((dpp >= en2) .or. (dpp <= en1)) then + if (abs(dlh) > abs(dlhold) .or. dpp < DEM30) then + ibflg = 1 + dpp = DHALF * (en1 + en2) + end if + end if + ! + ! -- check for slow convergence + ! -- set flags to determine if the Newton-Raphson method oscillates + ! or if convergence is slow + if (qgwf1*qgwfold < DEM30) then + iic2 = iic2 + 1 + else + iic2 = 0 + end if + if (qgwf1 < DEM30) then + iic3 = iic3 + 1 + else + iic3 = 0 + end if + if (dlh*dlhold < DEM30 .or. ABS(dlh) > ABS(dlhold)) then + iic = iic + 1 + end if + iic4 = 0 + if (iic3 > 7 .and. iic > 12) then + iic4 = 1 + end if + ! + ! -- switch to bisection when the Newton-Raphson method oscillates + ! or when convergence is slow + if (iic2 > 7 .or. iic > 12 .or. iic4 == 1) then + ibflg = 1 + dpp = DHALF * (en1 + en2) + end if + ! + ! -- + call sChSmooth(dpp, sat, derv) + if (hgwf > bt) then + qgwfp = sat * cstr * (dpp + tp - hgwf) + else + qgwfp = sat * cstr * (dpp + tp - bt) + end if + if (qgwfp > qsrc) then + qgwfp = qsrc + if (abs(en1-en2) < this%dmaxchg*DEM6) then + call this%sfr_rectch_depth(n, (qmpsrc-DHALF*qgwfp), dpp) + end if + end if + call this%sfr_rectch_depth(n, (qmpsrc-DHALF*qgwfp), dx) + end if + ! + ! -- + fp = dpp - dx + if (ibflg == 1) then + dlh = fp + ! -- change end points + ! -- root is between f1 and fp + if (f1*fp < DZERO) then + en2 = dpp + f2 = fp + ! -- root is between fp and f2 + else + en1 = dpp + f1 = fp + end if + err = min(abs(fp), abs(en2-en1)) + else + err = abs(dlh) + end if + if (err < this%dmaxchg) then + d1 = dpp + qgwf = qgwfp + qd = qsrc - qgwf + exit + end if + ! + ! -- save iterates + errold = err + dlhold = dlh + if (ibflg == 1) then + qgwfold = qgwfp + else + qgwfold = qgwf1 + end if + ! + ! -- end of iteration + end do + end if itersol + + ! -- simple routing option or where depth = 0 and hgwf < bt + if (isolve == 0) then + call sChSmooth(d1, sat, derv) + if (hgwf > bt) then + qgwf = sat * cstr * (d1 + tp - hgwf) + else + qgwf = sat * cstr * (d1 + tp - bt) + end if + ! -- leakage exceeds inflow + if (qgwf > qsrc) then + d1 = DZERO + call this%sfr_calc_qsource(n, d1, qsrc) + qgwf = qsrc + end if + ! -- set qd + qd = qsrc - qgwf + end if + + ! -- update sfr stage + hsfr = tp + d1 + + ! -- update stored values + if (lupdate) then + ! + ! -- save depth and calculate stage + this%depth(n) = d1 + this%stage(n) = hsfr + ! + call this%sfr_update_flows(n, qd, qgwf) + end if + ! + ! -- calculate sumleak and sumrch + sumleak = DZERO + sumrch = DZERO + if (this%gwfiss == 0) then + sumleak = qgwf + else + sumleak = qgwf + end if + if (hgwf < bt) then + sumrch = qgwf + end if + ! + ! -- calculate hcof and rhs for MODFLOW + call sChSmooth(d1, sat, derv) + if (abs(sumleak) > DZERO) then + ! -- stream leakage is not head dependent + if (hgwf < bt) then + rhs = rhs - sumrch + ! -- stream leakage is head dependent + else if ((sumleak-qsrc) < -DEM30) then + if (this%gwfiss == 0) then + rhs = rhs - sat * cstr * hsfr - sumrch + else + rhs = rhs - sat * cstr * hsfr + end if + hcof = -cstr + ! -- place holder for UZF + else + if (this%gwfiss == 0) then + rhs = rhs - sumleak - sumrch + else + rhs = rhs - sumleak + end if + end if + ! -- add groundwater leakage + else if (hgwf < bt) then + rhs = rhs - sumrch + end if + ! + ! -- return + return + end subroutine sfr_solve + + subroutine sfr_update_flows(this, n, qd, qgwf) + ! ****************************************************************************** + ! sfr_update_flows -- Update downstream and groundwater leakage terms for reach + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + class(SfrType), intent(inout) :: this + integer(I4B), intent(in) :: n + real(DP), intent(inout) :: qd + real(DP), intent(in) :: qgwf + ! -- local + integer(I4B) :: i + integer(I4B) :: n2 + real(DP) :: q2 + real(DP) :: f + ! ------------------------------------------------------------------------------ + ! + ! -- update reach terms + ! + ! -- save final downstream stream flow + this%dsflow(n) = qd + ! + ! -- save groundwater leakage + this%gwflow(n) = qgwf + ! + ! -- route downstream flow + if (qd > DZERO) then + ! + ! -- route water to diversions + do i = 1, this%nconnreach(n) + if (this%reaches(n)%idir(i) > 0) cycle + if (this%reaches(n)%idiv(i) == 0) cycle + call this%sfr_calc_div(n, this%reaches(n)%idiv(i), qd, q2) + this%reaches(n)%qconn(i) = q2 + end do + ! + ! -- Mover terms: store outflow after diversion loss + ! as qformvr and reduce outflow (qd) + ! by how much was actually sent to the mover + if (this%imover == 1) then + call this%pakmvrobj%accumulate_qformvr(n, qd) + qd = MAX(qd - this%pakmvrobj%get_qtomvr(n), DZERO) + endif + ! + ! -- route remaining water to downstream reaches + do i = 1, this%nconnreach(n) + if (this%reaches(n)%idir(i) > 0) cycle + if (this%reaches(n)%idiv(i) > 0) cycle + n2 = this%reaches(n)%iconn(i) + f = this%ustrf(n2) / this%ftotnd(n) + this%reaches(n)%qconn(i) = qd * f + end do + else + do i = 1, this%nconnreach(n) + if (this%reaches(n)%idir(i) > 0) cycle + this%reaches(n)%qconn(i) = DZERO + end do + end if + ! + ! -- return + return + end subroutine sfr_update_flows + + subroutine sfr_calc_qd(this, n, depth, hgwf, qgwf, qd) + ! ****************************************************************************** + ! sfr_calc_dq -- Calculate downstream flow for reach + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + class(SfrType) :: this + integer(I4B), intent(in) :: n + real(DP), intent(in) :: depth + real(DP), intent(in) :: hgwf + real(DP), intent(inout) :: qgwf + real(DP), intent(inout) :: qd + ! -- local + real(DP) :: qsrc + ! ------------------------------------------------------------------------------ + ! + ! -- initialize residual + qd = DZERO + ! + ! -- calculate total water sources excluding groundwater leakage + call this%sfr_calc_qsource(n, depth, qsrc) + ! + ! -- estimate groundwater leakage + call this%sfr_calc_qgwf(n, depth, hgwf, qgwf) + if (-qgwf > qsrc) qgwf = -qsrc + ! + ! -- calculate down stream flow + qd = qsrc + qgwf + ! + ! -- limit downstream flow to a positive value + if (qd < DEM30) qd = DZERO + ! + ! -- return + return + end subroutine sfr_calc_qd + + subroutine sfr_calc_qsource(this, n, depth, qsrc) + ! ****************************************************************************** + ! sfr_calc_qsource -- Calculate sum of sources for reach - excluding + ! reach leakage + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + class(SfrType) :: this + integer(I4B), intent(in) :: n + real(DP), intent(in) :: depth + real(DP), intent(inout) :: qsrc + ! -- local + real(DP) :: qu, qi, qr, qe, qro, qfrommvr + real(DP) :: qt + real(DP) :: a, ae + ! ------------------------------------------------------------------------------ + ! + ! -- initialize residual + qsrc = DZERO + ! + ! -- calculate flow terms + qu = this%usflow(n) + qi = this%reaches(n)%inflow%value + qro = this%reaches(n)%runoff%value + ! + ! -- calculate rainfall and evap + a = this%surface_area(n) + ae = this%surface_area_wet(n, depth) + qr = this%reaches(n)%rain%value * a + !qe = this%reaches(n)%evap%value * ae + qe = this%reaches(n)%evap%value * a + ! + ! -- calculate mover term + qfrommvr = DZERO + if (this%imover == 1) then + qfrommvr = this%pakmvrobj%get_qfrommvr(n) + endif + ! + ! -- calculate down stream flow + qsrc = qu + qi + qr - qe + qro + qfrommvr + ! + ! -- adjust runoff or evaporation if sum of sources is negative + if (qsrc < DZERO) then + ! + ! -- calculate sources without et + qt = qu + qi + qr + qro + qfrommvr + ! + ! -- runoff exceeds sources of water for reach + if (qt < DZERO) then + qro = -(qu + qi + qr + qfrommvr) + qe = DZERO + ! + ! -- evaporation exceeds sources of water for reach + else + qe = qu + qi + qr + qro + qfrommvr + end if + qsrc = qu + qi + qr - qe + qro + qfrommvr + end if + ! + ! -- return + return + end subroutine sfr_calc_qsource + + + subroutine sfr_calc_qman(this, n, depth, qman) + ! ****************************************************************************** + ! sfr_calc_qman -- Calculate stream flow using Manning's equation + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + class(SfrType) :: this + integer(I4B), intent(in) :: n + real(DP), intent(in) :: depth + real(DP), intent(inout) :: qman + ! -- local + real(DP) :: sat + real(DP) :: derv + real(DP) :: s, r, aw, wp, rh + ! ------------------------------------------------------------------------------ + ! + ! -- initialize qman + qman = DZERO + ! + ! -- calculate terms for Manning's equation + call sChSmooth(depth, sat, derv) + s = this%slope(n) + r = this%reaches(n)%rough%value + aw = this%area_wet(n, depth) + wp = this%perimeter_wet(n) + rh = DZERO + if (wp > DZERO) then + rh = aw / wp + end if + ! + ! -- calculate flow + qman = sat * this%unitconv * aw * (rh**DTWOTHIRDS) * sqrt(s) / r + ! + ! -- return + return + end subroutine sfr_calc_qman + + + subroutine sfr_calc_qgwf(this, n, depth, hgwf, qgwf) + ! ****************************************************************************** + ! sfr_calc_qgwf -- Calculate sfr-aquifer exchange (relative to sfr reach) + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + class(SfrType) :: this + integer(I4B), intent(in) :: n + real(DP), intent(in) :: depth + real(DP), intent(in) :: hgwf + real(DP), intent(inout) :: qgwf + ! -- local + integer(I4B) :: node + real(DP) :: tp + real(DP) :: bt + real(DP) :: hsfr + real(DP) :: htmp + real(DP) :: cond + real(DP) :: sat + real(DP) :: derv + ! ------------------------------------------------------------------------------ + ! + ! -- initialize qgwf + qgwf = DZERO + ! + ! -- skip sfr-aquifer exchange in external cells + node = this%igwfnode(n) + if (node < 1) return + ! + ! -- skip sfr-aquifer exchange in inactive cells + if (this%ibound(node) == 0) return + ! + ! -- calculate saturation + call sChSmooth(depth, sat, derv) + ! + ! -- calculate conductance + call this%sfr_calc_cond(n, cond) + ! + ! -- calculate groundwater leakage + tp = this%strtop(n) + bt = tp - this%bthick(n) + hsfr = tp + depth + htmp = hgwf + if (htmp < bt) then + htmp = bt + end if + qgwf = sat * cond * (htmp - hsfr) + ! + ! -- return + return + end subroutine sfr_calc_qgwf + + subroutine sfr_calc_cond(this, n, cond) + ! ****************************************************************************** + ! sfr_calc_qgwf -- Calculate sfr-aquifer exchange + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + class(SfrType) :: this + integer(I4B), intent(in) :: n + real(DP), intent(inout) :: cond + ! -- local + integer(I4B) :: node + real(DP) :: wp + ! ------------------------------------------------------------------------------ + ! + ! -- initialize a few variables + cond = DZERO + node = this%igwfnode(n) + if (node > 0) then + if (this%ibound(node) > 0) then + wp = this%perimeter_wet(n) + cond = this%hk(n) * this%length(n) * wp / this%bthick(n) + end if + end if + ! + ! -- return + return + end subroutine sfr_calc_cond + + + subroutine sfr_calc_div(this, n, i, q, qd) + ! ****************************************************************************** + ! sfr_calc_resid -- Calculate residual for reach + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + class(SfrType) :: this + integer(I4B), intent(in) :: n + integer(I4B), intent(in) :: i + real(DP), intent(inout) :: q + real(DP), intent(inout) :: qd + ! -- local + character (len=10) :: cp + integer(I4B) :: n2 + !integer(I4B) :: ip + real(DP) :: v + ! ------------------------------------------------------------------------------ + ! + ! -- set local variables + n2 = this%reaches(n)%diversion(i)%reach + cp = this%reaches(n)%diversion(i)%cprior + !ip = this%reaches(n)%diversion(i)%iprior + v = this%reaches(n)%diversion(i)%rate%value + ! + ! -- calculate diversion + select case(cp) + ! -- flood diversion + !case (-3) + case ('EXCESS') + if (q < v) then + v = DZERO + else + v = q - v + end if + ! -- diversion percentage + !case (-2) + case ('FRACTION') + v = q * v + ! -- STR priority algorithm + !case (-1) + case ('THRESHOLD') + if (q < v) then + v = DZERO + end if + ! -- specified diversion + !case (0) + case ('UPTO') + if (v > q) then + v = q + end if + case default + v = DZERO + end select + ! + ! -- update upstream from for downstream reaches + q = q - v + qd = v + ! + ! -- return + return + end subroutine sfr_calc_div + + subroutine sfr_rectch_depth(this, n, q1, d1) + class(SfrType) :: this + integer(I4B), intent(in) :: n + real(DP), intent(in) :: q1 + real(DP), intent(inout) :: d1 + ! -- local + real(DP) :: w + real(DP) :: s + real(DP) :: r + real(DP) :: qconst + ! -- code + ! -- calculate stream depth at the midpoint + w = this%width(n) + s = this%slope(n) + r = this%reaches(n)%rough%value + qconst = this%unitconv * w * sqrt(s) / r + d1 = (q1 / qconst)**DP6 + if (d1 < DEM30) d1 = DZERO + ! -- return + return + end subroutine sfr_rectch_depth + + + subroutine sfr_check_reaches(this) + class(SfrType) :: this + ! -- local + character (len= 5) :: crch + character (len=10) :: cval + character (len=30) :: nodestr + character (len=LINELENGTH) :: title + character (len=LINELENGTH) :: text + character (len=LINELENGTH) :: errmsg + integer(I4B) :: n, nn + real(DP) :: btgwf, bt + ! -- code + ! + ! -- setup inputtab tableobj + if (this%iprpak /= 0) then + title = trim(adjustl(this%text)) // ' PACKAGE (' // & + trim(adjustl(this%name)) //') STATIC REACH DATA' + call table_cr(this%inputtab, this%name, title) + call this%inputtab%table_df(this%maxbound, 10, this%iout) + text = 'NUMBER' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'CELLID' + call this%inputtab%initialize_column(text, 20, alignment=TABLEFT) + text = 'LENGTH' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'WIDTH' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'SLOPE' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'TOP' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'THICKNESS' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'HK' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'ROUGHNESS' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'UPSTREAM FRACTION' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + end if + ! + ! -- check the reach data for simple errors + do n = 1, this%maxbound + write(crch, '(i5)') n + nn = this%igwfnode(n) + if (nn > 0) then + btgwf = this%dis%bot(nn) + call this%dis%noder_to_string(nn, nodestr) + else + nodestr = 'none' + end if + ! -- check reach length + if (this%length(n) <= DZERO) then + errmsg = 'ERROR: Reach ' // crch // ' length must be > 0.0' + call store_error(errmsg) + end if + ! -- check reach width + if (this%width(n) <= DZERO) then + errmsg = 'ERROR: Reach ' // crch // ' width must be > 0.0' + call store_error(errmsg) + end if + ! -- check reach slope + if (this%slope(n) <= DZERO) then + errmsg = 'ERROR: Reach ' // crch // ' slope must be > 0.0' + call store_error(errmsg) + end if + ! -- check bed thickness and bed hk for reaches connected to GWF + if (nn > 0) then + bt = this%strtop(n) - this%bthick(n) + if (bt <= btgwf .and. this%icheck /= 0) then + write(cval,'(f10.4)') bt + errmsg = 'ERROR: Reach ' // crch // ' bed bottom (rtp-rbth =' // & + cval // ') must be > the bottom of cell (' // nodestr + write(cval,'(f10.4)') btgwf + errmsg = trim(adjustl(errmsg)) // '=' // cval // ').' + call store_error(errmsg) + end if + if (this%hk(n) < DZERO) then + errmsg = 'ERROR: Reach ' // crch // ' hk must be >= 0.0' + call store_error(errmsg) + end if + end if + ! -- check reach roughness + if (this%reaches(n)%rough%value <= DZERO) then + errmsg = 'ERROR: Reach ' // crch // " Manning's roughness " // & + 'coefficient must be > 0.0' + call store_error(errmsg) + end if + ! -- check reach upstream fraction + if (this%ustrf(n) < DZERO) then + errmsg = 'ERROR: Reach ' // crch // " upstream fraction must be >= 0.0" + call store_error(errmsg) + end if + ! -- write summary of reach information + if (this%iprpak /= 0) then + call this%inputtab%add_term(n) + call this%inputtab%add_term(nodestr) + call this%inputtab%add_term(this%length(n)) + call this%inputtab%add_term(this%width(n)) + call this%inputtab%add_term(this%slope(n)) + call this%inputtab%add_term(this%strtop(n)) + call this%inputtab%add_term(this%bthick(n)) + call this%inputtab%add_term(this%hk(n)) + call this%inputtab%add_term(this%reaches(n)%rough%value) + call this%inputtab%add_term(this%ustrf(n)) + end if + end do + + ! -- return + return + end subroutine sfr_check_reaches + + + subroutine sfr_check_connections(this) + class(SfrType) :: this + ! -- local + character (len= 5) :: crch + character (len= 5) :: crch2 + character (len=LINELENGTH) :: text + character (len=LINELENGTH) :: title + character (len=LINELENGTH) :: errmsg + integer(I4B) :: n, nn, nc + integer(I4B) :: i, ii + integer(I4B) :: ifound + integer(I4B) :: ierr + integer(I4B) :: maxconn + integer(I4B) :: ntabcol + ! -- code + ! + ! -- create input table for reach connections data + if (this%iprpak /= 0) then + ! + ! -- calculate the maximum number of connections + maxconn = 0 + do n = 1, this%maxbound + maxconn = max(maxconn, this%nconnreach(n)) + end do + ntabcol = 1 + maxconn + ! + ! -- reset the input table object + title = trim(adjustl(this%text)) // ' PACKAGE (' // & + trim(adjustl(this%name)) //') STATIC REACH CONNECTION DATA' + call table_cr(this%inputtab, this%name, title) + call this%inputtab%table_df(this%maxbound, ntabcol, this%iout) + text = 'REACH' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + do n = 1, maxconn + write(text, '(a,1x,i6)') 'CONN', n + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + end do + end if + ! + ! -- check the reach connections for simple errors + ! -- connection check + do n = 1, this%maxbound + write(crch, '(i5)') n + eachconn: do i = 1, this%nconnreach(n) + nn = this%reaches(n)%iconn(i) + write(crch2, '(i5)') nn + ifound = 0 + connreach: do ii = 1, this%nconnreach(nn) + nc = this%reaches(nn)%iconn(ii) + if (nc == n) then + ifound = 1 + exit connreach + end if + end do connreach + if (ifound /= 1) then + errmsg = 'ERROR: Reach ' // crch // ' is connected to ' // & + 'reach ' // crch2 // ' but reach ' // crch2 // & + ' is not connected to reach ' // crch // '.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end if + end do eachconn + ! + ! -- write connection data to the table + if (this%iprpak /= 0) then + call this%inputtab%add_term(n) + do i = 1, this%nconnreach(n) + call this%inputtab%add_term(this%reaches(n)%iconn(i)) + end do + nn = maxconn - this%nconnreach(n) + do i = 1, nn + call this%inputtab%add_term(' ') + end do + end if + end do + ! + ! -- check for incorrect connections between upstream connections + ! + ! -- check upstream connections for each reach + ierr = 0 + do n = 1, this%maxbound + write(crch, '(i5)') n + eachconnv: do i = 1, this%nconnreach(n) + ! + ! -- skip downstream connections + if (this%reaches(n)%idir(i) < 0) cycle eachconnv + nn = this%reaches(n)%iconn(i) + write(crch2, '(i5)') nn + connreachv: do ii = 1, this%nconnreach(nn) + ! -- skip downstream connections + if (this%reaches(nn)%idir(ii) < 0) cycle connreachv + nc = this%reaches(nn)%iconn(ii) + ! + ! -- if n == n then that means reach n is an upstream connection for + ! reach nn and reach nn is an upstream connection for reach n + if (nc == n) then + ierr = ierr + 1 + errmsg = 'ERROR: Reach ' // crch // ' is connected to ' // & + 'reach ' // crch2 // ' but streamflow from reach ' // & + crch // ' to reach ' // crch2 // ' is not permitted.' + call store_error(errmsg) + exit connreachv + end if + end do connreachv + end do eachconnv + end do + if (ierr > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- check that downstream reaches for a reach are + ! the upstream reaches for the reach + do n = 1, this%maxbound + write(crch, '(i5)') n + eachconnds: do i = 1, this%nconnreach(n) + nn = this%reaches(n)%iconn(i) + if (this%reaches(n)%idir(i) > 0) cycle eachconnds + write(crch2, '(i5)') nn + ifound = 0 + connreachds: do ii = 1, this%nconnreach(nn) + nc = this%reaches(nn)%iconn(ii) + if (nc == n) then + if (this%reaches(n)%idir(i) /= this%reaches(nn)%idir(ii)) then + ifound = 1 + end if + exit connreachds + end if + end do connreachds + if (ifound /= 1) then + errmsg = 'ERROR: Reach ' // crch // ' downstream connected reach ' // & + 'is reach ' // crch2 // ' but reach ' // crch // ' is not' // & + ' the upstream connected reach for reach ' // crch2 // '.' + call store_error(errmsg) + end if + end do eachconnds + end do + ! + ! -- create input table for upstream and downstream connections + if (this%iprpak /= 0) then + ! + ! -- calculate the maximum number of upstream connections + maxconn = 0 + do n = 1, this%maxbound + ii = 0 + do i = 1, this%nconnreach(n) + if (this%reaches(n)%idir(i) > 0) then + ii = ii + 1 + end if + end do + maxconn = max(maxconn, ii) + end do + ntabcol = 1 + maxconn + ! + ! -- reset the input table object + title = trim(adjustl(this%text)) // ' PACKAGE (' // & + trim(adjustl(this%name)) //') STATIC UPSTREAM REACH ' // & + 'CONNECTION DATA' + call table_cr(this%inputtab, this%name, title) + call this%inputtab%table_df(this%maxbound, ntabcol, this%iout) + text = 'REACH' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + do n = 1, maxconn + write(text, '(a,1x,i6)') 'UPSTREAM CONN', n + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + end do + ! + ! -- upstream connection data + do n = 1, this%maxbound + call this%inputtab%add_term(n) + ii = 0 + do i = 1, this%nconnreach(n) + if (this%reaches(n)%idir(i) > 0) then + call this%inputtab%add_term(this%reaches(n)%iconn(i)) + ii = ii + 1 + end if + end do + nn = maxconn - ii + do i = 1, nn + call this%inputtab%add_term(' ') + end do + end do + ! + ! -- calculate the maximum number of downstream connections + maxconn = 0 + do n = 1, this%maxbound + ii = 0 + do i = 1, this%nconnreach(n) + if (this%reaches(n)%idir(i) < 0) then + ii = ii + 1 + end if + end do + maxconn = max(maxconn, ii) + end do + ntabcol = 1 + maxconn + ! + ! -- reset the input table object + title = trim(adjustl(this%text)) // ' PACKAGE (' // & + trim(adjustl(this%name)) //') STATIC DOWNSTREAM ' // & + 'REACH CONNECTION DATA' + call table_cr(this%inputtab, this%name, title) + call this%inputtab%table_df(this%maxbound, ntabcol, this%iout) + text = 'REACH' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + do n = 1, maxconn + write(text, '(a,1x,i6)') 'DOWNSTREAM CONN', n + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + end do + ! + ! -- downstream connection data + do n = 1, this%maxbound + call this%inputtab%add_term(n) + ii = 0 + do i = 1, this%nconnreach(n) + if (this%reaches(n)%idir(i) < 0) then + call this%inputtab%add_term(this%reaches(n)%iconn(i)) + ii = ii + 1 + end if + end do + nn = maxconn - ii + do i = 1, nn + call this%inputtab%add_term(' ') + end do + end do + end if + ! + ! -- return + return + end subroutine sfr_check_connections + + + subroutine sfr_check_diversions(this) + class(SfrType) :: this + ! -- local + character (len=LINELENGTH) :: title + character (len=LINELENGTH) :: text + character (len= 5) :: crch + character (len= 5) :: cdiv + character (len= 5) :: crch2 + character (len=10) :: cprior + character (len=LINELENGTH) :: errmsg + integer(I4B) :: maxdiv + integer(I4B) :: n, nn, nc + integer(I4B) :: ii + integer(I4B) :: idiv + integer(I4B) :: ifound + ! -- format +10 format('Diversion ',i0,' of reach ',i0, & + ' is invalid or has not been defined.') + ! -- code + ! + ! -- write header + if (this%iprpak /= 0) then + ! + ! -- determine the maximum number of diversions + maxdiv = 0 + do n = 1, this%maxbound + maxdiv = maxdiv + this%ndiv(n) + end do + ! + ! -- reset the input table object + title = trim(adjustl(this%text)) // ' PACKAGE (' // & + trim(adjustl(this%name)) //') REACH DIVERSION DATA' + call table_cr(this%inputtab, this%name, title) + call this%inputtab%table_df(maxdiv, 4, this%iout) + text = 'REACH' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'DIVERSION' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'REACH 2' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'CPRIOR' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + end if + ! + ! -- check that diversion data are correct + do n = 1, this%maxbound + if (this%ndiv(n) < 1) cycle + write(crch, '(i5)') n + !line = ' ' // crch + + do idiv = 1, this%ndiv(n) + write(cdiv, '(i5)') idiv + ! + ! + nn = this%reaches(n)%diversion(idiv)%reach + write(crch2, '(i5)') nn + ! + ! -- make sure diversion reach is connected to current reach + ifound = 0 + if (nn < 1 .or. nn > this%maxbound) then + write(errmsg,10)idiv, n + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + connreach: do ii = 1, this%nconnreach(nn) + nc = this%reaches(nn)%iconn(ii) + if (nc == n) then + if (this%reaches(nn)%idir(ii) > 0) then + ifound = 1 + end if + exit connreach + end if + end do connreach + if (ifound /= 1) then + errmsg = 'ERROR: Reach ' // crch // ' is not a upstream reach for ' // & + 'reach ' // crch2 // ' as a result diversion ' // cdiv // & + ' from reach ' // crch //' to reach ' // crch2 // & + ' is not possible. Check reach connectivity.' + call store_error(errmsg) + end if + ! -- iprior + cprior = this%reaches(n)%diversion(idiv)%cprior + ! + ! -- add terms to the table + if (this%iprpak /= 0) then + call this%inputtab%add_term(n) + call this%inputtab%add_term(idiv) + call this%inputtab%add_term(nn) + call this%inputtab%add_term(this%reaches(n)%diversion(idiv)%cprior) + end if + end do + end do + ! + ! -- return + return + end subroutine sfr_check_diversions + + + subroutine sfr_check_ustrf(this) + class(SfrType) :: this + ! -- local + character (len=LINELENGTH) :: title + character (len=LINELENGTH) :: text + logical :: lcycle + logical :: ladd + character (len=5) :: crch, crch2 + character (len=10) :: cval + character (len=LINELENGTH) :: errmsg + integer(I4B) :: maxcols + integer(I4B) :: npairs + integer(I4B) :: ipair + integer(I4B) :: i, n + integer(I4B) :: n2 + integer(I4B) :: idiv + integer(I4B) :: ids + real(DP) :: f + real(DP) :: rval + ! -- code + ! + ! -- write table header + if (this%iprpak /= 0) then + ! + ! -- determine the maximum number of columns + npairs = 0 + do n = 1, this%maxbound + ipair = 0 + ec: do i = 1, this%nconnreach(n) + ! + ! -- skip upstream connections + if (this%reaches(n)%idir(i) > 0) cycle ec + n2 = this%reaches(n)%iconn(i) + ! + ! -- skip inactive downstream reaches + if (this%iboundpak(n2) == 0) cycle ec + ! + ! -- increment ipair and see if it exceeds npairs + ipair = ipair + 1 + npairs = max(npairs, ipair) + end do ec + end do + maxcols = 1 + npairs * 2 + ! + ! -- reset the input table object + title = trim(adjustl(this%text)) // ' PACKAGE (' // & + trim(adjustl(this%name)) //') CONNECTED REACH UPSTREAM ' // & + 'FRACTION DATA' + call table_cr(this%inputtab, this%name, title) + call this%inputtab%table_df(this%maxbound, maxcols, this%iout) + text = 'REACH' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + do i = 1, npairs + write(cval, '(i10)') i + text = 'DOWNSTREAM REACH ' // trim(adjustl(cval)) + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'FRACTION ' // trim(adjustl(cval)) + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + end do + end if + ! + ! -- calculate the total fraction of connected reaches that are + ! not diversions and check that the sum of upstream fractions + ! is equal to 1 for each reach + do n = 1, this%maxbound + ids = 0 + rval = DZERO + f = DZERO + write(crch, '(i5)') n + if (this%iprpak /= 0) then + call this%inputtab%add_term(n) + end if + ipair = 0 + eachconn: do i = 1, this%nconnreach(n) + lcycle = .FALSE. + ! + ! -- initialize downstream connection q + this%reaches(n)%qconn(i) = DZERO + ! + ! -- skip upstream connections + if (this%reaches(n)%idir(i) > 0) then + lcycle = .TRUE. + end if + n2 = this%reaches(n)%iconn(i) + ! + ! -- skip inactive downstream reaches + if (this%iboundpak(n2) == 0) then + lcycle = .TRUE. + end if + if (lcycle) then + cycle eachconn + end if + ipair = ipair + 1 + write(crch2, '(i5)') n2 + ids = ids + 1 + ladd = .true. + f = f + this%ustrf(n2) + write(cval, '(f10.4)') this%ustrf(n2) + ! + ! -- write upstream fractions + if (this%iprpak /= 0) then + call this%inputtab%add_term(n2) + call this%inputtab%add_term(this%ustrf(n2)) + end if + eachdiv: do idiv = 1, this%ndiv(n) + if (this%reaches(n)%diversion(idiv)%reach == n2) then + this%reaches(n)%idiv(i) = idiv + ladd = .false. + exit eachconn + end if + end do eachdiv + if (ladd) then + rval = rval + this%ustrf(n2) + end if + end do eachconn + this%ftotnd(n) = rval + ! + ! -- write remaining table columns + if (this%iprpak /= 0) then + ipair = ipair + 1 + do i = ipair, npairs + call this%inputtab%add_term(' ') + call this%inputtab%add_term(' ') + end do + end if + ! + ! -- evaluate if an error condition has occured + ! the sum of fractions is not equal to 1 + if (ids /= 0) then + if (abs(f-DONE) > DEM6) then + write(cval, '(f10.4)') f + errmsg = 'ERROR: upstream fractions for reach ' // crch // ' not ' // & + 'equal to one (' // cval // '). Check reach connectivity.' + call store_error(errmsg) + end if + end if + end do + ! + ! -- return + return + end subroutine sfr_check_ustrf + + subroutine sfr_setup_budobj(this) +! ****************************************************************************** +! sfr_setup_budobj -- Set up the budget object that stores all the sfr flows +! The terms listed here must correspond in number and order to the ones +! listed in the sfr_fill_budobj routine. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LENBUDTXT + ! -- dummy + class(SfrType) :: this + ! -- local + integer(I4B) :: nbudterm + integer(I4B) :: i, n, n1, n2 + integer(I4B) :: maxlist, naux + integer(I4B) :: idx + real(DP) :: q + character(len=LENBUDTXT) :: text + character(len=LENBUDTXT), dimension(1) :: auxtxt +! ------------------------------------------------------------------------------ + ! + ! -- Determine the number of sfr budget terms. These are fixed for + ! the simulation and cannot change. This includes FLOW-JA-FACE + ! so they can be written to the binary budget files, but these internal + ! flows are not included as part of the budget table. + nbudterm = 8 + if (this%imover == 1) nbudterm = nbudterm + 2 + if (this%naux > 0) nbudterm = nbudterm + 1 + ! + ! -- set up budobj + call budgetobject_cr(this%budobj, this%name) + call this%budobj%budgetobject_df(this%maxbound, nbudterm, 0, 0) + idx = 0 + ! + ! -- Go through and set up each budget term + text = ' FLOW-JA-FACE' + idx = idx + 1 + maxlist = this%nconn + naux = 1 + auxtxt(1) = ' FLOW-AREA' + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux, auxtxt) + ! + ! -- store connectivity + call this%budobj%budterm(idx)%reset(this%nconn) + q = DZERO + do n = 1, this%maxbound + n1 = n + do i = 1, this%nconnreach(n) + n2 = this%reaches(n)%iconn(i) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + end do + end do + ! + ! -- + text = ' GWF' + idx = idx + 1 + maxlist = this%maxbound + naux = 1 + auxtxt(1) = ' FLOW-AREA' + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name_model, & + maxlist, .false., .true., & + naux, auxtxt) + call this%budobj%budterm(idx)%reset(this%maxbound) + q = DZERO + do n = 1, this%maxbound + n2 = this%igwfnode(n) + call this%budobj%budterm(idx)%update_term(n, n2, q) + end do + ! + ! -- + text = ' RAINFALL' + idx = idx + 1 + maxlist = this%maxbound + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' EVAPORATION' + idx = idx + 1 + maxlist = this%maxbound + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' RUNOFF' + idx = idx + 1 + maxlist = this%maxbound + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' EXT-INFLOW' + idx = idx + 1 + maxlist = this%maxbound + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' EXT-OUTFLOW' + idx = idx + 1 + maxlist = this%maxbound + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' STORAGE' + idx = idx + 1 + maxlist = this%maxbound + naux = 1 + auxtxt(1) = ' VOLUME' + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux, auxtxt) + ! + ! -- + if (this%imover == 1) then + ! + ! -- + text = ' FROM-MVR' + idx = idx + 1 + maxlist = this%maxbound + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' TO-MVR' + idx = idx + 1 + maxlist = this%maxbound + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + end if + ! + ! -- + naux = this%naux + if (naux > 0) then + ! + ! -- + text = ' AUXILIARY' + idx = idx + 1 + maxlist = this%maxbound + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux, this%auxname) + end if + ! + ! -- if sfr flow for each reach are written to the listing file + if (this%iprflow /= 0) then + call this%budobj%flowtable_df(this%iout, cellids='GWF') + end if + ! + ! -- return + return + end subroutine sfr_setup_budobj + + subroutine sfr_fill_budobj(this) +! ****************************************************************************** +! sfr_fill_budobj -- copy flow terms into this%budobj +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(SfrType) :: this + ! -- local + integer(I4B) :: naux + integer(I4B) :: i, n, n1, n2 + integer(I4B) :: ii + integer(I4B) :: idx + real(DP) :: q + real(DP) :: qt + real(DP) :: d + real(DP) :: a + ! -- formats +! ----------------------------------------------------------------------------- + ! + ! -- initialize counter + idx = 0 + + + ! -- FLOW JA FACE + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nconn) + do n = 1, this%maxbound + n1 = n + do i = 1, this%nconnreach(n) + n2 = this%reaches(n)%iconn(i) + ! flow to downstream reaches + if (this%reaches(n)%idir(i) < 0) then + qt = this%dsflow(n) + q = -this%reaches(n)%qconn(i) + ! flow from upstream reaches + else + qt = this%usflow(n) + do ii = 1, this%nconnreach(n2) + if (this%reaches(n2)%idir(ii) > 0) cycle + if (this%reaches(n2)%iconn(ii) /= n) cycle + q = this%reaches(n2)%qconn(ii) + exit + end do + end if + ! calculate flow area + call this%sfr_rectch_depth(n, qt, d) + this%qauxcbc(1) = d * this%width(n) + call this%budobj%budterm(idx)%update_term(n1, n2, q, this%qauxcbc) + end do + end do + + + ! -- GWF (LEAKAGE) + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound) + do n = 1, this%maxbound + this%qauxcbc(1) = this%width(n) * this%length(n) + n2 = this%igwfnode(n) + q = -this%gwflow(n) + call this%budobj%budterm(idx)%update_term(n, n2, q, this%qauxcbc) + end do + + + ! -- RAIN + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound) + do n = 1, this%maxbound + a = this%surface_area(n) + q = this%reaches(n)%rain%value * a + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + + + ! -- EVAPORATION + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound) + do n = 1, this%maxbound + q = -this%simevap(n) + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + + + ! -- RUNOFF + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound) + do n = 1, this%maxbound + q = this%simrunoff(n) + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + + + ! -- INFLOW + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound) + do n = 1, this%maxbound + q = this%reaches(n)%inflow%value + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + + + ! -- EXTERNAL OUTFLOW + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound) + do n = 1, this%maxbound + q = this%dsflow(n) + if (q > DZERO) q = -q + do i = 1, this%nconnreach(n) + if (this%reaches(n)%idir(i) > 0) cycle + q = DZERO + exit + end do + if (this%imover == 1) then + q = q + this%pakmvrobj%get_qtomvr(n) + end if + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + + ! -- STORAGE + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound) + do n = 1, this%maxbound + q = DZERO + d = this%depth(n) + a = this%width(n) * this%length(n) + this%qauxcbc(1) = a * d + call this%budobj%budterm(idx)%update_term(n, n, q, this%qauxcbc) + end do + + ! -- MOVER + if (this%imover == 1) then + + ! -- FROM MOVER + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound) + do n = 1, this%maxbound + q = this%pakmvrobj%get_qfrommvr(n) + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + + + ! -- TO MOVER + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound) + do n = 1, this%maxbound + q = this%pakmvrobj%get_qtomvr(n) + if (q > DZERO) then + q = -q + end if + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + + end if + + + ! -- AUXILIARY VARIABLES + naux = this%naux + if (naux > 0) then + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound) + do n = 1, this%maxbound + q = DZERO + call this%budobj%budterm(idx)%update_term(n, n, q, this%auxvar(:, n)) + end do + end if + ! + ! --Terms are filled, now accumulate them for this time step + call this%budobj%accumulate_terms() + ! + ! -- return + return + end subroutine sfr_fill_budobj + + subroutine sfr_setup_tableobj(this) +! ****************************************************************************** +! sfr_setup_tableobj -- Set up the table object that is used to write the sfr +! stage data. The terms listed here must correspond in +! number and order to the ones written to the stage table +! in the sfr_ot method. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH, LENBUDTXT + ! -- dummy + class(SfrType) :: this + ! -- local + integer(I4B) :: nterms + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: text +! ------------------------------------------------------------------------------ + ! + ! -- setup stage table + if (this%iprhed > 0) then + ! + ! -- Determine the number of sfr budget terms. These are fixed for + ! the simulation and cannot change. This includes FLOW-JA-FACE + ! so they can be written to the binary budget files, but these internal + ! flows are not included as part of the budget table. + nterms = 8 + if (this%inamedbound == 1) nterms = nterms + 1 + ! + ! -- set up table title + title = trim(adjustl(this%text)) // ' PACKAGE (' // & + trim(adjustl(this%name)) //') STAGES FOR EACH CONTROL VOLUME' + ! + ! -- set up stage tableobj + call table_cr(this%stagetab, this%name, title) + call this%stagetab%table_df(this%maxbound, nterms, this%iout, & + transient=.TRUE.) + ! + ! -- Go through and set up table budget term + if (this%inamedbound == 1) then + text = 'NAME' + call this%stagetab%initialize_column(text, 20, alignment=TABLEFT) + end if + ! + ! -- reach number + text = 'NUMBER' + call this%stagetab%initialize_column(text, 10, alignment=TABCENTER) + ! + ! -- cellids + text = 'CELLID' + call this%stagetab%initialize_column(text, 20, alignment=TABLEFT) + ! + ! -- reach stage + text = 'STAGE' + call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) + ! + ! -- reach depth + text = 'DEPTH' + call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) + ! + ! -- reach width + text = 'WIDTH' + call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) + ! + ! -- gwf head + text = 'GWF HEAD' + call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) + ! + ! -- streambed conductance + text = 'STREAMBED CONDUCTANCE' + call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) + ! + ! -- streambed gradient + text = 'STREAMBED GRADIENT' + call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) + end if + ! + ! -- return + return + end subroutine sfr_setup_tableobj + + + + ! -- geometry functions + function area_wet(this, n, depth) +! ****************************************************************************** +! area_wet -- return wetted area +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + real(DP) :: area_wet + ! -- dummy + class(SfrType) :: this + integer(I4B), intent(in) :: n + real(DP), intent(in) :: depth +! ------------------------------------------------------------------------------ + ! + ! -- Calculate area + area_wet = depth * this%width(n) + ! + ! -- Return + return + end function area_wet + + + function perimeter_wet(this, n) +! ****************************************************************************** +! perimeter_wet -- return wetted perimeter +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + real(DP) :: perimeter_wet + ! -- dummy + class(SfrType) :: this + integer(I4B), intent(in) :: n +! ------------------------------------------------------------------------------ + ! + ! -- Calculate wetted perimeter + perimeter_wet = this%width(n) + ! + ! -- return + return + end function perimeter_wet + + function surface_area(this, n) +! ****************************************************************************** +! surface_area -- return surface area +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return variable + real(DP) :: surface_area + ! -- dummy + class(SfrType) :: this + integer(I4B), intent(in) :: n +! ------------------------------------------------------------------------------ + ! + ! -- Calculate surface area + surface_area = this%width(n) * this%length(n) + ! + ! -- Return + return + end function surface_area + + function surface_area_wet(this, n, depth) +! ****************************************************************************** +! area_wet -- return wetted surface area +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + real(DP) :: surface_area_wet + ! -- dummy + class(SfrType) :: this + integer(I4B), intent(in) :: n + real(DP), intent(in) :: depth + ! -- local + real(DP) :: top_width +! ------------------------------------------------------------------------------ + ! + ! -- Calculate surface area + top_width = this%top_width_wet(n, depth) + surface_area_wet = top_width * this%length(n) + ! + ! -- Return + return + end function surface_area_wet + + function top_width_wet(this, n, depth) +! ****************************************************************************** +! area_wet -- return wetted surface area +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DEM5, DZERO + ! -- return + real(DP) :: top_width_wet + ! -- dummy + class(SfrType) :: this + integer(I4B), intent(in) :: n + real(DP), intent(in) :: depth + ! -- local + real(DP) :: sat +! ------------------------------------------------------------------------------ + ! + ! -- Calculate surface area + sat = sCubicSaturation(DEM5, DZERO, depth, DEM5) + top_width_wet = this%width(n) * sat + ! + ! -- Return + return + end function top_width_wet + +end module SfrModule diff --git a/src/Model/GroundWaterFlow/gwf3sto8.f90 b/src/Model/GroundWaterFlow/gwf3sto8.f90 index 0b7cfd7f372..e77a2b42f69 100644 --- a/src/Model/GroundWaterFlow/gwf3sto8.f90 +++ b/src/Model/GroundWaterFlow/gwf3sto8.f90 @@ -1,945 +1,945 @@ -module GwfStoModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, DEM6, DEM4, DONE, LENBUDTXT - use SmoothingModule, only: sQuadraticSaturation, & - sQuadraticSaturationDerivative, & - sQSaturation, sLinearSaturation - use BaseDisModule, only: DisBaseType - use NumericalPackageModule, only: NumericalPackageType - use BlockParserModule, only: BlockParserType - - implicit none - public :: GwfStoType, sto_cr - - character(len=LENBUDTXT), dimension(2) :: budtxt = & !text labels for budget terms - [' STO-SS', ' STO-SY'] - - type, extends(NumericalPackageType) :: GwfStoType - integer(I4B), pointer :: isfac => null() !indicates if ss is read as storativity - integer(I4B), pointer :: isseg => null() !indicates if ss is 0 below the top of a layer - integer(I4B), pointer :: iss => null() !steady state flag - integer(I4B), pointer :: iusesy => null() !flag set if any cell is convertible (0, 1) - integer(I4B), dimension(:), pointer, contiguous :: iconvert => null() !confined (0) or convertible (1) - real(DP),dimension(:), pointer, contiguous :: sc1 => null() !primary storage capacity (when cell is fully saturated) - real(DP),dimension(:), pointer, contiguous :: sc2 => null() !secondary storage capacity (when cell is partially saturated) - real(DP), dimension(:), pointer, contiguous :: strgss => null() !vector of specific storage rates - real(DP), dimension(:), pointer, contiguous :: strgsy => null() !vector of specific yield rates - integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !pointer to model ibound - real(DP), pointer :: satomega => null() !newton-raphson saturation omega - contains - procedure :: sto_ar - procedure :: sto_rp - procedure :: sto_ad - procedure :: sto_fc - procedure :: sto_fn - procedure :: bdcalc => sto_bdcalc - procedure :: bdsav => sto_bdsav - procedure :: sto_da - procedure :: allocate_scalars - procedure, private :: allocate_arrays - procedure, private :: read_options - procedure, private :: read_data - endtype - - contains - - subroutine sto_cr(stoobj, name_model, inunit, iout) -! ****************************************************************************** -! sto_cr -- Create a new STO object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - type(GwfStoType), pointer :: stoobj - character(len=*), intent(in) :: name_model - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout -! ------------------------------------------------------------------------------ - ! - ! -- Create the object - allocate(stoobj) - ! - ! -- create name and origin - call stoobj%set_names(1, name_model, 'STO', 'STO') - ! - ! -- Allocate scalars - call stoobj%allocate_scalars() - ! - ! -- Set variables - stoobj%inunit = inunit - stoobj%iout = iout - ! - ! -- Initialize block parser - call stoobj%parser%Initialize(stoobj%inunit, stoobj%iout) - ! - ! -- Return - return - end subroutine sto_cr - - subroutine sto_ar(this, dis, ibound) -! ****************************************************************************** -! sto_ar -- Allocate and Read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - !modules - use MemoryManagerModule, only: mem_setptr - ! -- dummy - class(GwfStoType) :: this - class(DisBaseType), pointer, intent(in) :: dis - integer(I4B), dimension(:), pointer, contiguous :: ibound - ! -- local - ! -- formats - character(len=*), parameter :: fmtsto = & - "(1x,/1x,'STO -- STORAGE PACKAGE, VERSION 1, 5/19/2014', & - &' INPUT READ FROM UNIT ', i0, //)" -! ------------------------------------------------------------------------------ - ! - ! --print a message identifying the storage package. - write(this%iout, fmtsto) this%inunit - ! - ! -- store pointers to arguments that were passed in - this%dis => dis - this%ibound => ibound - ! - ! -- set pointer to gwf iss - call mem_setptr(this%iss, 'ISS', trim(this%name_model)) - ! - ! -- Allocate arrays - call this%allocate_arrays(dis%nodes) - ! - ! -- Read storage options - call this%read_options() - ! - ! -- read the data block - call this%read_data() - ! - ! -- Return - return - end subroutine sto_ar - - subroutine sto_rp(this) -! ****************************************************************************** -! sto_rp -- Read and prepare -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use TdisModule, only: kper, nper - use SimModule, only: store_error, ustop - implicit none - ! -- dummy - class(GwfStoType) :: this - ! -- local - integer(I4B) :: ierr - logical :: isfound, readss, readsy, endOfBlock - !character(len=24) :: aname(4) , stotxt - character (len=16) :: css(0:1) - character(len=LINELENGTH) :: line, errmsg, keyword - ! -- formats - character(len=*),parameter :: fmtlsp = & - "(1X,/1X,'REUSING ',A,' FROM LAST STRESS PERIOD')" - character(len=*),parameter :: fmtblkerr = & - "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - !data - data css(0) /' TRANSIENT'/ - data css(1) /' STEADY-STATE'/ - !data aname(1) /' ICONVERT'/ - !data aname(2) /' SPECIFIC STORAGE'/ - !data aname(3) /' SPECIFIC YIELD'/ - !data aname(4) /' STORAGE COEFFICIENT'/ -! ------------------------------------------------------------------------------ - ! - ! -- get stress period data - if (this%ionper < kper) then - ! - ! -- get period block - call this%parser%GetBlock('PERIOD', isfound, ierr, & - supportOpenClose=.true.) - if (isfound) then - ! - ! -- read ionper and check for increasing period numbers - call this%read_check_ionper() - else - ! - ! -- PERIOD block not found - if (ierr < 0) then - ! -- End of file found; data applies for remainder of simulation. - this%ionper = nper + 1 - else - ! -- Found invalid block - call this%parser%GetCurrentLine(line) - write(errmsg, fmtblkerr) adjustl(trim(line)) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - endif - end if - ! - ! -- read data if ionper == kper - readss = .false. - readsy = .false. - !stotxt = aname(2) - if(this%ionper==kper) then - write(this%iout, '(//,1x,a)') 'UPDATING STORAGE VALUES' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('STEADY-STATE') - this%iss = 1 - case ('TRANSIENT') - this%iss = 0 - case default - write(errmsg,'(4x,a,a)') 'ERROR. UNKNOWN STORAGE DATA TAG: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - end do - write(this%iout,'(1x,a)') 'END UPDATING STORAGE VALUES' - !else - ! write(this%iout,fmtlsp) 'STORAGE VALUES' - endif - - write(this%iout,'(//1X,A,I0,A,A,/)') & - 'STRESS PERIOD ', kper, ' IS ', trim(adjustl(css(this%iss))) - ! - ! -- Return - return - end subroutine sto_rp - - subroutine sto_ad(this) -! ****************************************************************************** -! sto_ad -- Advance -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(GwfStoType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Subroutine does not do anything at the moment - ! - ! -- Return - return - end subroutine sto_ad - - subroutine sto_fc(this, kiter, hold, hnew, njasln, amat, idxglo, rhs) -! ****************************************************************************** -! sto_fc -- Fill the solution amat and rhs with storage contribution newton -! term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: ustop, store_error - use ConstantsModule, only: LINELENGTH - use TdisModule, only: delt - ! -- dummy - class(GwfStoType) :: this - integer(I4B),intent(in) :: kiter - real(DP), intent(in), dimension(:) :: hold - real(DP), intent(in), dimension(:) :: hnew - integer(I4B),intent(in) :: njasln - real(DP), dimension(njasln),intent(inout) :: amat - integer(I4B), intent(in),dimension(:) :: idxglo - real(DP),intent(inout),dimension(:) :: rhs - ! -- local - integer(I4B) :: n, idiag - real(DP) :: tled, rho1, rho2 - real(DP) :: tp, bt, tthk - real(DP) :: snold, snnew - real(DP) :: ss0, ss1, ssh0, ssh1 - real(DP) :: rhsterm - character(len=LINELENGTH) :: errmsg - ! -- formats - character(len=*), parameter :: fmtsperror = & - &"('DETECTED TIME STEP LENGTH OF ZERO. GWF STORAGE PACKAGE CANNOT BE ', & - &'USED UNLESS DELT IS NON-ZERO.')" -! ------------------------------------------------------------------------------ - ! - ! -- test if steady-state stress period - if (this%iss /= 0) return - ! - ! -- Ensure time step length is not zero - if (delt == DZERO) then - write(errmsg, fmtsperror) - call store_error(errmsg) - call ustop() - endif - ! - ! -- set variables - tled = DONE / delt - ! - ! -- loop through and calculate storage contribution to hcof and rhs - do n = 1, this%dis%nodes - idiag = this%dis%con%ia(n) - if (this%ibound(n) < 1) cycle - ! -- aquifer elevations and thickness - tp = this%dis%top(n) - bt = this%dis%bot(n) - tthk = tp - bt - ! -- aquifer saturation - snold = sQuadraticSaturation(tp, bt, hold(n), this%satomega) - snnew = sQuadraticSaturation(tp, bt, hnew(n), this%satomega) - ! -- set saturation used for ss - ss0 = snold - ssh0 = hold(n) - ss1 = snnew - ssh1 = DZERO - if (this%isseg /= 0) then - if (ss0 < DONE) then - ss0 = DONE - ssh0 = tp - end if - if (ss1 < DONE) then - ss1 = DZERO - ssh1 = tp - end if - end if - ! -- storage coefficients - rho1 = this%sc1(n) * tled - rho2 = this%sc2(n) * tled - ! -- calculate storage coefficients for amat and rhs - ! -- specific storage - if (this%iconvert(n) /= 0) then - amat(idxglo(idiag)) = amat(idxglo(idiag)) - rho1 * ss1 - rhs(n) = rhs(n) - rho1 * ss0 * ssh0 + rho1 * ssh1 - else - amat(idxglo(idiag)) = amat(idxglo(idiag)) - rho1 - rhs(n) = rhs(n) - rho1 * hold(n) - end if - ! -- specific yield - if (this%iconvert(n) /= 0) then - rhsterm = DZERO - ! -- add specific yield terms to amat at rhs - if (snnew < DONE) then - if (snnew > DZERO) then - amat(idxglo(idiag)) = amat(idxglo(idiag)) - rho2 - rhsterm = rho2 * tthk * snold - rhsterm = rhsterm + rho2 * bt - else - rhsterm = -rho2 * tthk * (DZERO - snold) - end if - ! -- known flow from specific yield - else - rhsterm = -rho2 * tthk * (DONE - snold) - end if - rhs(n) = rhs(n) - rhsterm - end if - end do - ! - ! -- Return - return - end subroutine sto_fc - - subroutine sto_fn(this, kiter, hold, hnew, njasln, amat, idxglo, rhs) -! ****************************************************************************** -! sto_fn -- Fill the solution amat and rhs with storage contribution -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use TdisModule, only: delt - ! -- dummy - class(GwfStoType) :: this - integer(I4B),intent(in) :: kiter - real(DP), intent(in), dimension(:) :: hold - real(DP), intent(in), dimension(:) :: hnew - integer(I4B),intent(in) :: njasln - real(DP), dimension(njasln),intent(inout) :: amat - integer(I4B), intent(in),dimension(:) :: idxglo - real(DP),intent(inout),dimension(:) :: rhs - ! -- local - integer(I4B) :: n, idiag - real(DP) :: tled, rho1, rho2 - real(DP) :: tp, bt, tthk - real(DP) :: snold, snnew - real(DP) :: ss0, ss1 - real(DP) :: derv, rterm, drterm -! ------------------------------------------------------------------------------ - ! - ! -- test if steady-state stress period - if (this%iss /= 0) return - ! - ! -- set variables - tled = DONE / delt - ! - ! -- loop through and calculate storage contribution to hcof and rhs - do n = 1, this%dis%nodes - idiag = this%dis%con%ia(n) - if(this%ibound(n) <= 0) cycle - ! -- aquifer elevations and thickness - tp = this%dis%top(n) - bt = this%dis%bot(n) - tthk = tp - bt - ! -- aquifer saturation - snold = sQuadraticSaturation(tp, bt, hold(n)) - snnew = sQuadraticSaturation(tp, bt, hnew(n)) - ! -- set saturation used for ss - ss0 = snold - ss1 = snnew - if (this%isseg /= 0) then - if (ss0 < DONE) ss0 = DZERO - if (ss1 < DONE) ss1 = DZERO - end if - ! -- storage coefficients - rho1 = this%sc1(n) * tled - rho2 = this%sc2(n) * tled - ! -- calculate storage coefficients for amat and rhs - ! -- specific storage - if (this%iconvert(n) /= 0) then - rterm = - rho1 * ss1 * hnew(n) - derv = sQuadraticSaturationDerivative(tp, bt, hnew(n)) - if (this%isseg /= 0) derv = DZERO - drterm = -(rho1 * derv * hnew(n)) - amat(idxglo(idiag)) = amat(idxglo(idiag)) + drterm - rhs(n) = rhs(n) + drterm * hnew(n) - end if - ! -- specific yield - if (this%iconvert(n) /= 0) then - ! -- newton terms for specific yield only apply if - ! current saturation is less than one - if (snnew < DONE) then - ! -- calculate newton terms for specific yield - if (snnew > DZERO) then - rterm = - rho2 * tthk * snnew - derv = sQuadraticSaturationDerivative(tp, bt, hnew(n)) - drterm = -rho2 * tthk * derv - amat(idxglo(idiag)) = amat(idxglo(idiag)) + drterm + rho2 - rhs(n) = rhs(n) - rterm + drterm * hnew(n) + rho2 * bt - end if - end if - end if - end do - ! - ! -- Return - return - end subroutine sto_fn - - subroutine sto_bdcalc(this, nodes, hnew, hold, isuppress_output, model_budget) -! ****************************************************************************** -! sto_bdcalc -- Calculate budget terms -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: delt - use BudgetModule, only: BudgetType - ! -- dummy - class(GwfStoType) :: this - integer(I4B), intent(in) :: nodes - real(DP), intent(in), dimension(nodes) :: hnew - real(DP), intent(in), dimension(nodes) :: hold - integer(I4B), intent(in) :: isuppress_output - type(BudgetType), intent(inout) :: model_budget - ! -- local - integer(I4B) :: n - real(DP) :: rate - real(DP) :: tled, rho1, rho2 - real(DP) :: tp, bt, tthk - real(DP) :: snold, snnew - real(DP) :: ss0, ss1, ssh0, ssh1 - real(DP) :: rssin, rssout, rsyin, rsyout -! ------------------------------------------------------------------------------ - ! - ! -- initialize accumulators - rssin = DZERO - rssout = DZERO - rsyin = DZERO - rsyout = DZERO - ! - ! -- Set strt to zero or calculate terms if not steady-state stress period - if (this%iss == 1) then - do n = 1, nodes - this%strgss(n) = DZERO - this%strgsy(n) = DZERO - end do - ! - else - ! - ! -- set variables - tled = DONE / delt - ! - ! -- Calculate storage change - do n = 1, nodes - this%strgss(n) = DZERO - this%strgsy(n) = DZERO - if(this%ibound(n) <= 0) cycle - ! -- aquifer elevations and thickness - tp = this%dis%top(n) - bt = this%dis%bot(n) - tthk = tp - bt - snold = sQuadraticSaturation(tp, bt, hold(n), this%satomega) - snnew = sQuadraticSaturation(tp, bt, hnew(n), this%satomega) - ! -- set saturation used for ss - ss0 = snold - ssh0 = hold(n) - ss1 = snnew - ssh1 = DZERO - if (this%isseg /= 0) then - if (ss0 < DONE) then - ss0 = DONE - ssh0 = tp - end if - if (ss1 < DONE) then - ss1 = DZERO - ssh1 = tp - end if - end if - ! -- storage coefficients - rho1 = this%sc1(n) * tled - rho2 = this%sc2(n) * tled - ! -- specific storage - if (this%iconvert(n) /= 0) then - rate = rho1 * ss0 * ssh0 - rho1 * ss1 * hnew(n) - rho1 * ssh1 - else - rate = rho1 * hold(n) - rho1 * hnew(n) - end if - this%strgss(n) = rate - ! -- specific yield - rate = DZERO - if (this%iconvert(n) /= 0) then - rate = rho2 * tthk * snold - rho2 * tthk * snnew - end if - this%strgsy(n) = rate - ! - ! -- accumulate ss - if(this%strgss(n) < DZERO) then - rssout = rssout - this%strgss(n) - else - rssin = rssin + this%strgss(n) - endif - ! - ! -- accumulate sy - if(this%strgsy(n) < DZERO) then - rsyout = rsyout - this%strgsy(n) - else - rsyin = rsyin + this%strgsy(n) - endif - enddo - endif - ! - ! -- Add contributions to model budget - call model_budget%addentry(rssin, rssout, delt, budtxt(1), & - isuppress_output, ' STORAGE') - if (this%iusesy == 1) then - call model_budget%addentry(rsyin, rsyout, delt, budtxt(2), & - isuppress_output, ' STORAGE') - end if - ! - ! -- Return - return - end subroutine sto_bdcalc - - subroutine sto_bdsav(this, icbcfl, icbcun) -! ****************************************************************************** -! sto_bdsav -- Save budget terms -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwfStoType) :: this - integer(I4B), intent(in) :: icbcfl - integer(I4B), intent(in) :: icbcun - ! -- local - integer(I4B) :: ibinun - !character(len=16), dimension(2) :: aname - integer(I4B) :: iprint, nvaluesp, nwidthp - character(len=1) :: cdatafmp=' ', editdesc=' ' - real(DP) :: dinact -! ------------------------------------------------------------------------------ - ! - ! -- Set unit number for binary output - if(this%ipakcb < 0) then - ibinun = icbcun - elseif(this%ipakcb == 0) then - ibinun = 0 - else - ibinun = this%ipakcb - endif - if(icbcfl == 0) ibinun = 0 - ! - ! -- Record the storage rates if requested - if(ibinun /= 0) then - iprint = 0 - dinact = DZERO - ! - ! -- storage(ss) - call this%dis%record_array(this%strgss, this%iout, iprint, -ibinun, & - budtxt(1), cdatafmp, nvaluesp, & - nwidthp, editdesc, dinact) - ! - ! -- storage(sy) - if (this%iusesy == 1) then - call this%dis%record_array(this%strgsy, this%iout, iprint, -ibinun, & - budtxt(2), cdatafmp, nvaluesp, & - nwidthp, editdesc, dinact) - end if - endif - ! - ! -- Return - return - end subroutine sto_bdsav - - subroutine sto_da(this) -! ****************************************************************************** -! sto_da -- Deallocate variables -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(GwfStoType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Deallocate arrays if package is active - if(this%inunit > 0) then - call mem_deallocate(this%iconvert) - call mem_deallocate(this%sc1) - call mem_deallocate(this%sc2) - call mem_deallocate(this%strgss) - call mem_deallocate(this%strgsy) - endif - ! - ! -- Deallocate scalars - call mem_deallocate(this%isfac) - call mem_deallocate(this%isseg) - call mem_deallocate(this%satomega) - call mem_deallocate(this%iusesy) - ! - ! -- deallocate parent - call this%NumericalPackageType%da() - ! - ! -- Return - return - end subroutine sto_da - - subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate, mem_setptr - ! -- dummy - class(GwfStoType) :: this - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- allocate scalars in NumericalPackageType - call this%NumericalPackageType%allocate_scalars() - ! - ! -- Allocate - call mem_allocate(this%iusesy, 'IUSESY', this%origin) - call mem_allocate(this%isfac, 'ISFAC', this%origin) - call mem_allocate(this%isseg, 'ISSEG', this%origin) - call mem_allocate(this%satomega, 'SATOMEGA', this%origin) - ! - ! -- Initialize - this%iusesy = 0 - this%isfac = 0 - this%isseg = 0 - this%satomega = DZERO - ! - ! -- Return - return - end subroutine allocate_scalars - - subroutine allocate_arrays(this, nodes) -! ****************************************************************************** -! allocate_arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use MemoryManagerModule, only: mem_allocate - !modules - use ConstantsModule, only: DZERO - ! -- dummy - class(GwfStoType) :: this - integer(I4B), intent(in) :: nodes - ! -- local - integer(I4B) :: n -! ------------------------------------------------------------------------------ - ! - ! -- Allocate - !call mem_allocate(this%iss, 'ISS', this%name_model) - call mem_allocate(this%iconvert, nodes, 'ICONVERT', this%origin) - call mem_allocate(this%sc1, nodes, 'SC1', this%origin) - call mem_allocate(this%sc2, nodes, 'SC2', this%origin) - call mem_allocate(this%strgss, nodes, 'STRGSS', this%origin) - call mem_allocate(this%strgsy, nodes, 'STRGSY', this%origin) - ! - ! -- Initialize - this%iss = 0 - do n = 1, nodes - this%iconvert(n) = 1 - this%sc1(n) = DZERO - this%sc2(n) = DZERO - this%strgss(n) = DZERO - this%strgsy(n) = DZERO - enddo - ! - ! -- Return - return - end subroutine allocate_arrays - - subroutine read_options(this) -! ****************************************************************************** -! gwf3sto1ar -- Allocate and Read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - !modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error - ! -- dummy - class(GwfStoType) :: this - ! -- local - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock - ! -- formats - character(len=*), parameter :: fmtisvflow = & - "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE " // & - "WHENEVER ICBCFL IS NOT ZERO.')" - character(len=*),parameter :: fmtflow = & - "(4x, 'FLOWS WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" - character(len=*), parameter :: fmtstoc = & - "(4X,'STORAGECOEFFICIENT OPTION:',/, & - &1X,'Read storage coefficient rather than specific storage')" - character(len=*), parameter :: fmtstoseg = & - "(4X,'OLDSTORAGEFORMULATION OPTION:',/, & - &1X,'Specific storage changes only occur above cell top')" -! ------------------------------------------------------------------------------ - ! - ! -- 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 STORAGE OPTIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('SAVE_FLOWS') - this%ipakcb = -1 - write(this%iout, fmtisvflow) - case ('STORAGECOEFFICIENT') - this%isfac = 1 - write(this%iout,fmtstoc) - ! - ! -- right now these 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 cell storage' - case ('DEV_OLDSTORAGEFORMULATION') - call this%parser%DevOpt() - this%isseg = 1 - write(this%iout,fmtstoseg) - case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN STO OPTION: ', & - trim(keyword) - call store_error(errmsg) - call ustop() - end select - end do - write(this%iout,'(1x,a)')'END OF STORAGE OPTIONS' - end if - ! - ! -- set omega value used for saturation calculations - if (this%inewton > 0) then - this%satomega = DEM6 - end if - ! - ! -- Return - return - end subroutine read_options - - subroutine read_data(this) -! ****************************************************************************** -! read_data -- read the storage data (stodata) block -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors - ! -- dummy - class(GwfStotype) :: this - ! -- local - character(len=LINELENGTH) :: line, errmsg, keyword - character(len=LINELENGTH) :: cellstr - integer(I4B) :: istart, istop, lloc, ierr - logical :: isfound, endOfBlock - logical :: readiconv - logical :: readss - logical :: readsy - logical :: isconv - character(len=24), dimension(4) :: aname - integer(I4B) :: n - real(DP) :: thick - ! -- formats - !data - data aname(1) /' ICONVERT'/ - data aname(2) /' SPECIFIC STORAGE'/ - data aname(3) /' SPECIFIC YIELD'/ - data aname(4) /' STORAGE COEFFICIENT'/ -! ------------------------------------------------------------------------------ - ! - ! -- initialize - isfound = .false. - readiconv = .false. - readss = .false. - readsy = .false. - isconv = .false. - ! - ! -- get stodata 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 ('ICONVERT') - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%iconvert, & - aname(1)) - readiconv = .true. - case ('SS') - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%sc1, & - aname(2)) - readss = .true. - case ('SY') - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%sc2, & - aname(3)) - readsy = .true. - case default - write(errmsg,'(4x,a,a)')'ERROR. UNKNOWN GRIDDATA TAG: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - end do - write(this%iout,'(1x,a)')'END PROCESSING GRIDDATA' - else - write(errmsg,'(1x,a)')'ERROR. REQUIRED GRIDDATA BLOCK NOT FOUND.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- Check for ICONVERT - if(.not. readiconv) then - write(errmsg, '(a, a, a)') 'Error in GRIDDATA block: ', & - trim(adjustl(aname(1))), ' not found.' - call store_error(errmsg) - else - isconv = .false. - do n = 1, this%dis%nodes - if (this%iconvert(n) /= 0) then - isconv = .true. - this%iusesy = 1 - exit - end if - end do - end if - ! - ! -- Check for SS - if(.not. readss) then - write(errmsg, '(a, a, a)') 'Error in GRIDDATA block: ', & - trim(adjustl(aname(2))), ' not found.' - call store_error(errmsg) - endif - ! - ! -- Check for SY - if(.not. readsy .and. isconv) then - write(errmsg, '(a, a, a)') 'Error in GRIDDATA block: ', & - trim(adjustl(aname(3))), ' not found.' - call store_error(errmsg) - endif - ! - if(count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Check SS and SY for negative values - do n = 1, this%dis%nodes - if (this%sc1(n) < DZERO) then - call this%dis%noder_to_string(n, cellstr) - write(errmsg, '(a,2(1x,a),1x,g0,1x,a)') & - 'Error in SS DATA: SS value in cell', trim(adjustl(cellstr)), & - 'is less than zero (', this%sc1(n), ').' - call store_error(errmsg) - end if - if (readsy) then - if (this%sc2(n) < DZERO) then - call this%dis%noder_to_string(n, cellstr) - write(errmsg, '(a,2(1x,a),1x,g0,1x,a)') & - 'Error in SY DATA: SY value in cell', trim(adjustl(cellstr)), & - 'is less than zero (', this%sc2(n), ').' - call store_error(errmsg) - end if - end if - end do - - ! - ! -- calculate sc1 - if (readss) then - if(this%isfac == 0) then - do n = 1, this%dis%nodes - thick = this%dis%top(n) - this%dis%bot(n) - this%sc1(n) = this%sc1(n) * thick * this%dis%area(n) - end do - else - do n = 1, this%dis%nodes - this%sc1(n) = this%sc1(n) * this%dis%area(n) - enddo - endif - endif - ! - ! -- calculate sc2 - if(readsy) then - do n=1, this%dis%nodes - this%sc2(n) = this%sc2(n) * this%dis%area(n) - enddo - endif - ! - ! -- Return - return - end subroutine read_data - -end module GwfStoModule +module GwfStoModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, DEM6, DEM4, DONE, LENBUDTXT + use SmoothingModule, only: sQuadraticSaturation, & + sQuadraticSaturationDerivative, & + sQSaturation, sLinearSaturation + use BaseDisModule, only: DisBaseType + use NumericalPackageModule, only: NumericalPackageType + use BlockParserModule, only: BlockParserType + + implicit none + public :: GwfStoType, sto_cr + + character(len=LENBUDTXT), dimension(2) :: budtxt = & !text labels for budget terms + [' STO-SS', ' STO-SY'] + + type, extends(NumericalPackageType) :: GwfStoType + integer(I4B), pointer :: isfac => null() !indicates if ss is read as storativity + integer(I4B), pointer :: isseg => null() !indicates if ss is 0 below the top of a layer + integer(I4B), pointer :: iss => null() !steady state flag + integer(I4B), pointer :: iusesy => null() !flag set if any cell is convertible (0, 1) + integer(I4B), dimension(:), pointer, contiguous :: iconvert => null() !confined (0) or convertible (1) + real(DP),dimension(:), pointer, contiguous :: sc1 => null() !primary storage capacity (when cell is fully saturated) + real(DP),dimension(:), pointer, contiguous :: sc2 => null() !secondary storage capacity (when cell is partially saturated) + real(DP), dimension(:), pointer, contiguous :: strgss => null() !vector of specific storage rates + real(DP), dimension(:), pointer, contiguous :: strgsy => null() !vector of specific yield rates + integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !pointer to model ibound + real(DP), pointer :: satomega => null() !newton-raphson saturation omega + contains + procedure :: sto_ar + procedure :: sto_rp + procedure :: sto_ad + procedure :: sto_fc + procedure :: sto_fn + procedure :: bdcalc => sto_bdcalc + procedure :: bdsav => sto_bdsav + procedure :: sto_da + procedure :: allocate_scalars + procedure, private :: allocate_arrays + procedure, private :: read_options + procedure, private :: read_data + endtype + + contains + + subroutine sto_cr(stoobj, name_model, inunit, iout) +! ****************************************************************************** +! sto_cr -- Create a new STO object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + type(GwfStoType), pointer :: stoobj + character(len=*), intent(in) :: name_model + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout +! ------------------------------------------------------------------------------ + ! + ! -- Create the object + allocate(stoobj) + ! + ! -- create name and origin + call stoobj%set_names(1, name_model, 'STO', 'STO') + ! + ! -- Allocate scalars + call stoobj%allocate_scalars() + ! + ! -- Set variables + stoobj%inunit = inunit + stoobj%iout = iout + ! + ! -- Initialize block parser + call stoobj%parser%Initialize(stoobj%inunit, stoobj%iout) + ! + ! -- Return + return + end subroutine sto_cr + + subroutine sto_ar(this, dis, ibound) +! ****************************************************************************** +! sto_ar -- Allocate and Read +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + !modules + use MemoryManagerModule, only: mem_setptr + ! -- dummy + class(GwfStoType) :: this + class(DisBaseType), pointer, intent(in) :: dis + integer(I4B), dimension(:), pointer, contiguous :: ibound + ! -- local + ! -- formats + character(len=*), parameter :: fmtsto = & + "(1x,/1x,'STO -- STORAGE PACKAGE, VERSION 1, 5/19/2014', & + &' INPUT READ FROM UNIT ', i0, //)" +! ------------------------------------------------------------------------------ + ! + ! --print a message identifying the storage package. + write(this%iout, fmtsto) this%inunit + ! + ! -- store pointers to arguments that were passed in + this%dis => dis + this%ibound => ibound + ! + ! -- set pointer to gwf iss + call mem_setptr(this%iss, 'ISS', trim(this%name_model)) + ! + ! -- Allocate arrays + call this%allocate_arrays(dis%nodes) + ! + ! -- Read storage options + call this%read_options() + ! + ! -- read the data block + call this%read_data() + ! + ! -- Return + return + end subroutine sto_ar + + subroutine sto_rp(this) +! ****************************************************************************** +! sto_rp -- Read and prepare +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use TdisModule, only: kper, nper + use SimModule, only: store_error, ustop + implicit none + ! -- dummy + class(GwfStoType) :: this + ! -- local + integer(I4B) :: ierr + logical :: isfound, readss, readsy, endOfBlock + !character(len=24) :: aname(4) , stotxt + character (len=16) :: css(0:1) + character(len=LINELENGTH) :: line, errmsg, keyword + ! -- formats + character(len=*),parameter :: fmtlsp = & + "(1X,/1X,'REUSING ',A,' FROM LAST STRESS PERIOD')" + character(len=*),parameter :: fmtblkerr = & + "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + !data + data css(0) /' TRANSIENT'/ + data css(1) /' STEADY-STATE'/ + !data aname(1) /' ICONVERT'/ + !data aname(2) /' SPECIFIC STORAGE'/ + !data aname(3) /' SPECIFIC YIELD'/ + !data aname(4) /' STORAGE COEFFICIENT'/ +! ------------------------------------------------------------------------------ + ! + ! -- get stress period data + if (this%ionper < kper) then + ! + ! -- get period block + call this%parser%GetBlock('PERIOD', isfound, ierr, & + supportOpenClose=.true.) + if (isfound) then + ! + ! -- read ionper and check for increasing period numbers + call this%read_check_ionper() + else + ! + ! -- PERIOD block not found + if (ierr < 0) then + ! -- End of file found; data applies for remainder of simulation. + this%ionper = nper + 1 + else + ! -- Found invalid block + call this%parser%GetCurrentLine(line) + write(errmsg, fmtblkerr) adjustl(trim(line)) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end if + endif + end if + ! + ! -- read data if ionper == kper + readss = .false. + readsy = .false. + !stotxt = aname(2) + if(this%ionper==kper) then + write(this%iout, '(//,1x,a)') 'UPDATING STORAGE VALUES' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('STEADY-STATE') + this%iss = 1 + case ('TRANSIENT') + this%iss = 0 + case default + write(errmsg,'(4x,a,a)') 'ERROR. UNKNOWN STORAGE DATA TAG: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + end do + write(this%iout,'(1x,a)') 'END UPDATING STORAGE VALUES' + !else + ! write(this%iout,fmtlsp) 'STORAGE VALUES' + endif + + write(this%iout,'(//1X,A,I0,A,A,/)') & + 'STRESS PERIOD ', kper, ' IS ', trim(adjustl(css(this%iss))) + ! + ! -- Return + return + end subroutine sto_rp + + subroutine sto_ad(this) +! ****************************************************************************** +! sto_ad -- Advance +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GwfStoType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Subroutine does not do anything at the moment + ! + ! -- Return + return + end subroutine sto_ad + + subroutine sto_fc(this, kiter, hold, hnew, njasln, amat, idxglo, rhs) +! ****************************************************************************** +! sto_fc -- Fill the solution amat and rhs with storage contribution newton +! term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: ustop, store_error + use ConstantsModule, only: LINELENGTH + use TdisModule, only: delt + ! -- dummy + class(GwfStoType) :: this + integer(I4B),intent(in) :: kiter + real(DP), intent(in), dimension(:) :: hold + real(DP), intent(in), dimension(:) :: hnew + integer(I4B),intent(in) :: njasln + real(DP), dimension(njasln),intent(inout) :: amat + integer(I4B), intent(in),dimension(:) :: idxglo + real(DP),intent(inout),dimension(:) :: rhs + ! -- local + integer(I4B) :: n, idiag + real(DP) :: tled, rho1, rho2 + real(DP) :: tp, bt, tthk + real(DP) :: snold, snnew + real(DP) :: ss0, ss1, ssh0, ssh1 + real(DP) :: rhsterm + character(len=LINELENGTH) :: errmsg + ! -- formats + character(len=*), parameter :: fmtsperror = & + &"('DETECTED TIME STEP LENGTH OF ZERO. GWF STORAGE PACKAGE CANNOT BE ', & + &'USED UNLESS DELT IS NON-ZERO.')" +! ------------------------------------------------------------------------------ + ! + ! -- test if steady-state stress period + if (this%iss /= 0) return + ! + ! -- Ensure time step length is not zero + if (delt == DZERO) then + write(errmsg, fmtsperror) + call store_error(errmsg) + call ustop() + endif + ! + ! -- set variables + tled = DONE / delt + ! + ! -- loop through and calculate storage contribution to hcof and rhs + do n = 1, this%dis%nodes + idiag = this%dis%con%ia(n) + if (this%ibound(n) < 1) cycle + ! -- aquifer elevations and thickness + tp = this%dis%top(n) + bt = this%dis%bot(n) + tthk = tp - bt + ! -- aquifer saturation + snold = sQuadraticSaturation(tp, bt, hold(n), this%satomega) + snnew = sQuadraticSaturation(tp, bt, hnew(n), this%satomega) + ! -- set saturation used for ss + ss0 = snold + ssh0 = hold(n) + ss1 = snnew + ssh1 = DZERO + if (this%isseg /= 0) then + if (ss0 < DONE) then + ss0 = DONE + ssh0 = tp + end if + if (ss1 < DONE) then + ss1 = DZERO + ssh1 = tp + end if + end if + ! -- storage coefficients + rho1 = this%sc1(n) * tled + rho2 = this%sc2(n) * tled + ! -- calculate storage coefficients for amat and rhs + ! -- specific storage + if (this%iconvert(n) /= 0) then + amat(idxglo(idiag)) = amat(idxglo(idiag)) - rho1 * ss1 + rhs(n) = rhs(n) - rho1 * ss0 * ssh0 + rho1 * ssh1 + else + amat(idxglo(idiag)) = amat(idxglo(idiag)) - rho1 + rhs(n) = rhs(n) - rho1 * hold(n) + end if + ! -- specific yield + if (this%iconvert(n) /= 0) then + rhsterm = DZERO + ! -- add specific yield terms to amat at rhs + if (snnew < DONE) then + if (snnew > DZERO) then + amat(idxglo(idiag)) = amat(idxglo(idiag)) - rho2 + rhsterm = rho2 * tthk * snold + rhsterm = rhsterm + rho2 * bt + else + rhsterm = -rho2 * tthk * (DZERO - snold) + end if + ! -- known flow from specific yield + else + rhsterm = -rho2 * tthk * (DONE - snold) + end if + rhs(n) = rhs(n) - rhsterm + end if + end do + ! + ! -- Return + return + end subroutine sto_fc + + subroutine sto_fn(this, kiter, hold, hnew, njasln, amat, idxglo, rhs) +! ****************************************************************************** +! sto_fn -- Fill the solution amat and rhs with storage contribution +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use TdisModule, only: delt + ! -- dummy + class(GwfStoType) :: this + integer(I4B),intent(in) :: kiter + real(DP), intent(in), dimension(:) :: hold + real(DP), intent(in), dimension(:) :: hnew + integer(I4B),intent(in) :: njasln + real(DP), dimension(njasln),intent(inout) :: amat + integer(I4B), intent(in),dimension(:) :: idxglo + real(DP),intent(inout),dimension(:) :: rhs + ! -- local + integer(I4B) :: n, idiag + real(DP) :: tled, rho1, rho2 + real(DP) :: tp, bt, tthk + real(DP) :: snold, snnew + real(DP) :: ss0, ss1 + real(DP) :: derv, rterm, drterm +! ------------------------------------------------------------------------------ + ! + ! -- test if steady-state stress period + if (this%iss /= 0) return + ! + ! -- set variables + tled = DONE / delt + ! + ! -- loop through and calculate storage contribution to hcof and rhs + do n = 1, this%dis%nodes + idiag = this%dis%con%ia(n) + if(this%ibound(n) <= 0) cycle + ! -- aquifer elevations and thickness + tp = this%dis%top(n) + bt = this%dis%bot(n) + tthk = tp - bt + ! -- aquifer saturation + snold = sQuadraticSaturation(tp, bt, hold(n)) + snnew = sQuadraticSaturation(tp, bt, hnew(n)) + ! -- set saturation used for ss + ss0 = snold + ss1 = snnew + if (this%isseg /= 0) then + if (ss0 < DONE) ss0 = DZERO + if (ss1 < DONE) ss1 = DZERO + end if + ! -- storage coefficients + rho1 = this%sc1(n) * tled + rho2 = this%sc2(n) * tled + ! -- calculate storage coefficients for amat and rhs + ! -- specific storage + if (this%iconvert(n) /= 0) then + rterm = - rho1 * ss1 * hnew(n) + derv = sQuadraticSaturationDerivative(tp, bt, hnew(n)) + if (this%isseg /= 0) derv = DZERO + drterm = -(rho1 * derv * hnew(n)) + amat(idxglo(idiag)) = amat(idxglo(idiag)) + drterm + rhs(n) = rhs(n) + drterm * hnew(n) + end if + ! -- specific yield + if (this%iconvert(n) /= 0) then + ! -- newton terms for specific yield only apply if + ! current saturation is less than one + if (snnew < DONE) then + ! -- calculate newton terms for specific yield + if (snnew > DZERO) then + rterm = - rho2 * tthk * snnew + derv = sQuadraticSaturationDerivative(tp, bt, hnew(n)) + drterm = -rho2 * tthk * derv + amat(idxglo(idiag)) = amat(idxglo(idiag)) + drterm + rho2 + rhs(n) = rhs(n) - rterm + drterm * hnew(n) + rho2 * bt + end if + end if + end if + end do + ! + ! -- Return + return + end subroutine sto_fn + + subroutine sto_bdcalc(this, nodes, hnew, hold, isuppress_output, model_budget) +! ****************************************************************************** +! sto_bdcalc -- Calculate budget terms +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: delt + use BudgetModule, only: BudgetType + ! -- dummy + class(GwfStoType) :: this + integer(I4B), intent(in) :: nodes + real(DP), intent(in), dimension(nodes) :: hnew + real(DP), intent(in), dimension(nodes) :: hold + integer(I4B), intent(in) :: isuppress_output + type(BudgetType), intent(inout) :: model_budget + ! -- local + integer(I4B) :: n + real(DP) :: rate + real(DP) :: tled, rho1, rho2 + real(DP) :: tp, bt, tthk + real(DP) :: snold, snnew + real(DP) :: ss0, ss1, ssh0, ssh1 + real(DP) :: rssin, rssout, rsyin, rsyout +! ------------------------------------------------------------------------------ + ! + ! -- initialize accumulators + rssin = DZERO + rssout = DZERO + rsyin = DZERO + rsyout = DZERO + ! + ! -- Set strt to zero or calculate terms if not steady-state stress period + if (this%iss == 1) then + do n = 1, nodes + this%strgss(n) = DZERO + this%strgsy(n) = DZERO + end do + ! + else + ! + ! -- set variables + tled = DONE / delt + ! + ! -- Calculate storage change + do n = 1, nodes + this%strgss(n) = DZERO + this%strgsy(n) = DZERO + if(this%ibound(n) <= 0) cycle + ! -- aquifer elevations and thickness + tp = this%dis%top(n) + bt = this%dis%bot(n) + tthk = tp - bt + snold = sQuadraticSaturation(tp, bt, hold(n), this%satomega) + snnew = sQuadraticSaturation(tp, bt, hnew(n), this%satomega) + ! -- set saturation used for ss + ss0 = snold + ssh0 = hold(n) + ss1 = snnew + ssh1 = DZERO + if (this%isseg /= 0) then + if (ss0 < DONE) then + ss0 = DONE + ssh0 = tp + end if + if (ss1 < DONE) then + ss1 = DZERO + ssh1 = tp + end if + end if + ! -- storage coefficients + rho1 = this%sc1(n) * tled + rho2 = this%sc2(n) * tled + ! -- specific storage + if (this%iconvert(n) /= 0) then + rate = rho1 * ss0 * ssh0 - rho1 * ss1 * hnew(n) - rho1 * ssh1 + else + rate = rho1 * hold(n) - rho1 * hnew(n) + end if + this%strgss(n) = rate + ! -- specific yield + rate = DZERO + if (this%iconvert(n) /= 0) then + rate = rho2 * tthk * snold - rho2 * tthk * snnew + end if + this%strgsy(n) = rate + ! + ! -- accumulate ss + if(this%strgss(n) < DZERO) then + rssout = rssout - this%strgss(n) + else + rssin = rssin + this%strgss(n) + endif + ! + ! -- accumulate sy + if(this%strgsy(n) < DZERO) then + rsyout = rsyout - this%strgsy(n) + else + rsyin = rsyin + this%strgsy(n) + endif + enddo + endif + ! + ! -- Add contributions to model budget + call model_budget%addentry(rssin, rssout, delt, budtxt(1), & + isuppress_output, ' STORAGE') + if (this%iusesy == 1) then + call model_budget%addentry(rsyin, rsyout, delt, budtxt(2), & + isuppress_output, ' STORAGE') + end if + ! + ! -- Return + return + end subroutine sto_bdcalc + + subroutine sto_bdsav(this, icbcfl, icbcun) +! ****************************************************************************** +! sto_bdsav -- Save budget terms +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfStoType) :: this + integer(I4B), intent(in) :: icbcfl + integer(I4B), intent(in) :: icbcun + ! -- local + integer(I4B) :: ibinun + !character(len=16), dimension(2) :: aname + integer(I4B) :: iprint, nvaluesp, nwidthp + character(len=1) :: cdatafmp=' ', editdesc=' ' + real(DP) :: dinact +! ------------------------------------------------------------------------------ + ! + ! -- Set unit number for binary output + if(this%ipakcb < 0) then + ibinun = icbcun + elseif(this%ipakcb == 0) then + ibinun = 0 + else + ibinun = this%ipakcb + endif + if(icbcfl == 0) ibinun = 0 + ! + ! -- Record the storage rates if requested + if(ibinun /= 0) then + iprint = 0 + dinact = DZERO + ! + ! -- storage(ss) + call this%dis%record_array(this%strgss, this%iout, iprint, -ibinun, & + budtxt(1), cdatafmp, nvaluesp, & + nwidthp, editdesc, dinact) + ! + ! -- storage(sy) + if (this%iusesy == 1) then + call this%dis%record_array(this%strgsy, this%iout, iprint, -ibinun, & + budtxt(2), cdatafmp, nvaluesp, & + nwidthp, editdesc, dinact) + end if + endif + ! + ! -- Return + return + end subroutine sto_bdsav + + subroutine sto_da(this) +! ****************************************************************************** +! sto_da -- Deallocate variables +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(GwfStoType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Deallocate arrays if package is active + if(this%inunit > 0) then + call mem_deallocate(this%iconvert) + call mem_deallocate(this%sc1) + call mem_deallocate(this%sc2) + call mem_deallocate(this%strgss) + call mem_deallocate(this%strgsy) + endif + ! + ! -- Deallocate scalars + call mem_deallocate(this%isfac) + call mem_deallocate(this%isseg) + call mem_deallocate(this%satomega) + call mem_deallocate(this%iusesy) + ! + ! -- deallocate parent + call this%NumericalPackageType%da() + ! + ! -- Return + return + end subroutine sto_da + + subroutine allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate, mem_setptr + ! -- dummy + class(GwfStoType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- allocate scalars in NumericalPackageType + call this%NumericalPackageType%allocate_scalars() + ! + ! -- Allocate + call mem_allocate(this%iusesy, 'IUSESY', this%origin) + call mem_allocate(this%isfac, 'ISFAC', this%origin) + call mem_allocate(this%isseg, 'ISSEG', this%origin) + call mem_allocate(this%satomega, 'SATOMEGA', this%origin) + ! + ! -- Initialize + this%iusesy = 0 + this%isfac = 0 + this%isseg = 0 + this%satomega = DZERO + ! + ! -- Return + return + end subroutine allocate_scalars + + subroutine allocate_arrays(this, nodes) +! ****************************************************************************** +! allocate_arrays +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use MemoryManagerModule, only: mem_allocate + !modules + use ConstantsModule, only: DZERO + ! -- dummy + class(GwfStoType) :: this + integer(I4B), intent(in) :: nodes + ! -- local + integer(I4B) :: n +! ------------------------------------------------------------------------------ + ! + ! -- Allocate + !call mem_allocate(this%iss, 'ISS', this%name_model) + call mem_allocate(this%iconvert, nodes, 'ICONVERT', this%origin) + call mem_allocate(this%sc1, nodes, 'SC1', this%origin) + call mem_allocate(this%sc2, nodes, 'SC2', this%origin) + call mem_allocate(this%strgss, nodes, 'STRGSS', this%origin) + call mem_allocate(this%strgsy, nodes, 'STRGSY', this%origin) + ! + ! -- Initialize + this%iss = 0 + do n = 1, nodes + this%iconvert(n) = 1 + this%sc1(n) = DZERO + this%sc2(n) = DZERO + this%strgss(n) = DZERO + this%strgsy(n) = DZERO + enddo + ! + ! -- Return + return + end subroutine allocate_arrays + + subroutine read_options(this) +! ****************************************************************************** +! gwf3sto1ar -- Allocate and Read +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + !modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error + ! -- dummy + class(GwfStoType) :: this + ! -- local + character(len=LINELENGTH) :: errmsg, keyword + integer(I4B) :: ierr + logical :: isfound, endOfBlock + ! -- formats + character(len=*), parameter :: fmtisvflow = & + "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE " // & + "WHENEVER ICBCFL IS NOT ZERO.')" + character(len=*),parameter :: fmtflow = & + "(4x, 'FLOWS WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" + character(len=*), parameter :: fmtstoc = & + "(4X,'STORAGECOEFFICIENT OPTION:',/, & + &1X,'Read storage coefficient rather than specific storage')" + character(len=*), parameter :: fmtstoseg = & + "(4X,'OLDSTORAGEFORMULATION OPTION:',/, & + &1X,'Specific storage changes only occur above cell top')" +! ------------------------------------------------------------------------------ + ! + ! -- 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 STORAGE OPTIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('SAVE_FLOWS') + this%ipakcb = -1 + write(this%iout, fmtisvflow) + case ('STORAGECOEFFICIENT') + this%isfac = 1 + write(this%iout,fmtstoc) + ! + ! -- right now these 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 cell storage' + case ('DEV_OLDSTORAGEFORMULATION') + call this%parser%DevOpt() + this%isseg = 1 + write(this%iout,fmtstoseg) + case default + write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN STO OPTION: ', & + trim(keyword) + call store_error(errmsg) + call ustop() + end select + end do + write(this%iout,'(1x,a)')'END OF STORAGE OPTIONS' + end if + ! + ! -- set omega value used for saturation calculations + if (this%inewton > 0) then + this%satomega = DEM6 + end if + ! + ! -- Return + return + end subroutine read_options + + subroutine read_data(this) +! ****************************************************************************** +! read_data -- read the storage data (stodata) block +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors + ! -- dummy + class(GwfStotype) :: this + ! -- local + character(len=LINELENGTH) :: line, errmsg, keyword + character(len=LINELENGTH) :: cellstr + integer(I4B) :: istart, istop, lloc, ierr + logical :: isfound, endOfBlock + logical :: readiconv + logical :: readss + logical :: readsy + logical :: isconv + character(len=24), dimension(4) :: aname + integer(I4B) :: n + real(DP) :: thick + ! -- formats + !data + data aname(1) /' ICONVERT'/ + data aname(2) /' SPECIFIC STORAGE'/ + data aname(3) /' SPECIFIC YIELD'/ + data aname(4) /' STORAGE COEFFICIENT'/ +! ------------------------------------------------------------------------------ + ! + ! -- initialize + isfound = .false. + readiconv = .false. + readss = .false. + readsy = .false. + isconv = .false. + ! + ! -- get stodata 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 ('ICONVERT') + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%iconvert, & + aname(1)) + readiconv = .true. + case ('SS') + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%sc1, & + aname(2)) + readss = .true. + case ('SY') + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%sc2, & + aname(3)) + readsy = .true. + case default + write(errmsg,'(4x,a,a)')'ERROR. UNKNOWN GRIDDATA TAG: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + end do + write(this%iout,'(1x,a)')'END PROCESSING GRIDDATA' + else + write(errmsg,'(1x,a)')'ERROR. REQUIRED GRIDDATA BLOCK NOT FOUND.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- Check for ICONVERT + if(.not. readiconv) then + write(errmsg, '(a, a, a)') 'Error in GRIDDATA block: ', & + trim(adjustl(aname(1))), ' not found.' + call store_error(errmsg) + else + isconv = .false. + do n = 1, this%dis%nodes + if (this%iconvert(n) /= 0) then + isconv = .true. + this%iusesy = 1 + exit + end if + end do + end if + ! + ! -- Check for SS + if(.not. readss) then + write(errmsg, '(a, a, a)') 'Error in GRIDDATA block: ', & + trim(adjustl(aname(2))), ' not found.' + call store_error(errmsg) + endif + ! + ! -- Check for SY + if(.not. readsy .and. isconv) then + write(errmsg, '(a, a, a)') 'Error in GRIDDATA block: ', & + trim(adjustl(aname(3))), ' not found.' + call store_error(errmsg) + endif + ! + if(count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Check SS and SY for negative values + do n = 1, this%dis%nodes + if (this%sc1(n) < DZERO) then + call this%dis%noder_to_string(n, cellstr) + write(errmsg, '(a,2(1x,a),1x,g0,1x,a)') & + 'Error in SS DATA: SS value in cell', trim(adjustl(cellstr)), & + 'is less than zero (', this%sc1(n), ').' + call store_error(errmsg) + end if + if (readsy) then + if (this%sc2(n) < DZERO) then + call this%dis%noder_to_string(n, cellstr) + write(errmsg, '(a,2(1x,a),1x,g0,1x,a)') & + 'Error in SY DATA: SY value in cell', trim(adjustl(cellstr)), & + 'is less than zero (', this%sc2(n), ').' + call store_error(errmsg) + end if + end if + end do + + ! + ! -- calculate sc1 + if (readss) then + if(this%isfac == 0) then + do n = 1, this%dis%nodes + thick = this%dis%top(n) - this%dis%bot(n) + this%sc1(n) = this%sc1(n) * thick * this%dis%area(n) + end do + else + do n = 1, this%dis%nodes + this%sc1(n) = this%sc1(n) * this%dis%area(n) + enddo + endif + endif + ! + ! -- calculate sc2 + if(readsy) then + do n=1, this%dis%nodes + this%sc2(n) = this%sc2(n) * this%dis%area(n) + enddo + endif + ! + ! -- Return + return + end subroutine read_data + +end module GwfStoModule diff --git a/src/Model/GroundWaterFlow/gwf3uzf8.f90 b/src/Model/GroundWaterFlow/gwf3uzf8.f90 index dbebb540417..c2b5ef4009e 100644 --- a/src/Model/GroundWaterFlow/gwf3uzf8.f90 +++ b/src/Model/GroundWaterFlow/gwf3uzf8.f90 @@ -1,3488 +1,3488 @@ -! -- Uzf module -module UzfModule - - use KindModule, only: DP, I4B - use ArrayHandlersModule, only: ExpandArray - use ConstantsModule, only: DZERO, DEM6, DEM4, DEM2, DEM1, DHALF, & - DONE, DHUNDRED, & - LINELENGTH, LENFTYPE, LENPACKAGENAME, & - LENBOUNDNAME, LENBUDTXT, LENPAKLOC, DNODATA, & - NAMEDBOUNDFLAG, MAXCHARLEN, & - DHNOFLO, DHDRY, & - TABLEFT, TABCENTER, TABRIGHT, & - TABSTRING, TABUCSTRING, TABINTEGER, TABREAL - use GenericUtilitiesModule, only: sim_message - use MemoryTypeModule, only: MemoryTSType - use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_setptr, & - mem_deallocate - use SparseModule, only: sparsematrix - use BndModule, only: BndType - use UzfCellGroupModule, only: UzfCellGroupType - use BudgetObjectModule, only: BudgetObjectType, budgetobject_cr - use BaseDisModule, only: DisBaseType - use ObserveModule, only: ObserveType - use ObsModule, only: ObsType - use InputOutputModule, only: URWORD - use SimModule, only: count_errors, store_error, ustop, store_error_unit - use BlockParserModule, only: BlockParserType - use TableModule, only: TableType, table_cr - - implicit none - - character(len=LENFTYPE) :: ftype = 'UZF' - character(len=LENPACKAGENAME) :: text = ' UZF CELLS' - - private - public :: uzf_create - public :: UzfType - - type, extends(BndType) :: UzfType - ! output integers - integer(I4B), pointer :: iprwcont => null() - integer(I4B), pointer :: iwcontout => null() - integer(I4B), pointer :: ibudgetout => null() - integer(I4B), pointer :: ipakcsv => null() - ! - type(BudgetObjectType), pointer :: budobj => null() - integer(I4B), pointer :: bditems => null() !number of budget items - integer(I4B), pointer :: nbdtxt => null() !number of budget text items - character(len=LENBUDTXT), dimension(:), pointer, & - contiguous :: bdtxt => null() !budget items written to cbc file - character(len=LENBOUNDNAME), dimension(:), pointer, & - contiguous :: uzfname => null() - ! - ! -- uzf table objects - type(TableType), pointer :: pakcsvtab => null() - ! - ! -- uzf kinematic object - type(UzfCellGroupType), pointer :: uzfobj => null() - ! - ! -- pointer to gwf variables - integer(I4B), pointer :: gwfiss => null() - real(DP), dimension(:), pointer, contiguous :: gwftop => null() - real(DP), dimension(:), pointer, contiguous :: gwfbot => null() - real(DP), dimension(:), pointer, contiguous :: gwfarea => null() - real(DP), dimension(:), pointer, contiguous :: gwfhcond => null() - ! - ! -- uzf data - integer(I4B), pointer :: ntrail => null() - integer(I4B), pointer :: nsets => null() - integer(I4B), pointer :: nwav => null() - integer(I4B), pointer :: nodes => null() - integer(I4B), pointer :: nper => null() - integer(I4B), pointer :: nstp => null() - integer(I4B), pointer :: readflag => null() - integer(I4B), pointer :: outunitbud => null() - integer(I4B), pointer :: ietflag => null() - integer(I4B), pointer :: igwetflag => null() - integer(I4B), pointer :: iseepflag => null() - integer(I4B), pointer :: imaxcellcnt => null() - integer(I4B), dimension(:), pointer, contiguous :: igwfnode => null() - real(DP), dimension(:), pointer, contiguous :: appliedinf => null() - real(DP), dimension(:), pointer, contiguous :: rejinf => null() - real(DP), dimension(:), pointer, contiguous :: rejinf0 => null() - real(DP), dimension(:), pointer, contiguous :: rejinftomvr => null() - real(DP), dimension(:), pointer, contiguous :: infiltration => null() - real(DP), dimension(:), pointer, contiguous :: recharge => null() - real(DP), dimension(:), pointer, contiguous :: gwet => null() - real(DP), dimension(:), pointer, contiguous :: uzet => null() - real(DP), dimension(:), pointer, contiguous :: gwd => null() - real(DP), dimension(:), pointer, contiguous :: gwd0 => null() - real(DP), dimension(:), pointer, contiguous :: gwdtomvr => null() - real(DP), dimension(:), pointer, contiguous :: rch => null() - real(DP), dimension(:), pointer, contiguous :: rch0 => null() - real(DP), dimension(:), pointer, contiguous :: qsto => null() - integer(I4B), pointer :: iuzf2uzf => null() - ! - ! -- integer vectors - integer(I4B), dimension(:), pointer, contiguous :: ia => null() - integer(I4B), dimension(:), pointer, contiguous :: ja => null() - ! - ! -- timeseries aware variables - type (MemoryTSType), dimension(:), pointer, contiguous :: sinf => null() - type (MemoryTSType), dimension(:), pointer, contiguous :: pet => null() - type (MemoryTSType), dimension(:), pointer, contiguous :: extdp => null() - type (MemoryTSType), dimension(:), pointer, contiguous :: extwc => null() - type (MemoryTSType), dimension(:), pointer, contiguous :: ha => null() - type (MemoryTSType), dimension(:), pointer, contiguous :: hroot => null() - type (MemoryTSType), dimension(:), pointer, contiguous :: rootact => null() - type (MemoryTSType), dimension(:), pointer, contiguous :: lauxvar => null() - ! - ! -- convergence check - integer(I4B), pointer :: iconvchk => null() - ! - ! formulate variables - real(DP), dimension(:), pointer, contiguous :: deriv => null() - ! - ! budget variables - real(DP), pointer :: totfluxtot => null() - real(DP), pointer :: infilsum => null() - real(DP), pointer :: rechsum => null() - real(DP), pointer :: delstorsum => null() - real(DP), pointer :: uzetsum => null() - real(DP), pointer :: vfluxsum => null() - integer(I4B), pointer :: issflag => null() - integer(I4B), pointer :: issflagold => null() - integer(I4B), pointer :: istocb => null() - ! - ! -- uzf cbc budget items - integer(I4B), pointer :: cbcauxitems => NULL() - character(len=16), dimension(:), pointer, contiguous :: cauxcbc => NULL() - real(DP), dimension(:), pointer, contiguous :: qauxcbc => null() - ! - ! -- observations - real(DP), dimension(:), pointer, contiguous :: obs_theta => null() - real(DP), dimension(:), pointer, contiguous :: obs_depth => null() - integer(I4B), dimension(:), pointer, contiguous :: obs_num => null() - - contains - - procedure :: uzf_allocate_arrays - procedure :: uzf_allocate_scalars - procedure :: bnd_options => uzf_options - procedure :: read_dimensions => uzf_readdimensions - procedure :: bnd_ar => uzf_ar - procedure :: bnd_rp => uzf_rp - procedure :: bnd_ad => uzf_ad - procedure :: bnd_cf => uzf_cf - procedure :: bnd_cc => uzf_cc - procedure :: bnd_bd => uzf_bd - procedure :: bnd_ot => uzf_ot - procedure :: bnd_fc => uzf_fc - procedure :: bnd_fn => uzf_fn - procedure :: bnd_da => uzf_da - procedure :: define_listlabel - ! - ! -- methods for observations - procedure, public :: bnd_obs_supported => uzf_obs_supported - procedure, public :: bnd_df_obs => uzf_df_obs - procedure, public :: bnd_rp_obs => uzf_rp_obs - procedure, private :: uzf_bd_obs - ! - ! -- methods specific for uzf - procedure, private :: uzf_solve - procedure, private :: read_cell_properties - procedure, private :: print_cell_properties - procedure, private :: findcellabove - procedure, private :: check_cell_area - ! - ! -- budget - procedure, private :: uzf_setup_budobj - procedure, private :: uzf_fill_budobj - - end type UzfType - -contains - - subroutine uzf_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) -! ****************************************************************************** -! uzf_create -- Create a New UZF Package -! Subroutine: (1) create new-style package -! (2) point packobj to the new package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout - character(len=*), intent(in) :: namemodel - character(len=*), intent(in) :: pakname - ! -- local - type(UzfType), pointer :: uzfobj -! ------------------------------------------------------------------------------ - ! - ! -- allocate the object and assign values to object variables - allocate(uzfobj) - packobj => uzfobj - ! - ! -- create name and origin - call packobj%set_names(ibcnum, namemodel, pakname, ftype) - packobj%text = text - ! - ! -- allocate scalars - call uzfobj%uzf_allocate_scalars() - ! - ! -- initialize package - call packobj%pack_initialize() - ! - packobj%inunit = inunit - packobj%iout = iout - packobj%id = id - packobj%ibcnum = ibcnum - packobj%ncolbnd = 1 - packobj%iscloc = 0 ! not supported - packobj%ictorigin = 'NPF' - ! - ! -- return - return - end subroutine uzf_create - - subroutine uzf_ar(this) -! ****************************************************************************** -! uzf_ar -- Allocate and Read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate, mem_setptr, mem_reallocate - ! -- dummy - class(UzfType), intent(inout) :: this - ! -- local - integer(I4B) :: n, i - real(DP) :: hgwf -! ------------------------------------------------------------------------------ - ! - call this%obs%obs_ar() - ! - ! -- call standard BndType allocate scalars - call this%BndType%allocate_arrays() - ! - ! -- set pointers now that data is available - call mem_setptr(this%gwfhcond, 'CONDSAT', trim(this%name_model)//' NPF') - call mem_setptr(this%gwfiss, 'ISS', trim(this%name_model)) - ! - ! -- set boundname for each connection - if (this%inamedbound /= 0) then - do n = 1, this%nodes - this%boundname(n) = this%uzfname(n) - end do - endif - ! - ! -- copy igwfnode into nodelist and set water table - do i = 1, this%nodes - this%nodelist(i) = this%igwfnode(i) - n = this%igwfnode(i) - hgwf = this%xnew(n) - call this%uzfobj%sethead(i, hgwf) - end do - ! - ! allocate space to store moisture content observations - n = this%obs%npakobs - if ( n > 0 ) then - call mem_reallocate(this%obs_theta, n, 'OBS_THETA', this%origin) - call mem_reallocate(this%obs_depth, n, 'OBS_DEPTH', this%origin) - call mem_reallocate(this%obs_num, n, 'OBS_NUM', this%origin) - end if - ! - ! -- setup pakmvrobj - if (this%imover /= 0) then - allocate(this%pakmvrobj) - call this%pakmvrobj%ar(this%maxbound, this%maxbound, this%origin) - endif - ! - ! -- return - return - end subroutine uzf_ar - - subroutine uzf_allocate_arrays(this) -! ****************************************************************************** -! allocate_arrays -- allocate arrays used for uzf -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(UzfType), intent(inout) :: this - ! -- local - integer (I4B) :: i - integer (I4B) :: j - integer (I4B) :: ipos -! ------------------------------------------------------------------------------ - ! - ! -- call standard BndType allocate scalars (now done from AR) - !call this%BndType%allocate_arrays() - ! - ! -- allocate uzf specific arrays - call mem_allocate(this%igwfnode, this%nodes, 'IGWFNODE', this%origin) - call mem_allocate(this%appliedinf, this%nodes, 'APPLIEDINF', this%origin) - call mem_allocate(this%rejinf, this%nodes, 'REJINF', this%origin) - call mem_allocate(this%rejinf0, this%nodes, 'REJINF0', this%origin) - call mem_allocate(this%rejinftomvr, this%nodes, 'REJINFTOMVR', this%origin) - call mem_allocate(this%infiltration, this%nodes, 'INFILTRATION', this%origin) - call mem_allocate(this%recharge, this%nodes, 'RECHARGE', this%origin) - call mem_allocate(this%gwet, this%nodes, 'GWET', this%origin) - call mem_allocate(this%uzet, this%nodes, 'UZET', this%origin) - call mem_allocate(this%gwd, this%nodes, 'GWD', this%origin) - call mem_allocate(this%gwd0, this%nodes, 'GWD0', this%origin) - call mem_allocate(this%gwdtomvr, this%nodes, 'GWDTOMVR', this%origin) - call mem_allocate(this%rch, this%nodes, 'RCH', this%origin) - call mem_allocate(this%rch0, this%nodes, 'RCH0', this%origin) - call mem_allocate(this%qsto, this%nodes, 'QSTO', this%origin) - call mem_allocate(this%deriv, this%nodes, 'DERIV', this%origin) - - ! -- integer vectors - call mem_allocate(this%ia, this%dis%nodes+1, 'IA', this%origin) - call mem_allocate(this%ja, this%nodes, 'JA', this%origin) - - ! -- allocate timeseries aware variables - call mem_allocate(this%sinf, this%nodes, 'SINF', this%origin) - call mem_allocate(this%pet, this%nodes, 'PET', this%origin) - call mem_allocate(this%extdp, this%nodes, 'EXDP', this%origin) - call mem_allocate(this%extwc, this%nodes, 'EXTWC', this%origin) - call mem_allocate(this%ha, this%nodes, 'HA', this%origin) - call mem_allocate(this%hroot, this%nodes, 'HROOT', this%origin) - call mem_allocate(this%rootact, this%nodes, 'ROOTACT', this%origin) - call mem_allocate(this%lauxvar, this%naux*this%nodes, 'LAUXVAR', this%origin) - - ! -- initialize - do i = 1, this%nodes - this%appliedinf(i) = DZERO - this%recharge(i) = DZERO - this%rejinf(i) = DZERO - this%rejinf0(i) = DZERO - this%rejinftomvr(i) = DZERO - this%gwet(i) = DZERO - this%uzet(i) = DZERO - this%gwd(i) = DZERO - this%gwd0(i) = DZERO - this%gwdtomvr(i) = DZERO - this%rch(i) = DZERO - this%rch0(i) = DZERO - this%qsto(i) = DZERO - this%deriv(i) = DZERO - ! -- timeseries aware variables - this%sinf(i)%name = '' - this%pet(i)%name = '' - this%extdp(i)%name = '' - this%extwc(i)%name = '' - this%ha(i)%name = '' - this%hroot(i)%name = '' - this%rootact(i)%name = '' - this%sinf(i)%value = DZERO - this%pet(i)%value = DZERO - this%extdp(i)%value = DZERO - this%extwc(i)%value = DZERO - this%ha(i)%value = DZERO - this%hroot(i)%value = DZERO - this%rootact(i)%value = DZERO - do j = 1, this%naux - ipos = (i - 1) * this%naux + j - this%lauxvar(ipos)%name = '' - if (this%iauxmultcol > 0 .and. j == this%iauxmultcol) then - this%lauxvar(ipos)%value = DONE - else - this%lauxvar(ipos)%value = DZERO - end if - end do - end do - ! - ! -- allocate and initialize character array for budget text - allocate(this%bdtxt(this%nbdtxt)) - this%bdtxt(1) = ' UZF-INF' - this%bdtxt(2) = ' UZF-GWRCH' - this%bdtxt(3) = ' UZF-GWD' - this%bdtxt(4) = ' UZF-GWET' - this%bdtxt(5) = ' UZF-GWD TO-MVR' - ! - ! -- allocate character array for aux budget text - allocate(this%cauxcbc(this%cbcauxitems)) - allocate(this%uzfname(this%nodes)) - ! - ! -- allocate and initialize qauxcbc - call mem_allocate(this%qauxcbc, this%cbcauxitems, 'QAUXCBC', this%origin) - do i = 1, this%cbcauxitems - this%qauxcbc(i) = DZERO - end do - ! - ! -- Allocate obs members - call mem_allocate(this%obs_theta, 0, 'OBS_THETA', this%origin) - call mem_allocate(this%obs_depth, 0, 'OBS_DEPTH', this%origin) - call mem_allocate(this%obs_num, 0, 'OBS_NUM', this%origin) - ! - ! -- return - return - end subroutine uzf_allocate_arrays -! - - subroutine uzf_options(this, option, found) -! ****************************************************************************** -! uzf_options -- set options specific to UzfType -! -! uzf_options overrides BoundaryPackageType%child_class_options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: DZERO - use OpenSpecModule, only: access, form - use SimModule, only: ustop, store_error - use InputOutputModule, only: urword, getunit, openfile - implicit none - ! -- dummy - class(uzftype), intent(inout) :: this - character(len=*), intent(inout) :: option - logical, intent(inout) :: found - ! -- local - character(len=MAXCHARLEN) :: fname, keyword - ! -- formats - character(len=*),parameter :: fmtnotfound= & - "(4x, 'NO UZF OPTIONS WERE FOUND.')" - character(len=*),parameter :: fmtet = & - "(4x, 'ET WILL BE SIMULATED WITHIN UZ AND GW ZONES, WITH LINEAR ', & - &'GWET IF OPTION NOT SPECIFIED OTHERWISE.')" - character(len=*),parameter :: fmtgwetlin = & - "(4x, 'GROUNDWATER ET FUNCTION WILL BE LINEAR.')" - character(len=*),parameter :: fmtgwetsquare = & - "(4x, 'GROUNDWATER ET FUNCTION WILL BE SQUARE WITH SMOOTHING.')" - character(len=*),parameter :: fmtgwseepout = & - "(4x, 'GROUNDWATER DISCHARGE TO LAND SURFACE WILL BE SIMULATED.')" - character(len=*),parameter :: fmtuzetwc = & - "(4x, 'UNSATURATED ET FUNCTION OF WATER CONTENT.')" - character(len=*),parameter :: fmtuzetae = & - "(4x, 'UNSATURATED ET FUNCTION OF AIR ENTRY PRESSURE.')" - character(len=*),parameter :: fmtuznlay = & - "(4x, 'UNSATURATED FLOW WILL BE SIMULATED SEPARATELY IN EACH LAYER.')" - character(len=*),parameter :: fmtuzfbin = & - "(4x, 'UZF ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" - character(len=*),parameter :: fmtuzfopt = & - "(4x, 'UZF ', a, ' VALUE (',g15.7,') SPECIFIED.')" - -! ------------------------------------------------------------------------------ - ! - ! - select case (option) - !case ('PRINT_WATER-CONTENT') - ! this%iprwcont = 1 - ! write(this%iout,'(4x,a)') trim(adjustl(this%text))// & - ! ' WATERCONTENT WILL BE PRINTED TO LISTING FILE.' - ! found = .true. - !case('WATER-CONTENT') - ! call this%parser%GetStringCaps(keyword) - ! if (keyword == 'FILEOUT') then - ! call this%parser%GetString(fname) - ! this%iwcontout = getunit() - ! call openfile(this%iwcontout, this%iout, fname, 'DATA(BINARY)', & - ! form, access, 'REPLACE') - ! write(this%iout,fmtuzfbin) 'WATERCONTENT', fname, this%iwcontout - ! found = .true. - ! else - ! call store_error('OPTIONAL WATER-CONTENT KEYWORD MUST BE FOLLOWED BY FILEOUT') - ! end if - case('BUDGET') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ibudgetout = getunit() - call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE') - write(this%iout,fmtuzfbin) 'BUDGET', fname, this%ibudgetout - found = .true. - else - call store_error('OPTIONAL BUDGET KEYWORD MUST BE FOLLOWED BY FILEOUT') - end if - case('PACKAGE_CONVERGENCE') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ipakcsv = getunit() - call openfile(this%ipakcsv, this%iout, fname, 'CSV', & - filstat_opt='REPLACE') - write(this%iout,fmtuzfbin) 'PACKAGE_CONVERGENCE', fname, this%ipakcsv - found = .true. - else - call store_error('OPTIONAL PACKAGE_CONVERGENCE KEYWORD MUST BE ' // & - 'FOLLOWED BY FILEOUT') - end if - case('SIMULATE_ET') - this%ietflag = 1 !default - this%igwetflag = 0 - found = .true. - write(this%iout, fmtet) - case('LINEAR_GWET') - this%igwetflag = 1 - found = .true. - write(this%iout, fmtgwetlin) - case('SQUARE_GWET') - this%igwetflag = 2 - found = .true. - write(this%iout, fmtgwetsquare) - case('SIMULATE_GWSEEP') - this%iseepflag = 1 - found = .true. - write(this%iout, fmtgwseepout) - case('UNSAT_ETWC') - this%ietflag = 1 - found = .true. - write(this%iout, fmtuzetwc) - case('UNSAT_ETAE') - this%ietflag = 2 - found = .true. - write(this%iout, fmtuzetae) - case('MOVER') - this%imover = 1 - found = .true. - ! - ! -- right now these are options that are available but may not be available in - ! the release (or in documentation) - case('DEV_NO_FINAL_CHECK') - call this%parser%DevOpt() - this%iconvchk = 0 - write(this%iout, '(4x,a)') & - & 'A FINAL CONVERGENCE CHECK OF THE CHANGE IN UZF RECHARGE ' // & - & 'WILL NOT BE MADE' - found = .true. - !case('DEV_MAXIMUM_PERCENT_DIFFERENCE') - ! call this%parser%DevOpt() - ! r = this%parser%GetDouble() - ! if (r > DZERO) then - ! this%pdmax = r - ! write(this%iout, fmtuzfopt) 'MAXIMUM_PERCENT_DIFFERENCE', this%pdmax - ! else - ! write(this%iout, fmtuzfopt) 'INVALID MAXIMUM_PERCENT_DIFFERENCE', r - ! write(this%iout, fmtuzfopt) 'USING DEFAULT MAXIMUM_PERCENT_DIFFERENCE', this%pdmax - ! end if - ! found = .true. - case default - ! -- No options found - found = .false. - end select - ! -- return - return - end subroutine uzf_options -! - subroutine uzf_readdimensions(this) -! ****************************************************************************** -! uzf_readdimensions -- set dimensions specific to UzfType -! -! uzf_readdimensions BoundaryPackageType%readdimensions -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use InputOutputModule, only: urword - use SimModule, only: ustop, store_error, count_errors - class(uzftype),intent(inout) :: this - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock -! ------------------------------------------------------------------------------ - ! - ! -- initialize dimensions to -1 - this%nodes= -1 - this%ntrail = 0 - this%nsets = 0 - ! - ! -- 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 '//trim(adjustl(this%text))// & - ' DIMENSIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('NUZFCELLS') - this%nodes = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)')'NUZFCELLS = ', this%nodes - case ('NTRAILWAVES') - this%ntrail = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)')'NTRAILWAVES = ', this%ntrail - case ('NWAVESETS') - this%nsets = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)')'NTRAILSETS = ', this%nsets - case default - write(errmsg,'(4x,a,a)') & - '****ERROR. UNKNOWN '//trim(this%text)//' DIMENSION: ', & - trim(keyword) - call store_error(errmsg) - call ustop() - end select - end do - write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' DIMENSIONS' - else - call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- increment maxbound - this%maxbound = this%maxbound + this%nodes - ! - ! -- verify dimensions were set - if(this%nodes <= 0) then - write(errmsg, '(1x,a)') & - 'ERROR. NUZFCELLS WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - - if(this%ntrail <= 0) then - write(errmsg, '(1x,a)') & - 'ERROR. NTRAILWAVES WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - if(this%nsets <= 0) then - write(errmsg, '(1x,a)') & - 'ERROR. NWAVESETS WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - this%nwav = this%ntrail*this%nsets - ! - ! -- Call define_listlabel to construct the list label that is written - ! when PRINT_INPUT option is used. - call this%define_listlabel() - ! - ! -- Allocate arrays in package superclass - call this%uzf_allocate_arrays() - ! - ! -- initialize uzf group object - allocate(this%uzfobj) - call this%uzfobj%init(this%nodes, this%nwav, this%origin) - ! - ! -- Set pointers to GWF model arrays - call mem_setptr(this%gwftop, 'TOP', trim(this%name_model)//' DIS') - call mem_setptr(this%gwfbot, 'BOT', trim(this%name_model)//' DIS') - call mem_setptr(this%gwfarea, 'AREA', trim(this%name_model)//' DIS') - ! - !--Read uzf cell properties and set values - call this%read_cell_properties() - ! - ! -- print cell data - if (this%iprpak /= 0) then - call this%print_cell_properties() - end if - ! - ! -- setup the budget object - call this%uzf_setup_budobj() - ! - ! -- return - return - end subroutine uzf_readdimensions - - subroutine uzf_rp(this) -! ****************************************************************************** -! uzf_rp -- Read stress data -! Subroutine: (1) check if bc changes -! (2) read new bc for stress period -! (3) set kinematic variables to bc values -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: kper, nper, perlen, totimsav - use TimeSeriesManagerModule, only: read_single_value_or_time_series - use InputOutputModule, only: urword - use SimModule, only: ustop, store_error, count_errors - ! -- dummy - class(UzfType), intent(inout) :: this - ! -- local - character(len=LENBOUNDNAME) :: bndName - character(len=LENBOUNDNAME) :: cval - integer (I4B) :: i - integer (I4B) :: j - integer (I4B) :: jj - integer (I4B) :: ipos - integer(I4B) :: ierr - real (DP) :: endtim - logical :: isfound, endOfBlock - character(len=LINELENGTH) :: line, errmsg - ! -- table output - character (len=20) :: cellid - character(len=LINELENGTH) :: title - character(len=LINELENGTH) :: tag - integer(I4B) :: ntabrows - integer(I4B) :: ntabcols - integer(I4B) :: node - !-- formats - character(len=*),parameter :: fmtlsp = & - "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" - character(len=*),parameter :: fmtblkerr = & - "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - character(len=*), parameter :: fmtisvflow = & - "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE " // & - "WHENEVER ICBCFL IS NOT ZERO.')" - character(len=*),parameter :: fmtflow = & - "(4x, 'FLOWS WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" -! ------------------------------------------------------------------------------ - ! - ! -- Set ionper to the stress period number for which a new block of data - ! will be read. - if(this%inunit == 0) return - ! - ! -- Find time interval of current stress period. - endtim = totimsav + perlen(kper) - ! - ! -- get stress period data - if (this%ionper < kper) then - ! - ! -- get period block - call this%parser%GetBlock('PERIOD', isfound, ierr, & - supportOpenClose=.true.) - if (isfound) then - ! - ! -- read ionper and check for increasing period numbers - call this%read_check_ionper() - else - ! - ! -- PERIOD block not found - if (ierr < 0) then - ! -- End of file found; data applies for remainder of simulation. - this%ionper = nper + 1 - else - ! -- Found invalid block - call this%parser%GetCurrentLine(line) - write(errmsg, fmtblkerr) adjustl(trim(line)) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - endif - end if - ! - ! -- set steady-state flag based on gwfiss - this%issflag = this%gwfiss - ! - ! -- read data if ionper == kper - if(this%ionper==kper) then - ! - ! -- write header - if (this%iprpak /= 0) then - ! - ! -- setup inputtab tableobj - ! - ! -- table dimensions - ntabrows = 1 - ntabcols = 3 - if (this%ietflag /= 0) then - ntabcols = ntabcols + 3 - if (this%ietflag == 2) then - ntabcols = ntabcols + 3 - end if - end if - if (this%inamedbound == 1) then - ntabcols = ntabcols + 1 - end if - ! - ! -- initialize table and define columns - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%name)) //') DATA FOR PERIOD' - write(title, '(a,1x,i6)') trim(adjustl(title)), kper - call table_cr(this%inputtab, this%name, title) - call this%inputtab%table_df(ntabrows, ntabcols, this%iout, & - finalize=.FALSE.) - tag = 'NUMBER' - call this%inputtab%initialize_column(tag, 10) - tag = 'CELLID' - call this%inputtab%initialize_column(tag, 20, alignment=TABLEFT) - tag = 'FINF' - call this%inputtab%initialize_column(tag, 12) - if (this%ietflag /= 0) then - tag = 'PET' - call this%inputtab%initialize_column(tag, 12) - tag = 'EXTDEP' - call this%inputtab%initialize_column(tag, 12) - tag = 'EXTWC' - call this%inputtab%initialize_column(tag, 12) - if (this%ietflag == 2) then - tag = 'HA' - call this%inputtab%initialize_column(tag, 12) - tag = 'HROOT' - call this%inputtab%initialize_column(tag, 12) - tag = 'ROOTACT' - call this%inputtab%initialize_column(tag, 12) - end if - end if - if (this%inamedbound == 1) then - tag = 'BOUNDNAME' - call this%inputtab%initialize_column(tag, LENBOUNDNAME, alignment=TABLEFT) - end if - end if - ! - ! -- read the stress period data - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - ! - ! -- check for valid uzf node - i = this%parser%GetInteger() - if (i < 1 .or. i > this%nodes) then - tag = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%name)) //') DATA FOR PERIOD' - write(tag, '(a,1x,i0)') trim(adjustl(tag)), kper - write(errmsg,'(4x,a,1x,a,a,i0,1x,a,i0)') & - '****ERROR.', trim(adjustl(tag)), ': UZFNO ', i, & - 'MUST BE > 0 and <= ', this%nodes - call store_error(errmsg) - cycle - end if - ! - ! -- Setup boundname - if (this%inamedbound > 0) then - bndName = this%boundname(i) - else - bndName = '' - end if - ! - ! -- FINF - call this%parser%GetStringCaps(cval) - jj = 1 ! For SINF - call read_single_value_or_time_series(cval, & - this%sinf(i)%value, & - this%sinf(i)%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, i, jj, 'SINF', & - bndName, this%inunit) - ! - ! -- PET, EXTDP - call this%parser%GetStringCaps(cval) - jj = 1 ! For PET - call read_single_value_or_time_series(cval, & - this%pet(i)%value, & - this%pet(i)%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, i, jj, 'PET', & - bndName, this%inunit) - call this%parser%GetStringCaps(cval) - jj = 1 ! For EXTDP - call read_single_value_or_time_series(cval, & - this%extdp(i)%value, & - this%extdp(i)%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, i, jj, 'EXTDP', & - bndName, this%inunit) - ! - ! -- ETWC - call this%parser%GetStringCaps(cval) - jj = 1 ! For EXTWC - call read_single_value_or_time_series(cval, & - this%extwc(i)%value, & - this%extwc(i)%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, i, jj, 'EXTWC', & - bndName, this%inunit) - ! - ! -- HA, HROOT, ROOTACT - call this%parser%GetStringCaps(cval) - jj = 1 ! For HA - call read_single_value_or_time_series(cval, & - this%ha(i)%value, & - this%ha(i)%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, i, jj, 'HA', & - bndName, this%inunit) - call this%parser%GetStringCaps(cval) - jj = 1 ! For HROOT - call read_single_value_or_time_series(cval, & - this%hroot(i)%value, & - this%hroot(i)%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, i, jj, 'HROOT', & - bndName, this%inunit) - call this%parser%GetStringCaps(cval) - jj = 1 ! For ROOTACT - call read_single_value_or_time_series(cval, & - this%rootact(i)%value, & - this%rootact(i)%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, i, jj, 'ROOTACT', & - bndName, this%inunit) - - ! - ! -- read auxillary variables - do j = 1, this%naux - call this%parser%GetStringCaps(cval) - ipos = (i - 1) * this%naux + j - jj = 1 - call read_single_value_or_time_series(cval, & - this%lauxvar(ipos)%value, & - this%lauxvar(ipos)%name, & - endtim, & - this%name, 'BND', this%TsManager, & - this%iprpak, i, jj, & - this%auxname(j), bndName, & - this%inunit) - end do - ! - ! -- write line - if (this%iprpak /= 0) then - ! - ! -- get cellid - node = this%igwfnode(i) - if (node > 0) then - call this%dis%noder_to_string(node, cellid) - else - cellid = 'none' - end if - ! - ! -- write data to the table - call this%inputtab%add_term(i) - call this%inputtab%add_term(cellid) - call this%inputtab%add_term(this%sinf(i)%value) - if (this%ietflag /= 0) then - call this%inputtab%add_term(this%pet(i)%value) - call this%inputtab%add_term(this%extdp(i)%value) - call this%inputtab%add_term(this%extwc(i)%value) - if (this%ietflag == 2) then - call this%inputtab%add_term(this%ha(i)%value) - call this%inputtab%add_term(this%hroot(i)%value) - call this%inputtab%add_term(this%rootact(i)%value) - end if - end if - if (this%inamedbound == 1) then - call this%inputtab%add_term(this%boundname(i)) - end if - end if - - end do - ! - ! -- finalize the table - if (this%iprpak /= 0) then - call this%inputtab%finalize_table() - end if - - write(this%iout,'(1x,a,1x,i6)')'END OF '//trim(adjustl(this%text)) // & - ' PERIOD', kper - else - write(this%iout,fmtlsp) trim(this%filtyp) - endif - ! - !write summary of uzf stress period error messages - ierr = count_errors() - if (ierr > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- set wave data for first stress period and second that follows SS - if ((this%issflag == 0 .AND. kper == 1) .or. & - (kper == 2 .AND. this%issflagold == 1)) then - do i = 1, this%nodes - call this%uzfobj%setwaves(i) - end do - end if - this%issflagold = this%issflag - ! - ! -- return - return - end subroutine uzf_rp - - subroutine uzf_ad(this) -! ****************************************************************************** -! uzf_ad -- Advance UZF Package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(UzfType) :: this - ! -- locals - integer(I4B) :: i - integer(I4B) :: ivertflag - integer(I4B) :: ipos - integer(I4B) :: n, iaux, ii - real (DP) :: rval1, rval2, rval3 -! ------------------------------------------------------------------------------ - ! - ! -- Advance the time series - call this%TsManager%ad() - ! - ! -- update auxiliary variables by copying from the derived-type time - ! series variable into the bndpackage auxvar variable so that this - ! information is properly written to the GWF budget file - if (this%naux > 0) then - do n = 1, this%maxbound - do iaux = 1, this%naux - ii = (n - 1) * this%naux + iaux - this%auxvar(iaux, n) = this%lauxvar(ii)%value - end do - end do - end if - ! - do i = 1, this%nodes - call this%uzfobj%advance(i) - end do - ! - ! -- update uzf objects with timeseries aware variables - do i = 1, this%nodes - ! - ! -- Set ivertflag - ivertflag = this%uzfobj%ivertcon(i) - ! - ! -- recalculate uzfarea - if (this%iauxmultcol > 0) then - ipos = (i - 1) * this%naux + this%iauxmultcol - rval1 = this%lauxvar(ipos)%value - call this%uzfobj%setdatauzfarea(i, rval1) - end if - ! - ! -- FINF - rval1 = this%sinf(i)%value - call this%uzfobj%setdatafinf(i, rval1) - ! - ! -- PET, EXTDP - rval1 = this%pet(i)%value - rval2 = this%extdp(i)%value - call this%uzfobj%setdataet(i, ivertflag, rval1, rval2) - ! - ! -- ETWC - rval1 = this%extwc(i)%value - call this%uzfobj%setdataetwc(i, ivertflag, rval1) - ! - ! -- HA, HROOT, ROOTACT - rval1 = this%ha(i)%value - rval2 = this%hroot(i)%value - rval3 = this%rootact(i)%value - call this%uzfobj%setdataetha(i, ivertflag, rval1, rval2, rval3) - end do - ! - ! -- check uzfarea - if (this%iauxmultcol > 0) then - call this%check_cell_area() - end if - ! - ! -- pakmvrobj ad - if(this%imover == 1) then - call this%pakmvrobj%ad() - endif - ! - ! -- For each observation, push simulated value and corresponding - ! simulation time from "current" to "preceding" and reset - ! "current" value. - call this%obs%obs_ad() - ! - ! -- Return - return - end subroutine uzf_ad - - subroutine uzf_cf(this, reset_mover) -! ****************************************************************************** -! uzf_cf -- Formulate the HCOF and RHS terms -! Subroutine: (1) skip if no UZF cells -! (2) calculate hcof and rhs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(UzfType) :: this - logical, intent(in), optional :: reset_mover - ! -- locals - integer(I4B) :: n - logical :: lrm -! ------------------------------------------------------------------------------ - ! - ! -- Return if no UZF cells - if(this%nodes == 0) return - ! - ! -- Store values at start of outer iteration to compare with calculated - ! values for convergence check - do n = 1, this%maxbound - this%rejinf0(n) = this%rejinf(n) - this%rch0(n) = this%rch(n) - this%gwd0(n) = this%gwd(n) - end do - ! - ! -- pakmvrobj cf - lrm = .true. - if (present(reset_mover)) lrm = reset_mover - if(this%imover == 1 .and. lrm) then - call this%pakmvrobj%cf() - endif - ! - ! -- return - return - end subroutine uzf_cf - - subroutine uzf_fc(this, rhs, ia, idxglo, amatsln) -! ****************************************************************************** -! uzf_fc -- Copy rhs and hcof into solution rhs and amat -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(UzfType) :: this - real(DP), dimension(:), intent(inout) :: rhs - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln - ! -- local - integer(I4B) :: i, n, ipos -! ------------------------------------------------------------------------------ - ! - ! -- pakmvrobj fc - if(this%imover == 1) then - call this%pakmvrobj%fc() - endif - ! - ! -- Solve UZF - call this%uzf_solve() - ! - ! -- Copy package rhs and hcof into solution rhs and amat - do i = 1, this%nodes - n = this%nodelist(i) - rhs(n) = rhs(n) + this%rhs(i) - ipos = ia(n) - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) - enddo - ! - ! -- return - return - end subroutine uzf_fc -! - subroutine uzf_fn(this, rhs, ia, idxglo, amatsln) -! ************************************************************************** -! uzf_fn -- Fill newton terms -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - ! -- dummy - class(UzfType) :: this - real(DP), dimension(:), intent(inout) :: rhs - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln - ! -- local - integer(I4B) :: i, n - integer(I4B) :: ipos -! -------------------------------------------------------------------------- - ! - ! -- Add derivative terms to rhs and amat - do i = 1, this%nodes - n = this%nodelist(i) - ipos = ia(n) - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%deriv(i) - rhs(n) = rhs(n) + this%deriv(i) * this%xnew(n) - end do - ! - ! -- return - return - end subroutine uzf_fn - - subroutine uzf_cc(this, kiter, iend, icnvgmod, cpak, dpak) -! ************************************************************************** -! uzf_cc -- Final convergence check for package -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - use TdisModule, only: totim, kstp, kper, delt - ! -- dummy - class(Uzftype), intent(inout) :: this - integer(I4B), intent(in) :: kiter - integer(I4B), intent(in) :: icnvgmod - integer(I4B), intent(in) :: iend - character(len=LENPAKLOC), intent(inout) :: cpak - real(DP), intent(inout) :: dpak - ! -- local - character(len=LENPAKLOC) :: cloc - character(len=LINELENGTH) :: title - character(len=LINELENGTH) :: tag - character(len=20) :: cellid - integer(I4B) :: icheck - integer(I4B) :: ipakfail - integer(I4B) :: locdrejinfmax - integer(I4B) :: locdrchmax - integer(I4B) :: locdseepmax - integer(I4B) :: ntabrows - integer(I4B) :: ntabcols - integer(I4B) :: n - integer(I4B) :: node - real(DP) :: qtolfact - real(DP) :: drejinf - real(DP) :: drejinfmax - real(DP) :: drch - real(DP) :: drchmax - real(DP) :: dseep - real(DP) :: dseepmax - real(DP) :: dmax - ! format -! -------------------------------------------------------------------------- - ! - ! -- initialize local variables - icheck = this%iconvchk - ipakfail = 0 - locdrejinfmax = 0 - locdrchmax = 0 - locdseepmax = 0 - drejinfmax = DZERO - drchmax = DZERO - dseepmax = DZERO - ! - ! -- if not saving package convergence data on check convergence if - ! the model is considered converged - if (this%ipakcsv == 0) then - if (icnvgmod == 0) then - icheck = 0 - end if - else - ! - ! -- header for package csv - if (.not. associated(this%pakcsvtab)) then - ! - ! -- determine the number of columns and rows - ntabrows = 1 - ntabcols = 8 - if (this%iseepflag == 1) then - ntabcols = ntabcols + 2 - end if - ! - ! -- setup table - call table_cr(this%pakcsvtab, this%name, '') - call this%pakcsvtab%table_df(ntabrows, ntabcols, this%ipakcsv, & - lineseparator=.FALSE., separator=',', & - finalize=.FALSE.) - ! - ! -- add columns to package csv - tag = 'totim' - call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'kper' - call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'kstp' - call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'nouter' - call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'drejinfmax' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - tag = 'drejinfmax_loc' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - tag = 'drchmax' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - tag = 'drchmax_loc' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - if (this%iseepflag == 1) then - tag = 'dseepmax' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - tag = 'dseepmax_loc' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - end if - end if - end if - ! - ! -- perform package convergence check - if (icheck /= 0) then - final_check: do n = 1, this%nodes - ! - ! -- set the Q to length factor - qtolfact = delt / this%uzfobj%uzfarea(n) - ! - ! -- rejected infiltration - drejinf = qtolfact * (this%rejinf0(n) - this%rejinf(n)) - ! - ! -- groundwater recharge - drch = qtolfact * (this%rch0(n) - this%rch(n)) - ! - ! -- groundwater seepage to the land surface - dseep = DZERO - if (this%iseepflag == 1) then - dseep = qtolfact * (this%gwd0(n) - this%gwd(n)) - end if - ! - ! -- evaluate magnitude of differences - if (n == 1) then - drejinfmax = drejinf - locdrejinfmax = n - drchmax = drch - locdrchmax = n - dseepmax = dseep - locdseepmax = n - else - if (ABS(drejinf) > abs(drejinfmax)) then - drejinfmax = drejinf - locdrejinfmax = n - end if - if (ABS(drch) > abs(drchmax)) then - drchmax = drch - locdrchmax = n - end if - if (ABS(dseep) > abs(dseepmax)) then - dseepmax = dseep - locdseepmax = n - end if - end if - end do final_check - ! - ! -- set dpak and cpak - if (ABS(drejinfmax) > abs(dpak)) then - dpak = drejinfmax - write(cloc, "(a,'-(',i0,')-',a)") & - trim(this%name), locdrejinfmax, 'rejinf' - cpak = trim(cloc) - end if - if (ABS(drchmax) > abs(dpak)) then - dpak = drchmax - write(cloc, "(a,'-(',i0,')-',a)") & - trim(this%name), locdrchmax, 'rech' - cpak = trim(cloc) - end if - if (this%iseepflag == 1) then - if (ABS(dseepmax) > abs(dpak)) then - dpak = dseepmax - write(cloc, "(a,'-(',i0,')-',a)") & - trim(this%name), locdseepmax, 'seep' - cpak = trim(cloc) - end if - end if - ! - ! -- write convergence data to package csv - if (this%ipakcsv /= 0) then - ! - ! -- write the data - call this%pakcsvtab%add_term(totim) - call this%pakcsvtab%add_term(kper) - call this%pakcsvtab%add_term(kstp) - call this%pakcsvtab%add_term(kiter) - call this%pakcsvtab%add_term(drejinfmax) - call this%pakcsvtab%add_term(locdrejinfmax) - call this%pakcsvtab%add_term(drchmax) - call this%pakcsvtab%add_term(locdrchmax) - if (this%iseepflag == 1) then - call this%pakcsvtab%add_term(dseepmax) - call this%pakcsvtab%add_term(locdseepmax) - end if - ! - ! -- finalize the package csv - if (iend == 1) then - call this%pakcsvtab%finalize_table() - end if - end if - end if - ! - ! -- return - return - end subroutine uzf_cc - - subroutine uzf_bd(this, x, idvfl, icbcfl, ibudfl, icbcun, iprobs, & - isuppress_output, model_budget, imap, iadv) -! ****************************************************************************** -! uzf_bd -- Calculate Volumetric Budget -! Note that the compact budget will always be used. -! Subroutine: (1) Process each package entry -! (2) Write output -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: kstp, kper, delt, pertim, totim - use ConstantsModule, only: LENBOUNDNAME, DZERO, DHNOFLO, DHDRY - use BudgetModule, only: BudgetType - use InputOutputModule, only: ulasav, ubdsv06 - ! -- dummy - class(UzfType) :: this - class(ObserveType), pointer :: obsrv => null() - real(DP),dimension(:),intent(in) :: x - integer(I4B), intent(in) :: idvfl - integer(I4B), intent(in) :: icbcfl - integer(I4B), intent(in) :: ibudfl - integer(I4B), intent(in) :: icbcun - integer(I4B), intent(in) :: iprobs - integer(I4B), intent(in) :: isuppress_output - type(BudgetType), intent(inout) :: model_budget - integer(I4B), dimension(:), optional, intent(in) :: imap - integer(I4B), optional, intent(in) :: iadv - ! -- local - character(len=LINELENGTH) :: title - character(len=20) :: nodestr - integer(I4B) :: maxrows - integer(I4B) :: nodeu - integer(I4B) :: i, node, ibinun - integer(I4B) :: n, m, ivertflag, ierr - integer(I4B) :: n2 - real(DP) :: rfinf - real(DP) :: rin,rout,rsto,ret,retgw,rgwseep,rvflux - real(DP) :: hgwf,hgwflm1,ratin,ratout,rrate,rrech - real(DP) :: trhsgwet,thcofgwet,gwet,derivgwet - real(DP) :: qfrommvr, qformvr, qgwformvr, sumaet - real(DP) :: qfinf - real(DP) :: qrejinf - real(DP) :: qrejinftomvr - real(DP) :: qout - real(DP) :: qfact - real(DP) :: qtomvr - real(DP) :: sqtomvr - real(DP) :: q - real(DP) :: rfrommvr - real(DP) :: qseep - real(DP) :: qseeptomvr - real(DP) :: qgwet - real(DP) :: cvv - integer(I4B) :: naux, numobs - ! -- for observations - integer(I4B) :: j - character(len=LENBOUNDNAME) :: bname - character(len=100) :: msg - ! -- formats - character(len=*), parameter :: fmttkk = & - "(1X,/1X,A,' PERIOD ',I0,' STEP ',I0)" - ! -- for table - !character(len=LENBUDTXT) :: aname(10) - !data aname(1) /' INFILTRATION'/ - !data aname(2) /' GWF'/ - !data aname(3) /' STORAGE'/ - !data aname(4) /' UZET'/ - !data aname(5) /' UZF-GWET'/ - !data aname(6) /' UZF-GWD'/ - !data aname(7) /'SAT.-UNSAT. EXCH'/ - !data aname(8) /' REJ-INF'/ - !data aname(9) /' REJ-INF-TO-MVR'/ - !data aname(10) /' FROM-MVR'/ -! ------------------------------------------------------------------------------ - ! - ! -- initialize accumulators - ierr = 0 - rfinf = DZERO - rin = DZERO - rout = DZERO - rrech = DZERO - rsto = DZERO - ret = DZERO - retgw = DZERO - rgwseep = DZERO - rvflux = DZERO - sumaet = DZERO - qfinf = DZERO - qfrommvr = DZERO - qtomvr = DZERO - qrejinf = DZERO - qrejinftomvr = DZERO - sqtomvr = DZERO - rfrommvr = DZERO - qseep = DZERO - qseeptomvr = DZERO - qgwet = DZERO - ! - ! -- set maxrows - maxrows = 0 - if (this%iprflow /= 0) then - do i = 1, this%nodes - node = this%nodelist(i) - if (this%ibound(node) > 0) then - maxrows = maxrows + 1 - end if - end do - call this%outputtab%set_maxbound(maxrows) - end if - - ! - ! -- Go through and process each UZF cell - do i = 1, this%nodes - ! - ! -- Initialize variables - n = this%nodelist(i) - ivertflag = this%uzfobj%ivertcon(i) - ! - ! -- Skip if cell is not active - if (this%ibound(n) < 1) cycle - ! - ! -- Water mover added to infiltration - qfrommvr = DZERO - qformvr = DZERO - if(this%imover == 1) then - qfrommvr = this%pakmvrobj%get_qfrommvr(i) - rfrommvr = rfrommvr + qfrommvr - endif - ! - hgwf = this%xnew(n) - ! - m = n - hgwflm1 = hgwf - ! - ! -- for now set cvv = DZERO - ! cvv = this%gwfhcond(m) - cvv = DZERO - ! - ! -- Get obs information, check if there is obs in uzf cell - numobs = 0 - do j = 1, this%obs%npakobs - obsrv => this%obs%pakobs(j)%obsrv - if ( obsrv%intPak1 == i ) then - numobs = numobs + 1 - this%obs_num(numobs) = j - this%obs_depth(j) = obsrv%dblPak1 - end if - end do - ! - ! -- Call budget routine of the uzf kinematic object - call this%uzfobj%budget(ivertflag,i,this%totfluxtot, & - rfinf,rin,rout,rsto,ret,retgw,rgwseep,rvflux, & - this%ietflag,this%iseepflag,this%issflag,hgwf, & - hgwflm1,cvv,numobs,this%obs_num, & - this%obs_depth,this%obs_theta,qfrommvr,qformvr, & - qgwformvr,sumaet,ierr) - if ( ierr > 0 ) then - if ( ierr == 1 ) & - msg = 'Error: UZF variable NWAVESETS needs to be increased.' - call store_error(msg) - call ustop() - end if - ! - ! -- Calculate gwet - if (this%igwetflag > 0) then - gwet = DZERO - derivgwet = DZERO - call this%uzfobj%simgwet(this%igwetflag, i, hgwf, trhsgwet, thcofgwet, & - gwet, derivgwet) - retgw = retgw + this%gwet(i) - end if - ! - ! -- Calculate flows for cbc output and observations - if (hgwf > this%uzfobj%celbot(i)) then - this%recharge(i) = this%uzfobj%totflux(i) * this%uzfobj%uzfarea(i) / delt - else - if (ivertflag == 0) then - this%recharge(i) = this%uzfobj%surflux(i) * this%uzfobj%uzfarea(i) - else - this%recharge(i) = this%uzfobj%surflux(ivertflag) * this%uzfobj%uzfarea(i) - end if - end if - - this%rch(i) = this%uzfobj%totflux(i) * this%uzfobj%uzfarea(i) / delt - - this%appliedinf(i) = this%uzfobj%sinf(i) * this%uzfobj%uzfarea(i) - this%infiltration(i) = this%uzfobj%surflux(i) * this%uzfobj%uzfarea(i) - - this%rejinf(i) = this%uzfobj%finf_rej(i) * this%uzfobj%uzfarea(i) - - qout = this%rejinf(i) + this%uzfobj%surfseep(i) - qtomvr = DZERO - if (this%imover == 1) then - qtomvr = this%pakmvrobj%get_qtomvr(i) - sqtomvr = sqtomvr + qtomvr - end if - - qfact = DZERO - if (qout > DZERO) then - qfact = this%rejinf(i) / qout - end if - q = this%rejinf(i) - this%rejinftomvr(i) = qfact * qtomvr - ! -- set rejected infiltration to the remainder - q = q - this%rejinftomvr(i) - ! -- values less than zero represent a volumetric error resulting - ! from qtomvr being greater than water available to the mover - if (q < DZERO) then - q = DZERO - end if - this%rejinf(i) = q - - this%gwd(i) = this%uzfobj%surfseep(i) - qfact = DZERO - if (qout > DZERO) then - qfact = this%gwd(i) / qout - end if - q = this%gwd(i) - this%gwdtomvr(i) = qfact * qtomvr - ! -- set groundwater discharge to the remainder - q = q - this%gwdtomvr(i) - ! -- values less than zero represent a volumetric error resulting - ! from qtomvr being greater than water available to the mover - if (q < DZERO) then - q = DZERO - end if - this%gwd(i) = q - - qfinf = qfinf + this%appliedinf(i) - qrejinf = qrejinf + this%rejinf(i) - qrejinftomvr = qrejinftomvr + this%rejinftomvr(i) - - qseep = qseep + this%gwd(i) - qseeptomvr = qseeptomvr + this%gwdtomvr(i) - - this%gwet(i) = this%uzfobj%gwet(i) - this%uzet(i) = this%uzfobj%etact(i) * this%uzfobj%uzfarea(i) / delt - this%qsto(i) = this%uzfobj%delstor(i) / delt - - ! -- accumulate groundwater et - qgwet = qgwet + this%gwet(i) - - ! - ! -- End of UZF cell loop - ! - end do - ! - ! -- For continuous observations, save simulated values. - if (this%obs%npakobs > 0 .and. iprobs > 0) then - call this%uzf_bd_obs() - endif - ! - ! add cumulative flows to UZF budget - this%infilsum = rin * delt - this%rechsum = rout * delt - rrech = rout - this%delstorsum = rsto * delt - this%uzetsum = ret * delt - this%vfluxsum = rvflux - ! - ! - rin = DZERO - rout = DZERO - if(rsto < DZERO) then - rin = -rsto - else - rout = rsto - endif - ! - ! -- Clear accumulators and set flags - ratin = dzero - ratout = dzero - rrate = dzero - !iauxsv = 1 !always used compact budget - ! - ! -- Set unit number for binary output - if(this%ipakcb < 0) then - ibinun = icbcun - elseif(this%ipakcb == 0) then - ibinun = 0 - else - ibinun = this%ipakcb - endif - if(icbcfl == 0) ibinun = 0 - if (isuppress_output /= 0) ibinun = 0 - ! - ! -- If cell-by-cell flows will be saved as a list, write header. - if (ibinun /= 0 .or. ibudfl /= 0) then - naux = this%naux - ! - ! -- uzf-gwrch - if (ibinun /= 0) then - call this%dis%record_srcdst_list_header(this%bdtxt(2), this%name_model, & - this%name_model, this%name_model, this%name, naux, & - this%auxname, ibinun, this%nodes, this%iout) - end if - ! - ! -- Loop through each boundary calculating flow. - do i = 1, this%nodes - node = this%nodelist(i) - ! -- assign boundary name - if (this%inamedbound > 0) then - bname = this%boundname(i) - else - bname = '' - end if - ! - ! -- reset table title - if (this%iprflow /= 0) then - title = trim(this%text) // ' PACKAGE (' // trim(this%name) // & - ') ' // trim(adjustl(this%bdtxt(2))) // ' FLOW RATES' - call this%outputtab%set_title(title) - end if - ! - ! -- If cell is no-flow or constant-head, then ignore it. - rrate = DZERO - if (this%ibound(node) > 0) then - ! - ! -- Calculate the flow rate into the cell. - !rrate = this%hcof(i) * x(node) - this%rhs(i) - rrate = this%rch(i) - ! - ! -- Print the individual rates if requested(this%iprflow<0) - if (ibudfl /= 0) then - if (this%iprflow /= 0) then - ! - ! -- set nodestr and write outputtab table - nodeu = this%dis%get_nodeuser(node) - call this%dis%nodeu_to_string(nodeu, nodestr) - call this%outputtab%print_list_entry(i, nodestr, rrate, bname) - end if - end if - end if - ! - ! -- If saving cell-by-cell flows in list, write flow - if (ibinun /= 0) then - n2 = i - call this%dis%record_mf6_list_entry(ibinun, node, n2, rrate, & - naux, this%auxvar(:,i), & - olconv2=.FALSE.) - end if - end do - ! - ! -- uzf-gwd - if (this%iseepflag == 1) then - if (ibinun /= 0) then - call this%dis%record_srcdst_list_header(this%bdtxt(3), & - this%name_model, & - this%name_model, this%name_model, this%name, naux, & - this%auxname, ibinun, this%nodes, this%iout) - end if - ! - ! -- reset table title - if (this%iprflow /= 0) then - title = trim(this%text) // ' PACKAGE (' // trim(this%name) // & - ') ' // trim(adjustl(this%bdtxt(4))) // ' FLOW RATES' - call this%outputtab%set_title(title) - end if - ! - ! -- Loop through each boundary calculating flow. - do i = 1, this%nodes - node = this%nodelist(i) - ! -- assign boundary name - if (this%inamedbound > 0) then - bname = this%boundname(i) - else - bname = '' - end if - ! - ! -- If cell is no-flow or constant-head, then ignore it. - rrate = DZERO - if (this%ibound(node) > 0) then - ! - ! -- Calculate the flow rate into the cell. - rrate = -this%gwd(i) - ! - ! -- Print the individual rates if requested(this%iprflow<0) - if (ibudfl /= 0) then - if (this%iprflow /= 0) then - ! - ! -- set nodestr and write outputtab table - nodeu = this%dis%get_nodeuser(node) - call this%dis%nodeu_to_string(nodeu, nodestr) - call this%outputtab%print_list_entry(i, nodestr, rrate, bname) - end if - end if - end if - ! - ! -- If saving cell-by-cell flows in list, write flow - if (ibinun /= 0) then - n2 = i - call this%dis%record_mf6_list_entry(ibinun, node, n2, rrate, & - naux, this%auxvar(:,i), & - olconv2=.FALSE.) - end if - end do - ! - ! -- uzf-gwd to mover - if (this%imover == 1) then - if (ibinun /= 0) then - call this%dis%record_srcdst_list_header(this%bdtxt(5), & - this%name_model, this%name_model, & - this%name_model, this%name, naux, & - this%auxname, ibinun, this%nodes, this%iout) - end if - ! - ! -- reset table title - if (this%iprflow /= 0) then - title = trim(this%text) // ' PACKAGE (' // trim(this%name) // & - ') ' // trim(adjustl(this%bdtxt(5))) // ' FLOW RATES' - call this%outputtab%set_title(title) - end if - ! - ! -- Loop through each boundary calculating flow. - do i = 1, this%nodes - node = this%nodelist(i) - ! -- assign boundary name - if (this%inamedbound > 0) then - bname = this%boundname(i) - else - bname = '' - end if - ! - ! -- If cell is no-flow or constant-head, then ignore it. - rrate = DZERO - if (this%ibound(node) > 0) then - ! - ! -- Calculate the flow rate into the cell. - rrate = -this%gwdtomvr(i) - ! - ! -- Print the individual rates if requested(this%iprflow<0) - if (ibudfl /= 0) then - if (this%iprflow /= 0) then - ! - ! -- set nodestr and write outputtab table - nodeu = this%dis%get_nodeuser(node) - call this%dis%nodeu_to_string(nodeu, nodestr) - call this%outputtab%print_list_entry(i, nodestr, rrate, bname) - end if - end if - end if - ! - ! -- If saving cell-by-cell flows in list, write flow - if (ibinun /= 0) then - n2 = i - call this%dis%record_mf6_list_entry(ibinun, node, n2, rrate, & - naux, this%auxvar(:,i), & - olconv2=.FALSE.) - end if - end do - end if - end if - ! -- uzf-evt - if (this%ietflag /= 0) then - if (ibinun /= 0) then - call this%dis%record_srcdst_list_header(this%bdtxt(4), this%name_model,& - this%name_model, this%name_model, this%name, naux, & - this%auxname, ibinun, this%nodes, this%iout) - end if - ! - ! -- reset table title - if (this%iprflow /= 0) then - title = trim(this%text) // ' PACKAGE (' // trim(this%name) // & - ') ' // trim(adjustl(this%bdtxt(4))) // ' FLOW RATES' - call this%outputtab%set_title(title) - end if - ! - ! -- Loop through each boundary calculating flow. - do i = 1, this%nodes - node = this%nodelist(i) - ! -- assign boundary name - if (this%inamedbound > 0) then - bname = this%boundname(i) - else - bname = '' - end if - ! - ! -- If cell is no-flow or constant-head, then ignore it. - rrate = DZERO - if (this%ibound(node) > 0) then - ! - ! -- Calculate the flow rate into the cell. - rrate = -this%gwet(i) - ! - ! -- Print the individual rates if requested(this%iprflow<0) - if (ibudfl /= 0) then - if (this%iprflow /= 0) then - ! - ! -- set nodestr and write outputtab table - nodeu = this%dis%get_nodeuser(node) - call this%dis%nodeu_to_string(nodeu, nodestr) - call this%outputtab%print_list_entry(i, nodestr, rrate, bname) - end if - end if - end if - ! - ! -- If saving cell-by-cell flows in list, write flow - if (ibinun /= 0) then - n2 = i - call this%dis%record_mf6_list_entry(ibinun, node, n2, rrate, & - naux, this%auxvar(:,i), & - olconv2=.FALSE.) - end if - end do - end if - end if - ! - ! -- Add the UZF rates to the model budget - !uzf recharge - ratin = rrech - ratout = DZERO - call model_budget%addentry(ratin, ratout, delt, this%bdtxt(2), & - isuppress_output, this%name) - !groundwater discharge - if (this%iseepflag == 1) then - ratin = DZERO - ratout = qseep !rgwseep - call model_budget%addentry(ratin, ratout, delt, this%bdtxt(3), & - isuppress_output, this%name) - !groundwater discharge to mover - if (this%imover == 1) then - ratin = DZERO - ratout = qseeptomvr - call model_budget%addentry(ratin, ratout, delt, this%bdtxt(5), & - isuppress_output, this%name) - end if - end if - !groundwater et - if (this%igwetflag /= 0) then - ratin = DZERO - ratout = qgwet !retgw - !ratout = DZERO - !if (retgw > DZERO) then - ! ratout = -retgw - !end if - call model_budget%addentry(ratin, ratout, delt, this%bdtxt(4), & - isuppress_output, this%name) - end if - ! - ! -- set unit number for binary dependent variable output - ibinun = 0 - if(this%iwcontout /= 0) then - ibinun = this%iwcontout - end if - if(idvfl == 0) ibinun = 0 - if (isuppress_output /= 0) ibinun = 0 - ! - ! -- write uzf binary moisture-content output - if (ibinun > 0) then - ! here is where you add the code to write the simulated moisture content - ! may want to write a cell-by-cell file with imeth=6 (see sfr and lake) - end if - ! - ! -- fill the budget object - call this%uzf_fill_budobj() - ! - ! -- write the flows from the budobj - ibinun = 0 - if(this%ibudgetout /= 0) then - ibinun = this%ibudgetout - end if - if(icbcfl == 0) ibinun = 0 - if (isuppress_output /= 0) ibinun = 0 - if (ibinun > 0) then - call this%budobj%save_flows(this%dis, ibinun, kstp, kper, delt, & - pertim, totim, this%iout) - end if - ! - ! -- return - return - end subroutine uzf_bd - - subroutine uzf_ot(this, kstp, kper, iout, ihedfl, ibudfl) -! ****************************************************************************** -! uzf_ot -- UZF package budget -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(UzfType) :: this - integer(I4B),intent(in) :: kstp - integer(I4B),intent(in) :: kper - integer(I4B),intent(in) :: iout - integer(I4B),intent(in) :: ihedfl - integer(I4B),intent(in) :: ibudfl - ! -- local - ! -- format - 2000 FORMAT ( 1X, ///1X, A, A, A, ' PERIOD ', I6, ' STEP ', I8) -! ------------------------------------------------------------------------------ - ! - ! -- write uzf moisture content - if (ihedfl /= 0 .and. this%iprwcont /= 0) then - write (iout, 2000) 'UZF (', trim(this%name), ') WATER-CONTENT', kper, kstp - ! add code to write moisture content - end if - ! - ! -- Output uzf flow table - if (ibudfl /= 0 .and. this%iprflow /= 0) then - call this%budobj%write_flowtable(this%dis) - end if - ! - ! -- Output uzf budget - call this%budobj%write_budtable(kstp, kper, iout) - ! - ! -- return - return - end subroutine uzf_ot - - subroutine uzf_solve(this) -! ****************************************************************************** -! uzf_solve -- Formulate the HCOF and RHS terms -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only : delt - ! -- dummy - class(UzfType) :: this - ! -- locals - integer(I4B) :: i, ivertflag - integer(I4B) :: n, m, ierr - real(DP) :: trhs1, thcof1, trhs2, thcof2 - real(DP) :: hgwf, hgwflm1, cvv, uzderiv, gwet, derivgwet - real(DP) :: qfrommvr, qformvr,sumaet - character(len=100) :: msg - type(UzfCellGroupType) :: uzfobjwork -! ------------------------------------------------------------------------------ - ! - ! -- Initialize - call uzfobjwork%init(1, this%nwav) - ierr = 0 - sumaet = DZERO - ! - ! -- Calculate hcof and rhs for each UZF entry - do i = 1, this%nodes - thcof1 = DZERO - thcof2 = DZERO - trhs1 = DZERO - trhs2 = DZERO - uzderiv = DZERO - gwet = DZERO - derivgwet = DZERO - ivertflag = this%uzfobj%ivertcon(i) - ! - n = this%nodelist(i) - if ( this%ibound(n) > 0 ) then - ! - ! -- Water mover added to infiltration - qfrommvr = DZERO - qformvr = DZERO - if(this%imover == 1) then - qfrommvr = this%pakmvrobj%get_qfrommvr(i) - endif - ! - ! -- zero out hcof and rhs - this%hcof(i) = DZERO - this%rhs(i) = DZERO - ! - hgwf = this%xnew(n) - ! - m = n - hgwflm1 = hgwf - cvv = DZERO - ! - ! -- solve for current uzf cell - call this%uzfobj%formulate(uzfobjwork, ivertflag, i, & - this%totfluxtot, this%ietflag, & - this%issflag,this%iseepflag, & - trhs1,thcof1,hgwf,hgwflm1,cvv,uzderiv, & - qfrommvr,qformvr,ierr,sumaet,ivertflag) - if ( ierr > 0 ) then - if ( ierr == 1 ) & - msg = 'Error: UZF variable NWAVESETS needs to be increased ' - call store_error(msg) - call ustop() - end if - if ( this%igwetflag > 0 ) & - call this%uzfobj%simgwet(this%igwetflag,i,hgwf,trhs2,thcof2,gwet, & - derivgwet) - this%deriv(i) = uzderiv + derivgwet - ! - ! -- save current rejected infiltration, groundwater recharge, and - ! groundwater discharge - this%rejinf(i) = this%uzfobj%finf_rej(i) * this%uzfobj%uzfarea(i) - this%rch(i) = this%uzfobj%totflux(i) * this%uzfobj%uzfarea(i) / delt - this%gwd(i) = this%uzfobj%surfseep(i) - ! - ! -- add to hcof and rhs - this%hcof(i) = thcof1 + thcof2 - this%rhs(i) = -trhs1 - trhs2 - ! - ! -- add spring discharge and rejected infiltration to mover - if(this%imover == 1) then - call this%pakmvrobj%accumulate_qformvr(i, qformvr) - endif - ! - end if - end do - end subroutine uzf_solve - - subroutine define_listlabel(this) -! ****************************************************************************** -! define_listlabel -- Define the list heading that is written to iout when -! PRINT_INPUT option is used. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(UzfType), intent(inout) :: this -! ------------------------------------------------------------------------------ - ! - ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' - else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif - ! - ! -- return - return - end subroutine define_listlabel - - subroutine findcellabove(this,n,nml) - class(UzfType) :: this - integer(I4B), intent(in) :: n - integer(I4B), intent(inout) :: nml - integer(I4B) :: m, ipos -! ------------------------------------------------------------------------------ -! - ! -- return nml = n if no cell is above it - nml = n - do ipos = this%dis%con%ia(n)+1, this%dis%con%ia(n+1)-1 - m = this%dis%con%ja(ipos) - if(this%dis%con%ihc(ipos) /= 0) then - if (n < m) then - ! -- m is beneath n - else - nml = m ! -- m is above n - exit - endif - end if - enddo - return - end subroutine findcellabove - - subroutine read_cell_properties(this) -! ****************************************************************************** -! read_cell_properties -- Read UZF cell properties and set them for -! UzfCellGroup type. -! ****************************************************************************** - use InputOutputModule, only: urword - use SimModule, only: ustop, store_error, count_errors -! ------------------------------------------------------------------------------ - ! -- dummy - class(UzfType), intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: errmsg, cellid - integer(I4B) :: ierr - integer(I4B) :: i, n - integer(I4B) :: j - integer(I4B) :: ic - integer(I4B) :: jcol - logical :: isfound, endOfBlock - integer(I4B) :: landflag - integer(I4B) :: ivertcon - real(DP) :: surfdep, vks, thtr, thts, thti, eps, hgwf - integer(I4B), dimension(:), allocatable :: rowmaxnnz - type(sparsematrix) :: sparse - integer(I4B), dimension(:), allocatable :: nboundchk -! ------------------------------------------------------------------------------ -! - ! - ! -- allocate space for node counter and initilize - allocate(rowmaxnnz(this%dis%nodes)) - do n = 1, this%dis%nodes - rowmaxnnz(n) = 0 - end do - ! - ! -- allocate space for local variables - allocate(nboundchk(this%nodes)) - do n = 1, this%nodes - nboundchk(n) = 0 - end do - ! - ! -- initialize variables - landflag = 0 - ivertcon = 0 - surfdep = DZERO - vks = DZERO - thtr = DZERO - thts = DZERO - thti = DZERO - eps = DZERO - hgwf = DZERO - ! - ! -- get uzf properties block - call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & - supportOpenClose=.true.) - ! - ! -- parse locations block if detected - if (isfound) then - write(this%iout,'(/1x,3a)') 'PROCESSING ', trim(adjustl(this%text)), & - ' PACKAGEDATA' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - ! - ! -- get uzf cell number - i = this%parser%GetInteger() - - if (i < 1 .or. i > this%nodes) then - write(errmsg,'(4x,a,1x,i6)') & - '****ERROR. iuzno MUST BE > 0 and <= ', this%nodes - call store_error(errmsg) - cycle - end if - ! - ! -- increment nboundchk - nboundchk(i) = nboundchk(i) + 1 - - ! -- store the reduced gwf nodenumber in igwfnode - call this%parser%GetCellid(this%dis%ndim, cellid) - ic = this%dis%noder_from_cellid(cellid, & - this%parser%iuactive, this%iout) - this%igwfnode(i) = ic - rowmaxnnz(ic) = rowmaxnnz(ic) + 1 - ! - ! -- landflag - landflag = this%parser%GetInteger() - if (landflag < 0 .OR. landflag > 1) then - write(errmsg,'(4x,a,1x,i0,1x,a,1x,i0)') & - '****ERROR. LANDFLAG FOR UZF CELL', i, & - 'MUST BE 0 or 1 - SPECIFIED VALUE =', landflag - call store_error(errmsg) - end if - ! - ! -- ivertcon - ivertcon = this%parser%GetInteger() - if (ivertcon < 0 .OR. ivertcon > this%nodes) then - write(errmsg,'(4x,a,1x,i0,1x,a,1x,i0)') & - '****ERROR. IVERTCON FOR UZF CELL', i, & - 'MUST BE 0 or less than NUZFCELLS - SPECIFIED VALUE =', ivertcon - call store_error(errmsg) - ivertcon = 0 - end if - ! - ! -- surfdep - surfdep = this%parser%GetDouble() - if (surfdep <= DZERO) then !need to check for cell thickness - write(errmsg,'(4x,a,1x,i0,1x,a,1x,g0)') & - '****ERROR. SURFDEP FOR UZF CELL', i, & - 'MUST BE > 0 - SPECIFIED VALUE =', surfdep - call store_error(errmsg) - surfdep = DZERO - end if - ! - ! -- vks - vks = this%parser%GetDouble() - if (vks <= DZERO) then - write(errmsg,'(4x,a,1x,i0,1x,a,1x,g0)') & - '****ERROR. VKS FOR UZF CELL', i, & - 'MUST BE > 0 - SPECIFIED VALUE =', vks - call store_error(errmsg) - vks = DONE - end if - ! - ! -- thtr - thtr = this%parser%GetDouble() - if (thtr <= DZERO) then - write(errmsg,'(4x,a,1x,i0,1x,a,1x,g0)') & - '****ERROR. THTR FOR UZF CELL', i, & - 'MUST BE > 0 - SPECIFIED VALUE =', thtr - call store_error(errmsg) - thtr = 0.1 - end if - ! - ! -- thts - thts = this%parser%GetDouble() - if (thts <= thtr) then - write(errmsg,'(4x,a,1x,i0,1x,a,1x,g0)') & - '****ERROR. THTS FOR UZF CELL', i, & - 'MUST BE > THTR - SPECIFIED VALUE =', thts - call store_error(errmsg) - thts = 0.2 - end if - ! - ! -- thti - thti = this%parser%GetDouble() - if (thti < thtr .OR. thti > thts) then - write(errmsg,'(4x,a,1x,i0,1x,a,1x,g0)') & - '****ERROR. THTI FOR UZF CELL', i, & - 'MUST BE >= THTR AND < THTS - SPECIFIED VALUE =', thti - call store_error(errmsg) - thti = 0.1 - end if - ! - ! -- eps - eps = this%parser%GetDouble() - if (eps < 3.5 .OR. eps > 14) then - write(errmsg,'(4x,a,1x,i0,1x,a,1x,g0)') & - '****ERROR. EPSILON FOR UZF CELL', i, & - 'MUST BE BETWEEN 3.5 and 14.0 - SPECIFIED VALUE =', eps - call store_error(errmsg) - eps = 3.5 - end if - ! - ! -- boundname - if (this%inamedbound == 1) then - call this%parser%GetStringCaps(this%uzfname(i)) - endif - n = this%igwfnode(i) - !cdl hgwf = this%xnew(n) - call this%uzfobj%setdata(i,this%gwfarea(n),this%gwftop(n),this%gwfbot(n), & - surfdep,vks,thtr,thts,thti,eps,this%ntrail, & - landflag,ivertcon) !,hgwf) - if (ivertcon > 0) then - this%iuzf2uzf = 1 - end if - ! - end do - else - call store_error('ERROR. REQUIRED PACKAGEDATA BLOCK NOT FOUND.') - end if - ! - ! -- check for duplicate or missing uzf cells - do i = 1, this%nodes - if (nboundchk(i) == 0) then - write(errmsg,'(a,1x,i0)') & - 'ERROR. NO DATA SPECIFIED FOR UZF CELL', i - call store_error(errmsg) - else if (nboundchk(i) > 1) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & - 'ERROR. DATA FOR UZF CELL', i, 'SPECIFIED', nboundchk(i), 'TIMES' - call store_error(errmsg) - end if - end do - ! - ! -- write summary of UZF cell property error messages - ierr = count_errors() - if (ierr > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- setup sparse for connectivity used to identify multiple uzf cells per - ! GWF model cell - call sparse%init(this%dis%nodes, this%dis%nodes, rowmaxnnz) - ! -- - do i = 1, this%nodes - ic = this%igwfnode(i) - call sparse%addconnection(ic, i, 1) - end do - ! - ! -- create ia and ja from sparse - call sparse%filliaja(this%ia,this%ja,ierr) - ! - ! -- set imaxcellcnt - do i = 1, this%nodes - jcol = 0 - do j = this%ia(i), this%ia(i+1) - 1 - jcol = jcol + 1 - end do - if (jcol > this%imaxcellcnt) then - this%imaxcellcnt = jcol - end if - end do - ! - ! -- do an initial evaluation of the sum of uzfarea relative to the - ! GWF cell area in the case that there is more than one UZF cell - ! in a GWF cell and a auxmult value is not being applied to the - ! calculate the UZF cell area from the GWF cell area. - if (this%imaxcellcnt > 1 .and. this%iauxmultcol < 1) then - call this%check_cell_area() - end if - ! - ! -- deallocate local variables - deallocate(rowmaxnnz) - deallocate(nboundchk) - ! - ! -- return - return - end subroutine read_cell_properties - - subroutine print_cell_properties(this) -! ****************************************************************************** -! print_cell_properties -- Read UZF cell properties and set them for -! UZFCellGroup type. -! ****************************************************************************** -! ------------------------------------------------------------------------------ - ! -- dummy - class(UzfType), intent(inout) :: this - ! -- local - character (len=20) :: cellid - character(len=LINELENGTH) :: title - character(len=LINELENGTH) :: tag - integer(I4B) :: ntabrows - integer(I4B) :: ntabcols - integer(I4B) :: i - integer(I4B) :: node -! ------------------------------------------------------------------------------ -! - ! - ! -- setup inputtab tableobj - ! - ! -- table dimensions - ntabrows = this%nodes - ntabcols = 10 - if (this%inamedbound == 1) then - ntabcols = ntabcols + 1 - end if - ! - ! -- initialize table and define columns - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%name)) //') STATIC UZF CELL DATA' - call table_cr(this%inputtab, this%name, title) - call this%inputtab%table_df(ntabrows, ntabcols, this%iout) - tag = 'NUMBER' - call this%inputtab%initialize_column(tag, 10) - tag = 'CELLID' - call this%inputtab%initialize_column(tag, 20, alignment=TABLEFT) - tag = 'LANDFLAG' - call this%inputtab%initialize_column(tag, 12) - tag = 'IVERTCON' - call this%inputtab%initialize_column(tag, 12) - tag = 'SURFDEP' - call this%inputtab%initialize_column(tag, 12) - tag = 'VKS' - call this%inputtab%initialize_column(tag, 12) - tag = 'THTR' - call this%inputtab%initialize_column(tag, 12) - tag = 'THTS' - call this%inputtab%initialize_column(tag, 12) - tag = 'THTI' - call this%inputtab%initialize_column(tag, 12) - tag = 'EPS' - call this%inputtab%initialize_column(tag, 12) - if (this%inamedbound == 1) then - tag = 'BOUNDNAME' - call this%inputtab%initialize_column(tag, LENBOUNDNAME, alignment=TABLEFT) - end if - ! - ! -- write data for each cell - do i = 1, this%nodes - ! - ! -- get cellid - node = this%igwfnode(i) - if (node > 0) then - call this%dis%noder_to_string(node, cellid) - else - cellid = 'none' - end if - ! - ! -- add data - call this%inputtab%add_term(i) - call this%inputtab%add_term(cellid) - call this%inputtab%add_term(this%uzfobj%landflag(i)) - call this%inputtab%add_term(this%uzfobj%ivertcon(i)) - call this%inputtab%add_term(this%uzfobj%surfdep(i)) - call this%inputtab%add_term(this%uzfobj%vks(i)) - call this%inputtab%add_term(this%uzfobj%thtr(i)) - call this%inputtab%add_term(this%uzfobj%thts(i)) - call this%inputtab%add_term(this%uzfobj%thti(i)) - call this%inputtab%add_term(this%uzfobj%eps(i)) - if (this%inamedbound == 1) then - call this%inputtab%add_term(this%uzfname(i)) - end if - end do - ! - ! -- return - return - end subroutine print_cell_properties - - subroutine check_cell_area(this) -! ****************************************************************************** -! check_cell_area -- Check UZF cell areas. -! ****************************************************************************** - use InputOutputModule, only: urword - use SimModule, only: ustop, store_error, count_errors -! ------------------------------------------------------------------------------ - ! -- dummy - class(UzfType) :: this - ! -- local - character(len=LINELENGTH) :: errmsg - character(len=16) :: cuzf - character(len=20) :: cellid - character(len=LINELENGTH) :: cuzfcells - integer(I4B) :: ierr - integer(I4B) :: i - integer(I4B) :: i2 - integer(I4B) :: j - integer(I4B) :: n - integer(I4B) :: i0 - integer(I4B) :: i1 - real(DP) :: area - real(DP) :: area2 - real(DP) :: sumarea - real(DP) :: cellarea - real(DP) :: d -! ------------------------------------------------------------------------------ -! - ! - ! -- check that the area of vertically connected uzf cells is the equal - do i = 1, this%nodes - ! - ! -- Initialize variables - i2 = this%uzfobj%ivertcon(i) - area = this%uzfobj%uzfarea(i) - ! - ! Create pointer to object below - if (i2 > 0) then - area2 = this%uzfobj%uzfarea(i2) - d = abs(area - area2) - if (d > DEM6) then - write(errmsg,'(4x,2(a,1x,g15.7,1x,a,1x,i6,1x))') & - '****ERROR. UZF CELL AREA (', area, ') FOR CELL ', i, & - 'DOES NOT EQUAL UZF CELL AREA (', area2, ') FOR CELL ', i2 - call store_error(errmsg) - end if - end if - end do - ! - ! -- check that the area of uzf cells in a GWF cell is less than or equal - ! to the GWF cell area - do n = 1, this%dis%nodes - i0 = this%ia(n) - i1 = this%ia(n+1) - ! -- skip gwf cells with no UZF cells - if ((i1 - i0) < 1) cycle - sumarea = DZERO - cellarea = DZERO - cuzfcells = '' - do j = i0, i1 - 1 - i = this%ja(j) - write(cuzf,'(i0)') i - cuzfcells = trim(adjustl(cuzfcells)) // ' ' // trim(adjustl(cuzf)) - sumarea = sumarea + this%uzfobj%uzfarea(i) - cellarea = this%uzfobj%cellarea(i) - end do - ! -- calculate the difference between the sum of UZF areas and GWF cell area - d = abs(sumarea - cellarea) - if (d > DEM6) then - call this%dis%noder_to_string(n, cellid) - write(errmsg,'(4x,a,1x,g15.7,1x,a,1x,g15.7,1x,a,1x,a,1x,a,a)') & - '****ERROR. TOTAL UZF CELL AREA (', sumarea, & - ') EXCEEDS THE GWF CELL AREA (', cellarea, ') OF CELL', cellid, & - 'WHICH INCLUDES UZF CELL(S): ', trim(adjustl(cuzfcells)) - call store_error(errmsg) - end if - end do - ! - ! -- terminate if errors were encountered - ierr = count_errors() - if (ierr > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! -- return - return - end subroutine check_cell_area - - ! -- Procedures related to observations (type-bound) - logical function uzf_obs_supported(this) -! ****************************************************************************** -! uzf_obs_supported -! -- Return true because uzf package supports observations. -! -- Overrides BndType%bnd_obs_supported -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(UzfType) :: this -! ------------------------------------------------------------------------------ - uzf_obs_supported = .true. - return - end function uzf_obs_supported - - subroutine uzf_df_obs(this) -! ****************************************************************************** -! uzf_df_obs (implements bnd_df_obs) -! -- Store observation type supported by uzf package. -! -- Overrides BndType%bnd_df_obs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(UzfType) :: this - ! -- local - integer(I4B) :: indx - ! ------------------------------------------------------------------------------ - ! - ! -- Store obs type and assign procedure pointer - ! - ! for recharge observation type. - call this%obs%StoreObsType('uzf-gwrch', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID - ! - ! for discharge observation type. - call this%obs%StoreObsType('uzf-gwd', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID - ! - ! for discharge observation type. - call this%obs%StoreObsType('uzf-gwd-to-mvr', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID - ! - ! for gwet observation type. - call this%obs%StoreObsType('uzf-gwet', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID - ! - ! for infiltration observation type. - call this%obs%StoreObsType('infiltration', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID - ! - ! for from mover observation type. - call this%obs%StoreObsType('from-mvr', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID - ! - ! for rejected infiltration observation type. - call this%obs%StoreObsType('rej-inf', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID - ! - ! for rejected infiltration to mover observation type. - call this%obs%StoreObsType('rej-inf-to-mvr', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID - ! - ! for uzet observation type. - call this%obs%StoreObsType('uzet', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID - ! - ! for storage observation type. - call this%obs%StoreObsType('storage', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID - ! - ! for net infiltration observation type. - call this%obs%StoreObsType('net-infiltration', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID - ! - ! for water-content observation type. - call this%obs%StoreObsType('water-content', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID - ! - ! -- return - return - end subroutine uzf_df_obs -! - subroutine uzf_bd_obs(this) - ! ************************************************************************** - ! uzf_bd_obs - ! -- Calculate observations this time step and call - ! ObsType%SaveOneSimval for each UzfType observation. - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - ! -- dummy - class(UzfType) :: this - ! -- local - integer(I4B) :: i, ii, n, nn - real(DP) :: v - character(len=100) :: msg - type(ObserveType), pointer :: obsrv => null() - !--------------------------------------------------------------------------- - ! - ! Write simulated values for all uzf observations - if (this%obs%npakobs>0) then - call this%obs%obs_bd_clear() - do i = 1, this%obs%npakobs - obsrv => this%obs%pakobs(i)%obsrv - nn = size(obsrv%indxbnds) - do ii = 1, nn - n = obsrv%indxbnds(ii) - v = DNODATA - select case (obsrv%ObsTypeId) - case ('UZF-GWRCH') - v = this%rch(n) - case ('UZF-GWD') - v = this%gwd(n) - if (v > DZERO) then - v = -v - end if - case ('UZF-GWD-TO-MVR') - if (this%imover == 1) then - v = this%gwdtomvr(n) - if (v > DZERO) then - v = -v - end if - end if - case ('UZF-GWET') - if (this%igwetflag > 0) then - v = this%gwet(n) - if (v > DZERO) then - v = -v - end if - end if - case ('INFILTRATION') - v = this%appliedinf(n) - case ('FROM-MVR') - if (this%imover == 1) then - v = this%pakmvrobj%get_qfrommvr(n) - end if - case ('REJ-INF') - v = this%rejinf(n) - if (v > DZERO) then - v = -v - end if - case ('REJ-INF-TO-MVR') - if (this%imover == 1) then - v = this%rejinftomvr(n) - if (v > DZERO) then - v = -v - end if - end if - case ('UZET') - if (this%ietflag /= 0) then - v = this%uzet(n) - if (v > DZERO) then - v = -v - end if - end if - case ('STORAGE') - v = -this%qsto(n) - case ('NET-INFILTRATION') - v = this%infiltration(n) - case ('WATER-CONTENT') - v = this%obs_theta(i) ! more than one obs per node - case default - msg = 'Error: Unrecognized observation type: ' // trim(obsrv%ObsTypeId) - call store_error(msg) - end select - call this%obs%SaveOneSimval(obsrv, v) - end do - end do - end if - ! - ! -- write summary of package block error messages - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - return - end subroutine uzf_bd_obs -! - subroutine uzf_rp_obs(this) - ! -- dummy - class(UzfType), intent(inout) :: this - ! -- local - integer(I4B) :: i, j, n, nn - real(DP) :: obsdepth - real(DP) :: dmax - character(len=200) :: ermsg - character(len=LENBOUNDNAME) :: bname - class(ObserveType), pointer :: obsrv => null() - ! -------------------------------------------------------------------------- - ! -- formats -60 format('Error: Invalid node number in OBS input: ',i5) - ! - do i = 1, this%obs%npakobs - obsrv => this%obs%pakobs(i)%obsrv - ! -- indxbnds needs to be deallocated and reallocated (using - ! ExpandArray) each stress period because list of boundaries - ! can change each stress period. - if (allocated(obsrv%indxbnds)) then - deallocate(obsrv%indxbnds) - endif - ! - ! -- get node number 1 - nn = obsrv%NodeNumber - if (nn == NAMEDBOUNDFLAG) then - bname = obsrv%FeatureName - ! -- Observation location(s) is(are) based on a boundary name. - ! Iterate through all boundaries to identify and store - ! corresponding index(indices) in bound array. - do j = 1, this%nodes - if (this%boundname(j) == bname) then - !! In UZF, use of the same boundary name for multiple boundaries - !! in an observation is not supported for obs type UZF-WATERCONTENT - !if (obsrv%ObsTypeId=='WATER-CONTENT') then - ! if (obsrv%BndFound) then - ! ermsg = 'Duplicate names for multiple boundaries are not ' // & - ! 'supported for UZF observations of type ' // & - ! '"UZF-WATERCONTENT". There are multiple' // & - ! ' boundaries named "' // trim(bname) // & - ! '" for observation: ' // & - ! trim(obsrv%Name) // '.' - ! call store_error(ermsg) - ! call store_error_unit(this%inunit) - ! call ustop() - ! endif - !endif - obsrv%BndFound = .true. - obsrv%CurrentTimeStepEndValue = DZERO - call ExpandArray(obsrv%indxbnds) - n = size(obsrv%indxbnds) - obsrv%indxbnds(n) = j - if (n==1) then - ! Define intPak1 so that obs_theta is stored (for first uzf - ! cell if multiple cells share the same boundname). - obsrv%intPak1 = j - endif - endif - enddo - else - ! -- get node number - nn = obsrv%NodeNumber - ! -- put nn (a value meaningful only to UZF) in intPak1 - obsrv%intPak1 = nn - ! -- check that node number is valid; call store_error if not - if (nn < 1 .or. nn > this%nodes) then - write (ermsg, 60) nn - call store_error(ermsg) - else - obsrv%BndFound = .true. - endif - obsrv%CurrentTimeStepEndValue = DZERO - call ExpandArray(obsrv%indxbnds) - n = size(obsrv%indxbnds) - obsrv%indxbnds(n) = nn - end if - ! - ! -- catch non-cumulative observation assigned to observation defined - ! by a boundname that is assigned to more than one element - if (obsrv%ObsTypeId == 'WATER-CONTENT') then - n = size(obsrv%indxbnds) - if (n > 1) then - write (ermsg, '(4x,a,4(1x,a))') & - 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & - 'for observation', trim(adjustl(obsrv%Name)), & - ' must be assigned to a UZF cell with a unique boundname.' - call store_error(ermsg) - end if - ! - ! -- check WATER-CONTENT depth - obsdepth = obsrv%Obsdepth - ! -- put obsdepth (a value meaningful only to UZF) in dblPak1 - obsrv%dblPak1 = obsdepth - ! - ! -- determine maximum cell depth - dmax = this%uzfobj%celtop(n) - this%uzfobj%celbot(n) - ! -- check that obs depth is valid; call store_error if not - ! -- need to think about a way to put bounds on this depth - if (obsdepth < DZERO .or. obsdepth > dmax) then - write (ermsg, '(4x,a,4(1x,a),1x,g15.7,1x,a,1x,g15.7)') & - 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & - 'for observation', trim(adjustl(obsrv%Name)), & - ' specified depth (', obsdepth, ') must be between 0. and ', dmax - call store_error(ermsg) - endif - else - do j = 1, size(obsrv%indxbnds) - nn = obsrv%indxbnds(j) - if (nn < 1 .or. nn > this%maxbound) then - write (ermsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & - 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & - ' uzfno must be > 0 and <=', this%maxbound, & - '(specified value is ', nn, ')' - call store_error(ermsg) - end if - end do - end if - ! ! - ! select case (obsrv%ObsTypeId) - ! case ('WATER-CONTENT') - ! obsdepth = obsrv%Obsdepth - ! ! -- put obsdepth (a value meaningful only to UZF) in dblPak1 - ! obsrv%dblPak1 = obsdepth - ! ! -- check that obs depth is valid; call store_error if not - ! ! -- need to think about a way to put bounds on this depth - ! if (obsdepth < -999999.d0 .or. obsdepth > 999999.d0) then - ! write (ermsg, 70) obsdepth - ! call store_error(ermsg) - ! endif - ! case default - !! left to check other types of observations - ! end select - end do - if (count_errors() > 0) then - call store_error_unit(this%inunit) - call ustop() - endif - ! - return - end subroutine uzf_rp_obs - ! - ! -- Procedures related to observations (NOT type-bound) - subroutine uzf_process_obsID(obsrv, dis, inunitobs, iout) - ! -- This procedure is pointed to by ObsDataType%ProcesssIdPtr. It processes - ! the ID string of an observation definition for UZF-package observations. - ! -- dummy - type(ObserveType), intent(inout) :: obsrv - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: inunitobs - integer(I4B), intent(in) :: iout - ! -- local - integer(I4B) :: n, nn - real(DP) :: obsdepth - integer(I4B) :: icol, istart, istop, istat - real(DP) :: r - character(len=LINELENGTH) :: strng - ! formats - 30 format(i10) - ! - strng = obsrv%IDstring - ! -- Extract node number from strng and store it. - ! If 1st item is not an integer(I4B), it should be a - ! feature name--deal with it. - icol = 1 - ! -- get node number - call urword(strng, icol, istart, istop, 1, n, r, iout, inunitobs) - read (strng(istart:istop), 30, iostat=istat) nn - if (istat==0) then - ! -- store uzf node number (NodeNumber) - obsrv%NodeNumber = nn - else - ! Integer can't be read from strng; it's presumed to be a boundary - ! name (already converted to uppercase) - obsrv%FeatureName = strng(istart:istop) - ! -- Observation may require summing rates from multiple boundaries, - ! so assign NodeNumber as a value that indicates observation - ! is for a named boundary or group of boundaries. - obsrv%NodeNumber = NAMEDBOUNDFLAG - endif - ! - ! -- for soil water observation, store depth - if (obsrv%ObsTypeId=='WATER-CONTENT' ) then - call urword(strng, icol, istart, istop, 3, n, r, iout, inunitobs) - obsdepth = r - ! -- store observations depth - obsrv%Obsdepth = obsdepth - endif - ! - return - end subroutine uzf_process_obsID - - subroutine uzf_allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -- allocate scalar members -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(UzfType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- call standard BndType allocate scalars - call this%BndType%allocate_scalars() - ! - ! -- allocate uzf specific scalars - call mem_allocate(this%iprwcont, 'IPRWCONT', this%origin) - call mem_allocate(this%iwcontout, 'IWCONTOUT', this%origin) - call mem_allocate(this%ibudgetout, 'IBUDGETOUT', this%origin) - call mem_allocate(this%ipakcsv, 'IPAKCSV', this%origin) - call mem_allocate(this%ntrail, 'NTRAIL', this%origin) - call mem_allocate(this%nsets, 'NSETS', this%origin) - call mem_allocate(this%nodes, 'NODES', this%origin) - call mem_allocate(this%istocb, 'ISTOCB', this%origin) - call mem_allocate(this%nwav, 'NWAV', this%origin) - call mem_allocate(this%outunitbud, 'OUTUNITBUD', this%origin) - call mem_allocate(this%totfluxtot, 'TOTFLUXTOT', this%origin) - call mem_allocate(this%infilsum, 'INFILSUM', this%origin) - call mem_allocate(this%uzetsum, 'UZETSUM', this%origin) - call mem_allocate(this%rechsum, 'RECHSUM', this%origin) - call mem_allocate(this%vfluxsum, 'VFLUXSUM', this%origin) - call mem_allocate(this%delstorsum, 'DELSTORSUM', this%origin) - call mem_allocate(this%bditems, 'BDITEMS', this%origin) - call mem_allocate(this%nbdtxt, 'NBDTXT', this%origin) - call mem_allocate(this%issflag, 'ISSFLAG', this%origin) - call mem_allocate(this%issflagold, 'ISSFLAGOLD', this%origin) - call mem_allocate(this%readflag, 'READFLAG', this%origin) - call mem_allocate(this%iseepflag, 'ISEEPFLAG', this%origin) - call mem_allocate(this%imaxcellcnt, 'IMAXCELLCNT', this%origin) - call mem_allocate(this%ietflag, 'IETFLAG', this%origin) - call mem_allocate(this%igwetflag, 'IGWETFLAG', this%origin) - call mem_allocate(this%iuzf2uzf, 'IUZF2UZF', this%origin) - call mem_allocate(this%cbcauxitems, 'CBCAUXITEMS', this%origin) - - call mem_allocate(this%iconvchk, 'ICONVCHK', this%origin) - ! - ! -- initialize scalars - this%iprwcont = 0 - this%iwcontout = 0 - this%ibudgetout = 0 - this%ipakcsv = 0 - this%infilsum = DZERO - this%uzetsum = DZERO - this%rechsum = DZERO - this%delstorsum = DZERO - this%vfluxsum = DZERO - this%istocb = 0 - this%bditems = 7 - this%nbdtxt = 5 - this%issflag = 0 - this%issflagold = 0 - this%ietflag = 0 - this%igwetflag = 0 - this%iseepflag = 0 - this%imaxcellcnt = 0 - this%iuzf2uzf = 0 - this%cbcauxitems = 1 - this%imover = 0 - ! - ! -- convergence check - this%iconvchk = 1 - ! - ! -- return - return - end subroutine uzf_allocate_scalars -! - subroutine uzf_da(this) -! ****************************************************************************** -! uzf_da -- Deallocate objects -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(UzfType) :: this - ! -- locals - ! -- format -! ------------------------------------------------------------------------------ - ! - ! -- deallocate uzf objects - call this%uzfobj%dealloc() - nullify(this%uzfobj) - call this%budobj%budgetobject_da() - deallocate(this%budobj) - nullify(this%budobj) - ! - ! -- character arrays - deallocate(this%bdtxt) - deallocate(this%cauxcbc) - deallocate(this%uzfname) - ! - ! -- package csv table - if (this%ipakcsv > 0) then - call this%pakcsvtab%table_da() - deallocate(this%pakcsvtab) - nullify(this%pakcsvtab) - end if - ! - ! -- deallocate scalars - call mem_deallocate(this%iprwcont) - call mem_deallocate(this%iwcontout) - call mem_deallocate(this%ibudgetout) - call mem_deallocate(this%ipakcsv) - call mem_deallocate(this%ntrail) - call mem_deallocate(this%nsets) - call mem_deallocate(this%nodes) - call mem_deallocate(this%istocb) - call mem_deallocate(this%nwav) - call mem_deallocate(this%outunitbud) - call mem_deallocate(this%totfluxtot) - call mem_deallocate(this%infilsum) - call mem_deallocate(this%uzetsum) - call mem_deallocate(this%rechsum) - call mem_deallocate(this%vfluxsum) - call mem_deallocate(this%delstorsum) - call mem_deallocate(this%bditems) - call mem_deallocate(this%nbdtxt) - call mem_deallocate(this%issflag) - call mem_deallocate(this%issflagold) - call mem_deallocate(this%readflag) - call mem_deallocate(this%iseepflag) - call mem_deallocate(this%imaxcellcnt) - call mem_deallocate(this%ietflag) - call mem_deallocate(this%igwetflag) - call mem_deallocate(this%iuzf2uzf) - call mem_deallocate(this%cbcauxitems) - ! - ! -- convergence check - call mem_deallocate(this%iconvchk) - ! - ! -- deallocate arrays - call mem_deallocate(this%igwfnode) - call mem_deallocate(this%appliedinf) - call mem_deallocate(this%rejinf) - call mem_deallocate(this%rejinf0) - call mem_deallocate(this%rejinftomvr) - call mem_deallocate(this%infiltration) - call mem_deallocate(this%recharge) - call mem_deallocate(this%gwet) - call mem_deallocate(this%uzet) - call mem_deallocate(this%gwd) - call mem_deallocate(this%gwd0) - call mem_deallocate(this%gwdtomvr) - call mem_deallocate(this%rch) - call mem_deallocate(this%rch0) - call mem_deallocate(this%qsto) - call mem_deallocate(this%deriv) - call mem_deallocate(this%qauxcbc) - ! - ! -- deallocate integer arrays - call mem_deallocate(this%ia) - call mem_deallocate(this%ja) - ! - ! -- deallocate timeseries aware variables - call mem_deallocate(this%sinf) - call mem_deallocate(this%pet) - call mem_deallocate(this%extdp) - call mem_deallocate(this%extwc) - call mem_deallocate(this%ha) - call mem_deallocate(this%hroot) - call mem_deallocate(this%rootact) - call mem_deallocate(this%lauxvar) - ! - ! -- deallocate obs variables - call mem_deallocate(this%obs_theta) - call mem_deallocate(this%obs_depth) - call mem_deallocate(this%obs_num) - ! - ! -- Parent object - call this%BndType%bnd_da() - ! - ! -- Return - return - end subroutine uzf_da - - subroutine uzf_setup_budobj(this) -! ****************************************************************************** -! uzf_setup_budobj -- Set up the budget object that stores all the uzf flows -! The terms listed here must correspond in number and order to the ones -! listed in the uzf_fill_budobj routine. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LENBUDTXT - ! -- dummy - class(UzfType) :: this - ! -- local - integer(I4B) :: nbudterm - integer(I4B) :: maxlist, naux - integer(I4B) :: idx - integer(I4B) :: nlen - integer(I4B) :: n, n1, n2 - integer(I4B) :: ivertflag - real(DP) :: q - character(len=LENBUDTXT) :: text - character(len=LENBUDTXT), dimension(1) :: auxtxt -! ------------------------------------------------------------------------------ - ! - ! -- Determine the number of uzf to uzf connections - nlen = 0 - do n = 1, this%nodes - ivertflag = this%uzfobj%ivertcon(n) - if (ivertflag > 0) then - nlen = nlen + 1 - end if - end do - ! - ! -- Determine the number of uzf budget terms. These are fixed for - ! the simulation and cannot change. This includes FLOW-JA-FACE - ! so they can be written to the binary budget files, but these internal - ! flows are not included as part of the budget table. - nbudterm = 4 - if (nlen > 0) nbudterm = nbudterm + 1 - if (this%ietflag /= 0) nbudterm = nbudterm + 1 - if (this%imover == 1) nbudterm = nbudterm + 2 - if (this%naux > 0) nbudterm = nbudterm + 1 - ! - ! -- set up budobj - call budgetobject_cr(this%budobj, this%name) - call this%budobj%budgetobject_df(this%maxbound, nbudterm, 0, 0) - idx = 0 - ! - ! -- Go through and set up each budget term - text = ' FLOW-JA-FACE' - if (nlen > 0) then - idx = idx + 1 - maxlist = nlen * 2 - naux = 1 - auxtxt(1) = ' FLOW-AREA' - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux, auxtxt, ordered_id1=.false.) - ! - ! -- store connectivity - call this%budobj%budterm(idx)%reset(nlen * 2) - q = DZERO - do n = 1, this%nodes - ivertflag = this%uzfobj%ivertcon(n) - if (ivertflag > 0) then - n1 = n - n2 = ivertflag - call this%budobj%budterm(idx)%update_term(n1, n2, q) - call this%budobj%budterm(idx)%update_term(n2, n1, -q) - end if - end do - end if - ! - ! -- - text = ' GWF' - idx = idx + 1 - maxlist = this%nodes - naux = 1 - auxtxt(1) = ' FLOW-AREA' - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name_model, & - maxlist, .false., .true., & - naux, auxtxt) - call this%budobj%budterm(idx)%reset(this%nodes) - q = DZERO - do n = 1, this%nodes - n2 = this%igwfnode(n) - call this%budobj%budterm(idx)%update_term(n, n2, q) - end do - ! - ! -- - text = ' INFILTRATION' - idx = idx + 1 - maxlist = this%nodes - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- - text = ' REJ-INF' - idx = idx + 1 - maxlist = this%nodes - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- - text = ' UZET' - if (this%ietflag /= 0) then - idx = idx + 1 - maxlist = this%maxbound - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - end if - ! - ! -- - text = ' STORAGE' - idx = idx + 1 - maxlist = this%nodes - naux = 1 - auxtxt(1) = ' VOLUME' - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux, auxtxt) - ! - ! -- - if (this%imover == 1) then - ! - ! -- - text = ' FROM-MVR' - idx = idx + 1 - maxlist = this%nodes - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - ! - ! -- - text = ' REJ-INF-TO-MVR' - idx = idx + 1 - maxlist = this%nodes - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux) - end if - ! - ! -- - naux = this%naux - if (naux > 0) then - ! - ! -- - text = ' AUXILIARY' - idx = idx + 1 - maxlist = this%maxbound - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%name, & - this%name_model, & - this%name, & - maxlist, .false., .false., & - naux, this%auxname) - end if - ! - ! -- if uzf flow for each reach are written to the listing file - if (this%iprflow /= 0) then - call this%budobj%flowtable_df(this%iout, cellids='GWF') - end if - ! - ! -- return - return - end subroutine uzf_setup_budobj - - subroutine uzf_fill_budobj(this) -! ****************************************************************************** -! uzf_fill_budobj -- copy flow terms into this%budobj -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(UzfType) :: this - ! -- local - integer(I4B) :: naux - integer(I4B) :: nlen - integer(I4B) :: ivertflag - integer(I4B) :: n, n1, n2 - integer(I4B) :: idx - real(DP) :: q - real(DP) :: a - real(DP) :: top - real(DP) :: bot - real(DP) :: thick - real(DP) :: fm - real(DP) :: v - ! -- formats -! ----------------------------------------------------------------------------- - ! - ! -- initialize counter - idx = 0 - - - ! -- FLOW JA FACE - nlen = 0 - do n = 1, this%nodes - ivertflag = this%uzfobj%ivertcon(n) - if ( ivertflag > 0 ) then - nlen = nlen + 1 - end if - end do - if (nlen > 0) then - idx = idx + 1 - call this%budobj%budterm(idx)%reset(nlen * 2) - do n = 1, this%nodes - ivertflag = this%uzfobj%ivertcon(n) - if (ivertflag > 0) then - a = this%uzfobj%uzfarea(n) - q = this%uzfobj%surfluxbelow(n) * a - this%qauxcbc(1) = a - if (q > DZERO) then - q = -q - end if - n1 = n - n2 = ivertflag - call this%budobj%budterm(idx)%update_term(n1, n2, q, this%qauxcbc) - call this%budobj%budterm(idx)%update_term(n2, n1, -q, this%qauxcbc) - end if - end do - end if - - - ! -- GWF (LEAKAGE) - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nodes) - do n = 1, this%nodes - this%qauxcbc(1) = this%uzfobj%uzfarea(n) - n2 = this%igwfnode(n) - q = -this%rch(n) - call this%budobj%budterm(idx)%update_term(n, n2, q, this%qauxcbc) - end do - - - ! -- INFILTRATION - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nodes) - do n = 1, this%nodes - q = this%appliedinf(n) - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - - - ! -- REJECTED INFILTRATION - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nodes) - do n = 1, this%nodes - q = this%rejinf(n) - if (q > DZERO) then - q = -q - end if - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - - - ! -- UNSATURATED EVT - if (this%ietflag /= 0) then - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nodes) - do n = 1, this%nodes - q = this%uzet(n) - if (q > DZERO) then - q = -q - end if - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - end if - - - ! -- STORAGE - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nodes) - do n = 1, this%nodes - q = -this%qsto(n) - top = this%uzfobj%celtop(n) - bot = this%uzfobj%watab(n) - thick = top - bot - if (thick > DZERO) then - fm = this%uzfobj%unsat_stor(n, thick) - v = fm * this%uzfobj%uzfarea(n) - else - v = DZERO - end if - this%qauxcbc(1) = v - call this%budobj%budterm(idx)%update_term(n, n, q, this%qauxcbc) - end do - - - ! -- MOVER - if (this%imover == 1) then - - ! -- FROM MOVER - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nodes) - do n = 1, this%nodes - q = this%pakmvrobj%get_qfrommvr(n) - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - - - ! -- REJ-INF-TO-MVR - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nodes) - do n = 1, this%nodes - q = this%rejinftomvr(n) - if (q > DZERO) then - q = -q - end if - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - - end if - - - ! -- AUXILIARY VARIABLES - naux = this%naux - if (naux > 0) then - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nodes) - do n = 1, this%nodes - q = DZERO - call this%budobj%budterm(idx)%update_term(n, n, q, this%auxvar(:, n)) - end do - end if - ! - ! --Terms are filled, now accumulate them for this time step - call this%budobj%accumulate_terms() - ! - ! -- return - return - end subroutine uzf_fill_budobj - -end module UzfModule +! -- Uzf module +module UzfModule + + use KindModule, only: DP, I4B + use ArrayHandlersModule, only: ExpandArray + use ConstantsModule, only: DZERO, DEM6, DEM4, DEM2, DEM1, DHALF, & + DONE, DHUNDRED, & + LINELENGTH, LENFTYPE, LENPACKAGENAME, & + LENBOUNDNAME, LENBUDTXT, LENPAKLOC, DNODATA, & + NAMEDBOUNDFLAG, MAXCHARLEN, & + DHNOFLO, DHDRY, & + TABLEFT, TABCENTER, TABRIGHT, & + TABSTRING, TABUCSTRING, TABINTEGER, TABREAL + use GenericUtilitiesModule, only: sim_message + use MemoryTypeModule, only: MemoryTSType + use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_setptr, & + mem_deallocate + use SparseModule, only: sparsematrix + use BndModule, only: BndType + use UzfCellGroupModule, only: UzfCellGroupType + use BudgetObjectModule, only: BudgetObjectType, budgetobject_cr + use BaseDisModule, only: DisBaseType + use ObserveModule, only: ObserveType + use ObsModule, only: ObsType + use InputOutputModule, only: URWORD + use SimModule, only: count_errors, store_error, ustop, store_error_unit + use BlockParserModule, only: BlockParserType + use TableModule, only: TableType, table_cr + + implicit none + + character(len=LENFTYPE) :: ftype = 'UZF' + character(len=LENPACKAGENAME) :: text = ' UZF CELLS' + + private + public :: uzf_create + public :: UzfType + + type, extends(BndType) :: UzfType + ! output integers + integer(I4B), pointer :: iprwcont => null() + integer(I4B), pointer :: iwcontout => null() + integer(I4B), pointer :: ibudgetout => null() + integer(I4B), pointer :: ipakcsv => null() + ! + type(BudgetObjectType), pointer :: budobj => null() + integer(I4B), pointer :: bditems => null() !number of budget items + integer(I4B), pointer :: nbdtxt => null() !number of budget text items + character(len=LENBUDTXT), dimension(:), pointer, & + contiguous :: bdtxt => null() !budget items written to cbc file + character(len=LENBOUNDNAME), dimension(:), pointer, & + contiguous :: uzfname => null() + ! + ! -- uzf table objects + type(TableType), pointer :: pakcsvtab => null() + ! + ! -- uzf kinematic object + type(UzfCellGroupType), pointer :: uzfobj => null() + ! + ! -- pointer to gwf variables + integer(I4B), pointer :: gwfiss => null() + real(DP), dimension(:), pointer, contiguous :: gwftop => null() + real(DP), dimension(:), pointer, contiguous :: gwfbot => null() + real(DP), dimension(:), pointer, contiguous :: gwfarea => null() + real(DP), dimension(:), pointer, contiguous :: gwfhcond => null() + ! + ! -- uzf data + integer(I4B), pointer :: ntrail => null() + integer(I4B), pointer :: nsets => null() + integer(I4B), pointer :: nwav => null() + integer(I4B), pointer :: nodes => null() + integer(I4B), pointer :: nper => null() + integer(I4B), pointer :: nstp => null() + integer(I4B), pointer :: readflag => null() + integer(I4B), pointer :: outunitbud => null() + integer(I4B), pointer :: ietflag => null() + integer(I4B), pointer :: igwetflag => null() + integer(I4B), pointer :: iseepflag => null() + integer(I4B), pointer :: imaxcellcnt => null() + integer(I4B), dimension(:), pointer, contiguous :: igwfnode => null() + real(DP), dimension(:), pointer, contiguous :: appliedinf => null() + real(DP), dimension(:), pointer, contiguous :: rejinf => null() + real(DP), dimension(:), pointer, contiguous :: rejinf0 => null() + real(DP), dimension(:), pointer, contiguous :: rejinftomvr => null() + real(DP), dimension(:), pointer, contiguous :: infiltration => null() + real(DP), dimension(:), pointer, contiguous :: recharge => null() + real(DP), dimension(:), pointer, contiguous :: gwet => null() + real(DP), dimension(:), pointer, contiguous :: uzet => null() + real(DP), dimension(:), pointer, contiguous :: gwd => null() + real(DP), dimension(:), pointer, contiguous :: gwd0 => null() + real(DP), dimension(:), pointer, contiguous :: gwdtomvr => null() + real(DP), dimension(:), pointer, contiguous :: rch => null() + real(DP), dimension(:), pointer, contiguous :: rch0 => null() + real(DP), dimension(:), pointer, contiguous :: qsto => null() + integer(I4B), pointer :: iuzf2uzf => null() + ! + ! -- integer vectors + integer(I4B), dimension(:), pointer, contiguous :: ia => null() + integer(I4B), dimension(:), pointer, contiguous :: ja => null() + ! + ! -- timeseries aware variables + type (MemoryTSType), dimension(:), pointer, contiguous :: sinf => null() + type (MemoryTSType), dimension(:), pointer, contiguous :: pet => null() + type (MemoryTSType), dimension(:), pointer, contiguous :: extdp => null() + type (MemoryTSType), dimension(:), pointer, contiguous :: extwc => null() + type (MemoryTSType), dimension(:), pointer, contiguous :: ha => null() + type (MemoryTSType), dimension(:), pointer, contiguous :: hroot => null() + type (MemoryTSType), dimension(:), pointer, contiguous :: rootact => null() + type (MemoryTSType), dimension(:), pointer, contiguous :: lauxvar => null() + ! + ! -- convergence check + integer(I4B), pointer :: iconvchk => null() + ! + ! formulate variables + real(DP), dimension(:), pointer, contiguous :: deriv => null() + ! + ! budget variables + real(DP), pointer :: totfluxtot => null() + real(DP), pointer :: infilsum => null() + real(DP), pointer :: rechsum => null() + real(DP), pointer :: delstorsum => null() + real(DP), pointer :: uzetsum => null() + real(DP), pointer :: vfluxsum => null() + integer(I4B), pointer :: issflag => null() + integer(I4B), pointer :: issflagold => null() + integer(I4B), pointer :: istocb => null() + ! + ! -- uzf cbc budget items + integer(I4B), pointer :: cbcauxitems => NULL() + character(len=16), dimension(:), pointer, contiguous :: cauxcbc => NULL() + real(DP), dimension(:), pointer, contiguous :: qauxcbc => null() + ! + ! -- observations + real(DP), dimension(:), pointer, contiguous :: obs_theta => null() + real(DP), dimension(:), pointer, contiguous :: obs_depth => null() + integer(I4B), dimension(:), pointer, contiguous :: obs_num => null() + + contains + + procedure :: uzf_allocate_arrays + procedure :: uzf_allocate_scalars + procedure :: bnd_options => uzf_options + procedure :: read_dimensions => uzf_readdimensions + procedure :: bnd_ar => uzf_ar + procedure :: bnd_rp => uzf_rp + procedure :: bnd_ad => uzf_ad + procedure :: bnd_cf => uzf_cf + procedure :: bnd_cc => uzf_cc + procedure :: bnd_bd => uzf_bd + procedure :: bnd_ot => uzf_ot + procedure :: bnd_fc => uzf_fc + procedure :: bnd_fn => uzf_fn + procedure :: bnd_da => uzf_da + procedure :: define_listlabel + ! + ! -- methods for observations + procedure, public :: bnd_obs_supported => uzf_obs_supported + procedure, public :: bnd_df_obs => uzf_df_obs + procedure, public :: bnd_rp_obs => uzf_rp_obs + procedure, private :: uzf_bd_obs + ! + ! -- methods specific for uzf + procedure, private :: uzf_solve + procedure, private :: read_cell_properties + procedure, private :: print_cell_properties + procedure, private :: findcellabove + procedure, private :: check_cell_area + ! + ! -- budget + procedure, private :: uzf_setup_budobj + procedure, private :: uzf_fill_budobj + + end type UzfType + +contains + + subroutine uzf_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) +! ****************************************************************************** +! uzf_create -- Create a New UZF Package +! Subroutine: (1) create new-style package +! (2) point packobj to the new package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(BndType), pointer :: packobj + integer(I4B),intent(in) :: id + integer(I4B),intent(in) :: ibcnum + integer(I4B),intent(in) :: inunit + integer(I4B),intent(in) :: iout + character(len=*), intent(in) :: namemodel + character(len=*), intent(in) :: pakname + ! -- local + type(UzfType), pointer :: uzfobj +! ------------------------------------------------------------------------------ + ! + ! -- allocate the object and assign values to object variables + allocate(uzfobj) + packobj => uzfobj + ! + ! -- create name and origin + call packobj%set_names(ibcnum, namemodel, pakname, ftype) + packobj%text = text + ! + ! -- allocate scalars + call uzfobj%uzf_allocate_scalars() + ! + ! -- initialize package + call packobj%pack_initialize() + ! + packobj%inunit = inunit + packobj%iout = iout + packobj%id = id + packobj%ibcnum = ibcnum + packobj%ncolbnd = 1 + packobj%iscloc = 0 ! not supported + packobj%ictorigin = 'NPF' + ! + ! -- return + return + end subroutine uzf_create + + subroutine uzf_ar(this) +! ****************************************************************************** +! uzf_ar -- Allocate and Read +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate, mem_setptr, mem_reallocate + ! -- dummy + class(UzfType), intent(inout) :: this + ! -- local + integer(I4B) :: n, i + real(DP) :: hgwf +! ------------------------------------------------------------------------------ + ! + call this%obs%obs_ar() + ! + ! -- call standard BndType allocate scalars + call this%BndType%allocate_arrays() + ! + ! -- set pointers now that data is available + call mem_setptr(this%gwfhcond, 'CONDSAT', trim(this%name_model)//' NPF') + call mem_setptr(this%gwfiss, 'ISS', trim(this%name_model)) + ! + ! -- set boundname for each connection + if (this%inamedbound /= 0) then + do n = 1, this%nodes + this%boundname(n) = this%uzfname(n) + end do + endif + ! + ! -- copy igwfnode into nodelist and set water table + do i = 1, this%nodes + this%nodelist(i) = this%igwfnode(i) + n = this%igwfnode(i) + hgwf = this%xnew(n) + call this%uzfobj%sethead(i, hgwf) + end do + ! + ! allocate space to store moisture content observations + n = this%obs%npakobs + if ( n > 0 ) then + call mem_reallocate(this%obs_theta, n, 'OBS_THETA', this%origin) + call mem_reallocate(this%obs_depth, n, 'OBS_DEPTH', this%origin) + call mem_reallocate(this%obs_num, n, 'OBS_NUM', this%origin) + end if + ! + ! -- setup pakmvrobj + if (this%imover /= 0) then + allocate(this%pakmvrobj) + call this%pakmvrobj%ar(this%maxbound, this%maxbound, this%origin) + endif + ! + ! -- return + return + end subroutine uzf_ar + + subroutine uzf_allocate_arrays(this) +! ****************************************************************************** +! allocate_arrays -- allocate arrays used for uzf +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(UzfType), intent(inout) :: this + ! -- local + integer (I4B) :: i + integer (I4B) :: j + integer (I4B) :: ipos +! ------------------------------------------------------------------------------ + ! + ! -- call standard BndType allocate scalars (now done from AR) + !call this%BndType%allocate_arrays() + ! + ! -- allocate uzf specific arrays + call mem_allocate(this%igwfnode, this%nodes, 'IGWFNODE', this%origin) + call mem_allocate(this%appliedinf, this%nodes, 'APPLIEDINF', this%origin) + call mem_allocate(this%rejinf, this%nodes, 'REJINF', this%origin) + call mem_allocate(this%rejinf0, this%nodes, 'REJINF0', this%origin) + call mem_allocate(this%rejinftomvr, this%nodes, 'REJINFTOMVR', this%origin) + call mem_allocate(this%infiltration, this%nodes, 'INFILTRATION', this%origin) + call mem_allocate(this%recharge, this%nodes, 'RECHARGE', this%origin) + call mem_allocate(this%gwet, this%nodes, 'GWET', this%origin) + call mem_allocate(this%uzet, this%nodes, 'UZET', this%origin) + call mem_allocate(this%gwd, this%nodes, 'GWD', this%origin) + call mem_allocate(this%gwd0, this%nodes, 'GWD0', this%origin) + call mem_allocate(this%gwdtomvr, this%nodes, 'GWDTOMVR', this%origin) + call mem_allocate(this%rch, this%nodes, 'RCH', this%origin) + call mem_allocate(this%rch0, this%nodes, 'RCH0', this%origin) + call mem_allocate(this%qsto, this%nodes, 'QSTO', this%origin) + call mem_allocate(this%deriv, this%nodes, 'DERIV', this%origin) + + ! -- integer vectors + call mem_allocate(this%ia, this%dis%nodes+1, 'IA', this%origin) + call mem_allocate(this%ja, this%nodes, 'JA', this%origin) + + ! -- allocate timeseries aware variables + call mem_allocate(this%sinf, this%nodes, 'SINF', this%origin) + call mem_allocate(this%pet, this%nodes, 'PET', this%origin) + call mem_allocate(this%extdp, this%nodes, 'EXDP', this%origin) + call mem_allocate(this%extwc, this%nodes, 'EXTWC', this%origin) + call mem_allocate(this%ha, this%nodes, 'HA', this%origin) + call mem_allocate(this%hroot, this%nodes, 'HROOT', this%origin) + call mem_allocate(this%rootact, this%nodes, 'ROOTACT', this%origin) + call mem_allocate(this%lauxvar, this%naux*this%nodes, 'LAUXVAR', this%origin) + + ! -- initialize + do i = 1, this%nodes + this%appliedinf(i) = DZERO + this%recharge(i) = DZERO + this%rejinf(i) = DZERO + this%rejinf0(i) = DZERO + this%rejinftomvr(i) = DZERO + this%gwet(i) = DZERO + this%uzet(i) = DZERO + this%gwd(i) = DZERO + this%gwd0(i) = DZERO + this%gwdtomvr(i) = DZERO + this%rch(i) = DZERO + this%rch0(i) = DZERO + this%qsto(i) = DZERO + this%deriv(i) = DZERO + ! -- timeseries aware variables + this%sinf(i)%name = '' + this%pet(i)%name = '' + this%extdp(i)%name = '' + this%extwc(i)%name = '' + this%ha(i)%name = '' + this%hroot(i)%name = '' + this%rootact(i)%name = '' + this%sinf(i)%value = DZERO + this%pet(i)%value = DZERO + this%extdp(i)%value = DZERO + this%extwc(i)%value = DZERO + this%ha(i)%value = DZERO + this%hroot(i)%value = DZERO + this%rootact(i)%value = DZERO + do j = 1, this%naux + ipos = (i - 1) * this%naux + j + this%lauxvar(ipos)%name = '' + if (this%iauxmultcol > 0 .and. j == this%iauxmultcol) then + this%lauxvar(ipos)%value = DONE + else + this%lauxvar(ipos)%value = DZERO + end if + end do + end do + ! + ! -- allocate and initialize character array for budget text + allocate(this%bdtxt(this%nbdtxt)) + this%bdtxt(1) = ' UZF-INF' + this%bdtxt(2) = ' UZF-GWRCH' + this%bdtxt(3) = ' UZF-GWD' + this%bdtxt(4) = ' UZF-GWET' + this%bdtxt(5) = ' UZF-GWD TO-MVR' + ! + ! -- allocate character array for aux budget text + allocate(this%cauxcbc(this%cbcauxitems)) + allocate(this%uzfname(this%nodes)) + ! + ! -- allocate and initialize qauxcbc + call mem_allocate(this%qauxcbc, this%cbcauxitems, 'QAUXCBC', this%origin) + do i = 1, this%cbcauxitems + this%qauxcbc(i) = DZERO + end do + ! + ! -- Allocate obs members + call mem_allocate(this%obs_theta, 0, 'OBS_THETA', this%origin) + call mem_allocate(this%obs_depth, 0, 'OBS_DEPTH', this%origin) + call mem_allocate(this%obs_num, 0, 'OBS_NUM', this%origin) + ! + ! -- return + return + end subroutine uzf_allocate_arrays +! + + subroutine uzf_options(this, option, found) +! ****************************************************************************** +! uzf_options -- set options specific to UzfType +! +! uzf_options overrides BoundaryPackageType%child_class_options +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: DZERO + use OpenSpecModule, only: access, form + use SimModule, only: ustop, store_error + use InputOutputModule, only: urword, getunit, openfile + implicit none + ! -- dummy + class(uzftype), intent(inout) :: this + character(len=*), intent(inout) :: option + logical, intent(inout) :: found + ! -- local + character(len=MAXCHARLEN) :: fname, keyword + ! -- formats + character(len=*),parameter :: fmtnotfound= & + "(4x, 'NO UZF OPTIONS WERE FOUND.')" + character(len=*),parameter :: fmtet = & + "(4x, 'ET WILL BE SIMULATED WITHIN UZ AND GW ZONES, WITH LINEAR ', & + &'GWET IF OPTION NOT SPECIFIED OTHERWISE.')" + character(len=*),parameter :: fmtgwetlin = & + "(4x, 'GROUNDWATER ET FUNCTION WILL BE LINEAR.')" + character(len=*),parameter :: fmtgwetsquare = & + "(4x, 'GROUNDWATER ET FUNCTION WILL BE SQUARE WITH SMOOTHING.')" + character(len=*),parameter :: fmtgwseepout = & + "(4x, 'GROUNDWATER DISCHARGE TO LAND SURFACE WILL BE SIMULATED.')" + character(len=*),parameter :: fmtuzetwc = & + "(4x, 'UNSATURATED ET FUNCTION OF WATER CONTENT.')" + character(len=*),parameter :: fmtuzetae = & + "(4x, 'UNSATURATED ET FUNCTION OF AIR ENTRY PRESSURE.')" + character(len=*),parameter :: fmtuznlay = & + "(4x, 'UNSATURATED FLOW WILL BE SIMULATED SEPARATELY IN EACH LAYER.')" + character(len=*),parameter :: fmtuzfbin = & + "(4x, 'UZF ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" + character(len=*),parameter :: fmtuzfopt = & + "(4x, 'UZF ', a, ' VALUE (',g15.7,') SPECIFIED.')" + +! ------------------------------------------------------------------------------ + ! + ! + select case (option) + !case ('PRINT_WATER-CONTENT') + ! this%iprwcont = 1 + ! write(this%iout,'(4x,a)') trim(adjustl(this%text))// & + ! ' WATERCONTENT WILL BE PRINTED TO LISTING FILE.' + ! found = .true. + !case('WATER-CONTENT') + ! call this%parser%GetStringCaps(keyword) + ! if (keyword == 'FILEOUT') then + ! call this%parser%GetString(fname) + ! this%iwcontout = getunit() + ! call openfile(this%iwcontout, this%iout, fname, 'DATA(BINARY)', & + ! form, access, 'REPLACE') + ! write(this%iout,fmtuzfbin) 'WATERCONTENT', fname, this%iwcontout + ! found = .true. + ! else + ! call store_error('OPTIONAL WATER-CONTENT KEYWORD MUST BE FOLLOWED BY FILEOUT') + ! end if + case('BUDGET') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ibudgetout = getunit() + call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE') + write(this%iout,fmtuzfbin) 'BUDGET', fname, this%ibudgetout + found = .true. + else + call store_error('OPTIONAL BUDGET KEYWORD MUST BE FOLLOWED BY FILEOUT') + end if + case('PACKAGE_CONVERGENCE') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ipakcsv = getunit() + call openfile(this%ipakcsv, this%iout, fname, 'CSV', & + filstat_opt='REPLACE') + write(this%iout,fmtuzfbin) 'PACKAGE_CONVERGENCE', fname, this%ipakcsv + found = .true. + else + call store_error('OPTIONAL PACKAGE_CONVERGENCE KEYWORD MUST BE ' // & + 'FOLLOWED BY FILEOUT') + end if + case('SIMULATE_ET') + this%ietflag = 1 !default + this%igwetflag = 0 + found = .true. + write(this%iout, fmtet) + case('LINEAR_GWET') + this%igwetflag = 1 + found = .true. + write(this%iout, fmtgwetlin) + case('SQUARE_GWET') + this%igwetflag = 2 + found = .true. + write(this%iout, fmtgwetsquare) + case('SIMULATE_GWSEEP') + this%iseepflag = 1 + found = .true. + write(this%iout, fmtgwseepout) + case('UNSAT_ETWC') + this%ietflag = 1 + found = .true. + write(this%iout, fmtuzetwc) + case('UNSAT_ETAE') + this%ietflag = 2 + found = .true. + write(this%iout, fmtuzetae) + case('MOVER') + this%imover = 1 + found = .true. + ! + ! -- right now these are options that are available but may not be available in + ! the release (or in documentation) + case('DEV_NO_FINAL_CHECK') + call this%parser%DevOpt() + this%iconvchk = 0 + write(this%iout, '(4x,a)') & + & 'A FINAL CONVERGENCE CHECK OF THE CHANGE IN UZF RECHARGE ' // & + & 'WILL NOT BE MADE' + found = .true. + !case('DEV_MAXIMUM_PERCENT_DIFFERENCE') + ! call this%parser%DevOpt() + ! r = this%parser%GetDouble() + ! if (r > DZERO) then + ! this%pdmax = r + ! write(this%iout, fmtuzfopt) 'MAXIMUM_PERCENT_DIFFERENCE', this%pdmax + ! else + ! write(this%iout, fmtuzfopt) 'INVALID MAXIMUM_PERCENT_DIFFERENCE', r + ! write(this%iout, fmtuzfopt) 'USING DEFAULT MAXIMUM_PERCENT_DIFFERENCE', this%pdmax + ! end if + ! found = .true. + case default + ! -- No options found + found = .false. + end select + ! -- return + return + end subroutine uzf_options +! + subroutine uzf_readdimensions(this) +! ****************************************************************************** +! uzf_readdimensions -- set dimensions specific to UzfType +! +! uzf_readdimensions BoundaryPackageType%readdimensions +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use InputOutputModule, only: urword + use SimModule, only: ustop, store_error, count_errors + class(uzftype),intent(inout) :: this + character(len=LINELENGTH) :: errmsg, keyword + integer(I4B) :: ierr + logical :: isfound, endOfBlock +! ------------------------------------------------------------------------------ + ! + ! -- initialize dimensions to -1 + this%nodes= -1 + this%ntrail = 0 + this%nsets = 0 + ! + ! -- 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 '//trim(adjustl(this%text))// & + ' DIMENSIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('NUZFCELLS') + this%nodes = this%parser%GetInteger() + write(this%iout,'(4x,a,i7)')'NUZFCELLS = ', this%nodes + case ('NTRAILWAVES') + this%ntrail = this%parser%GetInteger() + write(this%iout,'(4x,a,i7)')'NTRAILWAVES = ', this%ntrail + case ('NWAVESETS') + this%nsets = this%parser%GetInteger() + write(this%iout,'(4x,a,i7)')'NTRAILSETS = ', this%nsets + case default + write(errmsg,'(4x,a,a)') & + '****ERROR. UNKNOWN '//trim(this%text)//' DIMENSION: ', & + trim(keyword) + call store_error(errmsg) + call ustop() + end select + end do + write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' DIMENSIONS' + else + call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- increment maxbound + this%maxbound = this%maxbound + this%nodes + ! + ! -- verify dimensions were set + if(this%nodes <= 0) then + write(errmsg, '(1x,a)') & + 'ERROR. NUZFCELLS WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + + if(this%ntrail <= 0) then + write(errmsg, '(1x,a)') & + 'ERROR. NTRAILWAVES WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + if(this%nsets <= 0) then + write(errmsg, '(1x,a)') & + 'ERROR. NWAVESETS WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + this%nwav = this%ntrail*this%nsets + ! + ! -- Call define_listlabel to construct the list label that is written + ! when PRINT_INPUT option is used. + call this%define_listlabel() + ! + ! -- Allocate arrays in package superclass + call this%uzf_allocate_arrays() + ! + ! -- initialize uzf group object + allocate(this%uzfobj) + call this%uzfobj%init(this%nodes, this%nwav, this%origin) + ! + ! -- Set pointers to GWF model arrays + call mem_setptr(this%gwftop, 'TOP', trim(this%name_model)//' DIS') + call mem_setptr(this%gwfbot, 'BOT', trim(this%name_model)//' DIS') + call mem_setptr(this%gwfarea, 'AREA', trim(this%name_model)//' DIS') + ! + !--Read uzf cell properties and set values + call this%read_cell_properties() + ! + ! -- print cell data + if (this%iprpak /= 0) then + call this%print_cell_properties() + end if + ! + ! -- setup the budget object + call this%uzf_setup_budobj() + ! + ! -- return + return + end subroutine uzf_readdimensions + + subroutine uzf_rp(this) +! ****************************************************************************** +! uzf_rp -- Read stress data +! Subroutine: (1) check if bc changes +! (2) read new bc for stress period +! (3) set kinematic variables to bc values +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: kper, nper, perlen, totimsav + use TimeSeriesManagerModule, only: read_single_value_or_time_series + use InputOutputModule, only: urword + use SimModule, only: ustop, store_error, count_errors + ! -- dummy + class(UzfType), intent(inout) :: this + ! -- local + character(len=LENBOUNDNAME) :: bndName + character(len=LENBOUNDNAME) :: cval + integer (I4B) :: i + integer (I4B) :: j + integer (I4B) :: jj + integer (I4B) :: ipos + integer(I4B) :: ierr + real (DP) :: endtim + logical :: isfound, endOfBlock + character(len=LINELENGTH) :: line, errmsg + ! -- table output + character (len=20) :: cellid + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: tag + integer(I4B) :: ntabrows + integer(I4B) :: ntabcols + integer(I4B) :: node + !-- formats + character(len=*),parameter :: fmtlsp = & + "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" + character(len=*),parameter :: fmtblkerr = & + "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + character(len=*), parameter :: fmtisvflow = & + "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE " // & + "WHENEVER ICBCFL IS NOT ZERO.')" + character(len=*),parameter :: fmtflow = & + "(4x, 'FLOWS WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" +! ------------------------------------------------------------------------------ + ! + ! -- Set ionper to the stress period number for which a new block of data + ! will be read. + if(this%inunit == 0) return + ! + ! -- Find time interval of current stress period. + endtim = totimsav + perlen(kper) + ! + ! -- get stress period data + if (this%ionper < kper) then + ! + ! -- get period block + call this%parser%GetBlock('PERIOD', isfound, ierr, & + supportOpenClose=.true.) + if (isfound) then + ! + ! -- read ionper and check for increasing period numbers + call this%read_check_ionper() + else + ! + ! -- PERIOD block not found + if (ierr < 0) then + ! -- End of file found; data applies for remainder of simulation. + this%ionper = nper + 1 + else + ! -- Found invalid block + call this%parser%GetCurrentLine(line) + write(errmsg, fmtblkerr) adjustl(trim(line)) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end if + endif + end if + ! + ! -- set steady-state flag based on gwfiss + this%issflag = this%gwfiss + ! + ! -- read data if ionper == kper + if(this%ionper==kper) then + ! + ! -- write header + if (this%iprpak /= 0) then + ! + ! -- setup inputtab tableobj + ! + ! -- table dimensions + ntabrows = 1 + ntabcols = 3 + if (this%ietflag /= 0) then + ntabcols = ntabcols + 3 + if (this%ietflag == 2) then + ntabcols = ntabcols + 3 + end if + end if + if (this%inamedbound == 1) then + ntabcols = ntabcols + 1 + end if + ! + ! -- initialize table and define columns + title = trim(adjustl(this%text)) // ' PACKAGE (' // & + trim(adjustl(this%name)) //') DATA FOR PERIOD' + write(title, '(a,1x,i6)') trim(adjustl(title)), kper + call table_cr(this%inputtab, this%name, title) + call this%inputtab%table_df(ntabrows, ntabcols, this%iout, & + finalize=.FALSE.) + tag = 'NUMBER' + call this%inputtab%initialize_column(tag, 10) + tag = 'CELLID' + call this%inputtab%initialize_column(tag, 20, alignment=TABLEFT) + tag = 'FINF' + call this%inputtab%initialize_column(tag, 12) + if (this%ietflag /= 0) then + tag = 'PET' + call this%inputtab%initialize_column(tag, 12) + tag = 'EXTDEP' + call this%inputtab%initialize_column(tag, 12) + tag = 'EXTWC' + call this%inputtab%initialize_column(tag, 12) + if (this%ietflag == 2) then + tag = 'HA' + call this%inputtab%initialize_column(tag, 12) + tag = 'HROOT' + call this%inputtab%initialize_column(tag, 12) + tag = 'ROOTACT' + call this%inputtab%initialize_column(tag, 12) + end if + end if + if (this%inamedbound == 1) then + tag = 'BOUNDNAME' + call this%inputtab%initialize_column(tag, LENBOUNDNAME, alignment=TABLEFT) + end if + end if + ! + ! -- read the stress period data + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + ! + ! -- check for valid uzf node + i = this%parser%GetInteger() + if (i < 1 .or. i > this%nodes) then + tag = trim(adjustl(this%text)) // ' PACKAGE (' // & + trim(adjustl(this%name)) //') DATA FOR PERIOD' + write(tag, '(a,1x,i0)') trim(adjustl(tag)), kper + write(errmsg,'(4x,a,1x,a,a,i0,1x,a,i0)') & + '****ERROR.', trim(adjustl(tag)), ': UZFNO ', i, & + 'MUST BE > 0 and <= ', this%nodes + call store_error(errmsg) + cycle + end if + ! + ! -- Setup boundname + if (this%inamedbound > 0) then + bndName = this%boundname(i) + else + bndName = '' + end if + ! + ! -- FINF + call this%parser%GetStringCaps(cval) + jj = 1 ! For SINF + call read_single_value_or_time_series(cval, & + this%sinf(i)%value, & + this%sinf(i)%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, i, jj, 'SINF', & + bndName, this%inunit) + ! + ! -- PET, EXTDP + call this%parser%GetStringCaps(cval) + jj = 1 ! For PET + call read_single_value_or_time_series(cval, & + this%pet(i)%value, & + this%pet(i)%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, i, jj, 'PET', & + bndName, this%inunit) + call this%parser%GetStringCaps(cval) + jj = 1 ! For EXTDP + call read_single_value_or_time_series(cval, & + this%extdp(i)%value, & + this%extdp(i)%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, i, jj, 'EXTDP', & + bndName, this%inunit) + ! + ! -- ETWC + call this%parser%GetStringCaps(cval) + jj = 1 ! For EXTWC + call read_single_value_or_time_series(cval, & + this%extwc(i)%value, & + this%extwc(i)%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, i, jj, 'EXTWC', & + bndName, this%inunit) + ! + ! -- HA, HROOT, ROOTACT + call this%parser%GetStringCaps(cval) + jj = 1 ! For HA + call read_single_value_or_time_series(cval, & + this%ha(i)%value, & + this%ha(i)%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, i, jj, 'HA', & + bndName, this%inunit) + call this%parser%GetStringCaps(cval) + jj = 1 ! For HROOT + call read_single_value_or_time_series(cval, & + this%hroot(i)%value, & + this%hroot(i)%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, i, jj, 'HROOT', & + bndName, this%inunit) + call this%parser%GetStringCaps(cval) + jj = 1 ! For ROOTACT + call read_single_value_or_time_series(cval, & + this%rootact(i)%value, & + this%rootact(i)%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, i, jj, 'ROOTACT', & + bndName, this%inunit) + + ! + ! -- read auxillary variables + do j = 1, this%naux + call this%parser%GetStringCaps(cval) + ipos = (i - 1) * this%naux + j + jj = 1 + call read_single_value_or_time_series(cval, & + this%lauxvar(ipos)%value, & + this%lauxvar(ipos)%name, & + endtim, & + this%name, 'BND', this%TsManager, & + this%iprpak, i, jj, & + this%auxname(j), bndName, & + this%inunit) + end do + ! + ! -- write line + if (this%iprpak /= 0) then + ! + ! -- get cellid + node = this%igwfnode(i) + if (node > 0) then + call this%dis%noder_to_string(node, cellid) + else + cellid = 'none' + end if + ! + ! -- write data to the table + call this%inputtab%add_term(i) + call this%inputtab%add_term(cellid) + call this%inputtab%add_term(this%sinf(i)%value) + if (this%ietflag /= 0) then + call this%inputtab%add_term(this%pet(i)%value) + call this%inputtab%add_term(this%extdp(i)%value) + call this%inputtab%add_term(this%extwc(i)%value) + if (this%ietflag == 2) then + call this%inputtab%add_term(this%ha(i)%value) + call this%inputtab%add_term(this%hroot(i)%value) + call this%inputtab%add_term(this%rootact(i)%value) + end if + end if + if (this%inamedbound == 1) then + call this%inputtab%add_term(this%boundname(i)) + end if + end if + + end do + ! + ! -- finalize the table + if (this%iprpak /= 0) then + call this%inputtab%finalize_table() + end if + + write(this%iout,'(1x,a,1x,i6)')'END OF '//trim(adjustl(this%text)) // & + ' PERIOD', kper + else + write(this%iout,fmtlsp) trim(this%filtyp) + endif + ! + !write summary of uzf stress period error messages + ierr = count_errors() + if (ierr > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- set wave data for first stress period and second that follows SS + if ((this%issflag == 0 .AND. kper == 1) .or. & + (kper == 2 .AND. this%issflagold == 1)) then + do i = 1, this%nodes + call this%uzfobj%setwaves(i) + end do + end if + this%issflagold = this%issflag + ! + ! -- return + return + end subroutine uzf_rp + + subroutine uzf_ad(this) +! ****************************************************************************** +! uzf_ad -- Advance UZF Package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(UzfType) :: this + ! -- locals + integer(I4B) :: i + integer(I4B) :: ivertflag + integer(I4B) :: ipos + integer(I4B) :: n, iaux, ii + real (DP) :: rval1, rval2, rval3 +! ------------------------------------------------------------------------------ + ! + ! -- Advance the time series + call this%TsManager%ad() + ! + ! -- update auxiliary variables by copying from the derived-type time + ! series variable into the bndpackage auxvar variable so that this + ! information is properly written to the GWF budget file + if (this%naux > 0) then + do n = 1, this%maxbound + do iaux = 1, this%naux + ii = (n - 1) * this%naux + iaux + this%auxvar(iaux, n) = this%lauxvar(ii)%value + end do + end do + end if + ! + do i = 1, this%nodes + call this%uzfobj%advance(i) + end do + ! + ! -- update uzf objects with timeseries aware variables + do i = 1, this%nodes + ! + ! -- Set ivertflag + ivertflag = this%uzfobj%ivertcon(i) + ! + ! -- recalculate uzfarea + if (this%iauxmultcol > 0) then + ipos = (i - 1) * this%naux + this%iauxmultcol + rval1 = this%lauxvar(ipos)%value + call this%uzfobj%setdatauzfarea(i, rval1) + end if + ! + ! -- FINF + rval1 = this%sinf(i)%value + call this%uzfobj%setdatafinf(i, rval1) + ! + ! -- PET, EXTDP + rval1 = this%pet(i)%value + rval2 = this%extdp(i)%value + call this%uzfobj%setdataet(i, ivertflag, rval1, rval2) + ! + ! -- ETWC + rval1 = this%extwc(i)%value + call this%uzfobj%setdataetwc(i, ivertflag, rval1) + ! + ! -- HA, HROOT, ROOTACT + rval1 = this%ha(i)%value + rval2 = this%hroot(i)%value + rval3 = this%rootact(i)%value + call this%uzfobj%setdataetha(i, ivertflag, rval1, rval2, rval3) + end do + ! + ! -- check uzfarea + if (this%iauxmultcol > 0) then + call this%check_cell_area() + end if + ! + ! -- pakmvrobj ad + if(this%imover == 1) then + call this%pakmvrobj%ad() + endif + ! + ! -- For each observation, push simulated value and corresponding + ! simulation time from "current" to "preceding" and reset + ! "current" value. + call this%obs%obs_ad() + ! + ! -- Return + return + end subroutine uzf_ad + + subroutine uzf_cf(this, reset_mover) +! ****************************************************************************** +! uzf_cf -- Formulate the HCOF and RHS terms +! Subroutine: (1) skip if no UZF cells +! (2) calculate hcof and rhs +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(UzfType) :: this + logical, intent(in), optional :: reset_mover + ! -- locals + integer(I4B) :: n + logical :: lrm +! ------------------------------------------------------------------------------ + ! + ! -- Return if no UZF cells + if(this%nodes == 0) return + ! + ! -- Store values at start of outer iteration to compare with calculated + ! values for convergence check + do n = 1, this%maxbound + this%rejinf0(n) = this%rejinf(n) + this%rch0(n) = this%rch(n) + this%gwd0(n) = this%gwd(n) + end do + ! + ! -- pakmvrobj cf + lrm = .true. + if (present(reset_mover)) lrm = reset_mover + if(this%imover == 1 .and. lrm) then + call this%pakmvrobj%cf() + endif + ! + ! -- return + return + end subroutine uzf_cf + + subroutine uzf_fc(this, rhs, ia, idxglo, amatsln) +! ****************************************************************************** +! uzf_fc -- Copy rhs and hcof into solution rhs and amat +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(UzfType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + real(DP), dimension(:), intent(inout) :: amatsln + ! -- local + integer(I4B) :: i, n, ipos +! ------------------------------------------------------------------------------ + ! + ! -- pakmvrobj fc + if(this%imover == 1) then + call this%pakmvrobj%fc() + endif + ! + ! -- Solve UZF + call this%uzf_solve() + ! + ! -- Copy package rhs and hcof into solution rhs and amat + do i = 1, this%nodes + n = this%nodelist(i) + rhs(n) = rhs(n) + this%rhs(i) + ipos = ia(n) + amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) + enddo + ! + ! -- return + return + end subroutine uzf_fc +! + subroutine uzf_fn(this, rhs, ia, idxglo, amatsln) +! ************************************************************************** +! uzf_fn -- Fill newton terms +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + ! -- dummy + class(UzfType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + real(DP), dimension(:), intent(inout) :: amatsln + ! -- local + integer(I4B) :: i, n + integer(I4B) :: ipos +! -------------------------------------------------------------------------- + ! + ! -- Add derivative terms to rhs and amat + do i = 1, this%nodes + n = this%nodelist(i) + ipos = ia(n) + amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%deriv(i) + rhs(n) = rhs(n) + this%deriv(i) * this%xnew(n) + end do + ! + ! -- return + return + end subroutine uzf_fn + + subroutine uzf_cc(this, kiter, iend, icnvgmod, cpak, dpak) +! ************************************************************************** +! uzf_cc -- Final convergence check for package +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + use TdisModule, only: totim, kstp, kper, delt + ! -- dummy + class(Uzftype), intent(inout) :: this + integer(I4B), intent(in) :: kiter + integer(I4B), intent(in) :: icnvgmod + integer(I4B), intent(in) :: iend + character(len=LENPAKLOC), intent(inout) :: cpak + real(DP), intent(inout) :: dpak + ! -- local + character(len=LENPAKLOC) :: cloc + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: tag + character(len=20) :: cellid + integer(I4B) :: icheck + integer(I4B) :: ipakfail + integer(I4B) :: locdrejinfmax + integer(I4B) :: locdrchmax + integer(I4B) :: locdseepmax + integer(I4B) :: ntabrows + integer(I4B) :: ntabcols + integer(I4B) :: n + integer(I4B) :: node + real(DP) :: qtolfact + real(DP) :: drejinf + real(DP) :: drejinfmax + real(DP) :: drch + real(DP) :: drchmax + real(DP) :: dseep + real(DP) :: dseepmax + real(DP) :: dmax + ! format +! -------------------------------------------------------------------------- + ! + ! -- initialize local variables + icheck = this%iconvchk + ipakfail = 0 + locdrejinfmax = 0 + locdrchmax = 0 + locdseepmax = 0 + drejinfmax = DZERO + drchmax = DZERO + dseepmax = DZERO + ! + ! -- if not saving package convergence data on check convergence if + ! the model is considered converged + if (this%ipakcsv == 0) then + if (icnvgmod == 0) then + icheck = 0 + end if + else + ! + ! -- header for package csv + if (.not. associated(this%pakcsvtab)) then + ! + ! -- determine the number of columns and rows + ntabrows = 1 + ntabcols = 8 + if (this%iseepflag == 1) then + ntabcols = ntabcols + 2 + end if + ! + ! -- setup table + call table_cr(this%pakcsvtab, this%name, '') + call this%pakcsvtab%table_df(ntabrows, ntabcols, this%ipakcsv, & + lineseparator=.FALSE., separator=',', & + finalize=.FALSE.) + ! + ! -- add columns to package csv + tag = 'totim' + call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'kper' + call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'kstp' + call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'nouter' + call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'drejinfmax' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + tag = 'drejinfmax_loc' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + tag = 'drchmax' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + tag = 'drchmax_loc' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + if (this%iseepflag == 1) then + tag = 'dseepmax' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + tag = 'dseepmax_loc' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + end if + end if + end if + ! + ! -- perform package convergence check + if (icheck /= 0) then + final_check: do n = 1, this%nodes + ! + ! -- set the Q to length factor + qtolfact = delt / this%uzfobj%uzfarea(n) + ! + ! -- rejected infiltration + drejinf = qtolfact * (this%rejinf0(n) - this%rejinf(n)) + ! + ! -- groundwater recharge + drch = qtolfact * (this%rch0(n) - this%rch(n)) + ! + ! -- groundwater seepage to the land surface + dseep = DZERO + if (this%iseepflag == 1) then + dseep = qtolfact * (this%gwd0(n) - this%gwd(n)) + end if + ! + ! -- evaluate magnitude of differences + if (n == 1) then + drejinfmax = drejinf + locdrejinfmax = n + drchmax = drch + locdrchmax = n + dseepmax = dseep + locdseepmax = n + else + if (ABS(drejinf) > abs(drejinfmax)) then + drejinfmax = drejinf + locdrejinfmax = n + end if + if (ABS(drch) > abs(drchmax)) then + drchmax = drch + locdrchmax = n + end if + if (ABS(dseep) > abs(dseepmax)) then + dseepmax = dseep + locdseepmax = n + end if + end if + end do final_check + ! + ! -- set dpak and cpak + if (ABS(drejinfmax) > abs(dpak)) then + dpak = drejinfmax + write(cloc, "(a,'-(',i0,')-',a)") & + trim(this%name), locdrejinfmax, 'rejinf' + cpak = trim(cloc) + end if + if (ABS(drchmax) > abs(dpak)) then + dpak = drchmax + write(cloc, "(a,'-(',i0,')-',a)") & + trim(this%name), locdrchmax, 'rech' + cpak = trim(cloc) + end if + if (this%iseepflag == 1) then + if (ABS(dseepmax) > abs(dpak)) then + dpak = dseepmax + write(cloc, "(a,'-(',i0,')-',a)") & + trim(this%name), locdseepmax, 'seep' + cpak = trim(cloc) + end if + end if + ! + ! -- write convergence data to package csv + if (this%ipakcsv /= 0) then + ! + ! -- write the data + call this%pakcsvtab%add_term(totim) + call this%pakcsvtab%add_term(kper) + call this%pakcsvtab%add_term(kstp) + call this%pakcsvtab%add_term(kiter) + call this%pakcsvtab%add_term(drejinfmax) + call this%pakcsvtab%add_term(locdrejinfmax) + call this%pakcsvtab%add_term(drchmax) + call this%pakcsvtab%add_term(locdrchmax) + if (this%iseepflag == 1) then + call this%pakcsvtab%add_term(dseepmax) + call this%pakcsvtab%add_term(locdseepmax) + end if + ! + ! -- finalize the package csv + if (iend == 1) then + call this%pakcsvtab%finalize_table() + end if + end if + end if + ! + ! -- return + return + end subroutine uzf_cc + + subroutine uzf_bd(this, x, idvfl, icbcfl, ibudfl, icbcun, iprobs, & + isuppress_output, model_budget, imap, iadv) +! ****************************************************************************** +! uzf_bd -- Calculate Volumetric Budget +! Note that the compact budget will always be used. +! Subroutine: (1) Process each package entry +! (2) Write output +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: kstp, kper, delt, pertim, totim + use ConstantsModule, only: LENBOUNDNAME, DZERO, DHNOFLO, DHDRY + use BudgetModule, only: BudgetType + use InputOutputModule, only: ulasav, ubdsv06 + ! -- dummy + class(UzfType) :: this + class(ObserveType), pointer :: obsrv => null() + real(DP),dimension(:),intent(in) :: x + integer(I4B), intent(in) :: idvfl + integer(I4B), intent(in) :: icbcfl + integer(I4B), intent(in) :: ibudfl + integer(I4B), intent(in) :: icbcun + integer(I4B), intent(in) :: iprobs + integer(I4B), intent(in) :: isuppress_output + type(BudgetType), intent(inout) :: model_budget + integer(I4B), dimension(:), optional, intent(in) :: imap + integer(I4B), optional, intent(in) :: iadv + ! -- local + character(len=LINELENGTH) :: title + character(len=20) :: nodestr + integer(I4B) :: maxrows + integer(I4B) :: nodeu + integer(I4B) :: i, node, ibinun + integer(I4B) :: n, m, ivertflag, ierr + integer(I4B) :: n2 + real(DP) :: rfinf + real(DP) :: rin,rout,rsto,ret,retgw,rgwseep,rvflux + real(DP) :: hgwf,hgwflm1,ratin,ratout,rrate,rrech + real(DP) :: trhsgwet,thcofgwet,gwet,derivgwet + real(DP) :: qfrommvr, qformvr, qgwformvr, sumaet + real(DP) :: qfinf + real(DP) :: qrejinf + real(DP) :: qrejinftomvr + real(DP) :: qout + real(DP) :: qfact + real(DP) :: qtomvr + real(DP) :: sqtomvr + real(DP) :: q + real(DP) :: rfrommvr + real(DP) :: qseep + real(DP) :: qseeptomvr + real(DP) :: qgwet + real(DP) :: cvv + integer(I4B) :: naux, numobs + ! -- for observations + integer(I4B) :: j + character(len=LENBOUNDNAME) :: bname + character(len=100) :: msg + ! -- formats + character(len=*), parameter :: fmttkk = & + "(1X,/1X,A,' PERIOD ',I0,' STEP ',I0)" + ! -- for table + !character(len=LENBUDTXT) :: aname(10) + !data aname(1) /' INFILTRATION'/ + !data aname(2) /' GWF'/ + !data aname(3) /' STORAGE'/ + !data aname(4) /' UZET'/ + !data aname(5) /' UZF-GWET'/ + !data aname(6) /' UZF-GWD'/ + !data aname(7) /'SAT.-UNSAT. EXCH'/ + !data aname(8) /' REJ-INF'/ + !data aname(9) /' REJ-INF-TO-MVR'/ + !data aname(10) /' FROM-MVR'/ +! ------------------------------------------------------------------------------ + ! + ! -- initialize accumulators + ierr = 0 + rfinf = DZERO + rin = DZERO + rout = DZERO + rrech = DZERO + rsto = DZERO + ret = DZERO + retgw = DZERO + rgwseep = DZERO + rvflux = DZERO + sumaet = DZERO + qfinf = DZERO + qfrommvr = DZERO + qtomvr = DZERO + qrejinf = DZERO + qrejinftomvr = DZERO + sqtomvr = DZERO + rfrommvr = DZERO + qseep = DZERO + qseeptomvr = DZERO + qgwet = DZERO + ! + ! -- set maxrows + maxrows = 0 + if (this%iprflow /= 0) then + do i = 1, this%nodes + node = this%nodelist(i) + if (this%ibound(node) > 0) then + maxrows = maxrows + 1 + end if + end do + call this%outputtab%set_maxbound(maxrows) + end if + + ! + ! -- Go through and process each UZF cell + do i = 1, this%nodes + ! + ! -- Initialize variables + n = this%nodelist(i) + ivertflag = this%uzfobj%ivertcon(i) + ! + ! -- Skip if cell is not active + if (this%ibound(n) < 1) cycle + ! + ! -- Water mover added to infiltration + qfrommvr = DZERO + qformvr = DZERO + if(this%imover == 1) then + qfrommvr = this%pakmvrobj%get_qfrommvr(i) + rfrommvr = rfrommvr + qfrommvr + endif + ! + hgwf = this%xnew(n) + ! + m = n + hgwflm1 = hgwf + ! + ! -- for now set cvv = DZERO + ! cvv = this%gwfhcond(m) + cvv = DZERO + ! + ! -- Get obs information, check if there is obs in uzf cell + numobs = 0 + do j = 1, this%obs%npakobs + obsrv => this%obs%pakobs(j)%obsrv + if ( obsrv%intPak1 == i ) then + numobs = numobs + 1 + this%obs_num(numobs) = j + this%obs_depth(j) = obsrv%dblPak1 + end if + end do + ! + ! -- Call budget routine of the uzf kinematic object + call this%uzfobj%budget(ivertflag,i,this%totfluxtot, & + rfinf,rin,rout,rsto,ret,retgw,rgwseep,rvflux, & + this%ietflag,this%iseepflag,this%issflag,hgwf, & + hgwflm1,cvv,numobs,this%obs_num, & + this%obs_depth,this%obs_theta,qfrommvr,qformvr, & + qgwformvr,sumaet,ierr) + if ( ierr > 0 ) then + if ( ierr == 1 ) & + msg = 'Error: UZF variable NWAVESETS needs to be increased.' + call store_error(msg) + call ustop() + end if + ! + ! -- Calculate gwet + if (this%igwetflag > 0) then + gwet = DZERO + derivgwet = DZERO + call this%uzfobj%simgwet(this%igwetflag, i, hgwf, trhsgwet, thcofgwet, & + gwet, derivgwet) + retgw = retgw + this%gwet(i) + end if + ! + ! -- Calculate flows for cbc output and observations + if (hgwf > this%uzfobj%celbot(i)) then + this%recharge(i) = this%uzfobj%totflux(i) * this%uzfobj%uzfarea(i) / delt + else + if (ivertflag == 0) then + this%recharge(i) = this%uzfobj%surflux(i) * this%uzfobj%uzfarea(i) + else + this%recharge(i) = this%uzfobj%surflux(ivertflag) * this%uzfobj%uzfarea(i) + end if + end if + + this%rch(i) = this%uzfobj%totflux(i) * this%uzfobj%uzfarea(i) / delt + + this%appliedinf(i) = this%uzfobj%sinf(i) * this%uzfobj%uzfarea(i) + this%infiltration(i) = this%uzfobj%surflux(i) * this%uzfobj%uzfarea(i) + + this%rejinf(i) = this%uzfobj%finf_rej(i) * this%uzfobj%uzfarea(i) + + qout = this%rejinf(i) + this%uzfobj%surfseep(i) + qtomvr = DZERO + if (this%imover == 1) then + qtomvr = this%pakmvrobj%get_qtomvr(i) + sqtomvr = sqtomvr + qtomvr + end if + + qfact = DZERO + if (qout > DZERO) then + qfact = this%rejinf(i) / qout + end if + q = this%rejinf(i) + this%rejinftomvr(i) = qfact * qtomvr + ! -- set rejected infiltration to the remainder + q = q - this%rejinftomvr(i) + ! -- values less than zero represent a volumetric error resulting + ! from qtomvr being greater than water available to the mover + if (q < DZERO) then + q = DZERO + end if + this%rejinf(i) = q + + this%gwd(i) = this%uzfobj%surfseep(i) + qfact = DZERO + if (qout > DZERO) then + qfact = this%gwd(i) / qout + end if + q = this%gwd(i) + this%gwdtomvr(i) = qfact * qtomvr + ! -- set groundwater discharge to the remainder + q = q - this%gwdtomvr(i) + ! -- values less than zero represent a volumetric error resulting + ! from qtomvr being greater than water available to the mover + if (q < DZERO) then + q = DZERO + end if + this%gwd(i) = q + + qfinf = qfinf + this%appliedinf(i) + qrejinf = qrejinf + this%rejinf(i) + qrejinftomvr = qrejinftomvr + this%rejinftomvr(i) + + qseep = qseep + this%gwd(i) + qseeptomvr = qseeptomvr + this%gwdtomvr(i) + + this%gwet(i) = this%uzfobj%gwet(i) + this%uzet(i) = this%uzfobj%etact(i) * this%uzfobj%uzfarea(i) / delt + this%qsto(i) = this%uzfobj%delstor(i) / delt + + ! -- accumulate groundwater et + qgwet = qgwet + this%gwet(i) + + ! + ! -- End of UZF cell loop + ! + end do + ! + ! -- For continuous observations, save simulated values. + if (this%obs%npakobs > 0 .and. iprobs > 0) then + call this%uzf_bd_obs() + endif + ! + ! add cumulative flows to UZF budget + this%infilsum = rin * delt + this%rechsum = rout * delt + rrech = rout + this%delstorsum = rsto * delt + this%uzetsum = ret * delt + this%vfluxsum = rvflux + ! + ! + rin = DZERO + rout = DZERO + if(rsto < DZERO) then + rin = -rsto + else + rout = rsto + endif + ! + ! -- Clear accumulators and set flags + ratin = dzero + ratout = dzero + rrate = dzero + !iauxsv = 1 !always used compact budget + ! + ! -- Set unit number for binary output + if(this%ipakcb < 0) then + ibinun = icbcun + elseif(this%ipakcb == 0) then + ibinun = 0 + else + ibinun = this%ipakcb + endif + if(icbcfl == 0) ibinun = 0 + if (isuppress_output /= 0) ibinun = 0 + ! + ! -- If cell-by-cell flows will be saved as a list, write header. + if (ibinun /= 0 .or. ibudfl /= 0) then + naux = this%naux + ! + ! -- uzf-gwrch + if (ibinun /= 0) then + call this%dis%record_srcdst_list_header(this%bdtxt(2), this%name_model, & + this%name_model, this%name_model, this%name, naux, & + this%auxname, ibinun, this%nodes, this%iout) + end if + ! + ! -- Loop through each boundary calculating flow. + do i = 1, this%nodes + node = this%nodelist(i) + ! -- assign boundary name + if (this%inamedbound > 0) then + bname = this%boundname(i) + else + bname = '' + end if + ! + ! -- reset table title + if (this%iprflow /= 0) then + title = trim(this%text) // ' PACKAGE (' // trim(this%name) // & + ') ' // trim(adjustl(this%bdtxt(2))) // ' FLOW RATES' + call this%outputtab%set_title(title) + end if + ! + ! -- If cell is no-flow or constant-head, then ignore it. + rrate = DZERO + if (this%ibound(node) > 0) then + ! + ! -- Calculate the flow rate into the cell. + !rrate = this%hcof(i) * x(node) - this%rhs(i) + rrate = this%rch(i) + ! + ! -- Print the individual rates if requested(this%iprflow<0) + if (ibudfl /= 0) then + if (this%iprflow /= 0) then + ! + ! -- set nodestr and write outputtab table + nodeu = this%dis%get_nodeuser(node) + call this%dis%nodeu_to_string(nodeu, nodestr) + call this%outputtab%print_list_entry(i, nodestr, rrate, bname) + end if + end if + end if + ! + ! -- If saving cell-by-cell flows in list, write flow + if (ibinun /= 0) then + n2 = i + call this%dis%record_mf6_list_entry(ibinun, node, n2, rrate, & + naux, this%auxvar(:,i), & + olconv2=.FALSE.) + end if + end do + ! + ! -- uzf-gwd + if (this%iseepflag == 1) then + if (ibinun /= 0) then + call this%dis%record_srcdst_list_header(this%bdtxt(3), & + this%name_model, & + this%name_model, this%name_model, this%name, naux, & + this%auxname, ibinun, this%nodes, this%iout) + end if + ! + ! -- reset table title + if (this%iprflow /= 0) then + title = trim(this%text) // ' PACKAGE (' // trim(this%name) // & + ') ' // trim(adjustl(this%bdtxt(4))) // ' FLOW RATES' + call this%outputtab%set_title(title) + end if + ! + ! -- Loop through each boundary calculating flow. + do i = 1, this%nodes + node = this%nodelist(i) + ! -- assign boundary name + if (this%inamedbound > 0) then + bname = this%boundname(i) + else + bname = '' + end if + ! + ! -- If cell is no-flow or constant-head, then ignore it. + rrate = DZERO + if (this%ibound(node) > 0) then + ! + ! -- Calculate the flow rate into the cell. + rrate = -this%gwd(i) + ! + ! -- Print the individual rates if requested(this%iprflow<0) + if (ibudfl /= 0) then + if (this%iprflow /= 0) then + ! + ! -- set nodestr and write outputtab table + nodeu = this%dis%get_nodeuser(node) + call this%dis%nodeu_to_string(nodeu, nodestr) + call this%outputtab%print_list_entry(i, nodestr, rrate, bname) + end if + end if + end if + ! + ! -- If saving cell-by-cell flows in list, write flow + if (ibinun /= 0) then + n2 = i + call this%dis%record_mf6_list_entry(ibinun, node, n2, rrate, & + naux, this%auxvar(:,i), & + olconv2=.FALSE.) + end if + end do + ! + ! -- uzf-gwd to mover + if (this%imover == 1) then + if (ibinun /= 0) then + call this%dis%record_srcdst_list_header(this%bdtxt(5), & + this%name_model, this%name_model, & + this%name_model, this%name, naux, & + this%auxname, ibinun, this%nodes, this%iout) + end if + ! + ! -- reset table title + if (this%iprflow /= 0) then + title = trim(this%text) // ' PACKAGE (' // trim(this%name) // & + ') ' // trim(adjustl(this%bdtxt(5))) // ' FLOW RATES' + call this%outputtab%set_title(title) + end if + ! + ! -- Loop through each boundary calculating flow. + do i = 1, this%nodes + node = this%nodelist(i) + ! -- assign boundary name + if (this%inamedbound > 0) then + bname = this%boundname(i) + else + bname = '' + end if + ! + ! -- If cell is no-flow or constant-head, then ignore it. + rrate = DZERO + if (this%ibound(node) > 0) then + ! + ! -- Calculate the flow rate into the cell. + rrate = -this%gwdtomvr(i) + ! + ! -- Print the individual rates if requested(this%iprflow<0) + if (ibudfl /= 0) then + if (this%iprflow /= 0) then + ! + ! -- set nodestr and write outputtab table + nodeu = this%dis%get_nodeuser(node) + call this%dis%nodeu_to_string(nodeu, nodestr) + call this%outputtab%print_list_entry(i, nodestr, rrate, bname) + end if + end if + end if + ! + ! -- If saving cell-by-cell flows in list, write flow + if (ibinun /= 0) then + n2 = i + call this%dis%record_mf6_list_entry(ibinun, node, n2, rrate, & + naux, this%auxvar(:,i), & + olconv2=.FALSE.) + end if + end do + end if + end if + ! -- uzf-evt + if (this%ietflag /= 0) then + if (ibinun /= 0) then + call this%dis%record_srcdst_list_header(this%bdtxt(4), this%name_model,& + this%name_model, this%name_model, this%name, naux, & + this%auxname, ibinun, this%nodes, this%iout) + end if + ! + ! -- reset table title + if (this%iprflow /= 0) then + title = trim(this%text) // ' PACKAGE (' // trim(this%name) // & + ') ' // trim(adjustl(this%bdtxt(4))) // ' FLOW RATES' + call this%outputtab%set_title(title) + end if + ! + ! -- Loop through each boundary calculating flow. + do i = 1, this%nodes + node = this%nodelist(i) + ! -- assign boundary name + if (this%inamedbound > 0) then + bname = this%boundname(i) + else + bname = '' + end if + ! + ! -- If cell is no-flow or constant-head, then ignore it. + rrate = DZERO + if (this%ibound(node) > 0) then + ! + ! -- Calculate the flow rate into the cell. + rrate = -this%gwet(i) + ! + ! -- Print the individual rates if requested(this%iprflow<0) + if (ibudfl /= 0) then + if (this%iprflow /= 0) then + ! + ! -- set nodestr and write outputtab table + nodeu = this%dis%get_nodeuser(node) + call this%dis%nodeu_to_string(nodeu, nodestr) + call this%outputtab%print_list_entry(i, nodestr, rrate, bname) + end if + end if + end if + ! + ! -- If saving cell-by-cell flows in list, write flow + if (ibinun /= 0) then + n2 = i + call this%dis%record_mf6_list_entry(ibinun, node, n2, rrate, & + naux, this%auxvar(:,i), & + olconv2=.FALSE.) + end if + end do + end if + end if + ! + ! -- Add the UZF rates to the model budget + !uzf recharge + ratin = rrech + ratout = DZERO + call model_budget%addentry(ratin, ratout, delt, this%bdtxt(2), & + isuppress_output, this%name) + !groundwater discharge + if (this%iseepflag == 1) then + ratin = DZERO + ratout = qseep !rgwseep + call model_budget%addentry(ratin, ratout, delt, this%bdtxt(3), & + isuppress_output, this%name) + !groundwater discharge to mover + if (this%imover == 1) then + ratin = DZERO + ratout = qseeptomvr + call model_budget%addentry(ratin, ratout, delt, this%bdtxt(5), & + isuppress_output, this%name) + end if + end if + !groundwater et + if (this%igwetflag /= 0) then + ratin = DZERO + ratout = qgwet !retgw + !ratout = DZERO + !if (retgw > DZERO) then + ! ratout = -retgw + !end if + call model_budget%addentry(ratin, ratout, delt, this%bdtxt(4), & + isuppress_output, this%name) + end if + ! + ! -- set unit number for binary dependent variable output + ibinun = 0 + if(this%iwcontout /= 0) then + ibinun = this%iwcontout + end if + if(idvfl == 0) ibinun = 0 + if (isuppress_output /= 0) ibinun = 0 + ! + ! -- write uzf binary moisture-content output + if (ibinun > 0) then + ! here is where you add the code to write the simulated moisture content + ! may want to write a cell-by-cell file with imeth=6 (see sfr and lake) + end if + ! + ! -- fill the budget object + call this%uzf_fill_budobj() + ! + ! -- write the flows from the budobj + ibinun = 0 + if(this%ibudgetout /= 0) then + ibinun = this%ibudgetout + end if + if(icbcfl == 0) ibinun = 0 + if (isuppress_output /= 0) ibinun = 0 + if (ibinun > 0) then + call this%budobj%save_flows(this%dis, ibinun, kstp, kper, delt, & + pertim, totim, this%iout) + end if + ! + ! -- return + return + end subroutine uzf_bd + + subroutine uzf_ot(this, kstp, kper, iout, ihedfl, ibudfl) +! ****************************************************************************** +! uzf_ot -- UZF package budget +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(UzfType) :: this + integer(I4B),intent(in) :: kstp + integer(I4B),intent(in) :: kper + integer(I4B),intent(in) :: iout + integer(I4B),intent(in) :: ihedfl + integer(I4B),intent(in) :: ibudfl + ! -- local + ! -- format + 2000 FORMAT ( 1X, ///1X, A, A, A, ' PERIOD ', I6, ' STEP ', I8) +! ------------------------------------------------------------------------------ + ! + ! -- write uzf moisture content + if (ihedfl /= 0 .and. this%iprwcont /= 0) then + write (iout, 2000) 'UZF (', trim(this%name), ') WATER-CONTENT', kper, kstp + ! add code to write moisture content + end if + ! + ! -- Output uzf flow table + if (ibudfl /= 0 .and. this%iprflow /= 0) then + call this%budobj%write_flowtable(this%dis) + end if + ! + ! -- Output uzf budget + call this%budobj%write_budtable(kstp, kper, iout) + ! + ! -- return + return + end subroutine uzf_ot + + subroutine uzf_solve(this) +! ****************************************************************************** +! uzf_solve -- Formulate the HCOF and RHS terms +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only : delt + ! -- dummy + class(UzfType) :: this + ! -- locals + integer(I4B) :: i, ivertflag + integer(I4B) :: n, m, ierr + real(DP) :: trhs1, thcof1, trhs2, thcof2 + real(DP) :: hgwf, hgwflm1, cvv, uzderiv, gwet, derivgwet + real(DP) :: qfrommvr, qformvr,sumaet + character(len=100) :: msg + type(UzfCellGroupType) :: uzfobjwork +! ------------------------------------------------------------------------------ + ! + ! -- Initialize + call uzfobjwork%init(1, this%nwav) + ierr = 0 + sumaet = DZERO + ! + ! -- Calculate hcof and rhs for each UZF entry + do i = 1, this%nodes + thcof1 = DZERO + thcof2 = DZERO + trhs1 = DZERO + trhs2 = DZERO + uzderiv = DZERO + gwet = DZERO + derivgwet = DZERO + ivertflag = this%uzfobj%ivertcon(i) + ! + n = this%nodelist(i) + if ( this%ibound(n) > 0 ) then + ! + ! -- Water mover added to infiltration + qfrommvr = DZERO + qformvr = DZERO + if(this%imover == 1) then + qfrommvr = this%pakmvrobj%get_qfrommvr(i) + endif + ! + ! -- zero out hcof and rhs + this%hcof(i) = DZERO + this%rhs(i) = DZERO + ! + hgwf = this%xnew(n) + ! + m = n + hgwflm1 = hgwf + cvv = DZERO + ! + ! -- solve for current uzf cell + call this%uzfobj%formulate(uzfobjwork, ivertflag, i, & + this%totfluxtot, this%ietflag, & + this%issflag,this%iseepflag, & + trhs1,thcof1,hgwf,hgwflm1,cvv,uzderiv, & + qfrommvr,qformvr,ierr,sumaet,ivertflag) + if ( ierr > 0 ) then + if ( ierr == 1 ) & + msg = 'Error: UZF variable NWAVESETS needs to be increased ' + call store_error(msg) + call ustop() + end if + if ( this%igwetflag > 0 ) & + call this%uzfobj%simgwet(this%igwetflag,i,hgwf,trhs2,thcof2,gwet, & + derivgwet) + this%deriv(i) = uzderiv + derivgwet + ! + ! -- save current rejected infiltration, groundwater recharge, and + ! groundwater discharge + this%rejinf(i) = this%uzfobj%finf_rej(i) * this%uzfobj%uzfarea(i) + this%rch(i) = this%uzfobj%totflux(i) * this%uzfobj%uzfarea(i) / delt + this%gwd(i) = this%uzfobj%surfseep(i) + ! + ! -- add to hcof and rhs + this%hcof(i) = thcof1 + thcof2 + this%rhs(i) = -trhs1 - trhs2 + ! + ! -- add spring discharge and rejected infiltration to mover + if(this%imover == 1) then + call this%pakmvrobj%accumulate_qformvr(i, qformvr) + endif + ! + end if + end do + end subroutine uzf_solve + + subroutine define_listlabel(this) +! ****************************************************************************** +! define_listlabel -- Define the list heading that is written to iout when +! PRINT_INPUT option is used. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(UzfType), intent(inout) :: this +! ------------------------------------------------------------------------------ + ! + ! -- create the header list label + this%listlabel = trim(this%filtyp) // ' NO.' + if(this%dis%ndim == 3) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif(this%dis%ndim == 2) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + else + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + endif + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' + if(this%inamedbound == 1) then + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + endif + ! + ! -- return + return + end subroutine define_listlabel + + subroutine findcellabove(this,n,nml) + class(UzfType) :: this + integer(I4B), intent(in) :: n + integer(I4B), intent(inout) :: nml + integer(I4B) :: m, ipos +! ------------------------------------------------------------------------------ +! + ! -- return nml = n if no cell is above it + nml = n + do ipos = this%dis%con%ia(n)+1, this%dis%con%ia(n+1)-1 + m = this%dis%con%ja(ipos) + if(this%dis%con%ihc(ipos) /= 0) then + if (n < m) then + ! -- m is beneath n + else + nml = m ! -- m is above n + exit + endif + end if + enddo + return + end subroutine findcellabove + + subroutine read_cell_properties(this) +! ****************************************************************************** +! read_cell_properties -- Read UZF cell properties and set them for +! UzfCellGroup type. +! ****************************************************************************** + use InputOutputModule, only: urword + use SimModule, only: ustop, store_error, count_errors +! ------------------------------------------------------------------------------ + ! -- dummy + class(UzfType), intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: errmsg, cellid + integer(I4B) :: ierr + integer(I4B) :: i, n + integer(I4B) :: j + integer(I4B) :: ic + integer(I4B) :: jcol + logical :: isfound, endOfBlock + integer(I4B) :: landflag + integer(I4B) :: ivertcon + real(DP) :: surfdep, vks, thtr, thts, thti, eps, hgwf + integer(I4B), dimension(:), allocatable :: rowmaxnnz + type(sparsematrix) :: sparse + integer(I4B), dimension(:), allocatable :: nboundchk +! ------------------------------------------------------------------------------ +! + ! + ! -- allocate space for node counter and initilize + allocate(rowmaxnnz(this%dis%nodes)) + do n = 1, this%dis%nodes + rowmaxnnz(n) = 0 + end do + ! + ! -- allocate space for local variables + allocate(nboundchk(this%nodes)) + do n = 1, this%nodes + nboundchk(n) = 0 + end do + ! + ! -- initialize variables + landflag = 0 + ivertcon = 0 + surfdep = DZERO + vks = DZERO + thtr = DZERO + thts = DZERO + thti = DZERO + eps = DZERO + hgwf = DZERO + ! + ! -- get uzf properties block + call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & + supportOpenClose=.true.) + ! + ! -- parse locations block if detected + if (isfound) then + write(this%iout,'(/1x,3a)') 'PROCESSING ', trim(adjustl(this%text)), & + ' PACKAGEDATA' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + ! + ! -- get uzf cell number + i = this%parser%GetInteger() + + if (i < 1 .or. i > this%nodes) then + write(errmsg,'(4x,a,1x,i6)') & + '****ERROR. iuzno MUST BE > 0 and <= ', this%nodes + call store_error(errmsg) + cycle + end if + ! + ! -- increment nboundchk + nboundchk(i) = nboundchk(i) + 1 + + ! -- store the reduced gwf nodenumber in igwfnode + call this%parser%GetCellid(this%dis%ndim, cellid) + ic = this%dis%noder_from_cellid(cellid, & + this%parser%iuactive, this%iout) + this%igwfnode(i) = ic + rowmaxnnz(ic) = rowmaxnnz(ic) + 1 + ! + ! -- landflag + landflag = this%parser%GetInteger() + if (landflag < 0 .OR. landflag > 1) then + write(errmsg,'(4x,a,1x,i0,1x,a,1x,i0)') & + '****ERROR. LANDFLAG FOR UZF CELL', i, & + 'MUST BE 0 or 1 - SPECIFIED VALUE =', landflag + call store_error(errmsg) + end if + ! + ! -- ivertcon + ivertcon = this%parser%GetInteger() + if (ivertcon < 0 .OR. ivertcon > this%nodes) then + write(errmsg,'(4x,a,1x,i0,1x,a,1x,i0)') & + '****ERROR. IVERTCON FOR UZF CELL', i, & + 'MUST BE 0 or less than NUZFCELLS - SPECIFIED VALUE =', ivertcon + call store_error(errmsg) + ivertcon = 0 + end if + ! + ! -- surfdep + surfdep = this%parser%GetDouble() + if (surfdep <= DZERO) then !need to check for cell thickness + write(errmsg,'(4x,a,1x,i0,1x,a,1x,g0)') & + '****ERROR. SURFDEP FOR UZF CELL', i, & + 'MUST BE > 0 - SPECIFIED VALUE =', surfdep + call store_error(errmsg) + surfdep = DZERO + end if + ! + ! -- vks + vks = this%parser%GetDouble() + if (vks <= DZERO) then + write(errmsg,'(4x,a,1x,i0,1x,a,1x,g0)') & + '****ERROR. VKS FOR UZF CELL', i, & + 'MUST BE > 0 - SPECIFIED VALUE =', vks + call store_error(errmsg) + vks = DONE + end if + ! + ! -- thtr + thtr = this%parser%GetDouble() + if (thtr <= DZERO) then + write(errmsg,'(4x,a,1x,i0,1x,a,1x,g0)') & + '****ERROR. THTR FOR UZF CELL', i, & + 'MUST BE > 0 - SPECIFIED VALUE =', thtr + call store_error(errmsg) + thtr = 0.1 + end if + ! + ! -- thts + thts = this%parser%GetDouble() + if (thts <= thtr) then + write(errmsg,'(4x,a,1x,i0,1x,a,1x,g0)') & + '****ERROR. THTS FOR UZF CELL', i, & + 'MUST BE > THTR - SPECIFIED VALUE =', thts + call store_error(errmsg) + thts = 0.2 + end if + ! + ! -- thti + thti = this%parser%GetDouble() + if (thti < thtr .OR. thti > thts) then + write(errmsg,'(4x,a,1x,i0,1x,a,1x,g0)') & + '****ERROR. THTI FOR UZF CELL', i, & + 'MUST BE >= THTR AND < THTS - SPECIFIED VALUE =', thti + call store_error(errmsg) + thti = 0.1 + end if + ! + ! -- eps + eps = this%parser%GetDouble() + if (eps < 3.5 .OR. eps > 14) then + write(errmsg,'(4x,a,1x,i0,1x,a,1x,g0)') & + '****ERROR. EPSILON FOR UZF CELL', i, & + 'MUST BE BETWEEN 3.5 and 14.0 - SPECIFIED VALUE =', eps + call store_error(errmsg) + eps = 3.5 + end if + ! + ! -- boundname + if (this%inamedbound == 1) then + call this%parser%GetStringCaps(this%uzfname(i)) + endif + n = this%igwfnode(i) + !cdl hgwf = this%xnew(n) + call this%uzfobj%setdata(i,this%gwfarea(n),this%gwftop(n),this%gwfbot(n), & + surfdep,vks,thtr,thts,thti,eps,this%ntrail, & + landflag,ivertcon) !,hgwf) + if (ivertcon > 0) then + this%iuzf2uzf = 1 + end if + ! + end do + else + call store_error('ERROR. REQUIRED PACKAGEDATA BLOCK NOT FOUND.') + end if + ! + ! -- check for duplicate or missing uzf cells + do i = 1, this%nodes + if (nboundchk(i) == 0) then + write(errmsg,'(a,1x,i0)') & + 'ERROR. NO DATA SPECIFIED FOR UZF CELL', i + call store_error(errmsg) + else if (nboundchk(i) > 1) then + write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & + 'ERROR. DATA FOR UZF CELL', i, 'SPECIFIED', nboundchk(i), 'TIMES' + call store_error(errmsg) + end if + end do + ! + ! -- write summary of UZF cell property error messages + ierr = count_errors() + if (ierr > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- setup sparse for connectivity used to identify multiple uzf cells per + ! GWF model cell + call sparse%init(this%dis%nodes, this%dis%nodes, rowmaxnnz) + ! -- + do i = 1, this%nodes + ic = this%igwfnode(i) + call sparse%addconnection(ic, i, 1) + end do + ! + ! -- create ia and ja from sparse + call sparse%filliaja(this%ia,this%ja,ierr) + ! + ! -- set imaxcellcnt + do i = 1, this%nodes + jcol = 0 + do j = this%ia(i), this%ia(i+1) - 1 + jcol = jcol + 1 + end do + if (jcol > this%imaxcellcnt) then + this%imaxcellcnt = jcol + end if + end do + ! + ! -- do an initial evaluation of the sum of uzfarea relative to the + ! GWF cell area in the case that there is more than one UZF cell + ! in a GWF cell and a auxmult value is not being applied to the + ! calculate the UZF cell area from the GWF cell area. + if (this%imaxcellcnt > 1 .and. this%iauxmultcol < 1) then + call this%check_cell_area() + end if + ! + ! -- deallocate local variables + deallocate(rowmaxnnz) + deallocate(nboundchk) + ! + ! -- return + return + end subroutine read_cell_properties + + subroutine print_cell_properties(this) +! ****************************************************************************** +! print_cell_properties -- Read UZF cell properties and set them for +! UZFCellGroup type. +! ****************************************************************************** +! ------------------------------------------------------------------------------ + ! -- dummy + class(UzfType), intent(inout) :: this + ! -- local + character (len=20) :: cellid + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: tag + integer(I4B) :: ntabrows + integer(I4B) :: ntabcols + integer(I4B) :: i + integer(I4B) :: node +! ------------------------------------------------------------------------------ +! + ! + ! -- setup inputtab tableobj + ! + ! -- table dimensions + ntabrows = this%nodes + ntabcols = 10 + if (this%inamedbound == 1) then + ntabcols = ntabcols + 1 + end if + ! + ! -- initialize table and define columns + title = trim(adjustl(this%text)) // ' PACKAGE (' // & + trim(adjustl(this%name)) //') STATIC UZF CELL DATA' + call table_cr(this%inputtab, this%name, title) + call this%inputtab%table_df(ntabrows, ntabcols, this%iout) + tag = 'NUMBER' + call this%inputtab%initialize_column(tag, 10) + tag = 'CELLID' + call this%inputtab%initialize_column(tag, 20, alignment=TABLEFT) + tag = 'LANDFLAG' + call this%inputtab%initialize_column(tag, 12) + tag = 'IVERTCON' + call this%inputtab%initialize_column(tag, 12) + tag = 'SURFDEP' + call this%inputtab%initialize_column(tag, 12) + tag = 'VKS' + call this%inputtab%initialize_column(tag, 12) + tag = 'THTR' + call this%inputtab%initialize_column(tag, 12) + tag = 'THTS' + call this%inputtab%initialize_column(tag, 12) + tag = 'THTI' + call this%inputtab%initialize_column(tag, 12) + tag = 'EPS' + call this%inputtab%initialize_column(tag, 12) + if (this%inamedbound == 1) then + tag = 'BOUNDNAME' + call this%inputtab%initialize_column(tag, LENBOUNDNAME, alignment=TABLEFT) + end if + ! + ! -- write data for each cell + do i = 1, this%nodes + ! + ! -- get cellid + node = this%igwfnode(i) + if (node > 0) then + call this%dis%noder_to_string(node, cellid) + else + cellid = 'none' + end if + ! + ! -- add data + call this%inputtab%add_term(i) + call this%inputtab%add_term(cellid) + call this%inputtab%add_term(this%uzfobj%landflag(i)) + call this%inputtab%add_term(this%uzfobj%ivertcon(i)) + call this%inputtab%add_term(this%uzfobj%surfdep(i)) + call this%inputtab%add_term(this%uzfobj%vks(i)) + call this%inputtab%add_term(this%uzfobj%thtr(i)) + call this%inputtab%add_term(this%uzfobj%thts(i)) + call this%inputtab%add_term(this%uzfobj%thti(i)) + call this%inputtab%add_term(this%uzfobj%eps(i)) + if (this%inamedbound == 1) then + call this%inputtab%add_term(this%uzfname(i)) + end if + end do + ! + ! -- return + return + end subroutine print_cell_properties + + subroutine check_cell_area(this) +! ****************************************************************************** +! check_cell_area -- Check UZF cell areas. +! ****************************************************************************** + use InputOutputModule, only: urword + use SimModule, only: ustop, store_error, count_errors +! ------------------------------------------------------------------------------ + ! -- dummy + class(UzfType) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + character(len=16) :: cuzf + character(len=20) :: cellid + character(len=LINELENGTH) :: cuzfcells + integer(I4B) :: ierr + integer(I4B) :: i + integer(I4B) :: i2 + integer(I4B) :: j + integer(I4B) :: n + integer(I4B) :: i0 + integer(I4B) :: i1 + real(DP) :: area + real(DP) :: area2 + real(DP) :: sumarea + real(DP) :: cellarea + real(DP) :: d +! ------------------------------------------------------------------------------ +! + ! + ! -- check that the area of vertically connected uzf cells is the equal + do i = 1, this%nodes + ! + ! -- Initialize variables + i2 = this%uzfobj%ivertcon(i) + area = this%uzfobj%uzfarea(i) + ! + ! Create pointer to object below + if (i2 > 0) then + area2 = this%uzfobj%uzfarea(i2) + d = abs(area - area2) + if (d > DEM6) then + write(errmsg,'(4x,2(a,1x,g15.7,1x,a,1x,i6,1x))') & + '****ERROR. UZF CELL AREA (', area, ') FOR CELL ', i, & + 'DOES NOT EQUAL UZF CELL AREA (', area2, ') FOR CELL ', i2 + call store_error(errmsg) + end if + end if + end do + ! + ! -- check that the area of uzf cells in a GWF cell is less than or equal + ! to the GWF cell area + do n = 1, this%dis%nodes + i0 = this%ia(n) + i1 = this%ia(n+1) + ! -- skip gwf cells with no UZF cells + if ((i1 - i0) < 1) cycle + sumarea = DZERO + cellarea = DZERO + cuzfcells = '' + do j = i0, i1 - 1 + i = this%ja(j) + write(cuzf,'(i0)') i + cuzfcells = trim(adjustl(cuzfcells)) // ' ' // trim(adjustl(cuzf)) + sumarea = sumarea + this%uzfobj%uzfarea(i) + cellarea = this%uzfobj%cellarea(i) + end do + ! -- calculate the difference between the sum of UZF areas and GWF cell area + d = abs(sumarea - cellarea) + if (d > DEM6) then + call this%dis%noder_to_string(n, cellid) + write(errmsg,'(4x,a,1x,g15.7,1x,a,1x,g15.7,1x,a,1x,a,1x,a,a)') & + '****ERROR. TOTAL UZF CELL AREA (', sumarea, & + ') EXCEEDS THE GWF CELL AREA (', cellarea, ') OF CELL', cellid, & + 'WHICH INCLUDES UZF CELL(S): ', trim(adjustl(cuzfcells)) + call store_error(errmsg) + end if + end do + ! + ! -- terminate if errors were encountered + ierr = count_errors() + if (ierr > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! -- return + return + end subroutine check_cell_area + + ! -- Procedures related to observations (type-bound) + logical function uzf_obs_supported(this) +! ****************************************************************************** +! uzf_obs_supported +! -- Return true because uzf package supports observations. +! -- Overrides BndType%bnd_obs_supported +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(UzfType) :: this +! ------------------------------------------------------------------------------ + uzf_obs_supported = .true. + return + end function uzf_obs_supported + + subroutine uzf_df_obs(this) +! ****************************************************************************** +! uzf_df_obs (implements bnd_df_obs) +! -- Store observation type supported by uzf package. +! -- Overrides BndType%bnd_df_obs +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(UzfType) :: this + ! -- local + integer(I4B) :: indx + ! ------------------------------------------------------------------------------ + ! + ! -- Store obs type and assign procedure pointer + ! + ! for recharge observation type. + call this%obs%StoreObsType('uzf-gwrch', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID + ! + ! for discharge observation type. + call this%obs%StoreObsType('uzf-gwd', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID + ! + ! for discharge observation type. + call this%obs%StoreObsType('uzf-gwd-to-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID + ! + ! for gwet observation type. + call this%obs%StoreObsType('uzf-gwet', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID + ! + ! for infiltration observation type. + call this%obs%StoreObsType('infiltration', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID + ! + ! for from mover observation type. + call this%obs%StoreObsType('from-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID + ! + ! for rejected infiltration observation type. + call this%obs%StoreObsType('rej-inf', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID + ! + ! for rejected infiltration to mover observation type. + call this%obs%StoreObsType('rej-inf-to-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID + ! + ! for uzet observation type. + call this%obs%StoreObsType('uzet', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID + ! + ! for storage observation type. + call this%obs%StoreObsType('storage', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID + ! + ! for net infiltration observation type. + call this%obs%StoreObsType('net-infiltration', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID + ! + ! for water-content observation type. + call this%obs%StoreObsType('water-content', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsID + ! + ! -- return + return + end subroutine uzf_df_obs +! + subroutine uzf_bd_obs(this) + ! ************************************************************************** + ! uzf_bd_obs + ! -- Calculate observations this time step and call + ! ObsType%SaveOneSimval for each UzfType observation. + ! ************************************************************************** + ! + ! SPECIFICATIONS: + ! -------------------------------------------------------------------------- + ! -- dummy + class(UzfType) :: this + ! -- local + integer(I4B) :: i, ii, n, nn + real(DP) :: v + character(len=100) :: msg + type(ObserveType), pointer :: obsrv => null() + !--------------------------------------------------------------------------- + ! + ! Write simulated values for all uzf observations + if (this%obs%npakobs>0) then + call this%obs%obs_bd_clear() + do i = 1, this%obs%npakobs + obsrv => this%obs%pakobs(i)%obsrv + nn = size(obsrv%indxbnds) + do ii = 1, nn + n = obsrv%indxbnds(ii) + v = DNODATA + select case (obsrv%ObsTypeId) + case ('UZF-GWRCH') + v = this%rch(n) + case ('UZF-GWD') + v = this%gwd(n) + if (v > DZERO) then + v = -v + end if + case ('UZF-GWD-TO-MVR') + if (this%imover == 1) then + v = this%gwdtomvr(n) + if (v > DZERO) then + v = -v + end if + end if + case ('UZF-GWET') + if (this%igwetflag > 0) then + v = this%gwet(n) + if (v > DZERO) then + v = -v + end if + end if + case ('INFILTRATION') + v = this%appliedinf(n) + case ('FROM-MVR') + if (this%imover == 1) then + v = this%pakmvrobj%get_qfrommvr(n) + end if + case ('REJ-INF') + v = this%rejinf(n) + if (v > DZERO) then + v = -v + end if + case ('REJ-INF-TO-MVR') + if (this%imover == 1) then + v = this%rejinftomvr(n) + if (v > DZERO) then + v = -v + end if + end if + case ('UZET') + if (this%ietflag /= 0) then + v = this%uzet(n) + if (v > DZERO) then + v = -v + end if + end if + case ('STORAGE') + v = -this%qsto(n) + case ('NET-INFILTRATION') + v = this%infiltration(n) + case ('WATER-CONTENT') + v = this%obs_theta(i) ! more than one obs per node + case default + msg = 'Error: Unrecognized observation type: ' // trim(obsrv%ObsTypeId) + call store_error(msg) + end select + call this%obs%SaveOneSimval(obsrv, v) + end do + end do + end if + ! + ! -- write summary of package block error messages + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + return + end subroutine uzf_bd_obs +! + subroutine uzf_rp_obs(this) + ! -- dummy + class(UzfType), intent(inout) :: this + ! -- local + integer(I4B) :: i, j, n, nn + real(DP) :: obsdepth + real(DP) :: dmax + character(len=200) :: ermsg + character(len=LENBOUNDNAME) :: bname + class(ObserveType), pointer :: obsrv => null() + ! -------------------------------------------------------------------------- + ! -- formats +60 format('Error: Invalid node number in OBS input: ',i5) + ! + do i = 1, this%obs%npakobs + obsrv => this%obs%pakobs(i)%obsrv + ! -- indxbnds needs to be deallocated and reallocated (using + ! ExpandArray) each stress period because list of boundaries + ! can change each stress period. + if (allocated(obsrv%indxbnds)) then + deallocate(obsrv%indxbnds) + endif + ! + ! -- get node number 1 + nn = obsrv%NodeNumber + if (nn == NAMEDBOUNDFLAG) then + bname = obsrv%FeatureName + ! -- Observation location(s) is(are) based on a boundary name. + ! Iterate through all boundaries to identify and store + ! corresponding index(indices) in bound array. + do j = 1, this%nodes + if (this%boundname(j) == bname) then + !! In UZF, use of the same boundary name for multiple boundaries + !! in an observation is not supported for obs type UZF-WATERCONTENT + !if (obsrv%ObsTypeId=='WATER-CONTENT') then + ! if (obsrv%BndFound) then + ! ermsg = 'Duplicate names for multiple boundaries are not ' // & + ! 'supported for UZF observations of type ' // & + ! '"UZF-WATERCONTENT". There are multiple' // & + ! ' boundaries named "' // trim(bname) // & + ! '" for observation: ' // & + ! trim(obsrv%Name) // '.' + ! call store_error(ermsg) + ! call store_error_unit(this%inunit) + ! call ustop() + ! endif + !endif + obsrv%BndFound = .true. + obsrv%CurrentTimeStepEndValue = DZERO + call ExpandArray(obsrv%indxbnds) + n = size(obsrv%indxbnds) + obsrv%indxbnds(n) = j + if (n==1) then + ! Define intPak1 so that obs_theta is stored (for first uzf + ! cell if multiple cells share the same boundname). + obsrv%intPak1 = j + endif + endif + enddo + else + ! -- get node number + nn = obsrv%NodeNumber + ! -- put nn (a value meaningful only to UZF) in intPak1 + obsrv%intPak1 = nn + ! -- check that node number is valid; call store_error if not + if (nn < 1 .or. nn > this%nodes) then + write (ermsg, 60) nn + call store_error(ermsg) + else + obsrv%BndFound = .true. + endif + obsrv%CurrentTimeStepEndValue = DZERO + call ExpandArray(obsrv%indxbnds) + n = size(obsrv%indxbnds) + obsrv%indxbnds(n) = nn + end if + ! + ! -- catch non-cumulative observation assigned to observation defined + ! by a boundname that is assigned to more than one element + if (obsrv%ObsTypeId == 'WATER-CONTENT') then + n = size(obsrv%indxbnds) + if (n > 1) then + write (ermsg, '(4x,a,4(1x,a))') & + 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & + 'for observation', trim(adjustl(obsrv%Name)), & + ' must be assigned to a UZF cell with a unique boundname.' + call store_error(ermsg) + end if + ! + ! -- check WATER-CONTENT depth + obsdepth = obsrv%Obsdepth + ! -- put obsdepth (a value meaningful only to UZF) in dblPak1 + obsrv%dblPak1 = obsdepth + ! + ! -- determine maximum cell depth + dmax = this%uzfobj%celtop(n) - this%uzfobj%celbot(n) + ! -- check that obs depth is valid; call store_error if not + ! -- need to think about a way to put bounds on this depth + if (obsdepth < DZERO .or. obsdepth > dmax) then + write (ermsg, '(4x,a,4(1x,a),1x,g15.7,1x,a,1x,g15.7)') & + 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & + 'for observation', trim(adjustl(obsrv%Name)), & + ' specified depth (', obsdepth, ') must be between 0. and ', dmax + call store_error(ermsg) + endif + else + do j = 1, size(obsrv%indxbnds) + nn = obsrv%indxbnds(j) + if (nn < 1 .or. nn > this%maxbound) then + write (ermsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & + 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & + ' uzfno must be > 0 and <=', this%maxbound, & + '(specified value is ', nn, ')' + call store_error(ermsg) + end if + end do + end if + ! ! + ! select case (obsrv%ObsTypeId) + ! case ('WATER-CONTENT') + ! obsdepth = obsrv%Obsdepth + ! ! -- put obsdepth (a value meaningful only to UZF) in dblPak1 + ! obsrv%dblPak1 = obsdepth + ! ! -- check that obs depth is valid; call store_error if not + ! ! -- need to think about a way to put bounds on this depth + ! if (obsdepth < -999999.d0 .or. obsdepth > 999999.d0) then + ! write (ermsg, 70) obsdepth + ! call store_error(ermsg) + ! endif + ! case default + !! left to check other types of observations + ! end select + end do + if (count_errors() > 0) then + call store_error_unit(this%inunit) + call ustop() + endif + ! + return + end subroutine uzf_rp_obs + ! + ! -- Procedures related to observations (NOT type-bound) + subroutine uzf_process_obsID(obsrv, dis, inunitobs, iout) + ! -- This procedure is pointed to by ObsDataType%ProcesssIdPtr. It processes + ! the ID string of an observation definition for UZF-package observations. + ! -- dummy + type(ObserveType), intent(inout) :: obsrv + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: inunitobs + integer(I4B), intent(in) :: iout + ! -- local + integer(I4B) :: n, nn + real(DP) :: obsdepth + integer(I4B) :: icol, istart, istop, istat + real(DP) :: r + character(len=LINELENGTH) :: strng + ! formats + 30 format(i10) + ! + strng = obsrv%IDstring + ! -- Extract node number from strng and store it. + ! If 1st item is not an integer(I4B), it should be a + ! feature name--deal with it. + icol = 1 + ! -- get node number + call urword(strng, icol, istart, istop, 1, n, r, iout, inunitobs) + read (strng(istart:istop), 30, iostat=istat) nn + if (istat==0) then + ! -- store uzf node number (NodeNumber) + obsrv%NodeNumber = nn + else + ! Integer can't be read from strng; it's presumed to be a boundary + ! name (already converted to uppercase) + obsrv%FeatureName = strng(istart:istop) + ! -- Observation may require summing rates from multiple boundaries, + ! so assign NodeNumber as a value that indicates observation + ! is for a named boundary or group of boundaries. + obsrv%NodeNumber = NAMEDBOUNDFLAG + endif + ! + ! -- for soil water observation, store depth + if (obsrv%ObsTypeId=='WATER-CONTENT' ) then + call urword(strng, icol, istart, istop, 3, n, r, iout, inunitobs) + obsdepth = r + ! -- store observations depth + obsrv%Obsdepth = obsdepth + endif + ! + return + end subroutine uzf_process_obsID + + subroutine uzf_allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars -- allocate scalar members +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(UzfType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- call standard BndType allocate scalars + call this%BndType%allocate_scalars() + ! + ! -- allocate uzf specific scalars + call mem_allocate(this%iprwcont, 'IPRWCONT', this%origin) + call mem_allocate(this%iwcontout, 'IWCONTOUT', this%origin) + call mem_allocate(this%ibudgetout, 'IBUDGETOUT', this%origin) + call mem_allocate(this%ipakcsv, 'IPAKCSV', this%origin) + call mem_allocate(this%ntrail, 'NTRAIL', this%origin) + call mem_allocate(this%nsets, 'NSETS', this%origin) + call mem_allocate(this%nodes, 'NODES', this%origin) + call mem_allocate(this%istocb, 'ISTOCB', this%origin) + call mem_allocate(this%nwav, 'NWAV', this%origin) + call mem_allocate(this%outunitbud, 'OUTUNITBUD', this%origin) + call mem_allocate(this%totfluxtot, 'TOTFLUXTOT', this%origin) + call mem_allocate(this%infilsum, 'INFILSUM', this%origin) + call mem_allocate(this%uzetsum, 'UZETSUM', this%origin) + call mem_allocate(this%rechsum, 'RECHSUM', this%origin) + call mem_allocate(this%vfluxsum, 'VFLUXSUM', this%origin) + call mem_allocate(this%delstorsum, 'DELSTORSUM', this%origin) + call mem_allocate(this%bditems, 'BDITEMS', this%origin) + call mem_allocate(this%nbdtxt, 'NBDTXT', this%origin) + call mem_allocate(this%issflag, 'ISSFLAG', this%origin) + call mem_allocate(this%issflagold, 'ISSFLAGOLD', this%origin) + call mem_allocate(this%readflag, 'READFLAG', this%origin) + call mem_allocate(this%iseepflag, 'ISEEPFLAG', this%origin) + call mem_allocate(this%imaxcellcnt, 'IMAXCELLCNT', this%origin) + call mem_allocate(this%ietflag, 'IETFLAG', this%origin) + call mem_allocate(this%igwetflag, 'IGWETFLAG', this%origin) + call mem_allocate(this%iuzf2uzf, 'IUZF2UZF', this%origin) + call mem_allocate(this%cbcauxitems, 'CBCAUXITEMS', this%origin) + + call mem_allocate(this%iconvchk, 'ICONVCHK', this%origin) + ! + ! -- initialize scalars + this%iprwcont = 0 + this%iwcontout = 0 + this%ibudgetout = 0 + this%ipakcsv = 0 + this%infilsum = DZERO + this%uzetsum = DZERO + this%rechsum = DZERO + this%delstorsum = DZERO + this%vfluxsum = DZERO + this%istocb = 0 + this%bditems = 7 + this%nbdtxt = 5 + this%issflag = 0 + this%issflagold = 0 + this%ietflag = 0 + this%igwetflag = 0 + this%iseepflag = 0 + this%imaxcellcnt = 0 + this%iuzf2uzf = 0 + this%cbcauxitems = 1 + this%imover = 0 + ! + ! -- convergence check + this%iconvchk = 1 + ! + ! -- return + return + end subroutine uzf_allocate_scalars +! + subroutine uzf_da(this) +! ****************************************************************************** +! uzf_da -- Deallocate objects +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(UzfType) :: this + ! -- locals + ! -- format +! ------------------------------------------------------------------------------ + ! + ! -- deallocate uzf objects + call this%uzfobj%dealloc() + nullify(this%uzfobj) + call this%budobj%budgetobject_da() + deallocate(this%budobj) + nullify(this%budobj) + ! + ! -- character arrays + deallocate(this%bdtxt) + deallocate(this%cauxcbc) + deallocate(this%uzfname) + ! + ! -- package csv table + if (this%ipakcsv > 0) then + call this%pakcsvtab%table_da() + deallocate(this%pakcsvtab) + nullify(this%pakcsvtab) + end if + ! + ! -- deallocate scalars + call mem_deallocate(this%iprwcont) + call mem_deallocate(this%iwcontout) + call mem_deallocate(this%ibudgetout) + call mem_deallocate(this%ipakcsv) + call mem_deallocate(this%ntrail) + call mem_deallocate(this%nsets) + call mem_deallocate(this%nodes) + call mem_deallocate(this%istocb) + call mem_deallocate(this%nwav) + call mem_deallocate(this%outunitbud) + call mem_deallocate(this%totfluxtot) + call mem_deallocate(this%infilsum) + call mem_deallocate(this%uzetsum) + call mem_deallocate(this%rechsum) + call mem_deallocate(this%vfluxsum) + call mem_deallocate(this%delstorsum) + call mem_deallocate(this%bditems) + call mem_deallocate(this%nbdtxt) + call mem_deallocate(this%issflag) + call mem_deallocate(this%issflagold) + call mem_deallocate(this%readflag) + call mem_deallocate(this%iseepflag) + call mem_deallocate(this%imaxcellcnt) + call mem_deallocate(this%ietflag) + call mem_deallocate(this%igwetflag) + call mem_deallocate(this%iuzf2uzf) + call mem_deallocate(this%cbcauxitems) + ! + ! -- convergence check + call mem_deallocate(this%iconvchk) + ! + ! -- deallocate arrays + call mem_deallocate(this%igwfnode) + call mem_deallocate(this%appliedinf) + call mem_deallocate(this%rejinf) + call mem_deallocate(this%rejinf0) + call mem_deallocate(this%rejinftomvr) + call mem_deallocate(this%infiltration) + call mem_deallocate(this%recharge) + call mem_deallocate(this%gwet) + call mem_deallocate(this%uzet) + call mem_deallocate(this%gwd) + call mem_deallocate(this%gwd0) + call mem_deallocate(this%gwdtomvr) + call mem_deallocate(this%rch) + call mem_deallocate(this%rch0) + call mem_deallocate(this%qsto) + call mem_deallocate(this%deriv) + call mem_deallocate(this%qauxcbc) + ! + ! -- deallocate integer arrays + call mem_deallocate(this%ia) + call mem_deallocate(this%ja) + ! + ! -- deallocate timeseries aware variables + call mem_deallocate(this%sinf) + call mem_deallocate(this%pet) + call mem_deallocate(this%extdp) + call mem_deallocate(this%extwc) + call mem_deallocate(this%ha) + call mem_deallocate(this%hroot) + call mem_deallocate(this%rootact) + call mem_deallocate(this%lauxvar) + ! + ! -- deallocate obs variables + call mem_deallocate(this%obs_theta) + call mem_deallocate(this%obs_depth) + call mem_deallocate(this%obs_num) + ! + ! -- Parent object + call this%BndType%bnd_da() + ! + ! -- Return + return + end subroutine uzf_da + + subroutine uzf_setup_budobj(this) +! ****************************************************************************** +! uzf_setup_budobj -- Set up the budget object that stores all the uzf flows +! The terms listed here must correspond in number and order to the ones +! listed in the uzf_fill_budobj routine. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LENBUDTXT + ! -- dummy + class(UzfType) :: this + ! -- local + integer(I4B) :: nbudterm + integer(I4B) :: maxlist, naux + integer(I4B) :: idx + integer(I4B) :: nlen + integer(I4B) :: n, n1, n2 + integer(I4B) :: ivertflag + real(DP) :: q + character(len=LENBUDTXT) :: text + character(len=LENBUDTXT), dimension(1) :: auxtxt +! ------------------------------------------------------------------------------ + ! + ! -- Determine the number of uzf to uzf connections + nlen = 0 + do n = 1, this%nodes + ivertflag = this%uzfobj%ivertcon(n) + if (ivertflag > 0) then + nlen = nlen + 1 + end if + end do + ! + ! -- Determine the number of uzf budget terms. These are fixed for + ! the simulation and cannot change. This includes FLOW-JA-FACE + ! so they can be written to the binary budget files, but these internal + ! flows are not included as part of the budget table. + nbudterm = 4 + if (nlen > 0) nbudterm = nbudterm + 1 + if (this%ietflag /= 0) nbudterm = nbudterm + 1 + if (this%imover == 1) nbudterm = nbudterm + 2 + if (this%naux > 0) nbudterm = nbudterm + 1 + ! + ! -- set up budobj + call budgetobject_cr(this%budobj, this%name) + call this%budobj%budgetobject_df(this%maxbound, nbudterm, 0, 0) + idx = 0 + ! + ! -- Go through and set up each budget term + text = ' FLOW-JA-FACE' + if (nlen > 0) then + idx = idx + 1 + maxlist = nlen * 2 + naux = 1 + auxtxt(1) = ' FLOW-AREA' + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux, auxtxt, ordered_id1=.false.) + ! + ! -- store connectivity + call this%budobj%budterm(idx)%reset(nlen * 2) + q = DZERO + do n = 1, this%nodes + ivertflag = this%uzfobj%ivertcon(n) + if (ivertflag > 0) then + n1 = n + n2 = ivertflag + call this%budobj%budterm(idx)%update_term(n1, n2, q) + call this%budobj%budterm(idx)%update_term(n2, n1, -q) + end if + end do + end if + ! + ! -- + text = ' GWF' + idx = idx + 1 + maxlist = this%nodes + naux = 1 + auxtxt(1) = ' FLOW-AREA' + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name_model, & + maxlist, .false., .true., & + naux, auxtxt) + call this%budobj%budterm(idx)%reset(this%nodes) + q = DZERO + do n = 1, this%nodes + n2 = this%igwfnode(n) + call this%budobj%budterm(idx)%update_term(n, n2, q) + end do + ! + ! -- + text = ' INFILTRATION' + idx = idx + 1 + maxlist = this%nodes + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' REJ-INF' + idx = idx + 1 + maxlist = this%nodes + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' UZET' + if (this%ietflag /= 0) then + idx = idx + 1 + maxlist = this%maxbound + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + end if + ! + ! -- + text = ' STORAGE' + idx = idx + 1 + maxlist = this%nodes + naux = 1 + auxtxt(1) = ' VOLUME' + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux, auxtxt) + ! + ! -- + if (this%imover == 1) then + ! + ! -- + text = ' FROM-MVR' + idx = idx + 1 + maxlist = this%nodes + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' REJ-INF-TO-MVR' + idx = idx + 1 + maxlist = this%nodes + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux) + end if + ! + ! -- + naux = this%naux + if (naux > 0) then + ! + ! -- + text = ' AUXILIARY' + idx = idx + 1 + maxlist = this%maxbound + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%name, & + this%name_model, & + this%name, & + maxlist, .false., .false., & + naux, this%auxname) + end if + ! + ! -- if uzf flow for each reach are written to the listing file + if (this%iprflow /= 0) then + call this%budobj%flowtable_df(this%iout, cellids='GWF') + end if + ! + ! -- return + return + end subroutine uzf_setup_budobj + + subroutine uzf_fill_budobj(this) +! ****************************************************************************** +! uzf_fill_budobj -- copy flow terms into this%budobj +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(UzfType) :: this + ! -- local + integer(I4B) :: naux + integer(I4B) :: nlen + integer(I4B) :: ivertflag + integer(I4B) :: n, n1, n2 + integer(I4B) :: idx + real(DP) :: q + real(DP) :: a + real(DP) :: top + real(DP) :: bot + real(DP) :: thick + real(DP) :: fm + real(DP) :: v + ! -- formats +! ----------------------------------------------------------------------------- + ! + ! -- initialize counter + idx = 0 + + + ! -- FLOW JA FACE + nlen = 0 + do n = 1, this%nodes + ivertflag = this%uzfobj%ivertcon(n) + if ( ivertflag > 0 ) then + nlen = nlen + 1 + end if + end do + if (nlen > 0) then + idx = idx + 1 + call this%budobj%budterm(idx)%reset(nlen * 2) + do n = 1, this%nodes + ivertflag = this%uzfobj%ivertcon(n) + if (ivertflag > 0) then + a = this%uzfobj%uzfarea(n) + q = this%uzfobj%surfluxbelow(n) * a + this%qauxcbc(1) = a + if (q > DZERO) then + q = -q + end if + n1 = n + n2 = ivertflag + call this%budobj%budterm(idx)%update_term(n1, n2, q, this%qauxcbc) + call this%budobj%budterm(idx)%update_term(n2, n1, -q, this%qauxcbc) + end if + end do + end if + + + ! -- GWF (LEAKAGE) + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nodes) + do n = 1, this%nodes + this%qauxcbc(1) = this%uzfobj%uzfarea(n) + n2 = this%igwfnode(n) + q = -this%rch(n) + call this%budobj%budterm(idx)%update_term(n, n2, q, this%qauxcbc) + end do + + + ! -- INFILTRATION + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nodes) + do n = 1, this%nodes + q = this%appliedinf(n) + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + + + ! -- REJECTED INFILTRATION + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nodes) + do n = 1, this%nodes + q = this%rejinf(n) + if (q > DZERO) then + q = -q + end if + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + + + ! -- UNSATURATED EVT + if (this%ietflag /= 0) then + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nodes) + do n = 1, this%nodes + q = this%uzet(n) + if (q > DZERO) then + q = -q + end if + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + end if + + + ! -- STORAGE + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nodes) + do n = 1, this%nodes + q = -this%qsto(n) + top = this%uzfobj%celtop(n) + bot = this%uzfobj%watab(n) + thick = top - bot + if (thick > DZERO) then + fm = this%uzfobj%unsat_stor(n, thick) + v = fm * this%uzfobj%uzfarea(n) + else + v = DZERO + end if + this%qauxcbc(1) = v + call this%budobj%budterm(idx)%update_term(n, n, q, this%qauxcbc) + end do + + + ! -- MOVER + if (this%imover == 1) then + + ! -- FROM MOVER + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nodes) + do n = 1, this%nodes + q = this%pakmvrobj%get_qfrommvr(n) + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + + + ! -- REJ-INF-TO-MVR + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nodes) + do n = 1, this%nodes + q = this%rejinftomvr(n) + if (q > DZERO) then + q = -q + end if + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + + end if + + + ! -- AUXILIARY VARIABLES + naux = this%naux + if (naux > 0) then + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nodes) + do n = 1, this%nodes + q = DZERO + call this%budobj%budterm(idx)%update_term(n, n, q, this%auxvar(:, n)) + end do + end if + ! + ! --Terms are filled, now accumulate them for this time step + call this%budobj%accumulate_terms() + ! + ! -- return + return + end subroutine uzf_fill_budobj + +end module UzfModule diff --git a/src/Model/GroundWaterFlow/gwf3wel8.f90 b/src/Model/GroundWaterFlow/gwf3wel8.f90 index 7ad1007ecdc..c1df258b17f 100644 --- a/src/Model/GroundWaterFlow/gwf3wel8.f90 +++ b/src/Model/GroundWaterFlow/gwf3wel8.f90 @@ -1,450 +1,450 @@ -module WelModule - ! - use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, DEM1, DONE, LENFTYPE - use BndModule, only: BndType - use ObsModule, only: DefaultObsIdProcessor - use SmoothingModule, only: sQSaturation, sQSaturationDerivative - use TimeSeriesLinkModule, only: TimeSeriesLinkType, & - GetTimeSeriesLinkFromList - use BlockParserModule, only: BlockParserType - ! - implicit none - ! - private - public :: wel_create - ! - character(len=LENFTYPE) :: ftype = 'WEL' - character(len=16) :: text = ' WEL' - ! - type, extends(BndType) :: WelType - integer(I4B), pointer :: iflowred => null() - real(DP), pointer :: flowred => null() - contains - procedure :: allocate_scalars => wel_allocate_scalars - procedure :: bnd_options => wel_options - procedure :: bnd_cf => wel_cf - procedure :: bnd_fc => wel_fc - procedure :: bnd_fn => wel_fn - procedure :: bnd_da => wel_da - procedure :: define_listlabel - ! -- methods for observations - procedure, public :: bnd_obs_supported => wel_obs_supported - procedure, public :: bnd_df_obs => wel_df_obs - ! -- methods for time series - procedure, public :: bnd_rp_ts => wel_rp_ts - end type weltype - -contains - - subroutine wel_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) -! ****************************************************************************** -! wel_create -- Create a New Well Package -! Subroutine: (1) create new-style package -! (2) point bndobj to the new package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout - character(len=*), intent(in) :: namemodel - character(len=*), intent(in) :: pakname - ! -- local - type(WelType), pointer :: welobj -! ------------------------------------------------------------------------------ - ! - ! -- allocate the object and assign values to object variables - allocate(welobj) - packobj => welobj - ! - ! -- create name and origin - call packobj%set_names(ibcnum, namemodel, pakname, ftype) - packobj%text = text - ! - ! -- allocate scalars - call welobj%allocate_scalars() - ! - ! -- initialize package - call packobj%pack_initialize() - - packobj%inunit=inunit - packobj%iout=iout - packobj%id=id - packobj%ibcnum = ibcnum - packobj%ncolbnd=1 - packobj%iscloc=1 - packobj%ictorigin = 'NPF' - ! - ! -- return - return - end subroutine wel_create - - subroutine wel_da(this) -! ****************************************************************************** -! wel_da -- deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(WelType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Deallocate parent package - call this%BndType%bnd_da() - ! - ! -- scalars - call mem_deallocate(this%iflowred) - call mem_deallocate(this%flowred) - ! - ! -- return - return - end subroutine wel_da - - subroutine wel_allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -- allocate scalar members -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(WelType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- call standard BndType allocate scalars - call this%BndType%allocate_scalars() - ! - ! -- allocate the object and assign values to object variables - call mem_allocate(this%iflowred, 'IFLOWRED', this%origin) - call mem_allocate(this%flowred, 'FLOWRED', this%origin) - ! - ! -- Set values - this%iflowred = 0 - this%flowred = DZERO - ! - ! -- return - return - end subroutine wel_allocate_scalars - - subroutine wel_options(this, option, found) -! ****************************************************************************** -! wel_options -- set options specific to WelType -! -! rch_options overrides BndType%bnd_options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use InputOutputModule, only: urword - ! -- dummy - class(WelType), intent(inout) :: this - character(len=*), intent(inout) :: option - logical, intent(inout) :: found - ! -- local - real(DP) :: r - ! -- formats - character(len=*),parameter :: fmtflowred = & - "(4x, 'AUTOMATIC FLOW REDUCTION OF WELLS IMPLEMENTED.')" - character(len=*),parameter :: fmtflowredv = & - "(4x, 'AUTOMATIC FLOW REDUCTION FRACTION (',g15.7,').')" -! ------------------------------------------------------------------------------ - ! - ! -- Check for 'AUTO_FLOW_REDUCE' and set this%iflowred - select case (option) - case('AUTO_FLOW_REDUCE') - this%iflowred = 1 - r = this%parser%GetDouble() - if (r <= DZERO) then - r = DEM1 - else if (r > DONE) then - r = DONE - end if - this%flowred = r - ! - ! -- Write option and return with found set to true - if(this%iflowred > 0) & - write(this%iout, fmtflowred) - write(this%iout, fmtflowredv) this%flowred - found = .true. - case('MOVER') - this%imover = 1 - write(this%iout, '(4x,A)') 'MOVER OPTION ENABLED' - found = .true. - case default - ! - ! -- No options found - found = .false. - end select - ! - ! -- return - return - end subroutine wel_options - - subroutine wel_cf(this, reset_mover) -! ****************************************************************************** -! wel_cf -- Formulate the HCOF and RHS terms -! Subroutine: (1) skip in no wells -! (2) calculate hcof and rhs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(WelType) :: this - logical, intent(in), optional :: reset_mover - ! -- local - integer(I4B) :: i, node, ict - real(DP) :: qmult - real(DP) :: q - real(DP) :: tp - real(DP) :: bt - real(DP) :: thick - logical :: lrm -! ------------------------------------------------------------------------------ - ! - ! -- Return if no wells - if(this%nbound == 0) return - ! - ! -- pakmvrobj cf - lrm = .true. - if (present(reset_mover)) lrm = reset_mover - if(this%imover == 1 .and. lrm) then - call this%pakmvrobj%cf() - endif - ! - ! -- Calculate hcof and rhs for each well entry - do i = 1, this%nbound - node = this%nodelist(i) - this%hcof(i) = DZERO - if(this%ibound(node) <= 0) then - this%rhs(i) = DZERO - cycle - end if - q = this%bound(1,i) - if (this%iflowred /= 0 .and. q < DZERO) then - ict = this%icelltype(node) - if (ict /= 0) then - tp = this%dis%top(node) - bt = this%dis%bot(node) - thick = tp - bt - tp = bt + this%flowred * thick - qmult = sQSaturation(tp, bt, this%xnew(node)) - q = q * qmult - endif - end if - this%rhs(i) = -q - enddo - ! - return - end subroutine wel_cf - - subroutine wel_fc(this, rhs, ia, idxglo, amatsln) -! ************************************************************************** -! wel_fc -- Copy rhs and hcof into solution rhs and amat -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - ! -- dummy - class(WelType) :: this - real(DP), dimension(:), intent(inout) :: rhs - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln - ! -- local - integer(I4B) :: i, n, ipos -! -------------------------------------------------------------------------- - ! - ! -- pakmvrobj fc - if(this%imover == 1) then - call this%pakmvrobj%fc() - endif - ! - ! -- Copy package rhs and hcof into solution rhs and amat - do i = 1, this%nbound - n = this%nodelist(i) - rhs(n) = rhs(n) + this%rhs(i) - ipos = ia(n) - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) - ! - ! -- If mover is active and this well is discharging, - ! store available water (as positive value). - if(this%imover == 1 .and. this%rhs(i) > DZERO) then - call this%pakmvrobj%accumulate_qformvr(i, this%rhs(i)) - endif - enddo - ! - ! -- return - return - end subroutine wel_fc - - subroutine wel_fn(this, rhs, ia, idxglo, amatsln) -! ************************************************************************** -! wel_fn -- Fill newton terms -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - implicit none - ! -- dummy - class(WelType) :: this - real(DP), dimension(:), intent(inout) :: rhs - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln - ! -- local - integer(I4B) :: i, node, ipos, ict - real(DP) :: drterm - real(DP) :: q - real(DP) :: tp - real(DP) :: bt - real(DP) :: thick -! -------------------------------------------------------------------------- - - ! - ! -- Copy package rhs and hcof into solution rhs and amat - do i = 1, this%nbound - node = this%nodelist(i) - ! - ! -- test if node is constant or inactive - if(this%ibound(node) <= 0) then - cycle - end if - ! - ! -- well rate is possibly head dependent - ict = this%icelltype(node) - if (this%iflowred /= 0 .and. ict /= 0) then - ipos = ia(node) - q = -this%rhs(i) - if (q < DZERO) then - ! -- calculate derivative for well - tp = this%dis%top(node) - bt = this%dis%bot(node) - thick = tp - bt - tp = bt + this%flowred * thick - drterm = sQSaturationDerivative(tp, bt, this%xnew(node)) - drterm = drterm * this%bound(1,i) - !--fill amat and rhs with newton-raphson terms - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + drterm - rhs(node) = rhs(node) + drterm * this%xnew(node) - end if - end if - end do - ! - ! -- return - return - end subroutine wel_fn - - - subroutine define_listlabel(this) -! ****************************************************************************** -! define_listlabel -- Define the list heading that is written to iout when -! PRINT_INPUT option is used. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(WelType), intent(inout) :: this -! ------------------------------------------------------------------------------ - ! - ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' - else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif - ! - ! -- return - return - end subroutine define_listlabel - - ! -- Procedures related to observations - logical function wel_obs_supported(this) - ! ****************************************************************************** - ! wel_obs_supported - ! -- Return true because WEL package supports observations. - ! -- Overrides BndType%bnd_obs_supported() - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - implicit none - class(WelType) :: this - ! ------------------------------------------------------------------------------ - wel_obs_supported = .true. - return - end function wel_obs_supported - - subroutine wel_df_obs(this) - ! ****************************************************************************** - ! wel_df_obs (implements bnd_df_obs) - ! -- Store observation type supported by WEL package. - ! -- Overrides BndType%bnd_df_obs - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - class(WelType) :: this - ! -- local - integer(I4B) :: indx - ! ------------------------------------------------------------------------------ - call this%obs%StoreObsType('wel', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor - ! - ! -- Store obs type and assign procedure pointer - ! for to-mvr observation type. - call this%obs%StoreObsType('to-mvr', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor - ! - ! -- return - return - end subroutine wel_df_obs - - ! -- Procedure related to time series - - subroutine wel_rp_ts(this) - ! -- Assign tsLink%Text appropriately for - ! all time series in use by package. - ! In the WEL package only the Q variable - ! can be controlled by time series. - ! -- dummy - class(WelType), intent(inout) :: this - ! -- local - integer(I4B) :: i, nlinks - type(TimeSeriesLinkType), pointer :: tslink => null() - ! - nlinks = this%TsManager%boundtslinks%Count() - do i=1,nlinks - tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) - if (associated(tslink)) then - if (tslink%JCol==1) then - tslink%Text = 'Q' - endif - endif - enddo - ! - return - end subroutine wel_rp_ts - -end module WelModule +module WelModule + ! + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, DEM1, DONE, LENFTYPE + use BndModule, only: BndType + use ObsModule, only: DefaultObsIdProcessor + use SmoothingModule, only: sQSaturation, sQSaturationDerivative + use TimeSeriesLinkModule, only: TimeSeriesLinkType, & + GetTimeSeriesLinkFromList + use BlockParserModule, only: BlockParserType + ! + implicit none + ! + private + public :: wel_create + ! + character(len=LENFTYPE) :: ftype = 'WEL' + character(len=16) :: text = ' WEL' + ! + type, extends(BndType) :: WelType + integer(I4B), pointer :: iflowred => null() + real(DP), pointer :: flowred => null() + contains + procedure :: allocate_scalars => wel_allocate_scalars + procedure :: bnd_options => wel_options + procedure :: bnd_cf => wel_cf + procedure :: bnd_fc => wel_fc + procedure :: bnd_fn => wel_fn + procedure :: bnd_da => wel_da + procedure :: define_listlabel + ! -- methods for observations + procedure, public :: bnd_obs_supported => wel_obs_supported + procedure, public :: bnd_df_obs => wel_df_obs + ! -- methods for time series + procedure, public :: bnd_rp_ts => wel_rp_ts + end type weltype + +contains + + subroutine wel_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) +! ****************************************************************************** +! wel_create -- Create a New Well Package +! Subroutine: (1) create new-style package +! (2) point bndobj to the new package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BndType), pointer :: packobj + integer(I4B),intent(in) :: id + integer(I4B),intent(in) :: ibcnum + integer(I4B),intent(in) :: inunit + integer(I4B),intent(in) :: iout + character(len=*), intent(in) :: namemodel + character(len=*), intent(in) :: pakname + ! -- local + type(WelType), pointer :: welobj +! ------------------------------------------------------------------------------ + ! + ! -- allocate the object and assign values to object variables + allocate(welobj) + packobj => welobj + ! + ! -- create name and origin + call packobj%set_names(ibcnum, namemodel, pakname, ftype) + packobj%text = text + ! + ! -- allocate scalars + call welobj%allocate_scalars() + ! + ! -- initialize package + call packobj%pack_initialize() + + packobj%inunit=inunit + packobj%iout=iout + packobj%id=id + packobj%ibcnum = ibcnum + packobj%ncolbnd=1 + packobj%iscloc=1 + packobj%ictorigin = 'NPF' + ! + ! -- return + return + end subroutine wel_create + + subroutine wel_da(this) +! ****************************************************************************** +! wel_da -- deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(WelType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Deallocate parent package + call this%BndType%bnd_da() + ! + ! -- scalars + call mem_deallocate(this%iflowred) + call mem_deallocate(this%flowred) + ! + ! -- return + return + end subroutine wel_da + + subroutine wel_allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars -- allocate scalar members +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(WelType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- call standard BndType allocate scalars + call this%BndType%allocate_scalars() + ! + ! -- allocate the object and assign values to object variables + call mem_allocate(this%iflowred, 'IFLOWRED', this%origin) + call mem_allocate(this%flowred, 'FLOWRED', this%origin) + ! + ! -- Set values + this%iflowred = 0 + this%flowred = DZERO + ! + ! -- return + return + end subroutine wel_allocate_scalars + + subroutine wel_options(this, option, found) +! ****************************************************************************** +! wel_options -- set options specific to WelType +! +! rch_options overrides BndType%bnd_options +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use InputOutputModule, only: urword + ! -- dummy + class(WelType), intent(inout) :: this + character(len=*), intent(inout) :: option + logical, intent(inout) :: found + ! -- local + real(DP) :: r + ! -- formats + character(len=*),parameter :: fmtflowred = & + "(4x, 'AUTOMATIC FLOW REDUCTION OF WELLS IMPLEMENTED.')" + character(len=*),parameter :: fmtflowredv = & + "(4x, 'AUTOMATIC FLOW REDUCTION FRACTION (',g15.7,').')" +! ------------------------------------------------------------------------------ + ! + ! -- Check for 'AUTO_FLOW_REDUCE' and set this%iflowred + select case (option) + case('AUTO_FLOW_REDUCE') + this%iflowred = 1 + r = this%parser%GetDouble() + if (r <= DZERO) then + r = DEM1 + else if (r > DONE) then + r = DONE + end if + this%flowred = r + ! + ! -- Write option and return with found set to true + if(this%iflowred > 0) & + write(this%iout, fmtflowred) + write(this%iout, fmtflowredv) this%flowred + found = .true. + case('MOVER') + this%imover = 1 + write(this%iout, '(4x,A)') 'MOVER OPTION ENABLED' + found = .true. + case default + ! + ! -- No options found + found = .false. + end select + ! + ! -- return + return + end subroutine wel_options + + subroutine wel_cf(this, reset_mover) +! ****************************************************************************** +! wel_cf -- Formulate the HCOF and RHS terms +! Subroutine: (1) skip in no wells +! (2) calculate hcof and rhs +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(WelType) :: this + logical, intent(in), optional :: reset_mover + ! -- local + integer(I4B) :: i, node, ict + real(DP) :: qmult + real(DP) :: q + real(DP) :: tp + real(DP) :: bt + real(DP) :: thick + logical :: lrm +! ------------------------------------------------------------------------------ + ! + ! -- Return if no wells + if(this%nbound == 0) return + ! + ! -- pakmvrobj cf + lrm = .true. + if (present(reset_mover)) lrm = reset_mover + if(this%imover == 1 .and. lrm) then + call this%pakmvrobj%cf() + endif + ! + ! -- Calculate hcof and rhs for each well entry + do i = 1, this%nbound + node = this%nodelist(i) + this%hcof(i) = DZERO + if(this%ibound(node) <= 0) then + this%rhs(i) = DZERO + cycle + end if + q = this%bound(1,i) + if (this%iflowred /= 0 .and. q < DZERO) then + ict = this%icelltype(node) + if (ict /= 0) then + tp = this%dis%top(node) + bt = this%dis%bot(node) + thick = tp - bt + tp = bt + this%flowred * thick + qmult = sQSaturation(tp, bt, this%xnew(node)) + q = q * qmult + endif + end if + this%rhs(i) = -q + enddo + ! + return + end subroutine wel_cf + + subroutine wel_fc(this, rhs, ia, idxglo, amatsln) +! ************************************************************************** +! wel_fc -- Copy rhs and hcof into solution rhs and amat +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + ! -- dummy + class(WelType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + real(DP), dimension(:), intent(inout) :: amatsln + ! -- local + integer(I4B) :: i, n, ipos +! -------------------------------------------------------------------------- + ! + ! -- pakmvrobj fc + if(this%imover == 1) then + call this%pakmvrobj%fc() + endif + ! + ! -- Copy package rhs and hcof into solution rhs and amat + do i = 1, this%nbound + n = this%nodelist(i) + rhs(n) = rhs(n) + this%rhs(i) + ipos = ia(n) + amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) + ! + ! -- If mover is active and this well is discharging, + ! store available water (as positive value). + if(this%imover == 1 .and. this%rhs(i) > DZERO) then + call this%pakmvrobj%accumulate_qformvr(i, this%rhs(i)) + endif + enddo + ! + ! -- return + return + end subroutine wel_fc + + subroutine wel_fn(this, rhs, ia, idxglo, amatsln) +! ************************************************************************** +! wel_fn -- Fill newton terms +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + implicit none + ! -- dummy + class(WelType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + real(DP), dimension(:), intent(inout) :: amatsln + ! -- local + integer(I4B) :: i, node, ipos, ict + real(DP) :: drterm + real(DP) :: q + real(DP) :: tp + real(DP) :: bt + real(DP) :: thick +! -------------------------------------------------------------------------- + + ! + ! -- Copy package rhs and hcof into solution rhs and amat + do i = 1, this%nbound + node = this%nodelist(i) + ! + ! -- test if node is constant or inactive + if(this%ibound(node) <= 0) then + cycle + end if + ! + ! -- well rate is possibly head dependent + ict = this%icelltype(node) + if (this%iflowred /= 0 .and. ict /= 0) then + ipos = ia(node) + q = -this%rhs(i) + if (q < DZERO) then + ! -- calculate derivative for well + tp = this%dis%top(node) + bt = this%dis%bot(node) + thick = tp - bt + tp = bt + this%flowred * thick + drterm = sQSaturationDerivative(tp, bt, this%xnew(node)) + drterm = drterm * this%bound(1,i) + !--fill amat and rhs with newton-raphson terms + amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + drterm + rhs(node) = rhs(node) + drterm * this%xnew(node) + end if + end if + end do + ! + ! -- return + return + end subroutine wel_fn + + + subroutine define_listlabel(this) +! ****************************************************************************** +! define_listlabel -- Define the list heading that is written to iout when +! PRINT_INPUT option is used. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(WelType), intent(inout) :: this +! ------------------------------------------------------------------------------ + ! + ! -- create the header list label + this%listlabel = trim(this%filtyp) // ' NO.' + if(this%dis%ndim == 3) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif(this%dis%ndim == 2) then + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + else + write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + endif + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' + if(this%inamedbound == 1) then + write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + endif + ! + ! -- return + return + end subroutine define_listlabel + + ! -- Procedures related to observations + logical function wel_obs_supported(this) + ! ****************************************************************************** + ! wel_obs_supported + ! -- Return true because WEL package supports observations. + ! -- Overrides BndType%bnd_obs_supported() + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + implicit none + class(WelType) :: this + ! ------------------------------------------------------------------------------ + wel_obs_supported = .true. + return + end function wel_obs_supported + + subroutine wel_df_obs(this) + ! ****************************************************************************** + ! wel_df_obs (implements bnd_df_obs) + ! -- Store observation type supported by WEL package. + ! -- Overrides BndType%bnd_df_obs + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + implicit none + ! -- dummy + class(WelType) :: this + ! -- local + integer(I4B) :: indx + ! ------------------------------------------------------------------------------ + call this%obs%StoreObsType('wel', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor + ! + ! -- Store obs type and assign procedure pointer + ! for to-mvr observation type. + call this%obs%StoreObsType('to-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor + ! + ! -- return + return + end subroutine wel_df_obs + + ! -- Procedure related to time series + + subroutine wel_rp_ts(this) + ! -- Assign tsLink%Text appropriately for + ! all time series in use by package. + ! In the WEL package only the Q variable + ! can be controlled by time series. + ! -- dummy + class(WelType), intent(inout) :: this + ! -- local + integer(I4B) :: i, nlinks + type(TimeSeriesLinkType), pointer :: tslink => null() + ! + nlinks = this%TsManager%boundtslinks%Count() + do i=1,nlinks + tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) + if (associated(tslink)) then + if (tslink%JCol==1) then + tslink%Text = 'Q' + endif + endif + enddo + ! + return + end subroutine wel_rp_ts + +end module WelModule diff --git a/src/Model/ModelUtilities/BoundaryPackage.f90 b/src/Model/ModelUtilities/BoundaryPackage.f90 index 3666b27c7c0..ad2e4434441 100644 --- a/src/Model/ModelUtilities/BoundaryPackage.f90 +++ b/src/Model/ModelUtilities/BoundaryPackage.f90 @@ -1,1705 +1,1705 @@ -module BndModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LENAUXNAME, LENBOUNDNAME, LENFTYPE, & - DZERO, LENMODELNAME, LENPACKAGENAME, & - LENORIGIN, MAXCHARLEN, LINELENGTH, & - DNODATA, LENLISTLABEL, LENPAKLOC, & - TABLEFT, TABCENTER - use SimModule, only: count_errors, store_error, ustop, & - store_error_unit - use NumericalPackageModule, only: NumericalPackageType - use ArrayHandlersModule, only: ExpandArray - use ObsModule, only: ObsType, obs_cr - use TdisModule, only: delt, totimc - use ObserveModule, only: ObserveType - use InputOutputModule, only: GetUnit, openfile - use TimeArraySeriesManagerModule, only: TimeArraySeriesManagerType - use TimeSeriesLinkModule, only: TimeSeriesLinkType - use TimeSeriesManagerModule, only: TimeSeriesManagerType - use ListModule, only: ListType - use PackageMoverModule, only: PackageMoverType - use BaseDisModule, only: DisBaseType - use BlockParserModule, only: BlockParserType - use TableModule, only: TableType, table_cr - - implicit none - - private - public :: BndType, AddBndToList, GetBndFromList - private :: CastAsBndClass - - type, extends(NumericalPackageType) :: BndType - ! -- characters - character(len=LENLISTLABEL) :: listlabel = '' !title of table written for RP - character(len=LENPACKAGENAME) :: text = '' - character(len=LENAUXNAME), allocatable, dimension(:) :: auxname !name for each auxiliary variable - character(len=LENBOUNDNAME), dimension(:), pointer, & - contiguous :: boundname => null() !vector of boundnames - ! - ! -- scalars - integer(I4B), pointer :: ibcnum => null() !consecutive package number for this boundary condition - integer(I4B), pointer :: maxbound => null() !max number of boundaries - integer(I4B), pointer :: nbound => null() !number of boundaries for current stress period - integer(I4B), pointer :: ncolbnd => null() !number of columns of the bound array - integer(I4B), pointer :: iscloc => null() !bound column to scale with SFAC - integer(I4B), pointer :: naux => null() !number of auxiliary variables - integer(I4B), pointer :: inamedbound => null() !flag to read boundnames - integer(I4B), pointer :: iauxmultcol => null() !column to use as multiplier for column iscloc - integer(I4B), pointer :: npakeq => null() !number of equations in this package (normally 0 unless package adds rows to matrix) - integer(I4B), pointer :: ioffset => null() !offset of this package in the model - ! -- arrays - integer(I4B), dimension(:), pointer, contiguous :: nodelist => null() !vector of reduced node numbers - real(DP), dimension(:,:), pointer, contiguous :: bound => null() !array of package specific boundary numbers - real(DP), dimension(:), pointer, contiguous :: hcof => null() !diagonal contribution - real(DP), dimension(:), pointer, contiguous :: rhs => null() !right-hand side contribution - real(DP), dimension(:,:), pointer, contiguous :: auxvar => null() !auxiliary variable array - real(DP), dimension(:), pointer, contiguous :: simvals => null() !simulated values - real(DP), dimension(:), pointer, contiguous :: simtomvr => null() !simulated values - ! - ! -- water mover flag and object - integer(I4B), pointer :: imover => null() - type(PackageMoverType), pointer :: pakmvrobj => null() - ! - ! -- timeseries - type(TimeSeriesManagerType), pointer :: TsManager => null() ! time series manager - type(TimeArraySeriesManagerType), pointer :: TasManager => null() ! time array series manager - integer(I4B) :: indxconvertflux = 0 ! indxconvertflux is column of bound to multiply by area to convert flux to rate - logical :: AllowTimeArraySeries = .false. - ! - ! -- pointers for observations - integer(I4B), pointer :: inobspkg => null() ! unit number for obs package - type(ObsType), pointer :: obs => null() ! observation package - ! - ! -- pointers to model/solution variables - integer(I4B), pointer :: neq !number of equations for model - integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !ibound array - real(DP), dimension(:), pointer, contiguous :: xnew => null() !dependent variable (head) for this time step - real(DP), dimension(:), pointer, contiguous :: xold => null() !dependent variable for last time step - real(DP), dimension(:), pointer, contiguous :: flowja => null() !intercell flows - integer(I4B), dimension(:), pointer, contiguous :: icelltype => null() !pointer to icelltype array in NPF - character(len=10) :: ictorigin = '' !package name for icelltype (NPF for GWF) - ! - ! -- table objects - type(TableType), pointer :: inputtab => null() - type(TableType), pointer :: outputtab => null() - type(TableType), pointer :: errortab => null() - - - contains - procedure :: bnd_df - procedure :: bnd_ac - procedure :: bnd_mc - procedure :: bnd_ar - procedure :: bnd_rp - procedure :: bnd_ad - procedure :: bnd_ck - procedure :: bnd_cf - procedure :: bnd_fc - procedure :: bnd_fn - procedure :: bnd_nur - procedure :: bnd_cc - procedure :: bnd_bd - procedure :: bnd_ot - procedure :: bnd_da - - procedure :: allocate_scalars - procedure :: allocate_arrays - procedure :: pack_initialize - procedure :: read_options => bnd_read_options - procedure :: read_dimensions => bnd_read_dimensions - procedure :: read_initial_attr => bnd_read_initial_attr - procedure :: bnd_options - procedure :: set_pointers - procedure :: define_listlabel - procedure, private :: pak_setup_outputtab - ! - ! -- procedures to support observations - procedure, public :: bnd_obs_supported - procedure, public :: bnd_df_obs - procedure, public :: bnd_bd_obs - procedure, public :: bnd_ot_obs - procedure, public :: bnd_rp_obs - ! - ! -- procedure to support time series - procedure, public :: bnd_rp_ts - ! - end type BndType - - contains - - subroutine bnd_df(this, neq, dis) -! ****************************************************************************** -! bnd_df -- Define package options and dimensions -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- module - use TimeSeriesManagerModule, only: tsmanager_cr - use TimeArraySeriesManagerModule, only: tasmanager_cr - ! -- dummy - class(BndType),intent(inout) :: this - integer(I4B), intent(inout) :: neq - class(DisBaseType), pointer :: dis - ! -- local - ! -- format -! ------------------------------------------------------------------------------ - ! - ! -- set pointer to dis object for the model - this%dis => dis - ! - ! -- Create time series managers - call tsmanager_cr(this%TsManager, this%iout) - call tasmanager_cr(this%TasManager, dis, this%iout) - ! - ! -- create obs package - call obs_cr(this%obs, this%inobspkg) - ! - ! -- Write information to model list file - write(this%iout,1) this%filtyp, trim(adjustl(this%text)), this%inunit -1 format(1X,/1X,a,' -- ',a,' PACKAGE, VERSION 8, 2/22/2014', & - ' INPUT READ FROM UNIT ',I0) - ! - ! -- Initialize block parser - call this%parser%Initialize(this%inunit, this%iout) - ! - ! -- set and read options - call this%read_options() - ! - ! -- Now that time series will have been read, need to call the df - ! routine to define the manager - call this%tsmanager%tsmanager_df() - call this%tasmanager%tasmanager_df() - ! - ! -- read the package dimensions block - call this%read_dimensions() - ! - ! -- update package moffset for packages that add rows - if (this%npakeq > 0) then - this%ioffset = neq - this%dis%nodes - end if - ! - ! -- update neq - neq = neq + this%npakeq - ! - ! -- Store information needed for observations - if (this%bnd_obs_supported()) then - call this%obs%obs_df(this%iout, this%name, this%filtyp, this%dis) - call this%bnd_df_obs() - endif - ! - ! -- return - return - end subroutine bnd_df - - subroutine bnd_ac(this, moffset, sparse) -! ****************************************************************************** -! bnd_ac -- Add package connection to matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use SparseModule, only: sparsematrix - use SimModule, only: store_error, ustop - ! -- dummy - class(BndType),intent(inout) :: this - integer(I4B), intent(in) :: moffset - type(sparsematrix), intent(inout) :: sparse - ! -- local - ! -- format -! ------------------------------------------------------------------------------ - ! - ! - ! -- return - return - end subroutine bnd_ac - - subroutine bnd_mc(this, moffset, iasln, jasln) -! ****************************************************************************** -! bnd_mc -- Map package connection to matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(BndType),intent(inout) :: this - integer(I4B), intent(in) :: moffset - integer(I4B), dimension(:), intent(in) :: iasln - integer(I4B), dimension(:), intent(in) :: jasln - ! -- local - ! -- format -! ------------------------------------------------------------------------------ - ! - ! - ! -- return - return - end subroutine bnd_mc - - subroutine bnd_ar(this) -! ****************************************************************************** -! bnd_ar -- Allocate and Read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_setptr - ! -- dummy - class(BndType),intent(inout) :: this - ! -- local - ! -- format -! ------------------------------------------------------------------------------ - ! - call this%obs%obs_ar() - ! - ! -- Allocate arrays in package superclass - call this%allocate_arrays() - ! - ! -- read optional initial package parameters - call this%read_initial_attr() - ! - ! -- setup pakmvrobj for standard stress packages - if (this%imover == 1) then - allocate(this%pakmvrobj) - call this%pakmvrobj%ar(this%maxbound, 0, this%origin) - endif - ! - ! -- return - return - end subroutine bnd_ar - - subroutine bnd_rp(this) -! ****************************************************************************** -! bnd_rp -- Read and Prepare -! Subroutine: (1) read itmp -! (2) read new boundaries if itmp>0 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use TdisModule, only: kper, nper - use SimModule, only: ustop, store_error, store_error_unit - ! -- dummy - class(BndType),intent(inout) :: this - ! -- local - integer(I4B) :: ierr, nlist - logical :: isfound - character(len=LINELENGTH) :: line, errmsg - ! -- formats - character(len=*),parameter :: fmtblkerr = & - "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - character(len=*),parameter :: fmtlsp = & - "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" - character(len=*), parameter :: fmtnbd = & - "(1X,/1X,'THE NUMBER OF ACTIVE ',A,'S (',I6, & - &') IS GREATER THAN MAXIMUM(',I6,')')" -! ------------------------------------------------------------------------------ - ! - ! -- Set ionper to the stress period number for which a new block of data - ! will be read. - if(this%inunit == 0) return - ! - ! -- get stress period data - if (this%ionper < kper) then - ! - ! -- get period block - call this%parser%GetBlock('PERIOD', isfound, ierr, & - supportOpenClose=.true.) - if (isfound) then - ! - ! -- read ionper and check for increasing period numbers - call this%read_check_ionper() - else - ! - ! -- PERIOD block not found - if (ierr < 0) then - ! -- End of file found; data applies for remainder of simulation. - this%ionper = nper + 1 - else - ! -- Found invalid block - call this%parser%GetCurrentLine(line) - write(errmsg, fmtblkerr) adjustl(trim(line)) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - endif - end if - ! - ! -- read data if ionper == kper - if(this%ionper == kper) then - nlist = -1 - ! -- Remove all time-series and time-array-series links associated with - ! this package. - call this%TsManager%Reset(this%name) - call this%TasManager%Reset(this%name) - ! - ! -- Read data as a list - call this%dis%read_list(this%parser%iuactive, this%iout, & - this%iprpak, nlist, this%inamedbound, & - this%iauxmultcol, this%nodelist, & - this%bound, this%auxvar, this%auxname, & - this%boundname, this%listlabel, & - this%name, this%tsManager, this%iscloc) - this%nbound = nlist - ! - ! Define the tsLink%Text value(s) appropriately. - ! E.g. for WEL package, entry 1, assign tsLink%Text = 'Q' - ! For RIV package, entry 1 text = 'STAGE', entry 2 text = 'COND', - ! entry 3 text = 'RBOT'; etc. - call this%bnd_rp_ts() - ! - ! -- Terminate the block - call this%parser%terminateblock() - ! - else - write(this%iout,fmtlsp) trim(this%filtyp) - endif - ! - ! -- return - return - end subroutine bnd_rp - - subroutine bnd_ad(this) - use ConstantsModule, only: DZERO - class(BndType) :: this - !this package has no AD routine - real(DP) :: begintime, endtime - ! - ! -- Initialize time variables - begintime = totimc - endtime = begintime + delt - ! - ! -- Advance the time series managers - call this%TsManager%ad() - call this%TasManager%ad() - ! - ! -- For each observation, push simulated value and corresponding - ! simulation time from "current" to "preceding" and reset - ! "current" value. - call this%obs%obs_ad() - ! - return - end subroutine bnd_ad - - subroutine bnd_ck(this) -! ****************************************************************************** -! bnd_ck -- Check boundary condition data -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error - ! -- dummy - class(BndType),intent(inout) :: this - ! -- local - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- check stress period data - ! -- each package must override generic functionality - ! - ! -- return - return - end subroutine bnd_ck - - subroutine bnd_cf(this, reset_mover) -! ****************************************************************************** -! bnd_cf -- This is the package specific routine where a package adds its -! contributions to this%rhs and this%hcof -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - class(BndType) :: this - logical, intent(in), optional :: reset_mover -! ------------------------------------------------------------------------------ - ! -- bnd has no cf routine - ! - ! -- return - return - end subroutine bnd_cf - - subroutine bnd_fc(this, rhs, ia, idxglo, amatsln) -! ****************************************************************************** -! bnd_fc -- Copy rhs and hcof into solution rhs and amat -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(BndType) :: this - real(DP), dimension(:), intent(inout) :: rhs - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln - ! -- local - integer(I4B) :: i, n, ipos -! ------------------------------------------------------------------------------ - ! - ! -- Copy package rhs and hcof into solution rhs and amat - do i = 1, this%nbound - n = this%nodelist(i) - rhs(n) = rhs(n) + this%rhs(i) - ipos = ia(n) - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) - enddo - ! - ! -- return - return - end subroutine bnd_fc - - subroutine bnd_fn(this, rhs, ia, idxglo, amatsln) -! ****************************************************************************** -! bnd_fn -- add additional terms to convert conductance formulation -! to Newton-Raphson formulation -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(BndType) :: this - real(DP), dimension(:), intent(inout) :: rhs - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln - ! -- local -! ------------------------------------------------------------------------------ - - ! - ! -- No addition terms for newton-raphson with constant conductance - ! boundary conditions - ! - ! -- return - return - end subroutine bnd_fn - - subroutine bnd_nur(this, neqpak, x, xtemp, dx, inewtonur, dxmax, locmax) -! ****************************************************************************** -! bnd_nur -- under-relaxation -! Subroutine: (1) Under-relaxation of Groundwater Flow Model Package Heads -! for current outer iteration using the cell bottoms at the -! bottom of the model -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(BndType), intent(inout) :: this - integer(I4B), intent(in) :: neqpak - real(DP), dimension(neqpak), intent(inout) :: x - real(DP), dimension(neqpak), intent(in) :: xtemp - real(DP), dimension(neqpak), intent(inout) :: dx - integer(I4B), intent(inout) :: inewtonur - real(DP), intent(inout) :: dxmax - integer(I4B), intent(inout) :: locmax - ! -- local -! ------------------------------------------------------------------------------ - - ! - ! -- Newton-Raphson under-relaxation - ! - ! -- return - return - end subroutine bnd_nur - - subroutine bnd_cc(this, kiter, iend, icnvgmod, cpak, dpak) -! ****************************************************************************** -! bnd_cc -- additional convergence check for advanced packages -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(BndType), intent(inout) :: this - integer(I4B), intent(in) :: kiter - integer(I4B),intent(in) :: iend - integer(I4B), intent(in) :: icnvgmod - character(len=LENPAKLOC), intent(inout) :: cpak - real(DP), intent(inout) :: dpak - ! -- local -! ------------------------------------------------------------------------------ - - ! - ! -- No addition convergence check for boundary conditions - ! - ! -- return - return - end subroutine bnd_cc - - subroutine bnd_bd(this, x, idvfl, icbcfl, ibudfl, icbcun, iprobs, & - isuppress_output, model_budget, imap, iadv) -! ****************************************************************************** -! bnd_bd -- Calculate Volumetric Budget -! Note that the compact budget will always be used. -! Subroutine: (1) Process each package entry -! (2) Write output -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: delt - use ConstantsModule, only: LENBOUNDNAME, DZERO - use BudgetModule, only: BudgetType - ! -- dummy - class(BndType) :: this - real(DP),dimension(:),intent(in) :: x - integer(I4B), intent(in) :: idvfl - integer(I4B), intent(in) :: icbcfl - integer(I4B), intent(in) :: ibudfl - integer(I4B), intent(in) :: icbcun - integer(I4B), intent(in) :: iprobs - integer(I4B), intent(in) :: isuppress_output - type(BudgetType), intent(inout) :: model_budget - integer(I4B), dimension(:), optional, intent(in) :: imap - integer(I4B), optional, intent(in) :: iadv - ! -- local - character (len=LINELENGTH) :: title - character(len=20) :: nodestr - character (len=LENPACKAGENAME) :: text - integer(I4B) :: nodeu - integer(I4B) :: maxrows - integer(I4B) :: imover - integer(I4B) :: i, node, n2, ibinun - real(DP) :: q - real(DP) :: qtomvr - real(DP) :: ratin, ratout, rrate - integer(I4B) :: naux - ! -- for observations - character(len=LENBOUNDNAME) :: bname - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- check for iadv optional variable - if (present(iadv)) then - if (iadv == 1) then - imover = 0 - else - imover = 1 - end if - else - imover = this%imover - end if - ! - ! -- set maxrows - maxrows = 0 - if (ibudfl /= 0 .and. this%iprflow /= 0) then - do i = 1, this%nbound - node = this%nodelist(i) - if (node > 0) then - if (this%ibound(node) > 0) then - maxrows = maxrows + 1 - end if - end if - end do - if (maxrows > 0) then - call this%outputtab%set_maxbound(maxrows) - end if - title = trim(adjustl(this%text)) // ' PACKAGE (' // trim(this%name) // & - ') FLOW RATES' - call this%outputtab%set_title(title) - end if - ! - ! -- Clear accumulators and set flags - ratin = DZERO - ratout = DZERO - ! - ! -- Set unit number for binary output - if (this%ipakcb < 0) then - ibinun = icbcun - else if (this%ipakcb == 0) then - ibinun = 0 - else - ibinun = this%ipakcb - end if - if (icbcfl == 0) ibinun = 0 - if (isuppress_output /= 0) ibinun = 0 - ! - ! -- If cell-by-cell flows will be saved as a list, write header. - if(ibinun /= 0) then - naux = this%naux - call this%dis%record_srcdst_list_header(this%text, this%name_model, & - this%name_model, this%name_model, this%name, naux, & - this%auxname, ibinun, this%nbound, this%iout) - endif - ! - ! -- If no boundaries, skip flow calculations. - if(this%nbound > 0) then - ! - ! -- Loop through each boundary calculating flow. - do i = 1, this%nbound - node = this%nodelist(i) - ! -- assign boundary name - if (this%inamedbound>0) then - bname = this%boundname(i) - else - bname = '' - endif - ! - ! -- If cell is no-flow or constant-head, then ignore it. - rrate = DZERO - if (node > 0) then - if(this%ibound(node) > 0) then - ! - ! -- Calculate the flow rate into the cell. - rrate = this%hcof(i) * x(node) - this%rhs(i) - ! - ! -- modify rrate with to mover - if (rrate < DZERO) then - if (imover == 1) then - qtomvr = this%pakmvrobj%get_qtomvr(i) - rrate = rrate + qtomvr - end if - end if - ! - ! -- Print the individual rates if the budget is being printed - ! and PRINT_FLOWS was specified (this%iprflow<0) - if (ibudfl /= 0) then - if (this%iprflow /= 0) then - ! - ! -- set nodestr and write outputtab table - nodeu = this%dis%get_nodeuser(node) - call this%dis%nodeu_to_string(nodeu, nodestr) - call this%outputtab%print_list_entry(i, trim(adjustl(nodestr)), & - rrate, bname) - end if - end if - ! - ! -- See if flow is into aquifer or out of aquifer. - if(rrate < dzero) then - ! - ! -- Flow is out of aquifer; subtract rate from ratout. - ratout=ratout - rrate - else - ! - ! -- Flow is into aquifer; add rate to ratin. - ratin=ratin + rrate - endif - endif - endif - ! - ! -- If saving cell-by-cell flows in list, write flow - if (ibinun /= 0) then - n2 = i - if (present(imap)) n2 = imap(i) - call this%dis%record_mf6_list_entry(ibinun, node, n2, rrate, & - naux, this%auxvar(:,i), & - olconv2=.FALSE.) - end if - ! - ! -- Save simulated value to simvals array. - this%simvals(i) = rrate - ! - enddo - if (ibudfl /= 0) then - if (this%iprflow /= 0) then - write(this%iout,'(1x)') - end if - end if - - endif - ! - ! -- Store the rates - call model_budget%addentry(ratin, ratout, delt, this%text, & - isuppress_output, this%name) - if (imover == 1) then - ratin = DZERO - ratout = DZERO - text = trim(adjustl(this%text)) // '-TO-MVR' - text = adjustr(text) - if (ibudfl /= 0 .and. this%iprflow /= 0) then - title = trim(adjustl(this%text)) // ' PACKAGE (' // trim(this%name) // & - ') FLOW RATES TO-MVR' - call this%outputtab%set_title(title) - end if - ! - ! -- If cell-by-cell flows will be saved as a list, write header. - if(ibinun /= 0) then - naux = this%naux - call this%dis%record_srcdst_list_header(text, this%name_model, & - this%name_model, this%name_model, this%name, naux, & - this%auxname, ibinun, this%nbound, this%iout) - endif - ! - ! -- If no boundaries, skip flow calculations. - if(this%nbound > 0) then - ! - ! -- Loop through each boundary calculating flow. - do i = 1, this%nbound - node = this%nodelist(i) - ! -- assign boundary name - if (this%inamedbound>0) then - bname = this%boundname(i) - else - bname = '' - endif - ! - ! -- If cell is no-flow or constant-head, then ignore it. - rrate = DZERO - if (node > 0) then - if(this%ibound(node) > 0) then - ! - ! -- Calculate the flow rate into the cell. - q = this%hcof(i) * x(node) - this%rhs(i) - if (q < DZERO) then - rrate = this%pakmvrobj%get_qtomvr(i) - if (rrate > DZERO) then - rrate = -rrate - end if - end if - ! - ! -- Print the individual rates if the budget is being printed - ! and PRINT_FLOWS was specified (this%iprflow<0) - if(ibudfl /= 0) then - if(this%iprflow /= 0) then - ! - ! -- set nodestr and write outputtab table - nodeu = this%dis%get_nodeuser(node) - call this%dis%nodeu_to_string(nodeu, nodestr) - call this%outputtab%print_list_entry(i, trim(adjustl(nodestr)),& - rrate, bname) - endif - endif - ! - ! -- See if flow is into aquifer or out of aquifer. - if(rrate < dzero) then - ! - ! -- Flow is out of aquifer; subtract rate from ratout. - ratout=ratout - rrate - else - ! - ! -- Flow is into aquifer; add rate to ratin. - ratin=ratin + rrate - endif - endif - endif - ! - ! -- If saving cell-by-cell flows in list, write flow - if (ibinun /= 0) then - n2 = i - if (present(imap)) n2 = imap(i) - call this%dis%record_mf6_list_entry(ibinun, node, n2, rrate, & - naux, this%auxvar(:,i), & - olconv2=.FALSE.) - end if - ! - ! -- Save simulated value to simvals array. - this%simtomvr(i) = rrate - ! - enddo - endif - ! - ! -- Store the rates - call model_budget%addentry(ratin, ratout, delt, text, & - isuppress_output, this%name) - - end if - ! - ! -- Save the simulated values to the ObserveType objects - if (iprobs /= 0 .and. this%obs%npakobs > 0) then - call this%bnd_bd_obs() - endif - ! - ! -- return - return - end subroutine bnd_bd - - subroutine bnd_ot(this, kstp, kper, iout, ihedfl, ibudfl) -! ****************************************************************************** -! bnd_ot -- Output package budget -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(BndType) :: this - integer(I4B),intent(in) :: kstp - integer(I4B),intent(in) :: kper - integer(I4B),intent(in) :: iout - integer(I4B),intent(in) :: ihedfl - integer(I4B),intent(in) :: ibudfl - ! -- format -! ------------------------------------------------------------------------------ - ! - ! -- return - return - end subroutine bnd_ot - - subroutine bnd_da(this) -! ****************************************************************************** -! bnd_da -- Deallocate objects -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(BndType) :: this - ! -- format -! ------------------------------------------------------------------------------ - ! - ! -- deallocate arrays - call mem_deallocate(this%nodelist) - call mem_deallocate(this%bound) - call mem_deallocate(this%hcof) - call mem_deallocate(this%rhs) - call mem_deallocate(this%simvals) - call mem_deallocate(this%simtomvr) - call mem_deallocate(this%auxvar) - deallocate(this%boundname) - deallocate(this%auxname) - nullify(this%icelltype) - ! - ! -- pakmvrobj - if (this%imover /= 0) then - call this%pakmvrobj%da() - deallocate(this%pakmvrobj) - nullify(this%pakmvrobj) - endif - ! - ! -- input table object - if (associated(this%inputtab)) then - call this%inputtab%table_da() - deallocate(this%inputtab) - nullify(this%inputtab) - end if - ! - ! -- output table object - if (associated(this%outputtab)) then - call this%outputtab%table_da() - deallocate(this%outputtab) - nullify(this%outputtab) - end if - ! - ! -- error table object - if (associated(this%errortab)) then - call this%errortab%table_da() - deallocate(this%errortab) - nullify(this%errortab) - end if - ! - ! -- Deallocate scalars - call mem_deallocate(this%ibcnum) - call mem_deallocate(this%maxbound) - call mem_deallocate(this%nbound) - call mem_deallocate(this%ncolbnd) - call mem_deallocate(this%iscloc) - call mem_deallocate(this%naux) - call mem_deallocate(this%inamedbound) - call mem_deallocate(this%iauxmultcol) - call mem_deallocate(this%inobspkg) - call mem_deallocate(this%imover) - call mem_deallocate(this%npakeq) - call mem_deallocate(this%ioffset) - ! - ! -- deallocate methods on objects - call this%obs%obs_da() - call this%TsManager%da() - call this%TasManager%da() - ! - ! -- deallocate objects - deallocate(this%obs) - deallocate(this%TsManager) - deallocate(this%TasManager) - nullify(this%TsManager) - nullify(this%TasManager) - ! - ! -- Deallocate parent object - call this%NumericalPackageType%da() - ! - ! -- Return - return - end subroutine bnd_da - - subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -- Allocate Package Members -! Subroutine: (1) allocate -! (2) initialize -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate, mem_setptr - ! -- dummy - class(BndType) :: this - ! -- local - integer(I4B), pointer :: imodelnewton => NULL() -! ------------------------------------------------------------------------------ - ! - ! -- allocate scalars in NumericalPackageType - call this%NumericalPackageType%allocate_scalars() - ! - ! -- allocate integer variables - call mem_allocate(this%ibcnum, 'IBCNUM', this%origin) - call mem_allocate(this%maxbound, 'MAXBOUND', this%origin) - call mem_allocate(this%nbound, 'NBOUND', this%origin) - call mem_allocate(this%ncolbnd, 'NCOLBND', this%origin) - call mem_allocate(this%iscloc, 'ISCLOC', this%origin) - call mem_allocate(this%naux, 'NAUX', this%origin) - call mem_allocate(this%inamedbound, 'INAMEDBOUND', this%origin) - call mem_allocate(this%iauxmultcol, 'IAUXMULTCOL', this%origin) - call mem_allocate(this%inobspkg, 'INOBSPKG', this%origin) - ! - ! -- allocate the object and assign values to object variables - call mem_allocate(this%imover, 'IMOVER', this%origin) - ! - ! -- allocate scalars for packages that add rows to the matrix (e.g. MAW) - call mem_allocate(this%npakeq, 'NPAKEQ', this%origin) - call mem_allocate(this%ioffset, 'IOFFSET', this%origin) - ! - ! -- allocate TS objects - allocate(this%TsManager) - allocate(this%TasManager) - ! - ! -- Allocate text strings - allocate(this%auxname(0)) - ! - ! -- Initialize variables - this%ibcnum = 0 - this%maxbound = 0 - this%nbound = 0 - this%ncolbnd = 0 - this%iscloc = 0 - this%naux = 0 - this%inamedbound = 0 - this%iauxmultcol = 0 - this%inobspkg = 0 - this%imover = 0 - this%npakeq = 0 - this%ioffset = 0 - ! - ! -- Set pointer to model inewton variable - call mem_setptr(imodelnewton, 'INEWTON', trim(this%name_model)) - this%inewton = imodelnewton - imodelnewton => null() - ! - ! -- return - return - end subroutine allocate_scalars - - subroutine allocate_arrays(this, nodelist, auxvar) -! ****************************************************************************** -! allocate_arrays -- Allocate Package Members -! Subroutine: (1) allocate -! (2) initialize -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate, mem_setptr - ! -- dummy - class(BndType) :: this - integer(I4B), dimension(:), pointer, contiguous, optional :: nodelist - real(DP), dimension(:, :), pointer, contiguous, optional :: auxvar - ! -- local - integer(I4B) :: i - integer(I4B) :: j -! ------------------------------------------------------------------------------ - ! - ! -- Point nodelist if it is passed in, otherwise allocate - if(present(nodelist)) then - this%nodelist => nodelist - else - call mem_allocate(this%nodelist, this%maxbound, 'NODELIST', this%origin) - this%nodelist = 0 - endif - ! - ! -- Allocate the bound array - call mem_allocate(this%bound, this%ncolbnd, this%maxbound, 'BOUND', & - this%origin) - ! - ! -- Allocate hcof and rhs - call mem_allocate(this%hcof, this%maxbound, 'HCOF', this%origin) - call mem_allocate(this%rhs, this%maxbound, 'RHS', this%origin) - ! - ! -- Allocate the simvals array - call mem_allocate(this%simvals, this%maxbound, 'SIMVALS', this%origin) - if (this%imover == 1) then - call mem_allocate(this%simtomvr, this%maxbound, 'SIMTOMVR', this%origin) - do i = 1, this%maxbound - this%simtomvr(i) = DZERO - enddo - else - call mem_allocate(this%simtomvr, 0, 'SIMTOMVR', this%origin) - endif - ! - ! -- Point or allocate auxvar - if(present(auxvar)) then - this%auxvar => auxvar - else - call mem_allocate(this%auxvar, this%naux, this%maxbound, 'AUXVAR', & - this%origin) - do i = 1, this%maxbound - do j = 1, this%naux - this%auxvar(j, i) = DZERO - end do - end do - endif - ! - ! -- Allocate boundname - if(this%inamedbound==1) then - allocate(this%boundname(this%maxbound)) - else - allocate(this%boundname(1)) - endif - ! - ! -- Set pointer to ICELLTYPE. For GWF boundary packages, - ! this%ictorigin will be 'NPF'. If boundary packages do not set - ! this%ictorigin, then icelltype will remain as null() - if (this%ictorigin /= '') & - call mem_setptr(this%icelltype, 'ICELLTYPE', & - trim(adjustl(this%name_model)) // ' ' // & - trim(adjustl(this%ictorigin))) - ! - ! -- Initialize values - do j = 1, this%maxbound - do i = 1, this%ncolbnd - this%bound(i, j) = DZERO - end do - end do - do i = 1, this%maxbound - this%hcof(i) = DZERO - this%rhs(i) = DZERO - if(this%inamedbound==1) then - this%boundname(i) = '' - end if - end do - if(this%inamedbound /= 1) this%boundname(1) = '' - ! - ! -- setup the output table - call this%pak_setup_outputtab() - ! - ! -- return - return - end subroutine allocate_arrays - - subroutine pack_initialize(this) -! ****************************************************************************** -! pack_initialize -- Allocate and/or initialize selected members -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(BndType) :: this -! ------------------------------------------------------------------------------ - ! - return - end subroutine pack_initialize - - subroutine set_pointers(this, neq, ibound, xnew, xold, flowja) -! ****************************************************************************** -! set_pointers -- Set pointers to model arrays and variables so that a package -! has access to these things. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(BndType) :: this - integer(I4B), pointer :: neq - integer(I4B), dimension(:), pointer, contiguous :: ibound - real(DP), dimension(:), pointer, contiguous :: xnew - real(DP), dimension(:), pointer, contiguous :: xold - real(DP), dimension(:), pointer, contiguous :: flowja -! ------------------------------------------------------------------------------ - ! - ! -- Set the pointers - this%neq => neq - this%ibound => ibound - this%xnew => xnew - this%xold => xold - this%flowja => flowja - ! - ! -- return - end subroutine set_pointers - - subroutine bnd_read_options(this) -! ****************************************************************************** -! read_options -- Read the base package options supported by BndType -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use InputOutputModule, only: urdaux - use SimModule, only: ustop, store_error, store_error_unit - ! -- dummy - class(BndType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: line, errmsg, fname, keyword - character(len=LENAUXNAME) :: sfacauxname - integer(I4B) :: lloc,istart,istop,n,ierr - integer(I4B) :: inobs - logical :: isfound, endOfBlock - logical :: foundchildclassoption - ! -- format - character(len=*),parameter :: fmtflow = & - "(4x, 'FLOWS WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" - character(len=*),parameter :: fmtflow2 = & - "(4x, 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL')" - character(len=*), parameter :: fmttas = & - "(4x, 'TIME-ARRAY SERIES DATA WILL BE READ FROM FILE: ', a)" - character(len=*), parameter :: fmtts = & - "(4x, 'TIME-SERIES DATA WILL BE READ FROM FILE: ', a)" - character(len=*), parameter :: fmtnme = & - "(a, i0, a)" -! ------------------------------------------------------------------------------ - ! - ! -- set default options - ! - ! -- 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 '//trim(adjustl(this%text)) & - //' OPTIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case('AUX', 'AUXILIARY') - call this%parser%GetRemainingLine(line) - lloc = 1 - call urdaux(this%naux, this%parser%iuactive, this%iout, lloc, & - istart, istop, this%auxname, line, this%text) - case ('SAVE_FLOWS') - this%ipakcb = -1 - write(this%iout, fmtflow2) - case ('PRINT_INPUT') - this%iprpak = 1 - write(this%iout,'(4x,a)') 'LISTS OF '//trim(adjustl(this%text))// & - ' CELLS WILL BE PRINTED.' - case ('PRINT_FLOWS') - this%iprflow = 1 - write(this%iout,'(4x,a)') trim(adjustl(this%text))// & - ' FLOWS WILL BE PRINTED TO LISTING FILE.' - case ('BOUNDNAMES') - this%inamedbound = 1 - write(this%iout,'(4x,a)') trim(adjustl(this%text))// & - ' BOUNDARIES HAVE NAMES IN LAST COLUMN.' - case ('TS6') - call this%parser%GetStringCaps(keyword) - if(trim(adjustl(keyword)) /= 'FILEIN') then - errmsg = 'TS6 keyword must be followed by "FILEIN" ' // & - 'then by filename.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - call this%parser%GetString(fname) - write(this%iout,fmtts)trim(fname) - call this%TsManager%add_tsfile(fname, this%inunit) - case ('TAS6') - if (this%AllowTimeArraySeries) then - if (.not. this%dis%supports_layers()) then - errmsg = 'TAS6 FILE cannot be used ' // & - 'with selected discretization type.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - else - errmsg = 'The ' // trim(this%filtyp) // & - ' package does not support TIMEARRAYSERIESFILE' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - call this%parser%GetStringCaps(keyword) - if(trim(adjustl(keyword)) /= 'FILEIN') then - errmsg = 'TAS6 keyword must be followed by "FILEIN" ' // & - 'then by filename.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - call this%parser%GetString(fname) - write(this%iout,fmttas)trim(fname) - call this%TasManager%add_tasfile(fname) - case ('AUXMULTNAME') - call this%parser%GetStringCaps(sfacauxname) - this%iauxmultcol = -1 - write(this%iout, '(4x,a,a)') & - 'AUXILIARY MULTIPLIER NAME: ', sfacauxname - case ('OBS6') - call this%parser%GetStringCaps(keyword) - if(trim(adjustl(keyword)) /= 'FILEIN') then - errmsg = 'OBS6 keyword must be followed by "FILEIN" ' // & - 'then by filename.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - if (this%obs%active) then - errmsg = 'Multiple OBS6 keywords detected in OPTIONS block. ' // & - 'Only one OBS6 entry allowed for a package.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - this%obs%active = .true. - call this%parser%GetString(this%obs%inputFilename) - inobs = GetUnit() - call openfile(inobs, this%iout, this%obs%inputFilename, 'OBS') - this%obs%inUnitObs = inobs - ! - ! -- right now these 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' - case default - ! - ! -- Check for child class options - call this%bnd_options(keyword, foundchildclassoption) - ! - ! -- No child class options found, so print error message - if(.not. foundchildclassoption) then - write(errmsg,'(4x,a,a)') '****ERROR. UNKNOWN '// & - trim(adjustl(this%text))//' OPTION: ', trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - end select - end do - write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' OPTIONS' - else - write(this%iout,'(1x,a)')'NO '//trim(adjustl(this%text))// & - ' OPTION BLOCK DETECTED.' - end if - ! - ! -- SFAC was specified, so find column of auxvar that will be multiplier - if(this%iauxmultcol < 0) then - ! - ! -- Error if no aux variable specified - if(this%naux == 0) then - write(errmsg,'(4x,a,a)') '****ERROR. AUXMULTNAME WAS SPECIFIED AS ' // & - trim(adjustl(sfacauxname))//' BUT NO AUX VARIABLES SPECIFIED.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Assign mult column - this%iauxmultcol = 0 - do n = 1, this%naux - if(sfacauxname == this%auxname(n)) then - this%iauxmultcol = n - exit - endif - enddo - ! - ! -- Error if aux variable cannot be found - if(this%iauxmultcol == 0) then - write(errmsg,'(4x,a,a)') '****ERROR. AUXMULTNAME WAS SPECIFIED AS ' // & - trim(adjustl(sfacauxname))//' BUT NO AUX VARIABLE FOUND WITH ' // & - 'THIS NAME.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - endif - ! - ! -- return - return - end subroutine bnd_read_options - - subroutine bnd_read_dimensions(this) -! ****************************************************************************** -! bnd_read_dimensions -- Read the dimensions for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, store_error_unit - ! -- dummy - class(BndType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock - ! -- format -! ------------------------------------------------------------------------------ - ! - ! -- 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 '//trim(adjustl(this%text))// & - ' DIMENSIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('MAXBOUND') - this%maxbound = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)') 'MAXBOUND = ', this%maxbound - case default - write(errmsg,'(4x,a,a)') & - '****ERROR. UNKNOWN '//trim(this%text)//' DIMENSION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - end do - ! - write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' DIMENSIONS' - else - call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- verify dimensions were set - if(this%maxbound <= 0) then - write(errmsg, '(1x,a)') & - 'ERROR. MAXBOUND MUST BE AN INTEGER GREATER THAN ZERO.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Call define_listlabel to construct the list label that is written - ! when PRINT_INPUT option is used. - call this%define_listlabel() - ! - ! -- return - return - end subroutine bnd_read_dimensions - - subroutine bnd_read_initial_attr(this) -! ****************************************************************************** -! bndreadinitialparms -- Read initial parameters for this package -! Most packages do not need initial parameter data -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(BndType),intent(inout) :: this - ! -- local - ! -- format -! ------------------------------------------------------------------------------ - ! - ! -- return - return - end subroutine bnd_read_initial_attr - - subroutine bnd_options(this, option, found) -! ****************************************************************************** -! bnd_options -- set options for a class derived from BndType -! This subroutine can be overridden by specific packages to set custom options -! that are not part of the package superclass. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(BndType),intent(inout) :: this - character(len=*), intent(inout) :: option - logical, intent(inout) :: found -! ------------------------------------------------------------------------------ - ! - ! Return with found = .false. - found = .false. - ! - ! -- return - return - end subroutine bnd_options - - subroutine pak_setup_outputtab(this) -! ****************************************************************************** -! bnd_options -- set options for a class derived from BndType -! This subroutine can be overridden by specific packages to set custom options -! that are not part of the package superclass. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(BndType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: title - character(len=LINELENGTH) :: text - integer(I4B) :: ntabcol -! ------------------------------------------------------------------------------ - ! - ! -- allocate and initialize the output table - if (this%iprflow /= 0) then - ! - ! -- dimension table - ntabcol = 3 - if (this%inamedbound > 0) then - ntabcol = ntabcol + 1 - end if - ! - ! -- initialize the output table object - title = trim(adjustl(this%text)) // ' PACKAGE (' // trim(this%name) // & - ') FLOW RATES' - call table_cr(this%outputtab, this%name, title) - call this%outputtab%table_df(this%maxbound, ntabcol, this%iout, & - transient=.TRUE.) - text = 'NUMBER' - call this%outputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'CELLID' - call this%outputtab%initialize_column(text, 20, alignment=TABLEFT) - text = 'RATE' - call this%outputtab%initialize_column(text, 15, alignment=TABCENTER) - if (this%inamedbound > 0) then - text = 'NAME' - call this%outputtab%initialize_column(text, 20, alignment=TABLEFT) - end if - end if - ! - ! -- return - return - end subroutine pak_setup_outputtab - - - subroutine define_listlabel(this) - ! define_listlabel - ! -- List-type packages should always override define_listlabel - ! to enable "NAME" to be added to label. - class(BndType), intent(inout) :: this - ! - return - end subroutine define_listlabel - - ! -- Procedures related to observations - - logical function bnd_obs_supported(this) - ! ************************************************************************** - ! bnd_obs_supported - ! -- Return true if package supports observations. Default is false. - ! -- Needs to be a BndType procedure. - ! -- Override for packages that do support observations. - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - class(BndType) :: this - ! -------------------------------------------------------------------------- - bnd_obs_supported = .false. - ! - ! -- Return - return - end function bnd_obs_supported - - subroutine bnd_df_obs(this) - ! ************************************************************************** - ! bnd_df_obs - ! -- Store observation type(s) supported by package. - ! -- Needs to be a BndType procedure. - ! -- Override in any package that supports observations. - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - class(BndType) :: this - ! -------------------------------------------------------------------------- - ! -- do nothing here. Override as needed. - return - end subroutine bnd_df_obs - - subroutine bnd_rp_obs(this) - ! -- This procedure should be overridden in any package that - ! supports observations and needs to check user input - ! or process observation input using package data in some - ! other way. - ! -- dummy - class(BndType), intent(inout) :: this - ! -- local - integer(I4B) :: i, j, n - class(ObserveType), pointer :: obsrv => null() - character(len=LENBOUNDNAME) :: bname - logical :: jfound - ! - if (.not. this%bnd_obs_supported()) return - ! - do i=1,this%obs%npakobs - obsrv => this%obs%pakobs(i)%obsrv - ! - ! -- indxbnds needs to be deallocated and reallocated (using - ! ExpandArray) each stress period because list of boundaries - ! can change each stress period. - if (allocated(obsrv%indxbnds)) then - deallocate(obsrv%indxbnds) - endif - obsrv%BndFound = .false. - ! - bname = obsrv%FeatureName - if (bname /= '') then - ! -- Observation location(s) is(are) based on a boundary name. - ! Iterate through all boundaries to identify and store - ! corresponding index(indices) in bound array. - jfound = .false. - do j=1,this%nbound - if (this%boundname(j) == bname) then - jfound = .true. - obsrv%BndFound = .true. - obsrv%CurrentTimeStepEndValue = DZERO - call ExpandArray(obsrv%indxbnds) - n = size(obsrv%indxbnds) - obsrv%indxbnds(n) = j - endif - enddo - else - ! -- Observation location is a single node number - jfound = .false. - jloop: do j=1,this%nbound - if (this%nodelist(j) == obsrv%NodeNumber) then - jfound = .true. - obsrv%BndFound = .true. - obsrv%CurrentTimeStepEndValue = DZERO - call ExpandArray(obsrv%indxbnds) - n = size(obsrv%indxbnds) - obsrv%indxbnds(n) = j - endif - enddo jloop - endif - enddo - ! - if (count_errors() > 0) then - call store_error_unit(this%inunit) - call ustop() - endif - ! - return - end subroutine bnd_rp_obs - - subroutine bnd_bd_obs(this) - ! obs_bd - ! -- Generic procedure to save simulated values for - ! all observations defined for a package. - class(BndType) :: this - ! -- local - integer(I4B) :: i, n - real(DP) :: v - type(ObserveType), pointer :: obsrv => null() - !--------------------------------------------------------------------------- - ! - call this%obs%obs_bd_clear() - ! - ! -- Save simulated values for all of package's observations. - do i=1,this%obs%npakobs - obsrv => this%obs%pakobs(i)%obsrv - if (obsrv%BndFound) then - do n=1,size(obsrv%indxbnds) - if (obsrv%ObsTypeId == 'TO-MVR') then - if (this%imover == 1) then - v = this%pakmvrobj%get_qtomvr(obsrv%indxbnds(n)) - if (v > DZERO) then - v = -v - end if - else - v = DNODATA - end if - else - v = this%simvals(obsrv%indxbnds(n)) - end if - call this%obs%SaveOneSimval(obsrv, v) - enddo - else - call this%obs%SaveOneSimval(obsrv, DNODATA) - endif - enddo - ! - return - end subroutine bnd_bd_obs - - subroutine bnd_ot_obs(this) - ! -- Generic procedure to save simulated values for - ! all observations defined for a package. - ! -- dummy - class(BndType) :: this - ! -- local - !--------------------------------------------------------------------------- - ! - call this%obs%obs_ot() - ! - return - end subroutine bnd_ot_obs - - ! -- Procedures related to time series - - subroutine bnd_rp_ts(this) - ! -- Generic procedure to assign tsLink%Text appropriately for - ! all time series in use by package. - ! Override as needed. - ! -- dummy - class(BndType), intent(inout) :: this - ! - return - end subroutine bnd_rp_ts - - ! -- Procedures related to casting - - function CastAsBndClass(obj) result(res) - implicit none - class(*), pointer, intent(inout) :: obj - class(BndType), pointer :: res - ! - res => null() - if (.not. associated(obj)) return - ! - select type (obj) - class is (BndType) - res => obj - end select - return - end function CastAsBndClass - - subroutine AddBndToList(list, bnd) - implicit none - ! -- dummy - type(ListType), intent(inout) :: list - class(BndType), pointer, intent(inout) :: bnd - ! -- local - class(*), pointer :: obj - ! - obj => bnd - call list%Add(obj) - ! - return - end subroutine AddBndToList - - function GetBndFromList(list, idx) result (res) - implicit none - ! -- dummy - type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx - class(BndType), pointer :: res - ! -- local - class(*), pointer :: obj - ! - obj => list%GetItem(idx) - res => CastAsBndClass(obj) - ! - return - end function GetBndFromList - -end module BndModule +module BndModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: LENAUXNAME, LENBOUNDNAME, LENFTYPE, & + DZERO, LENMODELNAME, LENPACKAGENAME, & + LENORIGIN, MAXCHARLEN, LINELENGTH, & + DNODATA, LENLISTLABEL, LENPAKLOC, & + TABLEFT, TABCENTER + use SimModule, only: count_errors, store_error, ustop, & + store_error_unit + use NumericalPackageModule, only: NumericalPackageType + use ArrayHandlersModule, only: ExpandArray + use ObsModule, only: ObsType, obs_cr + use TdisModule, only: delt, totimc + use ObserveModule, only: ObserveType + use InputOutputModule, only: GetUnit, openfile + use TimeArraySeriesManagerModule, only: TimeArraySeriesManagerType + use TimeSeriesLinkModule, only: TimeSeriesLinkType + use TimeSeriesManagerModule, only: TimeSeriesManagerType + use ListModule, only: ListType + use PackageMoverModule, only: PackageMoverType + use BaseDisModule, only: DisBaseType + use BlockParserModule, only: BlockParserType + use TableModule, only: TableType, table_cr + + implicit none + + private + public :: BndType, AddBndToList, GetBndFromList + private :: CastAsBndClass + + type, extends(NumericalPackageType) :: BndType + ! -- characters + character(len=LENLISTLABEL) :: listlabel = '' !title of table written for RP + character(len=LENPACKAGENAME) :: text = '' + character(len=LENAUXNAME), allocatable, dimension(:) :: auxname !name for each auxiliary variable + character(len=LENBOUNDNAME), dimension(:), pointer, & + contiguous :: boundname => null() !vector of boundnames + ! + ! -- scalars + integer(I4B), pointer :: ibcnum => null() !consecutive package number for this boundary condition + integer(I4B), pointer :: maxbound => null() !max number of boundaries + integer(I4B), pointer :: nbound => null() !number of boundaries for current stress period + integer(I4B), pointer :: ncolbnd => null() !number of columns of the bound array + integer(I4B), pointer :: iscloc => null() !bound column to scale with SFAC + integer(I4B), pointer :: naux => null() !number of auxiliary variables + integer(I4B), pointer :: inamedbound => null() !flag to read boundnames + integer(I4B), pointer :: iauxmultcol => null() !column to use as multiplier for column iscloc + integer(I4B), pointer :: npakeq => null() !number of equations in this package (normally 0 unless package adds rows to matrix) + integer(I4B), pointer :: ioffset => null() !offset of this package in the model + ! -- arrays + integer(I4B), dimension(:), pointer, contiguous :: nodelist => null() !vector of reduced node numbers + real(DP), dimension(:,:), pointer, contiguous :: bound => null() !array of package specific boundary numbers + real(DP), dimension(:), pointer, contiguous :: hcof => null() !diagonal contribution + real(DP), dimension(:), pointer, contiguous :: rhs => null() !right-hand side contribution + real(DP), dimension(:,:), pointer, contiguous :: auxvar => null() !auxiliary variable array + real(DP), dimension(:), pointer, contiguous :: simvals => null() !simulated values + real(DP), dimension(:), pointer, contiguous :: simtomvr => null() !simulated values + ! + ! -- water mover flag and object + integer(I4B), pointer :: imover => null() + type(PackageMoverType), pointer :: pakmvrobj => null() + ! + ! -- timeseries + type(TimeSeriesManagerType), pointer :: TsManager => null() ! time series manager + type(TimeArraySeriesManagerType), pointer :: TasManager => null() ! time array series manager + integer(I4B) :: indxconvertflux = 0 ! indxconvertflux is column of bound to multiply by area to convert flux to rate + logical :: AllowTimeArraySeries = .false. + ! + ! -- pointers for observations + integer(I4B), pointer :: inobspkg => null() ! unit number for obs package + type(ObsType), pointer :: obs => null() ! observation package + ! + ! -- pointers to model/solution variables + integer(I4B), pointer :: neq !number of equations for model + integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !ibound array + real(DP), dimension(:), pointer, contiguous :: xnew => null() !dependent variable (head) for this time step + real(DP), dimension(:), pointer, contiguous :: xold => null() !dependent variable for last time step + real(DP), dimension(:), pointer, contiguous :: flowja => null() !intercell flows + integer(I4B), dimension(:), pointer, contiguous :: icelltype => null() !pointer to icelltype array in NPF + character(len=10) :: ictorigin = '' !package name for icelltype (NPF for GWF) + ! + ! -- table objects + type(TableType), pointer :: inputtab => null() + type(TableType), pointer :: outputtab => null() + type(TableType), pointer :: errortab => null() + + + contains + procedure :: bnd_df + procedure :: bnd_ac + procedure :: bnd_mc + procedure :: bnd_ar + procedure :: bnd_rp + procedure :: bnd_ad + procedure :: bnd_ck + procedure :: bnd_cf + procedure :: bnd_fc + procedure :: bnd_fn + procedure :: bnd_nur + procedure :: bnd_cc + procedure :: bnd_bd + procedure :: bnd_ot + procedure :: bnd_da + + procedure :: allocate_scalars + procedure :: allocate_arrays + procedure :: pack_initialize + procedure :: read_options => bnd_read_options + procedure :: read_dimensions => bnd_read_dimensions + procedure :: read_initial_attr => bnd_read_initial_attr + procedure :: bnd_options + procedure :: set_pointers + procedure :: define_listlabel + procedure, private :: pak_setup_outputtab + ! + ! -- procedures to support observations + procedure, public :: bnd_obs_supported + procedure, public :: bnd_df_obs + procedure, public :: bnd_bd_obs + procedure, public :: bnd_ot_obs + procedure, public :: bnd_rp_obs + ! + ! -- procedure to support time series + procedure, public :: bnd_rp_ts + ! + end type BndType + + contains + + subroutine bnd_df(this, neq, dis) +! ****************************************************************************** +! bnd_df -- Define package options and dimensions +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- module + use TimeSeriesManagerModule, only: tsmanager_cr + use TimeArraySeriesManagerModule, only: tasmanager_cr + ! -- dummy + class(BndType),intent(inout) :: this + integer(I4B), intent(inout) :: neq + class(DisBaseType), pointer :: dis + ! -- local + ! -- format +! ------------------------------------------------------------------------------ + ! + ! -- set pointer to dis object for the model + this%dis => dis + ! + ! -- Create time series managers + call tsmanager_cr(this%TsManager, this%iout) + call tasmanager_cr(this%TasManager, dis, this%iout) + ! + ! -- create obs package + call obs_cr(this%obs, this%inobspkg) + ! + ! -- Write information to model list file + write(this%iout,1) this%filtyp, trim(adjustl(this%text)), this%inunit +1 format(1X,/1X,a,' -- ',a,' PACKAGE, VERSION 8, 2/22/2014', & + ' INPUT READ FROM UNIT ',I0) + ! + ! -- Initialize block parser + call this%parser%Initialize(this%inunit, this%iout) + ! + ! -- set and read options + call this%read_options() + ! + ! -- Now that time series will have been read, need to call the df + ! routine to define the manager + call this%tsmanager%tsmanager_df() + call this%tasmanager%tasmanager_df() + ! + ! -- read the package dimensions block + call this%read_dimensions() + ! + ! -- update package moffset for packages that add rows + if (this%npakeq > 0) then + this%ioffset = neq - this%dis%nodes + end if + ! + ! -- update neq + neq = neq + this%npakeq + ! + ! -- Store information needed for observations + if (this%bnd_obs_supported()) then + call this%obs%obs_df(this%iout, this%name, this%filtyp, this%dis) + call this%bnd_df_obs() + endif + ! + ! -- return + return + end subroutine bnd_df + + subroutine bnd_ac(this, moffset, sparse) +! ****************************************************************************** +! bnd_ac -- Add package connection to matrix +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use SparseModule, only: sparsematrix + use SimModule, only: store_error, ustop + ! -- dummy + class(BndType),intent(inout) :: this + integer(I4B), intent(in) :: moffset + type(sparsematrix), intent(inout) :: sparse + ! -- local + ! -- format +! ------------------------------------------------------------------------------ + ! + ! + ! -- return + return + end subroutine bnd_ac + + subroutine bnd_mc(this, moffset, iasln, jasln) +! ****************************************************************************** +! bnd_mc -- Map package connection to matrix +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BndType),intent(inout) :: this + integer(I4B), intent(in) :: moffset + integer(I4B), dimension(:), intent(in) :: iasln + integer(I4B), dimension(:), intent(in) :: jasln + ! -- local + ! -- format +! ------------------------------------------------------------------------------ + ! + ! + ! -- return + return + end subroutine bnd_mc + + subroutine bnd_ar(this) +! ****************************************************************************** +! bnd_ar -- Allocate and Read +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_setptr + ! -- dummy + class(BndType),intent(inout) :: this + ! -- local + ! -- format +! ------------------------------------------------------------------------------ + ! + call this%obs%obs_ar() + ! + ! -- Allocate arrays in package superclass + call this%allocate_arrays() + ! + ! -- read optional initial package parameters + call this%read_initial_attr() + ! + ! -- setup pakmvrobj for standard stress packages + if (this%imover == 1) then + allocate(this%pakmvrobj) + call this%pakmvrobj%ar(this%maxbound, 0, this%origin) + endif + ! + ! -- return + return + end subroutine bnd_ar + + subroutine bnd_rp(this) +! ****************************************************************************** +! bnd_rp -- Read and Prepare +! Subroutine: (1) read itmp +! (2) read new boundaries if itmp>0 +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use TdisModule, only: kper, nper + use SimModule, only: ustop, store_error, store_error_unit + ! -- dummy + class(BndType),intent(inout) :: this + ! -- local + integer(I4B) :: ierr, nlist + logical :: isfound + character(len=LINELENGTH) :: line, errmsg + ! -- formats + character(len=*),parameter :: fmtblkerr = & + "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + character(len=*),parameter :: fmtlsp = & + "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" + character(len=*), parameter :: fmtnbd = & + "(1X,/1X,'THE NUMBER OF ACTIVE ',A,'S (',I6, & + &') IS GREATER THAN MAXIMUM(',I6,')')" +! ------------------------------------------------------------------------------ + ! + ! -- Set ionper to the stress period number for which a new block of data + ! will be read. + if(this%inunit == 0) return + ! + ! -- get stress period data + if (this%ionper < kper) then + ! + ! -- get period block + call this%parser%GetBlock('PERIOD', isfound, ierr, & + supportOpenClose=.true.) + if (isfound) then + ! + ! -- read ionper and check for increasing period numbers + call this%read_check_ionper() + else + ! + ! -- PERIOD block not found + if (ierr < 0) then + ! -- End of file found; data applies for remainder of simulation. + this%ionper = nper + 1 + else + ! -- Found invalid block + call this%parser%GetCurrentLine(line) + write(errmsg, fmtblkerr) adjustl(trim(line)) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end if + endif + end if + ! + ! -- read data if ionper == kper + if(this%ionper == kper) then + nlist = -1 + ! -- Remove all time-series and time-array-series links associated with + ! this package. + call this%TsManager%Reset(this%name) + call this%TasManager%Reset(this%name) + ! + ! -- Read data as a list + call this%dis%read_list(this%parser%iuactive, this%iout, & + this%iprpak, nlist, this%inamedbound, & + this%iauxmultcol, this%nodelist, & + this%bound, this%auxvar, this%auxname, & + this%boundname, this%listlabel, & + this%name, this%tsManager, this%iscloc) + this%nbound = nlist + ! + ! Define the tsLink%Text value(s) appropriately. + ! E.g. for WEL package, entry 1, assign tsLink%Text = 'Q' + ! For RIV package, entry 1 text = 'STAGE', entry 2 text = 'COND', + ! entry 3 text = 'RBOT'; etc. + call this%bnd_rp_ts() + ! + ! -- Terminate the block + call this%parser%terminateblock() + ! + else + write(this%iout,fmtlsp) trim(this%filtyp) + endif + ! + ! -- return + return + end subroutine bnd_rp + + subroutine bnd_ad(this) + use ConstantsModule, only: DZERO + class(BndType) :: this + !this package has no AD routine + real(DP) :: begintime, endtime + ! + ! -- Initialize time variables + begintime = totimc + endtime = begintime + delt + ! + ! -- Advance the time series managers + call this%TsManager%ad() + call this%TasManager%ad() + ! + ! -- For each observation, push simulated value and corresponding + ! simulation time from "current" to "preceding" and reset + ! "current" value. + call this%obs%obs_ad() + ! + return + end subroutine bnd_ad + + subroutine bnd_ck(this) +! ****************************************************************************** +! bnd_ck -- Check boundary condition data +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error + ! -- dummy + class(BndType),intent(inout) :: this + ! -- local + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- check stress period data + ! -- each package must override generic functionality + ! + ! -- return + return + end subroutine bnd_ck + + subroutine bnd_cf(this, reset_mover) +! ****************************************************************************** +! bnd_cf -- This is the package specific routine where a package adds its +! contributions to this%rhs and this%hcof +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + class(BndType) :: this + logical, intent(in), optional :: reset_mover +! ------------------------------------------------------------------------------ + ! -- bnd has no cf routine + ! + ! -- return + return + end subroutine bnd_cf + + subroutine bnd_fc(this, rhs, ia, idxglo, amatsln) +! ****************************************************************************** +! bnd_fc -- Copy rhs and hcof into solution rhs and amat +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BndType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + real(DP), dimension(:), intent(inout) :: amatsln + ! -- local + integer(I4B) :: i, n, ipos +! ------------------------------------------------------------------------------ + ! + ! -- Copy package rhs and hcof into solution rhs and amat + do i = 1, this%nbound + n = this%nodelist(i) + rhs(n) = rhs(n) + this%rhs(i) + ipos = ia(n) + amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) + enddo + ! + ! -- return + return + end subroutine bnd_fc + + subroutine bnd_fn(this, rhs, ia, idxglo, amatsln) +! ****************************************************************************** +! bnd_fn -- add additional terms to convert conductance formulation +! to Newton-Raphson formulation +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BndType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + real(DP), dimension(:), intent(inout) :: amatsln + ! -- local +! ------------------------------------------------------------------------------ + + ! + ! -- No addition terms for newton-raphson with constant conductance + ! boundary conditions + ! + ! -- return + return + end subroutine bnd_fn + + subroutine bnd_nur(this, neqpak, x, xtemp, dx, inewtonur, dxmax, locmax) +! ****************************************************************************** +! bnd_nur -- under-relaxation +! Subroutine: (1) Under-relaxation of Groundwater Flow Model Package Heads +! for current outer iteration using the cell bottoms at the +! bottom of the model +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BndType), intent(inout) :: this + integer(I4B), intent(in) :: neqpak + real(DP), dimension(neqpak), intent(inout) :: x + real(DP), dimension(neqpak), intent(in) :: xtemp + real(DP), dimension(neqpak), intent(inout) :: dx + integer(I4B), intent(inout) :: inewtonur + real(DP), intent(inout) :: dxmax + integer(I4B), intent(inout) :: locmax + ! -- local +! ------------------------------------------------------------------------------ + + ! + ! -- Newton-Raphson under-relaxation + ! + ! -- return + return + end subroutine bnd_nur + + subroutine bnd_cc(this, kiter, iend, icnvgmod, cpak, dpak) +! ****************************************************************************** +! bnd_cc -- additional convergence check for advanced packages +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BndType), intent(inout) :: this + integer(I4B), intent(in) :: kiter + integer(I4B),intent(in) :: iend + integer(I4B), intent(in) :: icnvgmod + character(len=LENPAKLOC), intent(inout) :: cpak + real(DP), intent(inout) :: dpak + ! -- local +! ------------------------------------------------------------------------------ + + ! + ! -- No addition convergence check for boundary conditions + ! + ! -- return + return + end subroutine bnd_cc + + subroutine bnd_bd(this, x, idvfl, icbcfl, ibudfl, icbcun, iprobs, & + isuppress_output, model_budget, imap, iadv) +! ****************************************************************************** +! bnd_bd -- Calculate Volumetric Budget +! Note that the compact budget will always be used. +! Subroutine: (1) Process each package entry +! (2) Write output +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: delt + use ConstantsModule, only: LENBOUNDNAME, DZERO + use BudgetModule, only: BudgetType + ! -- dummy + class(BndType) :: this + real(DP),dimension(:),intent(in) :: x + integer(I4B), intent(in) :: idvfl + integer(I4B), intent(in) :: icbcfl + integer(I4B), intent(in) :: ibudfl + integer(I4B), intent(in) :: icbcun + integer(I4B), intent(in) :: iprobs + integer(I4B), intent(in) :: isuppress_output + type(BudgetType), intent(inout) :: model_budget + integer(I4B), dimension(:), optional, intent(in) :: imap + integer(I4B), optional, intent(in) :: iadv + ! -- local + character (len=LINELENGTH) :: title + character(len=20) :: nodestr + character (len=LENPACKAGENAME) :: text + integer(I4B) :: nodeu + integer(I4B) :: maxrows + integer(I4B) :: imover + integer(I4B) :: i, node, n2, ibinun + real(DP) :: q + real(DP) :: qtomvr + real(DP) :: ratin, ratout, rrate + integer(I4B) :: naux + ! -- for observations + character(len=LENBOUNDNAME) :: bname + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- check for iadv optional variable + if (present(iadv)) then + if (iadv == 1) then + imover = 0 + else + imover = 1 + end if + else + imover = this%imover + end if + ! + ! -- set maxrows + maxrows = 0 + if (ibudfl /= 0 .and. this%iprflow /= 0) then + do i = 1, this%nbound + node = this%nodelist(i) + if (node > 0) then + if (this%ibound(node) > 0) then + maxrows = maxrows + 1 + end if + end if + end do + if (maxrows > 0) then + call this%outputtab%set_maxbound(maxrows) + end if + title = trim(adjustl(this%text)) // ' PACKAGE (' // trim(this%name) // & + ') FLOW RATES' + call this%outputtab%set_title(title) + end if + ! + ! -- Clear accumulators and set flags + ratin = DZERO + ratout = DZERO + ! + ! -- Set unit number for binary output + if (this%ipakcb < 0) then + ibinun = icbcun + else if (this%ipakcb == 0) then + ibinun = 0 + else + ibinun = this%ipakcb + end if + if (icbcfl == 0) ibinun = 0 + if (isuppress_output /= 0) ibinun = 0 + ! + ! -- If cell-by-cell flows will be saved as a list, write header. + if(ibinun /= 0) then + naux = this%naux + call this%dis%record_srcdst_list_header(this%text, this%name_model, & + this%name_model, this%name_model, this%name, naux, & + this%auxname, ibinun, this%nbound, this%iout) + endif + ! + ! -- If no boundaries, skip flow calculations. + if(this%nbound > 0) then + ! + ! -- Loop through each boundary calculating flow. + do i = 1, this%nbound + node = this%nodelist(i) + ! -- assign boundary name + if (this%inamedbound>0) then + bname = this%boundname(i) + else + bname = '' + endif + ! + ! -- If cell is no-flow or constant-head, then ignore it. + rrate = DZERO + if (node > 0) then + if(this%ibound(node) > 0) then + ! + ! -- Calculate the flow rate into the cell. + rrate = this%hcof(i) * x(node) - this%rhs(i) + ! + ! -- modify rrate with to mover + if (rrate < DZERO) then + if (imover == 1) then + qtomvr = this%pakmvrobj%get_qtomvr(i) + rrate = rrate + qtomvr + end if + end if + ! + ! -- Print the individual rates if the budget is being printed + ! and PRINT_FLOWS was specified (this%iprflow<0) + if (ibudfl /= 0) then + if (this%iprflow /= 0) then + ! + ! -- set nodestr and write outputtab table + nodeu = this%dis%get_nodeuser(node) + call this%dis%nodeu_to_string(nodeu, nodestr) + call this%outputtab%print_list_entry(i, trim(adjustl(nodestr)), & + rrate, bname) + end if + end if + ! + ! -- See if flow is into aquifer or out of aquifer. + if(rrate < dzero) then + ! + ! -- Flow is out of aquifer; subtract rate from ratout. + ratout=ratout - rrate + else + ! + ! -- Flow is into aquifer; add rate to ratin. + ratin=ratin + rrate + endif + endif + endif + ! + ! -- If saving cell-by-cell flows in list, write flow + if (ibinun /= 0) then + n2 = i + if (present(imap)) n2 = imap(i) + call this%dis%record_mf6_list_entry(ibinun, node, n2, rrate, & + naux, this%auxvar(:,i), & + olconv2=.FALSE.) + end if + ! + ! -- Save simulated value to simvals array. + this%simvals(i) = rrate + ! + enddo + if (ibudfl /= 0) then + if (this%iprflow /= 0) then + write(this%iout,'(1x)') + end if + end if + + endif + ! + ! -- Store the rates + call model_budget%addentry(ratin, ratout, delt, this%text, & + isuppress_output, this%name) + if (imover == 1) then + ratin = DZERO + ratout = DZERO + text = trim(adjustl(this%text)) // '-TO-MVR' + text = adjustr(text) + if (ibudfl /= 0 .and. this%iprflow /= 0) then + title = trim(adjustl(this%text)) // ' PACKAGE (' // trim(this%name) // & + ') FLOW RATES TO-MVR' + call this%outputtab%set_title(title) + end if + ! + ! -- If cell-by-cell flows will be saved as a list, write header. + if(ibinun /= 0) then + naux = this%naux + call this%dis%record_srcdst_list_header(text, this%name_model, & + this%name_model, this%name_model, this%name, naux, & + this%auxname, ibinun, this%nbound, this%iout) + endif + ! + ! -- If no boundaries, skip flow calculations. + if(this%nbound > 0) then + ! + ! -- Loop through each boundary calculating flow. + do i = 1, this%nbound + node = this%nodelist(i) + ! -- assign boundary name + if (this%inamedbound>0) then + bname = this%boundname(i) + else + bname = '' + endif + ! + ! -- If cell is no-flow or constant-head, then ignore it. + rrate = DZERO + if (node > 0) then + if(this%ibound(node) > 0) then + ! + ! -- Calculate the flow rate into the cell. + q = this%hcof(i) * x(node) - this%rhs(i) + if (q < DZERO) then + rrate = this%pakmvrobj%get_qtomvr(i) + if (rrate > DZERO) then + rrate = -rrate + end if + end if + ! + ! -- Print the individual rates if the budget is being printed + ! and PRINT_FLOWS was specified (this%iprflow<0) + if(ibudfl /= 0) then + if(this%iprflow /= 0) then + ! + ! -- set nodestr and write outputtab table + nodeu = this%dis%get_nodeuser(node) + call this%dis%nodeu_to_string(nodeu, nodestr) + call this%outputtab%print_list_entry(i, trim(adjustl(nodestr)),& + rrate, bname) + endif + endif + ! + ! -- See if flow is into aquifer or out of aquifer. + if(rrate < dzero) then + ! + ! -- Flow is out of aquifer; subtract rate from ratout. + ratout=ratout - rrate + else + ! + ! -- Flow is into aquifer; add rate to ratin. + ratin=ratin + rrate + endif + endif + endif + ! + ! -- If saving cell-by-cell flows in list, write flow + if (ibinun /= 0) then + n2 = i + if (present(imap)) n2 = imap(i) + call this%dis%record_mf6_list_entry(ibinun, node, n2, rrate, & + naux, this%auxvar(:,i), & + olconv2=.FALSE.) + end if + ! + ! -- Save simulated value to simvals array. + this%simtomvr(i) = rrate + ! + enddo + endif + ! + ! -- Store the rates + call model_budget%addentry(ratin, ratout, delt, text, & + isuppress_output, this%name) + + end if + ! + ! -- Save the simulated values to the ObserveType objects + if (iprobs /= 0 .and. this%obs%npakobs > 0) then + call this%bnd_bd_obs() + endif + ! + ! -- return + return + end subroutine bnd_bd + + subroutine bnd_ot(this, kstp, kper, iout, ihedfl, ibudfl) +! ****************************************************************************** +! bnd_ot -- Output package budget +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BndType) :: this + integer(I4B),intent(in) :: kstp + integer(I4B),intent(in) :: kper + integer(I4B),intent(in) :: iout + integer(I4B),intent(in) :: ihedfl + integer(I4B),intent(in) :: ibudfl + ! -- format +! ------------------------------------------------------------------------------ + ! + ! -- return + return + end subroutine bnd_ot + + subroutine bnd_da(this) +! ****************************************************************************** +! bnd_da -- Deallocate objects +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(BndType) :: this + ! -- format +! ------------------------------------------------------------------------------ + ! + ! -- deallocate arrays + call mem_deallocate(this%nodelist) + call mem_deallocate(this%bound) + call mem_deallocate(this%hcof) + call mem_deallocate(this%rhs) + call mem_deallocate(this%simvals) + call mem_deallocate(this%simtomvr) + call mem_deallocate(this%auxvar) + deallocate(this%boundname) + deallocate(this%auxname) + nullify(this%icelltype) + ! + ! -- pakmvrobj + if (this%imover /= 0) then + call this%pakmvrobj%da() + deallocate(this%pakmvrobj) + nullify(this%pakmvrobj) + endif + ! + ! -- input table object + if (associated(this%inputtab)) then + call this%inputtab%table_da() + deallocate(this%inputtab) + nullify(this%inputtab) + end if + ! + ! -- output table object + if (associated(this%outputtab)) then + call this%outputtab%table_da() + deallocate(this%outputtab) + nullify(this%outputtab) + end if + ! + ! -- error table object + if (associated(this%errortab)) then + call this%errortab%table_da() + deallocate(this%errortab) + nullify(this%errortab) + end if + ! + ! -- Deallocate scalars + call mem_deallocate(this%ibcnum) + call mem_deallocate(this%maxbound) + call mem_deallocate(this%nbound) + call mem_deallocate(this%ncolbnd) + call mem_deallocate(this%iscloc) + call mem_deallocate(this%naux) + call mem_deallocate(this%inamedbound) + call mem_deallocate(this%iauxmultcol) + call mem_deallocate(this%inobspkg) + call mem_deallocate(this%imover) + call mem_deallocate(this%npakeq) + call mem_deallocate(this%ioffset) + ! + ! -- deallocate methods on objects + call this%obs%obs_da() + call this%TsManager%da() + call this%TasManager%da() + ! + ! -- deallocate objects + deallocate(this%obs) + deallocate(this%TsManager) + deallocate(this%TasManager) + nullify(this%TsManager) + nullify(this%TasManager) + ! + ! -- Deallocate parent object + call this%NumericalPackageType%da() + ! + ! -- Return + return + end subroutine bnd_da + + subroutine allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars -- Allocate Package Members +! Subroutine: (1) allocate +! (2) initialize +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate, mem_setptr + ! -- dummy + class(BndType) :: this + ! -- local + integer(I4B), pointer :: imodelnewton => NULL() +! ------------------------------------------------------------------------------ + ! + ! -- allocate scalars in NumericalPackageType + call this%NumericalPackageType%allocate_scalars() + ! + ! -- allocate integer variables + call mem_allocate(this%ibcnum, 'IBCNUM', this%origin) + call mem_allocate(this%maxbound, 'MAXBOUND', this%origin) + call mem_allocate(this%nbound, 'NBOUND', this%origin) + call mem_allocate(this%ncolbnd, 'NCOLBND', this%origin) + call mem_allocate(this%iscloc, 'ISCLOC', this%origin) + call mem_allocate(this%naux, 'NAUX', this%origin) + call mem_allocate(this%inamedbound, 'INAMEDBOUND', this%origin) + call mem_allocate(this%iauxmultcol, 'IAUXMULTCOL', this%origin) + call mem_allocate(this%inobspkg, 'INOBSPKG', this%origin) + ! + ! -- allocate the object and assign values to object variables + call mem_allocate(this%imover, 'IMOVER', this%origin) + ! + ! -- allocate scalars for packages that add rows to the matrix (e.g. MAW) + call mem_allocate(this%npakeq, 'NPAKEQ', this%origin) + call mem_allocate(this%ioffset, 'IOFFSET', this%origin) + ! + ! -- allocate TS objects + allocate(this%TsManager) + allocate(this%TasManager) + ! + ! -- Allocate text strings + allocate(this%auxname(0)) + ! + ! -- Initialize variables + this%ibcnum = 0 + this%maxbound = 0 + this%nbound = 0 + this%ncolbnd = 0 + this%iscloc = 0 + this%naux = 0 + this%inamedbound = 0 + this%iauxmultcol = 0 + this%inobspkg = 0 + this%imover = 0 + this%npakeq = 0 + this%ioffset = 0 + ! + ! -- Set pointer to model inewton variable + call mem_setptr(imodelnewton, 'INEWTON', trim(this%name_model)) + this%inewton = imodelnewton + imodelnewton => null() + ! + ! -- return + return + end subroutine allocate_scalars + + subroutine allocate_arrays(this, nodelist, auxvar) +! ****************************************************************************** +! allocate_arrays -- Allocate Package Members +! Subroutine: (1) allocate +! (2) initialize +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate, mem_setptr + ! -- dummy + class(BndType) :: this + integer(I4B), dimension(:), pointer, contiguous, optional :: nodelist + real(DP), dimension(:, :), pointer, contiguous, optional :: auxvar + ! -- local + integer(I4B) :: i + integer(I4B) :: j +! ------------------------------------------------------------------------------ + ! + ! -- Point nodelist if it is passed in, otherwise allocate + if(present(nodelist)) then + this%nodelist => nodelist + else + call mem_allocate(this%nodelist, this%maxbound, 'NODELIST', this%origin) + this%nodelist = 0 + endif + ! + ! -- Allocate the bound array + call mem_allocate(this%bound, this%ncolbnd, this%maxbound, 'BOUND', & + this%origin) + ! + ! -- Allocate hcof and rhs + call mem_allocate(this%hcof, this%maxbound, 'HCOF', this%origin) + call mem_allocate(this%rhs, this%maxbound, 'RHS', this%origin) + ! + ! -- Allocate the simvals array + call mem_allocate(this%simvals, this%maxbound, 'SIMVALS', this%origin) + if (this%imover == 1) then + call mem_allocate(this%simtomvr, this%maxbound, 'SIMTOMVR', this%origin) + do i = 1, this%maxbound + this%simtomvr(i) = DZERO + enddo + else + call mem_allocate(this%simtomvr, 0, 'SIMTOMVR', this%origin) + endif + ! + ! -- Point or allocate auxvar + if(present(auxvar)) then + this%auxvar => auxvar + else + call mem_allocate(this%auxvar, this%naux, this%maxbound, 'AUXVAR', & + this%origin) + do i = 1, this%maxbound + do j = 1, this%naux + this%auxvar(j, i) = DZERO + end do + end do + endif + ! + ! -- Allocate boundname + if(this%inamedbound==1) then + allocate(this%boundname(this%maxbound)) + else + allocate(this%boundname(1)) + endif + ! + ! -- Set pointer to ICELLTYPE. For GWF boundary packages, + ! this%ictorigin will be 'NPF'. If boundary packages do not set + ! this%ictorigin, then icelltype will remain as null() + if (this%ictorigin /= '') & + call mem_setptr(this%icelltype, 'ICELLTYPE', & + trim(adjustl(this%name_model)) // ' ' // & + trim(adjustl(this%ictorigin))) + ! + ! -- Initialize values + do j = 1, this%maxbound + do i = 1, this%ncolbnd + this%bound(i, j) = DZERO + end do + end do + do i = 1, this%maxbound + this%hcof(i) = DZERO + this%rhs(i) = DZERO + if(this%inamedbound==1) then + this%boundname(i) = '' + end if + end do + if(this%inamedbound /= 1) this%boundname(1) = '' + ! + ! -- setup the output table + call this%pak_setup_outputtab() + ! + ! -- return + return + end subroutine allocate_arrays + + subroutine pack_initialize(this) +! ****************************************************************************** +! pack_initialize -- Allocate and/or initialize selected members +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(BndType) :: this +! ------------------------------------------------------------------------------ + ! + return + end subroutine pack_initialize + + subroutine set_pointers(this, neq, ibound, xnew, xold, flowja) +! ****************************************************************************** +! set_pointers -- Set pointers to model arrays and variables so that a package +! has access to these things. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(BndType) :: this + integer(I4B), pointer :: neq + integer(I4B), dimension(:), pointer, contiguous :: ibound + real(DP), dimension(:), pointer, contiguous :: xnew + real(DP), dimension(:), pointer, contiguous :: xold + real(DP), dimension(:), pointer, contiguous :: flowja +! ------------------------------------------------------------------------------ + ! + ! -- Set the pointers + this%neq => neq + this%ibound => ibound + this%xnew => xnew + this%xold => xold + this%flowja => flowja + ! + ! -- return + end subroutine set_pointers + + subroutine bnd_read_options(this) +! ****************************************************************************** +! read_options -- Read the base package options supported by BndType +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use InputOutputModule, only: urdaux + use SimModule, only: ustop, store_error, store_error_unit + ! -- dummy + class(BndType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: line, errmsg, fname, keyword + character(len=LENAUXNAME) :: sfacauxname + integer(I4B) :: lloc,istart,istop,n,ierr + integer(I4B) :: inobs + logical :: isfound, endOfBlock + logical :: foundchildclassoption + ! -- format + character(len=*),parameter :: fmtflow = & + "(4x, 'FLOWS WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" + character(len=*),parameter :: fmtflow2 = & + "(4x, 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL')" + character(len=*), parameter :: fmttas = & + "(4x, 'TIME-ARRAY SERIES DATA WILL BE READ FROM FILE: ', a)" + character(len=*), parameter :: fmtts = & + "(4x, 'TIME-SERIES DATA WILL BE READ FROM FILE: ', a)" + character(len=*), parameter :: fmtnme = & + "(a, i0, a)" +! ------------------------------------------------------------------------------ + ! + ! -- set default options + ! + ! -- 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 '//trim(adjustl(this%text)) & + //' OPTIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case('AUX', 'AUXILIARY') + call this%parser%GetRemainingLine(line) + lloc = 1 + call urdaux(this%naux, this%parser%iuactive, this%iout, lloc, & + istart, istop, this%auxname, line, this%text) + case ('SAVE_FLOWS') + this%ipakcb = -1 + write(this%iout, fmtflow2) + case ('PRINT_INPUT') + this%iprpak = 1 + write(this%iout,'(4x,a)') 'LISTS OF '//trim(adjustl(this%text))// & + ' CELLS WILL BE PRINTED.' + case ('PRINT_FLOWS') + this%iprflow = 1 + write(this%iout,'(4x,a)') trim(adjustl(this%text))// & + ' FLOWS WILL BE PRINTED TO LISTING FILE.' + case ('BOUNDNAMES') + this%inamedbound = 1 + write(this%iout,'(4x,a)') trim(adjustl(this%text))// & + ' BOUNDARIES HAVE NAMES IN LAST COLUMN.' + case ('TS6') + call this%parser%GetStringCaps(keyword) + if(trim(adjustl(keyword)) /= 'FILEIN') then + errmsg = 'TS6 keyword must be followed by "FILEIN" ' // & + 'then by filename.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + call this%parser%GetString(fname) + write(this%iout,fmtts)trim(fname) + call this%TsManager%add_tsfile(fname, this%inunit) + case ('TAS6') + if (this%AllowTimeArraySeries) then + if (.not. this%dis%supports_layers()) then + errmsg = 'TAS6 FILE cannot be used ' // & + 'with selected discretization type.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + else + errmsg = 'The ' // trim(this%filtyp) // & + ' package does not support TIMEARRAYSERIESFILE' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + call this%parser%GetStringCaps(keyword) + if(trim(adjustl(keyword)) /= 'FILEIN') then + errmsg = 'TAS6 keyword must be followed by "FILEIN" ' // & + 'then by filename.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + call this%parser%GetString(fname) + write(this%iout,fmttas)trim(fname) + call this%TasManager%add_tasfile(fname) + case ('AUXMULTNAME') + call this%parser%GetStringCaps(sfacauxname) + this%iauxmultcol = -1 + write(this%iout, '(4x,a,a)') & + 'AUXILIARY MULTIPLIER NAME: ', sfacauxname + case ('OBS6') + call this%parser%GetStringCaps(keyword) + if(trim(adjustl(keyword)) /= 'FILEIN') then + errmsg = 'OBS6 keyword must be followed by "FILEIN" ' // & + 'then by filename.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + if (this%obs%active) then + errmsg = 'Multiple OBS6 keywords detected in OPTIONS block. ' // & + 'Only one OBS6 entry allowed for a package.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + this%obs%active = .true. + call this%parser%GetString(this%obs%inputFilename) + inobs = GetUnit() + call openfile(inobs, this%iout, this%obs%inputFilename, 'OBS') + this%obs%inUnitObs = inobs + ! + ! -- right now these 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' + case default + ! + ! -- Check for child class options + call this%bnd_options(keyword, foundchildclassoption) + ! + ! -- No child class options found, so print error message + if(.not. foundchildclassoption) then + write(errmsg,'(4x,a,a)') '****ERROR. UNKNOWN '// & + trim(adjustl(this%text))//' OPTION: ', trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + end select + end do + write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' OPTIONS' + else + write(this%iout,'(1x,a)')'NO '//trim(adjustl(this%text))// & + ' OPTION BLOCK DETECTED.' + end if + ! + ! -- SFAC was specified, so find column of auxvar that will be multiplier + if(this%iauxmultcol < 0) then + ! + ! -- Error if no aux variable specified + if(this%naux == 0) then + write(errmsg,'(4x,a,a)') '****ERROR. AUXMULTNAME WAS SPECIFIED AS ' // & + trim(adjustl(sfacauxname))//' BUT NO AUX VARIABLES SPECIFIED.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Assign mult column + this%iauxmultcol = 0 + do n = 1, this%naux + if(sfacauxname == this%auxname(n)) then + this%iauxmultcol = n + exit + endif + enddo + ! + ! -- Error if aux variable cannot be found + if(this%iauxmultcol == 0) then + write(errmsg,'(4x,a,a)') '****ERROR. AUXMULTNAME WAS SPECIFIED AS ' // & + trim(adjustl(sfacauxname))//' BUT NO AUX VARIABLE FOUND WITH ' // & + 'THIS NAME.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + endif + ! + ! -- return + return + end subroutine bnd_read_options + + subroutine bnd_read_dimensions(this) +! ****************************************************************************** +! bnd_read_dimensions -- Read the dimensions for this package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, store_error_unit + ! -- dummy + class(BndType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: errmsg, keyword + integer(I4B) :: ierr + logical :: isfound, endOfBlock + ! -- format +! ------------------------------------------------------------------------------ + ! + ! -- 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 '//trim(adjustl(this%text))// & + ' DIMENSIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('MAXBOUND') + this%maxbound = this%parser%GetInteger() + write(this%iout,'(4x,a,i7)') 'MAXBOUND = ', this%maxbound + case default + write(errmsg,'(4x,a,a)') & + '****ERROR. UNKNOWN '//trim(this%text)//' DIMENSION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + end do + ! + write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' DIMENSIONS' + else + call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- verify dimensions were set + if(this%maxbound <= 0) then + write(errmsg, '(1x,a)') & + 'ERROR. MAXBOUND MUST BE AN INTEGER GREATER THAN ZERO.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Call define_listlabel to construct the list label that is written + ! when PRINT_INPUT option is used. + call this%define_listlabel() + ! + ! -- return + return + end subroutine bnd_read_dimensions + + subroutine bnd_read_initial_attr(this) +! ****************************************************************************** +! bndreadinitialparms -- Read initial parameters for this package +! Most packages do not need initial parameter data +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BndType),intent(inout) :: this + ! -- local + ! -- format +! ------------------------------------------------------------------------------ + ! + ! -- return + return + end subroutine bnd_read_initial_attr + + subroutine bnd_options(this, option, found) +! ****************************************************************************** +! bnd_options -- set options for a class derived from BndType +! This subroutine can be overridden by specific packages to set custom options +! that are not part of the package superclass. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BndType),intent(inout) :: this + character(len=*), intent(inout) :: option + logical, intent(inout) :: found +! ------------------------------------------------------------------------------ + ! + ! Return with found = .false. + found = .false. + ! + ! -- return + return + end subroutine bnd_options + + subroutine pak_setup_outputtab(this) +! ****************************************************************************** +! bnd_options -- set options for a class derived from BndType +! This subroutine can be overridden by specific packages to set custom options +! that are not part of the package superclass. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BndType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: text + integer(I4B) :: ntabcol +! ------------------------------------------------------------------------------ + ! + ! -- allocate and initialize the output table + if (this%iprflow /= 0) then + ! + ! -- dimension table + ntabcol = 3 + if (this%inamedbound > 0) then + ntabcol = ntabcol + 1 + end if + ! + ! -- initialize the output table object + title = trim(adjustl(this%text)) // ' PACKAGE (' // trim(this%name) // & + ') FLOW RATES' + call table_cr(this%outputtab, this%name, title) + call this%outputtab%table_df(this%maxbound, ntabcol, this%iout, & + transient=.TRUE.) + text = 'NUMBER' + call this%outputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'CELLID' + call this%outputtab%initialize_column(text, 20, alignment=TABLEFT) + text = 'RATE' + call this%outputtab%initialize_column(text, 15, alignment=TABCENTER) + if (this%inamedbound > 0) then + text = 'NAME' + call this%outputtab%initialize_column(text, 20, alignment=TABLEFT) + end if + end if + ! + ! -- return + return + end subroutine pak_setup_outputtab + + + subroutine define_listlabel(this) + ! define_listlabel + ! -- List-type packages should always override define_listlabel + ! to enable "NAME" to be added to label. + class(BndType), intent(inout) :: this + ! + return + end subroutine define_listlabel + + ! -- Procedures related to observations + + logical function bnd_obs_supported(this) + ! ************************************************************************** + ! bnd_obs_supported + ! -- Return true if package supports observations. Default is false. + ! -- Needs to be a BndType procedure. + ! -- Override for packages that do support observations. + ! ************************************************************************** + ! + ! SPECIFICATIONS: + ! -------------------------------------------------------------------------- + class(BndType) :: this + ! -------------------------------------------------------------------------- + bnd_obs_supported = .false. + ! + ! -- Return + return + end function bnd_obs_supported + + subroutine bnd_df_obs(this) + ! ************************************************************************** + ! bnd_df_obs + ! -- Store observation type(s) supported by package. + ! -- Needs to be a BndType procedure. + ! -- Override in any package that supports observations. + ! ************************************************************************** + ! + ! SPECIFICATIONS: + ! -------------------------------------------------------------------------- + class(BndType) :: this + ! -------------------------------------------------------------------------- + ! -- do nothing here. Override as needed. + return + end subroutine bnd_df_obs + + subroutine bnd_rp_obs(this) + ! -- This procedure should be overridden in any package that + ! supports observations and needs to check user input + ! or process observation input using package data in some + ! other way. + ! -- dummy + class(BndType), intent(inout) :: this + ! -- local + integer(I4B) :: i, j, n + class(ObserveType), pointer :: obsrv => null() + character(len=LENBOUNDNAME) :: bname + logical :: jfound + ! + if (.not. this%bnd_obs_supported()) return + ! + do i=1,this%obs%npakobs + obsrv => this%obs%pakobs(i)%obsrv + ! + ! -- indxbnds needs to be deallocated and reallocated (using + ! ExpandArray) each stress period because list of boundaries + ! can change each stress period. + if (allocated(obsrv%indxbnds)) then + deallocate(obsrv%indxbnds) + endif + obsrv%BndFound = .false. + ! + bname = obsrv%FeatureName + if (bname /= '') then + ! -- Observation location(s) is(are) based on a boundary name. + ! Iterate through all boundaries to identify and store + ! corresponding index(indices) in bound array. + jfound = .false. + do j=1,this%nbound + if (this%boundname(j) == bname) then + jfound = .true. + obsrv%BndFound = .true. + obsrv%CurrentTimeStepEndValue = DZERO + call ExpandArray(obsrv%indxbnds) + n = size(obsrv%indxbnds) + obsrv%indxbnds(n) = j + endif + enddo + else + ! -- Observation location is a single node number + jfound = .false. + jloop: do j=1,this%nbound + if (this%nodelist(j) == obsrv%NodeNumber) then + jfound = .true. + obsrv%BndFound = .true. + obsrv%CurrentTimeStepEndValue = DZERO + call ExpandArray(obsrv%indxbnds) + n = size(obsrv%indxbnds) + obsrv%indxbnds(n) = j + endif + enddo jloop + endif + enddo + ! + if (count_errors() > 0) then + call store_error_unit(this%inunit) + call ustop() + endif + ! + return + end subroutine bnd_rp_obs + + subroutine bnd_bd_obs(this) + ! obs_bd + ! -- Generic procedure to save simulated values for + ! all observations defined for a package. + class(BndType) :: this + ! -- local + integer(I4B) :: i, n + real(DP) :: v + type(ObserveType), pointer :: obsrv => null() + !--------------------------------------------------------------------------- + ! + call this%obs%obs_bd_clear() + ! + ! -- Save simulated values for all of package's observations. + do i=1,this%obs%npakobs + obsrv => this%obs%pakobs(i)%obsrv + if (obsrv%BndFound) then + do n=1,size(obsrv%indxbnds) + if (obsrv%ObsTypeId == 'TO-MVR') then + if (this%imover == 1) then + v = this%pakmvrobj%get_qtomvr(obsrv%indxbnds(n)) + if (v > DZERO) then + v = -v + end if + else + v = DNODATA + end if + else + v = this%simvals(obsrv%indxbnds(n)) + end if + call this%obs%SaveOneSimval(obsrv, v) + enddo + else + call this%obs%SaveOneSimval(obsrv, DNODATA) + endif + enddo + ! + return + end subroutine bnd_bd_obs + + subroutine bnd_ot_obs(this) + ! -- Generic procedure to save simulated values for + ! all observations defined for a package. + ! -- dummy + class(BndType) :: this + ! -- local + !--------------------------------------------------------------------------- + ! + call this%obs%obs_ot() + ! + return + end subroutine bnd_ot_obs + + ! -- Procedures related to time series + + subroutine bnd_rp_ts(this) + ! -- Generic procedure to assign tsLink%Text appropriately for + ! all time series in use by package. + ! Override as needed. + ! -- dummy + class(BndType), intent(inout) :: this + ! + return + end subroutine bnd_rp_ts + + ! -- Procedures related to casting + + function CastAsBndClass(obj) result(res) + implicit none + class(*), pointer, intent(inout) :: obj + class(BndType), pointer :: res + ! + res => null() + if (.not. associated(obj)) return + ! + select type (obj) + class is (BndType) + res => obj + end select + return + end function CastAsBndClass + + subroutine AddBndToList(list, bnd) + implicit none + ! -- dummy + type(ListType), intent(inout) :: list + class(BndType), pointer, intent(inout) :: bnd + ! -- local + class(*), pointer :: obj + ! + obj => bnd + call list%Add(obj) + ! + return + end subroutine AddBndToList + + function GetBndFromList(list, idx) result (res) + implicit none + ! -- dummy + type(ListType), intent(inout) :: list + integer(I4B), intent(in) :: idx + class(BndType), pointer :: res + ! -- local + class(*), pointer :: obj + ! + obj => list%GetItem(idx) + res => CastAsBndClass(obj) + ! + return + end function GetBndFromList + +end module BndModule diff --git a/src/Model/ModelUtilities/Connections.f90 b/src/Model/ModelUtilities/Connections.f90 index 836977f0e5f..b327c18df3a 100644 --- a/src/Model/ModelUtilities/Connections.f90 +++ b/src/Model/ModelUtilities/Connections.f90 @@ -1,1356 +1,1356 @@ -module ConnectionsModule - - use ArrayReadersModule, only: ReadArray - use KindModule, only: DP, I4B - use ConstantsModule, only: LENMODELNAME, LENORIGIN - use GenericUtilitiesModule, only: sim_message - use BlockParserModule, only: BlockParserType - - implicit none - private - public :: ConnectionsType - public :: iac_to_ia - - type ConnectionsType - character(len=LENMODELNAME), pointer :: name_model => null() !name of the model - character(len=LENORIGIN), pointer :: cid => null() !character id of this object - integer(I4B), pointer :: nodes => null() !number of nodes - integer(I4B), pointer :: nja => null() !number of connections - integer(I4B), pointer :: njas => null() !number of symmetric connections - integer(I4B), pointer :: ianglex => null() !indicates whether or not anglex was read - integer(I4B), dimension(:), pointer, contiguous :: ia => null() !(size:nodes+1) csr index array - integer(I4B), dimension(:), pointer, contiguous :: ja => null() !(size:nja) csr pointer array - integer(I4B), dimension(:), pointer, contiguous :: mask => null() !(size:nja) to mask certain connections: ==0 means masked. Do not set the mask directly, use set_mask instead! - real(DP), dimension(:), pointer, contiguous :: cl1 => null() !(size:njas) connection length between node n and shared face with node m - real(DP), dimension(:), pointer, contiguous :: cl2 => null() !(size:njas) connection length between node m and shared face with node n - real(DP), dimension(:), pointer, contiguous :: hwva => null() !(size:njas) horizontal perpendicular width (ihc>0) or vertical flow area (ihc=0) - real(DP), dimension(:), pointer, contiguous :: anglex => null() !(size:njas) connection angle of face normal with x axis (read in degrees, stored as radians) - integer(I4B), dimension(:), pointer, contiguous :: isym => null() !(size:nja) returns csr index of symmetric counterpart - integer(I4B), dimension(:), pointer, contiguous :: jas => null() !(size:nja) map any connection to upper triangle (for pulling out of symmetric array) - integer(I4B), dimension(:), pointer, contiguous :: ihc => null() !(size:njas) horizontal connection (0:vertical, 1:mean thickness, 2:staggered) - integer(I4B), dimension(:), pointer, contiguous :: iausr => null() !(size:nodesusr+1) - integer(I4B), dimension(:), pointer, contiguous :: jausr => null() !(size:nja) - type(BlockParserType) :: parser !block parser - contains - procedure :: con_da - procedure :: allocate_scalars - procedure :: allocate_arrays - procedure :: con_finalize - procedure :: read_connectivity_from_block - procedure :: set_cl1_cl2_from_fleng - procedure :: disconnections - procedure :: disvconnections - procedure :: disuconnections - procedure :: iajausr - procedure :: getjaindex - procedure :: set_mask - end type ConnectionsType - - contains - - subroutine con_da(this) -! ****************************************************************************** -! con_da -- Deallocate connection variables -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(ConnectionsType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Strings - deallocate(this%name_model) - deallocate(this%cid) - ! - ! -- Scalars - call mem_deallocate(this%nodes) - call mem_deallocate(this%nja) - call mem_deallocate(this%njas) - call mem_deallocate(this%ianglex) - ! - ! -- iausr and jausr - if(associated(this%iausr, this%ia)) then - nullify(this%iausr) - else - call mem_deallocate(this%iausr) - endif - if(associated(this%jausr, this%ja)) then - nullify(this%jausr) - else - call mem_deallocate(this%jausr) - endif - ! -- mask - if (associated(this%mask, this%ja)) then - nullify(this%mask) - else - call mem_deallocate(this%mask) - end if - ! - ! -- Arrays - call mem_deallocate(this%ia) - call mem_deallocate(this%ja) - call mem_deallocate(this%isym) - call mem_deallocate(this%jas) - call mem_deallocate(this%hwva) - call mem_deallocate(this%anglex) - call mem_deallocate(this%ihc) - call mem_deallocate(this%cl1) - call mem_deallocate(this%cl2) - ! - ! -- return - return - end subroutine con_da - - subroutine allocate_scalars(this, name_model) -! ****************************************************************************** -! allocate_scalars -- Allocate scalars for ConnectionsType -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(ConnectionsType) :: this - character(len=*), intent(in) :: name_model -! ------------------------------------------------------------------------------ - ! - ! -- allocate - allocate(this%name_model) - allocate(this%cid) - this%cid = trim(adjustl(name_model)) // ' CON' - call mem_allocate(this%nodes, 'NODES', this%cid) - call mem_allocate(this%nja, 'NJA', this%cid) - call mem_allocate(this%njas, 'NJAS', this%cid) - call mem_allocate(this%ianglex, 'IANGLEX', this%cid) - this%name_model = name_model - this%nodes = 0 - this%nja = 0 - this%njas = 0 - this%ianglex = 0 - ! - ! -- Return - return - end subroutine allocate_scalars - - subroutine allocate_arrays(this) -! ****************************************************************************** -! allocate_arrays -- Allocate arrays for ConnectionsType -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(ConnectionsType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- allocate space for connection arrays - call mem_allocate(this%ia, this%nodes+1, 'IA', this%cid) - call mem_allocate(this%ja, this%nja, 'JA', this%cid) - call mem_allocate(this%isym, this%nja, 'ISYM', this%cid) - call mem_allocate(this%jas, this%nja, 'JAS', this%cid) - call mem_allocate(this%hwva, this%njas, 'HWVA', this%cid) - call mem_allocate(this%anglex, this%njas, 'ANGLEX', this%cid) - call mem_allocate(this%ihc, this%njas, 'IHC', this%cid) - call mem_allocate(this%cl1, this%njas, 'CL1', this%cid) - call mem_allocate(this%cl2, this%njas, 'CL2', this%cid) - call mem_allocate(this%iausr, 1, 'IAUSR', this%cid) - call mem_allocate(this%jausr, 1, 'JAUSR', this%cid) - ! - ! -- let mask point to ja, which is always nonzero, - ! until someone decides to do a 'set_mask' - this%mask => this%ja - ! - ! -- Return - return - end subroutine allocate_arrays - - subroutine con_finalize(this, ihctemp, cl12temp, hwvatemp, angldegx) -! ****************************************************************************** -! con_finalize -- Finalize connection data -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH, DONE, DHALF, DPIO180, DNODATA - use SimModule, only: ustop, store_error, count_errors, store_error_unit - ! -- dummy - class(ConnectionsType) :: this - integer(I4B), dimension(:), intent(in) :: ihctemp - real(DP), dimension(:), intent(in) :: cl12temp - real(DP), dimension(:), intent(in) :: hwvatemp - real(DP), dimension(:), intent(in) :: angldegx - ! -- local - character(len=LINELENGTH) :: errmsg - integer(I4B) :: ii, n, m - integer(I4B), parameter :: nname = 6 - character(len=24),dimension(nname) :: aname(nname) - ! -- formats - character(len=*),parameter :: fmtsymerr = & - &"('Error in array: ',a,'.', & - &' Array is not symmetric in positions: ',i0,' and ',i0,'.', & - &' Values in these positions are: ',1pg15.6,' and ', 1pg15.6, & - &' For node ',i0,' connected to node ',i0)" - character(len=*),parameter :: fmtsymerrja = & - &"('Error in array: ',a,'.', & - &' Array does not have symmetric counterpart in position ',i0, & - &' for cell ',i0,' connected to cell ',i0)" - character(len=*),parameter :: fmtjanmerr = & - &"('Error in array: ',a,'.', & - &' First value for cell : ',i0,' must equal ',i0,'.', & - &' Found ',i0,' instead.')" - character(len=*),parameter :: fmtjasorterr = & - &"('Error in array: ',a,'.', & - &' Entries not sorted for row: ',i0,'.', & - &' Offending entries are: ',i0,' and ',i0)" - character(len=*),parameter :: fmtihcerr = & - "('IHC must be 0, 1, or 2. Found: ',i0)" - ! -- 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'/ -! ------------------------------------------------------------------------------ - ! - ! -- Convert any negative ja numbers to positive - do ii = 1, this%nja - if(this%ja(ii) < 0) this%ja(ii) = -this%ja(ii) - enddo - ! - ! -- Ensure ja is sorted with the row column listed first - do n = 1, this%nodes - m = this%ja(this%ia(n)) - if (n /= m) then - write(errmsg, fmtjanmerr) trim(adjustl(aname(2))), n, n, m - call store_error(errmsg) - endif - do ii = this%ia(n) + 1, this%ia(n + 1) - 2 - m = this%ja(ii) - if(m > this%ja(ii+1)) then - write(errmsg, fmtjasorterr) trim(adjustl(aname(2))), n, & - m, this%ja(ii+1) - call store_error(errmsg) - endif - enddo - enddo - if(count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- fill the isym arrays - call fillisym(this%nodes, this%nja, this%ia, this%ja, this%isym) - ! - ! -- check for symmetry in ja (isym value of zero indicates there is no - ! symmetric connection - do n = 1, this%nodes - do ii = this%ia(n), this%ia(n + 1) - 1 - m = this%ja(ii) - if(this%isym(ii) == 0) then - write(errmsg, fmtsymerrja) trim(adjustl(aname(2))), ii, n, m - call store_error(errmsg) - endif - enddo - enddo - if(count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Fill the jas array, which maps any connection to upper triangle - call filljas(this%nodes, this%nja, this%ia, this%ja, this%isym, this%jas) - ! - ! -- Put into symmetric array - do n = 1, this%nodes - do ii = this%ia(n) + 1, this%ia(n + 1) - 1 - m = this%ja(ii) - if(ihctemp(ii) /= ihctemp(this%isym(ii))) then - write(errmsg, fmtsymerr) trim(adjustl(aname(3))), ii, this%isym(ii), & - ihctemp(ii), ihctemp(this%isym(ii)), n, m - call store_error(errmsg) - else - this%ihc(this%jas(ii)) = ihctemp(ii) - endif - enddo - enddo - if(count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Put cl12 into symmetric arrays cl1 and cl2 - do n = 1, this%nodes - do ii = this%ia(n) + 1, this%ia(n + 1) - 1 - m = this%ja(ii) - if(m > n) then - this%cl1(this%jas(ii)) = cl12temp(ii) - elseif(n > m) then - this%cl2(this%jas(ii)) = cl12temp(ii) - endif - enddo - enddo - ! - ! -- Put HWVA into symmetric array based on the value of IHC - ! IHC = 0, vertical connection, HWVA is vertical flow area - ! IHC = 1, horizontal connection, HWVA is the width perpendicular to - ! flow - ! IHC = 2, horizontal connection for a vertically staggered grid. - ! HWVA is the width perpendicular to flow. - do n = 1, this%nodes - do ii = this%ia(n) + 1, this%ia(n + 1) - 1 - m = this%ja(ii) - if(hwvatemp(ii) /= hwvatemp(this%isym(ii))) then - write(errmsg, fmtsymerr) trim(adjustl(aname(5))), ii, this%isym(ii), & - hwvatemp(ii), hwvatemp(this%isym(ii)), n, m - call store_error(errmsg) - endif - if(ihctemp(ii) < 0 .or. ihctemp(ii) > 2) then - write(errmsg, fmtihcerr) ihctemp(ii) - call store_error(errmsg) - endif - this%hwva(this%jas(ii)) = hwvatemp(ii) - enddo - enddo - if(count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Put anglextemp into this%anglex; store only upper triangle - if(this%ianglex /= 0) then - do n = 1, this%nodes - do ii = this%ia(n) + 1, this%ia(n + 1) - 1 - m = this%ja(ii) - if(n > m) cycle - this%anglex(this%jas(ii)) = angldegx(ii) * DPIO180 - enddo - enddo - else - do n = 1, size(this%anglex) - this%anglex(n) = DNODATA - enddo - endif - ! - ! -- Return - return - end subroutine con_finalize - - subroutine read_connectivity_from_block(this, name_model, nodes, nja, iout) -! ****************************************************************************** -! read_connectivity_from_block -- Read and process IAC and JA from an -! an input block called CONNECTIONDATA -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, count_errors - ! -- dummy - class(ConnectionsType) :: this - character(len=*), intent(in) :: name_model - integer(I4B), intent(in) :: nodes - integer(I4B), intent(in) :: nja - integer(I4B), intent(in) :: iout - ! -- local - character(len=LINELENGTH) :: line - character(len=LINELENGTH) :: keyword - integer(I4B) :: ii,n,m - integer(I4B) :: ierr, nerr - logical :: isfound, endOfBlock - integer(I4B), parameter :: nname = 2 - logical,dimension(nname) :: lname - character(len=24),dimension(nname) :: aname(nname) - character(len=300) :: ermsg - ! -- formats - character(len=*),parameter :: fmtsymerr = & - &"(/,'Error in array: ',(a),/, & - &'Array is not symmetric in positions: ',2i9,/, & - &'Values in these positions are: ', 2(1pg15.6))" - character(len=*),parameter :: fmtihcerr = & - &"(/,'IHC must be 0, 1, or 2. Found: ',i0)" - ! -- data - data aname(1) /' IAC'/ - data aname(2) /' JA'/ -! ------------------------------------------------------------------------------ - ! - ! -- Allocate and initialize dimensions - call this%allocate_scalars(name_model) - this%nodes = nodes - this%nja = nja - this%njas = (this%nja - this%nodes) / 2 - ! - ! -- Allocate space for connection arrays - call this%allocate_arrays() - ! - ! -- get connectiondata block - call this%parser%GetBlock('CONNECTIONDATA', isfound, ierr) - lname(:) = .false. - if(isfound) then - write(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%ia, aname(1), 1, & - this%nodes, iout, 0) - lname(1) = .true. - case ('JA') - call ReadArray(this%parser%iuactive, this%ja, aname(2), 1, & - this%nja, iout, 0) - lname(2) = .true. - case default - write(ermsg,'(4x,a,a)')'ERROR. UNKNOWN CONNECTIONDATA TAG: ', & - trim(keyword) - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - end do - write(iout,'(1x,a)')'END PROCESSING CONNECTIONDATA' - else - call store_error('ERROR. REQUIRED CONNECTIONDATA BLOCK NOT FOUND.') - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- verify all items were read - do n = 1, nname - if(.not. lname(n)) then - write(ermsg,'(1x,a,a)') & - 'ERROR. REQUIRED INPUT WAS NOT SPECIFIED: ',aname(n) - call store_error(ermsg) - endif - enddo - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Convert iac to ia - do n = 2, this%nodes + 1 - this%ia(n) = this%ia(n) + this%ia(n-1) - enddo - do n = this%nodes + 1, 2, -1 - this%ia(n) = this%ia(n - 1) + 1 - enddo - this%ia(1) = 1 - ! - ! -- Convert any negative ja numbers to positive - do ii = 1, this%nja - if(this%ja(ii) < 0) this%ja(ii) = -this%ja(ii) - enddo - ! - ! -- fill the isym and jas arrays - call fillisym(this%nodes, this%nja, this%ia, this%ja, this%isym) - call filljas(this%nodes, this%nja, this%ia, this%ja, this%isym, & - this%jas) - ! - ! -- check for symmetry in ja - do n = 1, this%nodes - do ii = this%ia(n), this%ia(n + 1) - 1 - m = this%ja(ii) - if(n /= this%ja(this%isym(ii))) then - write(line, fmtsymerr) aname(2), ii, this%isym(ii) - call sim_message(line) - call this%parser%StoreErrorUnit() - call ustop() - endif - enddo - enddo - ! - nerr = count_errors() - if(nerr > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Return - return - end subroutine read_connectivity_from_block - - subroutine set_cl1_cl2_from_fleng(this, fleng) -! ****************************************************************************** -! set_cl1_cl2_from_fleng -- Using a vector of cell lengths, -! calculate the cl1 and cl2 arrays. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DHALF - ! -- dummy - class(ConnectionsType) :: this - real(DP), dimension(:), intent(in) :: fleng - ! -- local - integer(I4B) :: n, m, ii -! ------------------------------------------------------------------------------ - ! - ! -- Fill symmetric arrays cl1 and cl2 from fleng of the node - do n = 1, this%nodes - do ii = this%ia(n) + 1, this%ia(n + 1) - 1 - m = this%ja(ii) - this%cl1(this%jas(ii)) = fleng(n) * DHALF - this%cl2(this%jas(ii)) = fleng(m) * DHALF - enddo - enddo - ! - ! -- Return - return - end subroutine set_cl1_cl2_from_fleng - - subroutine disconnections(this, name_model, nodes, ncol, nrow, nlay, & - nrsize, delr, delc, top, bot, nodereduced, & - nodeuser) -! ****************************************************************************** -! disconnections -- Construct the connectivity arrays for a structured -! three-dimensional grid. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DHALF, DZERO, DTHREE, DTWO, DPI - use SparseModule, only: sparsematrix - use InputOutputModule, only: get_node - ! -- dummy - class(ConnectionsType) :: this - character(len=*), intent(in) :: name_model - integer(I4B), intent(in) :: nodes - integer(I4B), intent(in) :: ncol - integer(I4B), intent(in) :: nrow - integer(I4B), intent(in) :: nlay - integer(I4B), intent(in) :: nrsize - real(DP), dimension(ncol), intent(in) :: delr - real(DP), dimension(nrow), intent(in) :: delc - real(DP), dimension(nodes), intent(in) :: top - real(DP), dimension(nodes), intent(in) :: bot - integer(I4B), dimension(:), target, intent(in) :: nodereduced - integer(I4B), dimension(:), intent(in) :: nodeuser - ! -- local - integer(I4B), dimension(:, :, :), pointer :: nrdcd_ptr => null() !non-contiguous because is a slice - integer(I4B), dimension(:), allocatable :: rowmaxnnz - type(sparsematrix) :: sparse - integer(I4B) :: i, j, k, kk, ierror, isympos, nodesuser - integer(I4B) :: nr, mr -! ------------------------------------------------------------------------------ - ! - ! -- Allocate scalars - call this%allocate_scalars(name_model) - ! - ! -- Set scalars - this%nodes = nodes - this%ianglex = 1 - ! - ! -- Setup the sparse matrix object - allocate(rowmaxnnz(this%nodes)) - do i = 1, this%nodes - rowmaxnnz(i) = 6 - enddo - call sparse%init(this%nodes, this%nodes, rowmaxnnz) - ! - ! -- Create a 3d pointer to nodereduced for easier processing - if(nrsize /= 0) then - nrdcd_ptr(1:ncol, 1:nrow, 1:nlay) => nodereduced - endif - ! - ! -- Add connections to sparse - do k = 1, nlay - do i = 1, nrow - do j = 1, ncol - ! - ! -- Find the reduced node number and then cycle if the - ! node is always inactive - if(nrsize == 0) then - nr = get_node(k, i, j, nlay, nrow, ncol) - else - nr = nrdcd_ptr(j, i, k) - endif - if(nr <= 0) cycle - ! - ! -- Process diagonal - call sparse%addconnection(nr, nr, 1) - ! - ! -- Up direction - if(k > 1) then - do kk = k - 1, 1, -1 - if(nrsize == 0) then - mr = get_node(kk, i, j, nlay, nrow, ncol) - else - mr = nrdcd_ptr(j, i, kk) - endif - if(mr >= 0) exit - enddo - if(mr > 0) then - call sparse%addconnection(nr, mr, 1) - endif - endif - ! - ! -- Back direction - if(i > 1) then - if(nrsize == 0) then - mr = get_node(k, i-1, j, nlay, nrow, ncol) - else - mr = nrdcd_ptr(j, i-1, k) - endif - if(mr > 0) then - call sparse%addconnection(nr, mr, 1) - endif - endif - ! - ! -- Left direction - if(j > 1) then - if(nrsize == 0) then - mr = get_node(k, i, j-1, nlay, nrow, ncol) - else - mr = nrdcd_ptr(j-1, i, k) - endif - if(mr > 0) then - call sparse%addconnection(nr, mr, 1) - endif - endif - ! - ! -- Right direction - if(j < ncol) then - if(nrsize == 0) then - mr = get_node(k, i, j+1, nlay, nrow, ncol) - else - mr = nrdcd_ptr(j+1, i, k) - endif - if(mr > 0) then - call sparse%addconnection(nr, mr, 1) - endif - endif - ! - ! -- Front direction - if(i < nrow) then !front - if(nrsize == 0) then - mr = get_node(k, i+1, j, nlay, nrow, ncol) - else - mr = nrdcd_ptr(j, i+1, k) - endif - if(mr > 0) then - call sparse%addconnection(nr, mr, 1) - endif - endif - ! - ! -- Down direction - if(k < nlay) then - do kk = k + 1, nlay - if(nrsize == 0) then - mr = get_node(kk, i, j, nlay, nrow, ncol) - else - mr = nrdcd_ptr(j, i, kk) - endif - if(mr >= 0) exit - enddo - if(mr > 0) then - call sparse%addconnection(nr, mr, 1) - endif - endif - enddo - enddo - enddo - this%nja = sparse%nnz - this%njas = (this%nja - this%nodes) / 2 - ! - ! -- Allocate index arrays of size nja and symmetric arrays - call this%allocate_arrays() - ! - ! -- Fill the IA and JA arrays from sparse, then destroy sparse - call sparse%filliaja(this%ia, this%ja, ierror) - call sparse%destroy() - ! - ! -- fill the isym and jas arrays - call fillisym(this%nodes, this%nja, this%ia, this%ja, this%isym) - call filljas(this%nodes, this%nja, this%ia, this%ja, this%isym, this%jas) - ! - ! -- Fill symmetric discretization arrays (ihc,cl1,cl2,hwva,anglex) - isympos = 1 - do k = 1, nlay - do i = 1, nrow - do j = 1, ncol - ! - ! -- cycle if node is always inactive - if(nrsize == 0) then - nr = get_node(k, i, j, nlay, nrow, ncol) - else - nr = nrdcd_ptr(j, i, k) - endif - if(nr <= 0) cycle - ! - ! -- right connection - if(j < ncol) then - if(nrsize == 0) then - mr = get_node(k, i, j+1, nlay, nrow, ncol) - else - mr = nrdcd_ptr(j+1, i, k) - endif - if(mr > 0) then - this%ihc(isympos) = 1 - this%cl1(isympos) = DHALF * delr(j) - this%cl2(isympos) = DHALF * delr(j + 1) - this%hwva(isympos) = delc(i) - this%anglex(isympos) = DZERO - isympos = isympos + 1 - endif - endif - ! - ! -- front connection - if(i < nrow) then - if(nrsize == 0) then - mr = get_node(k, i+1, j, nlay, nrow, ncol) - else - mr = nrdcd_ptr(j, i+1, k) - endif - if(mr > 0) then - this%ihc(isympos) = 1 - this%cl1(isympos) = DHALF * delc(i) - this%cl2(isympos) = DHALF * delc(i + 1) - this%hwva(isympos) = delr(j) - this%anglex(isympos) = DTHREE / DTWO * DPI - isympos = isympos + 1 - endif - endif - ! - ! -- down connection - if(k < nlay) then - do kk = k + 1, nlay - if(nrsize == 0) then - mr = get_node(kk, i, j, nlay, nrow, ncol) - else - mr = nrdcd_ptr(j, i, kk) - endif - if(mr >= 0) exit - enddo - if(mr > 0) then - this%ihc(isympos) = 0 - this%cl1(isympos) = DHALF * (top(nr) - bot(nr)) - this%cl2(isympos) = DHALF * (top(mr) - bot(mr)) - this%hwva(isympos) = delr(j) * delc(i) - this%anglex(isympos) = DZERO - isympos = isympos + 1 - endif - endif - enddo - enddo - enddo - ! - ! -- Deallocate temporary arrays - deallocate(rowmaxnnz) - ! - ! -- If reduced system, then need to build iausr and jausr, otherwise point - ! them to ia and ja. - nodesuser = nlay * nrow * ncol - call this%iajausr(nrsize, nodesuser, nodereduced, nodeuser) - ! - ! -- Return - return - end subroutine disconnections - - subroutine disvconnections(this, name_model, nodes, ncpl, nlay, nrsize, & - nvert, vertex, iavert, javert, cellxy, & - top, bot, nodereduced, nodeuser) -! ****************************************************************************** -! disvconnections -- Construct the connectivity arrays using cell disv -! information. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DHALF, DZERO, DTHREE, DTWO, DPI - use SparseModule, only: sparsematrix - use InputOutputModule, only: get_node - use DisvGeom, only: DisvGeomType - use MemoryManagerModule, only: mem_reallocate - ! -- dummy - class(ConnectionsType) :: this - character(len=*), intent(in) :: name_model - integer(I4B), intent(in) :: nodes - integer(I4B), intent(in) :: ncpl - integer(I4B), intent(in) :: nlay - integer(I4B), intent(in) :: nrsize - integer(I4B), intent(in) :: nvert - real(DP), dimension(2, nvert), intent(in) :: vertex - integer(I4B), dimension(:), intent(in) :: iavert - integer(I4B), dimension(:), intent(in) :: javert - real(DP), dimension(2, ncpl), intent(in) :: cellxy - real(DP), dimension(nodes), intent(in) :: top - real(DP), dimension(nodes), intent(in) :: bot - integer(I4B), dimension(:), intent(in) :: nodereduced - integer(I4B), dimension(:), intent(in) :: nodeuser - ! -- local - integer(I4B), dimension(:), allocatable :: itemp - type(sparsematrix) :: sparse, vertcellspm - integer(I4B) :: n, m, ipos, i, j, ierror, nodesuser - type(DisvGeomType) :: cell1, cell2 -! ------------------------------------------------------------------------------ - ! - ! -- Allocate scalars - call this%allocate_scalars(name_model) - ! - ! -- Set scalars - this%nodes = nodes - this%ianglex = 1 - ! - ! -- Initialize DisvGeomType objects - call cell1%init(nlay, ncpl, nodes, top, bot, iavert, javert, vertex, & - cellxy, nodereduced, nodeuser) - call cell2%init(nlay, ncpl, nodes, top, bot, iavert, javert, vertex, & - cellxy, nodereduced, nodeuser) - ! - ! -- Create a sparse matrix array with a row for each vertex. The columns - ! in the sparse matrix contains the cells that include that vertex. - ! This array will be used to determine horizontal cell connectivity. - allocate(itemp(nvert)) - do i = 1, nvert - itemp(i) = 4 - enddo - call vertcellspm%init(nvert, ncpl, itemp) - deallocate(itemp) - do j = 1, ncpl - do i = iavert(j), iavert(j + 1) - 1 - call vertcellspm%addconnection(javert(i), j, 1) - enddo - enddo - ! - ! -- Call routine to build a sparse matrix of the connections - call vertexconnect(this%nodes, nrsize, 6, nlay, ncpl, sparse, & - vertcellspm, cell1, cell2, nodereduced) - this%nja = sparse%nnz - this%njas = (this%nja - this%nodes) / 2 - ! - ! -- Allocate index arrays of size nja and symmetric arrays - call this%allocate_arrays() - ! - ! -- Fill the IA and JA arrays from sparse, then destroy sparse - call sparse%sort() - call sparse%filliaja(this%ia, this%ja, ierror) - call sparse%destroy() - ! - ! -- fill the isym and jas arrays - call fillisym(this%nodes, this%nja, this%ia, this%ja, this%isym) - call filljas(this%nodes, this%nja, this%ia, this%ja, this%isym, this%jas) - ! - ! -- Fill symmetric discretization arrays (ihc,cl1,cl2,hwva,anglex) - do n = 1, this%nodes - call cell1%set_nodered(n) - do ipos = this%ia(n) + 1, this%ia(n + 1) - 1 - m = this%ja(ipos) - if(m < n) cycle - call cell2%set_nodered(m) - call cell1%cprops(cell2, this%hwva(this%jas(ipos)), & - this%cl1(this%jas(ipos)), this%cl2(this%jas(ipos)), & - this%anglex(this%jas(ipos)), & - this%ihc(this%jas(ipos))) - enddo - enddo - ! - ! -- If reduced system, then need to build iausr and jausr, otherwise point - ! them to ia and ja. - nodesuser = nlay * ncpl - call this%iajausr(nrsize, nodesuser, nodereduced, nodeuser) - ! - ! -- Return - return - end subroutine disvconnections - - subroutine disuconnections(this, name_model, nodes, nodesuser, nrsize, & - nodereduced, nodeuser, iainp, jainp, & - ihcinp, cl12inp, hwvainp, angldegxinp) -! ****************************************************************************** -! disuconnections -- Construct the connectivity arrays using disu -! information. Grid may be reduced -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DHALF, DZERO, DTHREE, DTWO, DPI - use SparseModule, only: sparsematrix - use MemoryManagerModule, only: mem_reallocate - ! -- dummy - class(ConnectionsType) :: this - character(len=*), intent(in) :: name_model - integer(I4B), intent(in) :: nodes - integer(I4B), intent(in) :: nodesuser - integer(I4B), intent(in) :: nrsize - integer(I4B), dimension(:), contiguous, intent(in) :: nodereduced - integer(I4B), dimension(:), contiguous, intent(in) :: nodeuser - integer(I4B), dimension(:), contiguous, intent(in) :: iainp - integer(I4B), dimension(:), contiguous, intent(in) :: jainp - integer(I4B), dimension(:), contiguous, intent(in) :: ihcinp - real(DP), dimension(:), contiguous, intent(in) :: cl12inp - real(DP), dimension(:), contiguous, intent(in) :: hwvainp - real(DP), dimension(:), contiguous, intent(in) :: angldegxinp - ! -- local - integer(I4B),dimension(:),allocatable :: ihctemp - real(DP),dimension(:),allocatable :: cl12temp - real(DP),dimension(:),allocatable :: hwvatemp - real(DP),dimension(:),allocatable :: angldegxtemp - integer(I4B) :: nr, nu, mr, mu, ipos, iposr, ierror - integer(I4B), dimension(:), allocatable :: rowmaxnnz - type(sparsematrix) :: sparse -! ------------------------------------------------------------------------------ - ! - ! -- Allocate scalars - call this%allocate_scalars(name_model) - ! - ! -- Set scalars - this%nodes = nodes - this%ianglex = 1 - ! - ! -- If not a reduced grid, then copy and finalize, otherwise more - ! processing is required - if (nrsize == 0) then - this%nodes = nodes - this%nja = size(jainp) - this%njas = (this%nja - this%nodes) / 2 - call this%allocate_arrays() - do nu = 1, nodes + 1 - this%ia(nu) = iainp(nu) - end do - do ipos = 1, this%nja - this%ja(ipos) = jainp(ipos) - end do - ! - ! -- Call con_finalize to check inp arrays and push larger arrays - ! into compressed symmetric arrays - call this%con_finalize(ihcinp, cl12inp, hwvainp, angldegxinp) - ! - else - ! -- reduced system requires more work - ! - ! -- Setup the sparse matrix object - allocate(rowmaxnnz(this%nodes)) - do nr = 1, this%nodes - nu = nodeuser(nr) - rowmaxnnz(nr) = iainp(nu + 1) - iainp(nu) - enddo - call sparse%init(this%nodes, this%nodes, rowmaxnnz) - ! - ! -- go through user connectivity and create sparse - do nu = 1, nodesuser - nr = nodereduced(nu) - if (nr > 0) call sparse%addconnection(nr, nr, 1) - do ipos = iainp(nu) + 1, iainp(nu + 1) - 1 - mu = jainp(ipos) - mr = nodereduced(mu) - if (nr < 1) cycle - if (mr < 1) cycle - call sparse%addconnection(nr, mr, 1) - enddo - enddo - this%nja = sparse%nnz - this%njas = (this%nja - this%nodes) / 2 - ! - ! -- Allocate index arrays of size nja and symmetric arrays - call this%allocate_arrays() - ! - ! -- Fill the IA and JA arrays from sparse, then destroy sparse - call sparse%sort() - call sparse%filliaja(this%ia, this%ja, ierror) - call sparse%destroy() - deallocate(rowmaxnnz) - ! - ! -- At this point, need to reduce ihc, cl12, hwva, and angldegx - allocate(ihctemp(this%nja)) - allocate(cl12temp(this%nja)) - allocate(hwvatemp(this%nja)) - allocate(angldegxtemp(this%nja)) - ! - ! -- Compress user arrays into reduced arrays - iposr = 1 - do nu = 1, nodesuser - nr = nodereduced(nu) - do ipos = iainp(nu), iainp(nu + 1) - 1 - mu = jainp(ipos) - mr = nodereduced(mu) - if (nr < 1 .or. mr < 1) cycle - ihctemp(iposr) = ihcinp(ipos) - cl12temp(iposr) = cl12inp(ipos) - hwvatemp(iposr) = hwvainp(ipos) - angldegxtemp(iposr) = angldegxinp(ipos) - iposr = iposr + 1 - end do - end do - ! - ! -- call finalize - call this%con_finalize(ihctemp, cl12temp, hwvatemp, angldegxtemp) - ! - ! -- deallocate temporary arrays - deallocate(ihctemp) - deallocate(cl12temp) - deallocate(hwvatemp) - deallocate(angldegxtemp) - end if - ! - ! -- If reduced system, then need to build iausr and jausr, otherwise point - ! them to ia and ja. - call this%iajausr(nrsize, nodesuser, nodereduced, nodeuser) - ! - ! -- Return - return - end subroutine disuconnections - - subroutine iajausr(this, nrsize, nodesuser, nodereduced, nodeuser) -! ****************************************************************************** -! iajausr -- Fill iausr and jausr if reduced grid, otherwise point them -! to ia and ja. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_reallocate, mem_deallocate, mem_setptr - ! -- dummy - class(ConnectionsType) :: this - integer(I4B), intent(in) :: nrsize - integer(I4B), intent(in) :: nodesuser - integer(I4B), dimension(:), intent(in) :: nodereduced - integer(I4B), dimension(:), intent(in) :: nodeuser - ! -- local - integer(I4B) :: n, nr, ipos -! ------------------------------------------------------------------------------ - ! - ! -- If reduced system, then need to build iausr and jausr, otherwise point - ! them to ia and ja. - if(nrsize > 0) then - ! - ! -- Create the iausr array of size nodesuser + 1. For excluded cells, - ! iausr(n) and iausr(n + 1) should be equal to indicate no connections. - call mem_reallocate(this%iausr, nodesuser+1, 'IAUSR', this%cid) - this%iausr(nodesuser + 1) = this%ia(this%nodes + 1) - do n = nodesuser, 1, -1 - nr = nodereduced(n) - if(nr < 1) then - this%iausr(n) = this%iausr(n + 1) - else - this%iausr(n) = this%ia(nr) - endif - enddo - ! - ! -- Create the jausr array, which is the same size as ja, but it - ! contains user node numbers instead of reduced node numbers - call mem_reallocate(this%jausr, this%nja, 'JAUSR', this%cid) - do ipos = 1, this%nja - nr = this%ja(ipos) - n = nodeuser(nr) - this%jausr(ipos) = n - enddo - else - ! -- iausr and jausr will be pointers - call mem_deallocate(this%iausr) - call mem_deallocate(this%jausr) - call mem_setptr(this%iausr, 'IA', this%cid) - call mem_setptr(this%jausr, 'JA', this%cid) - endif - ! - ! -- Return - return - end subroutine iajausr - - function getjaindex(this,node1,node2) -! ****************************************************************************** -! Get the index in the JA array corresponding to the connection between -! two nodes of interest. Node1 is used as the index in the IA array, and -! IA(Node1) is the row index in the (nodes x nodes) matrix represented by -! the compressed sparse row format. -! -! -1 is returned if either node number is invalid. -! 0 is returned if the two nodes are not connected. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - integer(I4B) :: getjaindex - ! -- dummy - class(ConnectionsType) :: this - integer(I4B), intent(in) :: node1, node2 ! nodes of interest - ! -- local - integer(I4B) :: i -! ------------------------------------------------------------------------------ - ! - ! -- error checking - if (node1<1 .or. node1>this%nodes .or. node2<1 .or. node2>this%nodes) then - getjaindex = -1 ! indicates error (an invalid node number) - return - endif - ! - ! -- If node1==node2, just return the position for the diagonal. - if (node1==node2) then - getjaindex = this%ia(node1) - return - endif - ! - ! -- Look for connection among nonzero elements defined for row node1. - do i=this%ia(node1)+1,this%ia(node1+1)-1 - if (this%ja(i)==node2) then - getjaindex = i - return - endif - enddo - ! - ! -- If execution reaches here, no connection exists - ! between nodes of interest. - getjaindex = 0 ! indicates no connection exists - return - end function getjaindex - - subroutine fillisym(neq, nja, ia, ja, isym) -! ****************************************************************************** -! fillisym -- Private function to fill the isym array -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - integer(I4B),intent(in) :: neq - integer(I4B),intent(in) :: nja - integer(I4B),intent(inout),dimension(nja) :: isym - ! -- local - integer(I4B),intent(in),dimension(neq+1) :: ia - integer(I4B),intent(in),dimension(nja) :: ja - integer(I4B) :: n, m, ii, jj -! ------------------------------------------------------------------------------ - ! - do n=1, neq - do ii = ia(n), ia(n + 1) - 1 - m = ja(ii) - if(m /= n) then - isym(ii) = 0 - search: do jj = ia(m), ia(m + 1) - 1 - if(ja(jj) == n) then - isym(ii) = jj - exit search - endif - enddo search - else - isym(ii) = ii - endif - enddo - enddo - ! - ! -- Return - return - end subroutine fillisym - - subroutine filljas(neq, nja, ia, ja, isym, jas) -! ****************************************************************************** -! fillisym -- Private function to fill the jas array -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - integer(I4B),intent(in) :: neq - integer(I4B),intent(in) :: nja - integer(I4B),intent(in),dimension(neq+1) :: ia - integer(I4B),intent(in),dimension(nja) :: ja - integer(I4B),intent(in),dimension(nja) :: isym - integer(I4B),intent(inout),dimension(nja) :: jas - ! -- local - integer(I4B) :: n, m, ii, ipos -! ------------------------------------------------------------------------------ - ! - ! -- set diagonal to zero and fill upper - ipos = 1 - do n = 1, neq - jas(ia(n)) = 0 - do ii = ia(n) + 1, ia(n + 1) - 1 - m = ja(ii) - if(m > n) then - jas(ii) = ipos - ipos = ipos + 1 - endif - enddo - enddo - ! - ! -- fill lower - do n = 1, neq - do ii = ia(n), ia(n + 1) - 1 - m = ja(ii) - if(m < n) then - jas(ii) = jas(isym(ii)) - endif - enddo - enddo - ! - ! -- Return - return - end subroutine filljas - - - subroutine vertexconnect(nodes, nrsize, maxnnz, nlay, ncpl, sparse, & - vertcellspm, cell1, cell2, nodereduced) -! ****************************************************************************** -! vertexconnect -- routine to make cell connections from vertices -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SparseModule, only: sparsematrix - use InputOutputModule, only: get_node - use DisvGeom, only: DisvGeomType - ! -- dummy - integer(I4B), intent(in) :: nodes - integer(I4B), intent(in) :: nrsize - integer(I4B), intent(in) :: maxnnz - integer(I4B), intent(in) :: nlay - integer(I4B), intent(in) :: ncpl - type(SparseMatrix), intent(inout) :: sparse - type(SparseMatrix), intent(inout) :: vertcellspm - integer(I4B), dimension(:), intent(in) :: nodereduced - type(DisvGeomType), intent(inout) :: cell1, cell2 - ! -- local - integer(I4B), dimension(:), allocatable :: rowmaxnnz - integer(I4B) :: i, j, k, kk, nr, mr, j1, j2, icol1, icol2, nvert -! ------------------------------------------------------------------------------ - ! - ! -- Allocate and fill the ia and ja arrays - allocate(rowmaxnnz(nodes)) - do i = 1, nodes - rowmaxnnz(i) = maxnnz - enddo - call sparse%init(nodes, nodes, rowmaxnnz) - deallocate(rowmaxnnz) - do k = 1, nlay - do j = 1, ncpl - ! - ! -- Find the reduced node number and then cycle if the - ! node is always inactive - nr = get_node(k, 1, j, nlay, 1, ncpl) - if(nrsize > 0) nr = nodereduced(nr) - if(nr <= 0) cycle - ! - ! -- Process diagonal - call sparse%addconnection(nr, nr, 1) - ! - ! -- Up direction - if(k > 1) then - do kk = k - 1, 1, -1 - mr = get_node(kk, 1, j, nlay, 1, ncpl) - if(nrsize > 0) mr = nodereduced(mr) - if(mr >= 0) exit - enddo - if(mr > 0) then - call sparse%addconnection(nr, mr, 1) - endif - endif - ! - ! -- Down direction - if(k < nlay) then - do kk = k + 1, nlay - mr = get_node(kk, 1, j, nlay, 1, ncpl) - if(nrsize > 0) mr = nodereduced(mr) - if(mr >= 0) exit - enddo - if(mr > 0) then - call sparse%addconnection(nr, mr, 1) - endif - endif - enddo - enddo - ! - ! -- Go through each vertex and connect up all the cells that use - ! this vertex in their definition and share an edge. - nvert = vertcellspm%nrow - do i = 1, nvert - do icol1 = 1, vertcellspm%row(i)%nnz - j1 = vertcellspm%row(i)%icolarray(icol1) - do k = 1, nlay - nr = get_node(k, 1, j1, nlay, 1, ncpl) - if(nrsize > 0) nr = nodereduced(nr) - if(nr <= 0) cycle - call cell1%set_nodered(nr) - do icol2 = 1, vertcellspm%row(i)%nnz - j2 = vertcellspm%row(i)%icolarray(icol2) - if(j1 == j2) cycle - mr = get_node(k, 1, j2, nlay, 1, ncpl) - if(nrsize > 0) mr = nodereduced(mr) - if(mr <= 0) cycle - call cell2%set_nodered(mr) - if(cell1%shares_edge(cell2)) then - call sparse%addconnection(nr, mr, 1) - endif - enddo - enddo - enddo - enddo - ! - ! -- return - return - end subroutine vertexconnect - - subroutine set_mask(this, ipos, maskval) -! ****************************************************************************** -! set_mask -- routine to set a value in the mask array -! (which has the same shape as this%ja) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use MemoryManagerModule, only: mem_allocate - class(ConnectionsType) :: this - integer(I4B), intent(in) :: ipos - integer(I4B), intent(in) :: maskval - ! local - integer(I4B) :: i -! ------------------------------------------------------------------------------ - ! - ! if we still point to this%ja, we first need to allocate space - if (associated(this%mask, this%ja)) then - call mem_allocate(this%mask, this%nja, 'MASK', this%cid) - ! and initialize with unmasked - do i = 1, this%nja - this%mask(i) = 1 - end do - end if - ! - ! -- set the mask value - this%mask(ipos) = maskVal - ! - ! -- return - return - end subroutine set_mask - - subroutine iac_to_ia(ia) -! ****************************************************************************** -! iac_to_ia -- convert an iac array into an ia array -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - 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) - enddo - do n = nodes + 1, 2, -1 - ia(n) = ia(n - 1) + 1 - enddo - ia(1) = 1 - ! - ! -- return - return - end subroutine iac_to_ia - -end module ConnectionsModule +module ConnectionsModule + + use ArrayReadersModule, only: ReadArray + use KindModule, only: DP, I4B + use ConstantsModule, only: LENMODELNAME, LENORIGIN + use GenericUtilitiesModule, only: sim_message + use BlockParserModule, only: BlockParserType + + implicit none + private + public :: ConnectionsType + public :: iac_to_ia + + type ConnectionsType + character(len=LENMODELNAME), pointer :: name_model => null() !name of the model + character(len=LENORIGIN), pointer :: cid => null() !character id of this object + integer(I4B), pointer :: nodes => null() !number of nodes + integer(I4B), pointer :: nja => null() !number of connections + integer(I4B), pointer :: njas => null() !number of symmetric connections + integer(I4B), pointer :: ianglex => null() !indicates whether or not anglex was read + integer(I4B), dimension(:), pointer, contiguous :: ia => null() !(size:nodes+1) csr index array + integer(I4B), dimension(:), pointer, contiguous :: ja => null() !(size:nja) csr pointer array + integer(I4B), dimension(:), pointer, contiguous :: mask => null() !(size:nja) to mask certain connections: ==0 means masked. Do not set the mask directly, use set_mask instead! + real(DP), dimension(:), pointer, contiguous :: cl1 => null() !(size:njas) connection length between node n and shared face with node m + real(DP), dimension(:), pointer, contiguous :: cl2 => null() !(size:njas) connection length between node m and shared face with node n + real(DP), dimension(:), pointer, contiguous :: hwva => null() !(size:njas) horizontal perpendicular width (ihc>0) or vertical flow area (ihc=0) + real(DP), dimension(:), pointer, contiguous :: anglex => null() !(size:njas) connection angle of face normal with x axis (read in degrees, stored as radians) + integer(I4B), dimension(:), pointer, contiguous :: isym => null() !(size:nja) returns csr index of symmetric counterpart + integer(I4B), dimension(:), pointer, contiguous :: jas => null() !(size:nja) map any connection to upper triangle (for pulling out of symmetric array) + integer(I4B), dimension(:), pointer, contiguous :: ihc => null() !(size:njas) horizontal connection (0:vertical, 1:mean thickness, 2:staggered) + integer(I4B), dimension(:), pointer, contiguous :: iausr => null() !(size:nodesusr+1) + integer(I4B), dimension(:), pointer, contiguous :: jausr => null() !(size:nja) + type(BlockParserType) :: parser !block parser + contains + procedure :: con_da + procedure :: allocate_scalars + procedure :: allocate_arrays + procedure :: con_finalize + procedure :: read_connectivity_from_block + procedure :: set_cl1_cl2_from_fleng + procedure :: disconnections + procedure :: disvconnections + procedure :: disuconnections + procedure :: iajausr + procedure :: getjaindex + procedure :: set_mask + end type ConnectionsType + + contains + + subroutine con_da(this) +! ****************************************************************************** +! con_da -- Deallocate connection variables +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(ConnectionsType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Strings + deallocate(this%name_model) + deallocate(this%cid) + ! + ! -- Scalars + call mem_deallocate(this%nodes) + call mem_deallocate(this%nja) + call mem_deallocate(this%njas) + call mem_deallocate(this%ianglex) + ! + ! -- iausr and jausr + if(associated(this%iausr, this%ia)) then + nullify(this%iausr) + else + call mem_deallocate(this%iausr) + endif + if(associated(this%jausr, this%ja)) then + nullify(this%jausr) + else + call mem_deallocate(this%jausr) + endif + ! -- mask + if (associated(this%mask, this%ja)) then + nullify(this%mask) + else + call mem_deallocate(this%mask) + end if + ! + ! -- Arrays + call mem_deallocate(this%ia) + call mem_deallocate(this%ja) + call mem_deallocate(this%isym) + call mem_deallocate(this%jas) + call mem_deallocate(this%hwva) + call mem_deallocate(this%anglex) + call mem_deallocate(this%ihc) + call mem_deallocate(this%cl1) + call mem_deallocate(this%cl2) + ! + ! -- return + return + end subroutine con_da + + subroutine allocate_scalars(this, name_model) +! ****************************************************************************** +! allocate_scalars -- Allocate scalars for ConnectionsType +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(ConnectionsType) :: this + character(len=*), intent(in) :: name_model +! ------------------------------------------------------------------------------ + ! + ! -- allocate + allocate(this%name_model) + allocate(this%cid) + this%cid = trim(adjustl(name_model)) // ' CON' + call mem_allocate(this%nodes, 'NODES', this%cid) + call mem_allocate(this%nja, 'NJA', this%cid) + call mem_allocate(this%njas, 'NJAS', this%cid) + call mem_allocate(this%ianglex, 'IANGLEX', this%cid) + this%name_model = name_model + this%nodes = 0 + this%nja = 0 + this%njas = 0 + this%ianglex = 0 + ! + ! -- Return + return + end subroutine allocate_scalars + + subroutine allocate_arrays(this) +! ****************************************************************************** +! allocate_arrays -- Allocate arrays for ConnectionsType +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(ConnectionsType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- allocate space for connection arrays + call mem_allocate(this%ia, this%nodes+1, 'IA', this%cid) + call mem_allocate(this%ja, this%nja, 'JA', this%cid) + call mem_allocate(this%isym, this%nja, 'ISYM', this%cid) + call mem_allocate(this%jas, this%nja, 'JAS', this%cid) + call mem_allocate(this%hwva, this%njas, 'HWVA', this%cid) + call mem_allocate(this%anglex, this%njas, 'ANGLEX', this%cid) + call mem_allocate(this%ihc, this%njas, 'IHC', this%cid) + call mem_allocate(this%cl1, this%njas, 'CL1', this%cid) + call mem_allocate(this%cl2, this%njas, 'CL2', this%cid) + call mem_allocate(this%iausr, 1, 'IAUSR', this%cid) + call mem_allocate(this%jausr, 1, 'JAUSR', this%cid) + ! + ! -- let mask point to ja, which is always nonzero, + ! until someone decides to do a 'set_mask' + this%mask => this%ja + ! + ! -- Return + return + end subroutine allocate_arrays + + subroutine con_finalize(this, ihctemp, cl12temp, hwvatemp, angldegx) +! ****************************************************************************** +! con_finalize -- Finalize connection data +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH, DONE, DHALF, DPIO180, DNODATA + use SimModule, only: ustop, store_error, count_errors, store_error_unit + ! -- dummy + class(ConnectionsType) :: this + integer(I4B), dimension(:), intent(in) :: ihctemp + real(DP), dimension(:), intent(in) :: cl12temp + real(DP), dimension(:), intent(in) :: hwvatemp + real(DP), dimension(:), intent(in) :: angldegx + ! -- local + character(len=LINELENGTH) :: errmsg + integer(I4B) :: ii, n, m + integer(I4B), parameter :: nname = 6 + character(len=24),dimension(nname) :: aname(nname) + ! -- formats + character(len=*),parameter :: fmtsymerr = & + &"('Error in array: ',a,'.', & + &' Array is not symmetric in positions: ',i0,' and ',i0,'.', & + &' Values in these positions are: ',1pg15.6,' and ', 1pg15.6, & + &' For node ',i0,' connected to node ',i0)" + character(len=*),parameter :: fmtsymerrja = & + &"('Error in array: ',a,'.', & + &' Array does not have symmetric counterpart in position ',i0, & + &' for cell ',i0,' connected to cell ',i0)" + character(len=*),parameter :: fmtjanmerr = & + &"('Error in array: ',a,'.', & + &' First value for cell : ',i0,' must equal ',i0,'.', & + &' Found ',i0,' instead.')" + character(len=*),parameter :: fmtjasorterr = & + &"('Error in array: ',a,'.', & + &' Entries not sorted for row: ',i0,'.', & + &' Offending entries are: ',i0,' and ',i0)" + character(len=*),parameter :: fmtihcerr = & + "('IHC must be 0, 1, or 2. Found: ',i0)" + ! -- 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'/ +! ------------------------------------------------------------------------------ + ! + ! -- Convert any negative ja numbers to positive + do ii = 1, this%nja + if(this%ja(ii) < 0) this%ja(ii) = -this%ja(ii) + enddo + ! + ! -- Ensure ja is sorted with the row column listed first + do n = 1, this%nodes + m = this%ja(this%ia(n)) + if (n /= m) then + write(errmsg, fmtjanmerr) trim(adjustl(aname(2))), n, n, m + call store_error(errmsg) + endif + do ii = this%ia(n) + 1, this%ia(n + 1) - 2 + m = this%ja(ii) + if(m > this%ja(ii+1)) then + write(errmsg, fmtjasorterr) trim(adjustl(aname(2))), n, & + m, this%ja(ii+1) + call store_error(errmsg) + endif + enddo + enddo + if(count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- fill the isym arrays + call fillisym(this%nodes, this%nja, this%ia, this%ja, this%isym) + ! + ! -- check for symmetry in ja (isym value of zero indicates there is no + ! symmetric connection + do n = 1, this%nodes + do ii = this%ia(n), this%ia(n + 1) - 1 + m = this%ja(ii) + if(this%isym(ii) == 0) then + write(errmsg, fmtsymerrja) trim(adjustl(aname(2))), ii, n, m + call store_error(errmsg) + endif + enddo + enddo + if(count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Fill the jas array, which maps any connection to upper triangle + call filljas(this%nodes, this%nja, this%ia, this%ja, this%isym, this%jas) + ! + ! -- Put into symmetric array + do n = 1, this%nodes + do ii = this%ia(n) + 1, this%ia(n + 1) - 1 + m = this%ja(ii) + if(ihctemp(ii) /= ihctemp(this%isym(ii))) then + write(errmsg, fmtsymerr) trim(adjustl(aname(3))), ii, this%isym(ii), & + ihctemp(ii), ihctemp(this%isym(ii)), n, m + call store_error(errmsg) + else + this%ihc(this%jas(ii)) = ihctemp(ii) + endif + enddo + enddo + if(count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Put cl12 into symmetric arrays cl1 and cl2 + do n = 1, this%nodes + do ii = this%ia(n) + 1, this%ia(n + 1) - 1 + m = this%ja(ii) + if(m > n) then + this%cl1(this%jas(ii)) = cl12temp(ii) + elseif(n > m) then + this%cl2(this%jas(ii)) = cl12temp(ii) + endif + enddo + enddo + ! + ! -- Put HWVA into symmetric array based on the value of IHC + ! IHC = 0, vertical connection, HWVA is vertical flow area + ! IHC = 1, horizontal connection, HWVA is the width perpendicular to + ! flow + ! IHC = 2, horizontal connection for a vertically staggered grid. + ! HWVA is the width perpendicular to flow. + do n = 1, this%nodes + do ii = this%ia(n) + 1, this%ia(n + 1) - 1 + m = this%ja(ii) + if(hwvatemp(ii) /= hwvatemp(this%isym(ii))) then + write(errmsg, fmtsymerr) trim(adjustl(aname(5))), ii, this%isym(ii), & + hwvatemp(ii), hwvatemp(this%isym(ii)), n, m + call store_error(errmsg) + endif + if(ihctemp(ii) < 0 .or. ihctemp(ii) > 2) then + write(errmsg, fmtihcerr) ihctemp(ii) + call store_error(errmsg) + endif + this%hwva(this%jas(ii)) = hwvatemp(ii) + enddo + enddo + if(count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Put anglextemp into this%anglex; store only upper triangle + if(this%ianglex /= 0) then + do n = 1, this%nodes + do ii = this%ia(n) + 1, this%ia(n + 1) - 1 + m = this%ja(ii) + if(n > m) cycle + this%anglex(this%jas(ii)) = angldegx(ii) * DPIO180 + enddo + enddo + else + do n = 1, size(this%anglex) + this%anglex(n) = DNODATA + enddo + endif + ! + ! -- Return + return + end subroutine con_finalize + + subroutine read_connectivity_from_block(this, name_model, nodes, nja, iout) +! ****************************************************************************** +! read_connectivity_from_block -- Read and process IAC and JA from an +! an input block called CONNECTIONDATA +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, count_errors + ! -- dummy + class(ConnectionsType) :: this + character(len=*), intent(in) :: name_model + integer(I4B), intent(in) :: nodes + integer(I4B), intent(in) :: nja + integer(I4B), intent(in) :: iout + ! -- local + character(len=LINELENGTH) :: line + character(len=LINELENGTH) :: keyword + integer(I4B) :: ii,n,m + integer(I4B) :: ierr, nerr + logical :: isfound, endOfBlock + integer(I4B), parameter :: nname = 2 + logical,dimension(nname) :: lname + character(len=24),dimension(nname) :: aname(nname) + character(len=300) :: ermsg + ! -- formats + character(len=*),parameter :: fmtsymerr = & + &"(/,'Error in array: ',(a),/, & + &'Array is not symmetric in positions: ',2i9,/, & + &'Values in these positions are: ', 2(1pg15.6))" + character(len=*),parameter :: fmtihcerr = & + &"(/,'IHC must be 0, 1, or 2. Found: ',i0)" + ! -- data + data aname(1) /' IAC'/ + data aname(2) /' JA'/ +! ------------------------------------------------------------------------------ + ! + ! -- Allocate and initialize dimensions + call this%allocate_scalars(name_model) + this%nodes = nodes + this%nja = nja + this%njas = (this%nja - this%nodes) / 2 + ! + ! -- Allocate space for connection arrays + call this%allocate_arrays() + ! + ! -- get connectiondata block + call this%parser%GetBlock('CONNECTIONDATA', isfound, ierr) + lname(:) = .false. + if(isfound) then + write(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%ia, aname(1), 1, & + this%nodes, iout, 0) + lname(1) = .true. + case ('JA') + call ReadArray(this%parser%iuactive, this%ja, aname(2), 1, & + this%nja, iout, 0) + lname(2) = .true. + case default + write(ermsg,'(4x,a,a)')'ERROR. UNKNOWN CONNECTIONDATA TAG: ', & + trim(keyword) + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + end do + write(iout,'(1x,a)')'END PROCESSING CONNECTIONDATA' + else + call store_error('ERROR. REQUIRED CONNECTIONDATA BLOCK NOT FOUND.') + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- verify all items were read + do n = 1, nname + if(.not. lname(n)) then + write(ermsg,'(1x,a,a)') & + 'ERROR. REQUIRED INPUT WAS NOT SPECIFIED: ',aname(n) + call store_error(ermsg) + endif + enddo + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Convert iac to ia + do n = 2, this%nodes + 1 + this%ia(n) = this%ia(n) + this%ia(n-1) + enddo + do n = this%nodes + 1, 2, -1 + this%ia(n) = this%ia(n - 1) + 1 + enddo + this%ia(1) = 1 + ! + ! -- Convert any negative ja numbers to positive + do ii = 1, this%nja + if(this%ja(ii) < 0) this%ja(ii) = -this%ja(ii) + enddo + ! + ! -- fill the isym and jas arrays + call fillisym(this%nodes, this%nja, this%ia, this%ja, this%isym) + call filljas(this%nodes, this%nja, this%ia, this%ja, this%isym, & + this%jas) + ! + ! -- check for symmetry in ja + do n = 1, this%nodes + do ii = this%ia(n), this%ia(n + 1) - 1 + m = this%ja(ii) + if(n /= this%ja(this%isym(ii))) then + write(line, fmtsymerr) aname(2), ii, this%isym(ii) + call sim_message(line) + call this%parser%StoreErrorUnit() + call ustop() + endif + enddo + enddo + ! + nerr = count_errors() + if(nerr > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Return + return + end subroutine read_connectivity_from_block + + subroutine set_cl1_cl2_from_fleng(this, fleng) +! ****************************************************************************** +! set_cl1_cl2_from_fleng -- Using a vector of cell lengths, +! calculate the cl1 and cl2 arrays. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DHALF + ! -- dummy + class(ConnectionsType) :: this + real(DP), dimension(:), intent(in) :: fleng + ! -- local + integer(I4B) :: n, m, ii +! ------------------------------------------------------------------------------ + ! + ! -- Fill symmetric arrays cl1 and cl2 from fleng of the node + do n = 1, this%nodes + do ii = this%ia(n) + 1, this%ia(n + 1) - 1 + m = this%ja(ii) + this%cl1(this%jas(ii)) = fleng(n) * DHALF + this%cl2(this%jas(ii)) = fleng(m) * DHALF + enddo + enddo + ! + ! -- Return + return + end subroutine set_cl1_cl2_from_fleng + + subroutine disconnections(this, name_model, nodes, ncol, nrow, nlay, & + nrsize, delr, delc, top, bot, nodereduced, & + nodeuser) +! ****************************************************************************** +! disconnections -- Construct the connectivity arrays for a structured +! three-dimensional grid. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DHALF, DZERO, DTHREE, DTWO, DPI + use SparseModule, only: sparsematrix + use InputOutputModule, only: get_node + ! -- dummy + class(ConnectionsType) :: this + character(len=*), intent(in) :: name_model + integer(I4B), intent(in) :: nodes + integer(I4B), intent(in) :: ncol + integer(I4B), intent(in) :: nrow + integer(I4B), intent(in) :: nlay + integer(I4B), intent(in) :: nrsize + real(DP), dimension(ncol), intent(in) :: delr + real(DP), dimension(nrow), intent(in) :: delc + real(DP), dimension(nodes), intent(in) :: top + real(DP), dimension(nodes), intent(in) :: bot + integer(I4B), dimension(:), target, intent(in) :: nodereduced + integer(I4B), dimension(:), intent(in) :: nodeuser + ! -- local + integer(I4B), dimension(:, :, :), pointer :: nrdcd_ptr => null() !non-contiguous because is a slice + integer(I4B), dimension(:), allocatable :: rowmaxnnz + type(sparsematrix) :: sparse + integer(I4B) :: i, j, k, kk, ierror, isympos, nodesuser + integer(I4B) :: nr, mr +! ------------------------------------------------------------------------------ + ! + ! -- Allocate scalars + call this%allocate_scalars(name_model) + ! + ! -- Set scalars + this%nodes = nodes + this%ianglex = 1 + ! + ! -- Setup the sparse matrix object + allocate(rowmaxnnz(this%nodes)) + do i = 1, this%nodes + rowmaxnnz(i) = 6 + enddo + call sparse%init(this%nodes, this%nodes, rowmaxnnz) + ! + ! -- Create a 3d pointer to nodereduced for easier processing + if(nrsize /= 0) then + nrdcd_ptr(1:ncol, 1:nrow, 1:nlay) => nodereduced + endif + ! + ! -- Add connections to sparse + do k = 1, nlay + do i = 1, nrow + do j = 1, ncol + ! + ! -- Find the reduced node number and then cycle if the + ! node is always inactive + if(nrsize == 0) then + nr = get_node(k, i, j, nlay, nrow, ncol) + else + nr = nrdcd_ptr(j, i, k) + endif + if(nr <= 0) cycle + ! + ! -- Process diagonal + call sparse%addconnection(nr, nr, 1) + ! + ! -- Up direction + if(k > 1) then + do kk = k - 1, 1, -1 + if(nrsize == 0) then + mr = get_node(kk, i, j, nlay, nrow, ncol) + else + mr = nrdcd_ptr(j, i, kk) + endif + if(mr >= 0) exit + enddo + if(mr > 0) then + call sparse%addconnection(nr, mr, 1) + endif + endif + ! + ! -- Back direction + if(i > 1) then + if(nrsize == 0) then + mr = get_node(k, i-1, j, nlay, nrow, ncol) + else + mr = nrdcd_ptr(j, i-1, k) + endif + if(mr > 0) then + call sparse%addconnection(nr, mr, 1) + endif + endif + ! + ! -- Left direction + if(j > 1) then + if(nrsize == 0) then + mr = get_node(k, i, j-1, nlay, nrow, ncol) + else + mr = nrdcd_ptr(j-1, i, k) + endif + if(mr > 0) then + call sparse%addconnection(nr, mr, 1) + endif + endif + ! + ! -- Right direction + if(j < ncol) then + if(nrsize == 0) then + mr = get_node(k, i, j+1, nlay, nrow, ncol) + else + mr = nrdcd_ptr(j+1, i, k) + endif + if(mr > 0) then + call sparse%addconnection(nr, mr, 1) + endif + endif + ! + ! -- Front direction + if(i < nrow) then !front + if(nrsize == 0) then + mr = get_node(k, i+1, j, nlay, nrow, ncol) + else + mr = nrdcd_ptr(j, i+1, k) + endif + if(mr > 0) then + call sparse%addconnection(nr, mr, 1) + endif + endif + ! + ! -- Down direction + if(k < nlay) then + do kk = k + 1, nlay + if(nrsize == 0) then + mr = get_node(kk, i, j, nlay, nrow, ncol) + else + mr = nrdcd_ptr(j, i, kk) + endif + if(mr >= 0) exit + enddo + if(mr > 0) then + call sparse%addconnection(nr, mr, 1) + endif + endif + enddo + enddo + enddo + this%nja = sparse%nnz + this%njas = (this%nja - this%nodes) / 2 + ! + ! -- Allocate index arrays of size nja and symmetric arrays + call this%allocate_arrays() + ! + ! -- Fill the IA and JA arrays from sparse, then destroy sparse + call sparse%filliaja(this%ia, this%ja, ierror) + call sparse%destroy() + ! + ! -- fill the isym and jas arrays + call fillisym(this%nodes, this%nja, this%ia, this%ja, this%isym) + call filljas(this%nodes, this%nja, this%ia, this%ja, this%isym, this%jas) + ! + ! -- Fill symmetric discretization arrays (ihc,cl1,cl2,hwva,anglex) + isympos = 1 + do k = 1, nlay + do i = 1, nrow + do j = 1, ncol + ! + ! -- cycle if node is always inactive + if(nrsize == 0) then + nr = get_node(k, i, j, nlay, nrow, ncol) + else + nr = nrdcd_ptr(j, i, k) + endif + if(nr <= 0) cycle + ! + ! -- right connection + if(j < ncol) then + if(nrsize == 0) then + mr = get_node(k, i, j+1, nlay, nrow, ncol) + else + mr = nrdcd_ptr(j+1, i, k) + endif + if(mr > 0) then + this%ihc(isympos) = 1 + this%cl1(isympos) = DHALF * delr(j) + this%cl2(isympos) = DHALF * delr(j + 1) + this%hwva(isympos) = delc(i) + this%anglex(isympos) = DZERO + isympos = isympos + 1 + endif + endif + ! + ! -- front connection + if(i < nrow) then + if(nrsize == 0) then + mr = get_node(k, i+1, j, nlay, nrow, ncol) + else + mr = nrdcd_ptr(j, i+1, k) + endif + if(mr > 0) then + this%ihc(isympos) = 1 + this%cl1(isympos) = DHALF * delc(i) + this%cl2(isympos) = DHALF * delc(i + 1) + this%hwva(isympos) = delr(j) + this%anglex(isympos) = DTHREE / DTWO * DPI + isympos = isympos + 1 + endif + endif + ! + ! -- down connection + if(k < nlay) then + do kk = k + 1, nlay + if(nrsize == 0) then + mr = get_node(kk, i, j, nlay, nrow, ncol) + else + mr = nrdcd_ptr(j, i, kk) + endif + if(mr >= 0) exit + enddo + if(mr > 0) then + this%ihc(isympos) = 0 + this%cl1(isympos) = DHALF * (top(nr) - bot(nr)) + this%cl2(isympos) = DHALF * (top(mr) - bot(mr)) + this%hwva(isympos) = delr(j) * delc(i) + this%anglex(isympos) = DZERO + isympos = isympos + 1 + endif + endif + enddo + enddo + enddo + ! + ! -- Deallocate temporary arrays + deallocate(rowmaxnnz) + ! + ! -- If reduced system, then need to build iausr and jausr, otherwise point + ! them to ia and ja. + nodesuser = nlay * nrow * ncol + call this%iajausr(nrsize, nodesuser, nodereduced, nodeuser) + ! + ! -- Return + return + end subroutine disconnections + + subroutine disvconnections(this, name_model, nodes, ncpl, nlay, nrsize, & + nvert, vertex, iavert, javert, cellxy, & + top, bot, nodereduced, nodeuser) +! ****************************************************************************** +! disvconnections -- Construct the connectivity arrays using cell disv +! information. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DHALF, DZERO, DTHREE, DTWO, DPI + use SparseModule, only: sparsematrix + use InputOutputModule, only: get_node + use DisvGeom, only: DisvGeomType + use MemoryManagerModule, only: mem_reallocate + ! -- dummy + class(ConnectionsType) :: this + character(len=*), intent(in) :: name_model + integer(I4B), intent(in) :: nodes + integer(I4B), intent(in) :: ncpl + integer(I4B), intent(in) :: nlay + integer(I4B), intent(in) :: nrsize + integer(I4B), intent(in) :: nvert + real(DP), dimension(2, nvert), intent(in) :: vertex + integer(I4B), dimension(:), intent(in) :: iavert + integer(I4B), dimension(:), intent(in) :: javert + real(DP), dimension(2, ncpl), intent(in) :: cellxy + real(DP), dimension(nodes), intent(in) :: top + real(DP), dimension(nodes), intent(in) :: bot + integer(I4B), dimension(:), intent(in) :: nodereduced + integer(I4B), dimension(:), intent(in) :: nodeuser + ! -- local + integer(I4B), dimension(:), allocatable :: itemp + type(sparsematrix) :: sparse, vertcellspm + integer(I4B) :: n, m, ipos, i, j, ierror, nodesuser + type(DisvGeomType) :: cell1, cell2 +! ------------------------------------------------------------------------------ + ! + ! -- Allocate scalars + call this%allocate_scalars(name_model) + ! + ! -- Set scalars + this%nodes = nodes + this%ianglex = 1 + ! + ! -- Initialize DisvGeomType objects + call cell1%init(nlay, ncpl, nodes, top, bot, iavert, javert, vertex, & + cellxy, nodereduced, nodeuser) + call cell2%init(nlay, ncpl, nodes, top, bot, iavert, javert, vertex, & + cellxy, nodereduced, nodeuser) + ! + ! -- Create a sparse matrix array with a row for each vertex. The columns + ! in the sparse matrix contains the cells that include that vertex. + ! This array will be used to determine horizontal cell connectivity. + allocate(itemp(nvert)) + do i = 1, nvert + itemp(i) = 4 + enddo + call vertcellspm%init(nvert, ncpl, itemp) + deallocate(itemp) + do j = 1, ncpl + do i = iavert(j), iavert(j + 1) - 1 + call vertcellspm%addconnection(javert(i), j, 1) + enddo + enddo + ! + ! -- Call routine to build a sparse matrix of the connections + call vertexconnect(this%nodes, nrsize, 6, nlay, ncpl, sparse, & + vertcellspm, cell1, cell2, nodereduced) + this%nja = sparse%nnz + this%njas = (this%nja - this%nodes) / 2 + ! + ! -- Allocate index arrays of size nja and symmetric arrays + call this%allocate_arrays() + ! + ! -- Fill the IA and JA arrays from sparse, then destroy sparse + call sparse%sort() + call sparse%filliaja(this%ia, this%ja, ierror) + call sparse%destroy() + ! + ! -- fill the isym and jas arrays + call fillisym(this%nodes, this%nja, this%ia, this%ja, this%isym) + call filljas(this%nodes, this%nja, this%ia, this%ja, this%isym, this%jas) + ! + ! -- Fill symmetric discretization arrays (ihc,cl1,cl2,hwva,anglex) + do n = 1, this%nodes + call cell1%set_nodered(n) + do ipos = this%ia(n) + 1, this%ia(n + 1) - 1 + m = this%ja(ipos) + if(m < n) cycle + call cell2%set_nodered(m) + call cell1%cprops(cell2, this%hwva(this%jas(ipos)), & + this%cl1(this%jas(ipos)), this%cl2(this%jas(ipos)), & + this%anglex(this%jas(ipos)), & + this%ihc(this%jas(ipos))) + enddo + enddo + ! + ! -- If reduced system, then need to build iausr and jausr, otherwise point + ! them to ia and ja. + nodesuser = nlay * ncpl + call this%iajausr(nrsize, nodesuser, nodereduced, nodeuser) + ! + ! -- Return + return + end subroutine disvconnections + + subroutine disuconnections(this, name_model, nodes, nodesuser, nrsize, & + nodereduced, nodeuser, iainp, jainp, & + ihcinp, cl12inp, hwvainp, angldegxinp) +! ****************************************************************************** +! disuconnections -- Construct the connectivity arrays using disu +! information. Grid may be reduced +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DHALF, DZERO, DTHREE, DTWO, DPI + use SparseModule, only: sparsematrix + use MemoryManagerModule, only: mem_reallocate + ! -- dummy + class(ConnectionsType) :: this + character(len=*), intent(in) :: name_model + integer(I4B), intent(in) :: nodes + integer(I4B), intent(in) :: nodesuser + integer(I4B), intent(in) :: nrsize + integer(I4B), dimension(:), contiguous, intent(in) :: nodereduced + integer(I4B), dimension(:), contiguous, intent(in) :: nodeuser + integer(I4B), dimension(:), contiguous, intent(in) :: iainp + integer(I4B), dimension(:), contiguous, intent(in) :: jainp + integer(I4B), dimension(:), contiguous, intent(in) :: ihcinp + real(DP), dimension(:), contiguous, intent(in) :: cl12inp + real(DP), dimension(:), contiguous, intent(in) :: hwvainp + real(DP), dimension(:), contiguous, intent(in) :: angldegxinp + ! -- local + integer(I4B),dimension(:),allocatable :: ihctemp + real(DP),dimension(:),allocatable :: cl12temp + real(DP),dimension(:),allocatable :: hwvatemp + real(DP),dimension(:),allocatable :: angldegxtemp + integer(I4B) :: nr, nu, mr, mu, ipos, iposr, ierror + integer(I4B), dimension(:), allocatable :: rowmaxnnz + type(sparsematrix) :: sparse +! ------------------------------------------------------------------------------ + ! + ! -- Allocate scalars + call this%allocate_scalars(name_model) + ! + ! -- Set scalars + this%nodes = nodes + this%ianglex = 1 + ! + ! -- If not a reduced grid, then copy and finalize, otherwise more + ! processing is required + if (nrsize == 0) then + this%nodes = nodes + this%nja = size(jainp) + this%njas = (this%nja - this%nodes) / 2 + call this%allocate_arrays() + do nu = 1, nodes + 1 + this%ia(nu) = iainp(nu) + end do + do ipos = 1, this%nja + this%ja(ipos) = jainp(ipos) + end do + ! + ! -- Call con_finalize to check inp arrays and push larger arrays + ! into compressed symmetric arrays + call this%con_finalize(ihcinp, cl12inp, hwvainp, angldegxinp) + ! + else + ! -- reduced system requires more work + ! + ! -- Setup the sparse matrix object + allocate(rowmaxnnz(this%nodes)) + do nr = 1, this%nodes + nu = nodeuser(nr) + rowmaxnnz(nr) = iainp(nu + 1) - iainp(nu) + enddo + call sparse%init(this%nodes, this%nodes, rowmaxnnz) + ! + ! -- go through user connectivity and create sparse + do nu = 1, nodesuser + nr = nodereduced(nu) + if (nr > 0) call sparse%addconnection(nr, nr, 1) + do ipos = iainp(nu) + 1, iainp(nu + 1) - 1 + mu = jainp(ipos) + mr = nodereduced(mu) + if (nr < 1) cycle + if (mr < 1) cycle + call sparse%addconnection(nr, mr, 1) + enddo + enddo + this%nja = sparse%nnz + this%njas = (this%nja - this%nodes) / 2 + ! + ! -- Allocate index arrays of size nja and symmetric arrays + call this%allocate_arrays() + ! + ! -- Fill the IA and JA arrays from sparse, then destroy sparse + call sparse%sort() + call sparse%filliaja(this%ia, this%ja, ierror) + call sparse%destroy() + deallocate(rowmaxnnz) + ! + ! -- At this point, need to reduce ihc, cl12, hwva, and angldegx + allocate(ihctemp(this%nja)) + allocate(cl12temp(this%nja)) + allocate(hwvatemp(this%nja)) + allocate(angldegxtemp(this%nja)) + ! + ! -- Compress user arrays into reduced arrays + iposr = 1 + do nu = 1, nodesuser + nr = nodereduced(nu) + do ipos = iainp(nu), iainp(nu + 1) - 1 + mu = jainp(ipos) + mr = nodereduced(mu) + if (nr < 1 .or. mr < 1) cycle + ihctemp(iposr) = ihcinp(ipos) + cl12temp(iposr) = cl12inp(ipos) + hwvatemp(iposr) = hwvainp(ipos) + angldegxtemp(iposr) = angldegxinp(ipos) + iposr = iposr + 1 + end do + end do + ! + ! -- call finalize + call this%con_finalize(ihctemp, cl12temp, hwvatemp, angldegxtemp) + ! + ! -- deallocate temporary arrays + deallocate(ihctemp) + deallocate(cl12temp) + deallocate(hwvatemp) + deallocate(angldegxtemp) + end if + ! + ! -- If reduced system, then need to build iausr and jausr, otherwise point + ! them to ia and ja. + call this%iajausr(nrsize, nodesuser, nodereduced, nodeuser) + ! + ! -- Return + return + end subroutine disuconnections + + subroutine iajausr(this, nrsize, nodesuser, nodereduced, nodeuser) +! ****************************************************************************** +! iajausr -- Fill iausr and jausr if reduced grid, otherwise point them +! to ia and ja. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_reallocate, mem_deallocate, mem_setptr + ! -- dummy + class(ConnectionsType) :: this + integer(I4B), intent(in) :: nrsize + integer(I4B), intent(in) :: nodesuser + integer(I4B), dimension(:), intent(in) :: nodereduced + integer(I4B), dimension(:), intent(in) :: nodeuser + ! -- local + integer(I4B) :: n, nr, ipos +! ------------------------------------------------------------------------------ + ! + ! -- If reduced system, then need to build iausr and jausr, otherwise point + ! them to ia and ja. + if(nrsize > 0) then + ! + ! -- Create the iausr array of size nodesuser + 1. For excluded cells, + ! iausr(n) and iausr(n + 1) should be equal to indicate no connections. + call mem_reallocate(this%iausr, nodesuser+1, 'IAUSR', this%cid) + this%iausr(nodesuser + 1) = this%ia(this%nodes + 1) + do n = nodesuser, 1, -1 + nr = nodereduced(n) + if(nr < 1) then + this%iausr(n) = this%iausr(n + 1) + else + this%iausr(n) = this%ia(nr) + endif + enddo + ! + ! -- Create the jausr array, which is the same size as ja, but it + ! contains user node numbers instead of reduced node numbers + call mem_reallocate(this%jausr, this%nja, 'JAUSR', this%cid) + do ipos = 1, this%nja + nr = this%ja(ipos) + n = nodeuser(nr) + this%jausr(ipos) = n + enddo + else + ! -- iausr and jausr will be pointers + call mem_deallocate(this%iausr) + call mem_deallocate(this%jausr) + call mem_setptr(this%iausr, 'IA', this%cid) + call mem_setptr(this%jausr, 'JA', this%cid) + endif + ! + ! -- Return + return + end subroutine iajausr + + function getjaindex(this,node1,node2) +! ****************************************************************************** +! Get the index in the JA array corresponding to the connection between +! two nodes of interest. Node1 is used as the index in the IA array, and +! IA(Node1) is the row index in the (nodes x nodes) matrix represented by +! the compressed sparse row format. +! +! -1 is returned if either node number is invalid. +! 0 is returned if the two nodes are not connected. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + integer(I4B) :: getjaindex + ! -- dummy + class(ConnectionsType) :: this + integer(I4B), intent(in) :: node1, node2 ! nodes of interest + ! -- local + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + ! -- error checking + if (node1<1 .or. node1>this%nodes .or. node2<1 .or. node2>this%nodes) then + getjaindex = -1 ! indicates error (an invalid node number) + return + endif + ! + ! -- If node1==node2, just return the position for the diagonal. + if (node1==node2) then + getjaindex = this%ia(node1) + return + endif + ! + ! -- Look for connection among nonzero elements defined for row node1. + do i=this%ia(node1)+1,this%ia(node1+1)-1 + if (this%ja(i)==node2) then + getjaindex = i + return + endif + enddo + ! + ! -- If execution reaches here, no connection exists + ! between nodes of interest. + getjaindex = 0 ! indicates no connection exists + return + end function getjaindex + + subroutine fillisym(neq, nja, ia, ja, isym) +! ****************************************************************************** +! fillisym -- Private function to fill the isym array +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + integer(I4B),intent(in) :: neq + integer(I4B),intent(in) :: nja + integer(I4B),intent(inout),dimension(nja) :: isym + ! -- local + integer(I4B),intent(in),dimension(neq+1) :: ia + integer(I4B),intent(in),dimension(nja) :: ja + integer(I4B) :: n, m, ii, jj +! ------------------------------------------------------------------------------ + ! + do n=1, neq + do ii = ia(n), ia(n + 1) - 1 + m = ja(ii) + if(m /= n) then + isym(ii) = 0 + search: do jj = ia(m), ia(m + 1) - 1 + if(ja(jj) == n) then + isym(ii) = jj + exit search + endif + enddo search + else + isym(ii) = ii + endif + enddo + enddo + ! + ! -- Return + return + end subroutine fillisym + + subroutine filljas(neq, nja, ia, ja, isym, jas) +! ****************************************************************************** +! fillisym -- Private function to fill the jas array +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + integer(I4B),intent(in) :: neq + integer(I4B),intent(in) :: nja + integer(I4B),intent(in),dimension(neq+1) :: ia + integer(I4B),intent(in),dimension(nja) :: ja + integer(I4B),intent(in),dimension(nja) :: isym + integer(I4B),intent(inout),dimension(nja) :: jas + ! -- local + integer(I4B) :: n, m, ii, ipos +! ------------------------------------------------------------------------------ + ! + ! -- set diagonal to zero and fill upper + ipos = 1 + do n = 1, neq + jas(ia(n)) = 0 + do ii = ia(n) + 1, ia(n + 1) - 1 + m = ja(ii) + if(m > n) then + jas(ii) = ipos + ipos = ipos + 1 + endif + enddo + enddo + ! + ! -- fill lower + do n = 1, neq + do ii = ia(n), ia(n + 1) - 1 + m = ja(ii) + if(m < n) then + jas(ii) = jas(isym(ii)) + endif + enddo + enddo + ! + ! -- Return + return + end subroutine filljas + + + subroutine vertexconnect(nodes, nrsize, maxnnz, nlay, ncpl, sparse, & + vertcellspm, cell1, cell2, nodereduced) +! ****************************************************************************** +! vertexconnect -- routine to make cell connections from vertices +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SparseModule, only: sparsematrix + use InputOutputModule, only: get_node + use DisvGeom, only: DisvGeomType + ! -- dummy + integer(I4B), intent(in) :: nodes + integer(I4B), intent(in) :: nrsize + integer(I4B), intent(in) :: maxnnz + integer(I4B), intent(in) :: nlay + integer(I4B), intent(in) :: ncpl + type(SparseMatrix), intent(inout) :: sparse + type(SparseMatrix), intent(inout) :: vertcellspm + integer(I4B), dimension(:), intent(in) :: nodereduced + type(DisvGeomType), intent(inout) :: cell1, cell2 + ! -- local + integer(I4B), dimension(:), allocatable :: rowmaxnnz + integer(I4B) :: i, j, k, kk, nr, mr, j1, j2, icol1, icol2, nvert +! ------------------------------------------------------------------------------ + ! + ! -- Allocate and fill the ia and ja arrays + allocate(rowmaxnnz(nodes)) + do i = 1, nodes + rowmaxnnz(i) = maxnnz + enddo + call sparse%init(nodes, nodes, rowmaxnnz) + deallocate(rowmaxnnz) + do k = 1, nlay + do j = 1, ncpl + ! + ! -- Find the reduced node number and then cycle if the + ! node is always inactive + nr = get_node(k, 1, j, nlay, 1, ncpl) + if(nrsize > 0) nr = nodereduced(nr) + if(nr <= 0) cycle + ! + ! -- Process diagonal + call sparse%addconnection(nr, nr, 1) + ! + ! -- Up direction + if(k > 1) then + do kk = k - 1, 1, -1 + mr = get_node(kk, 1, j, nlay, 1, ncpl) + if(nrsize > 0) mr = nodereduced(mr) + if(mr >= 0) exit + enddo + if(mr > 0) then + call sparse%addconnection(nr, mr, 1) + endif + endif + ! + ! -- Down direction + if(k < nlay) then + do kk = k + 1, nlay + mr = get_node(kk, 1, j, nlay, 1, ncpl) + if(nrsize > 0) mr = nodereduced(mr) + if(mr >= 0) exit + enddo + if(mr > 0) then + call sparse%addconnection(nr, mr, 1) + endif + endif + enddo + enddo + ! + ! -- Go through each vertex and connect up all the cells that use + ! this vertex in their definition and share an edge. + nvert = vertcellspm%nrow + do i = 1, nvert + do icol1 = 1, vertcellspm%row(i)%nnz + j1 = vertcellspm%row(i)%icolarray(icol1) + do k = 1, nlay + nr = get_node(k, 1, j1, nlay, 1, ncpl) + if(nrsize > 0) nr = nodereduced(nr) + if(nr <= 0) cycle + call cell1%set_nodered(nr) + do icol2 = 1, vertcellspm%row(i)%nnz + j2 = vertcellspm%row(i)%icolarray(icol2) + if(j1 == j2) cycle + mr = get_node(k, 1, j2, nlay, 1, ncpl) + if(nrsize > 0) mr = nodereduced(mr) + if(mr <= 0) cycle + call cell2%set_nodered(mr) + if(cell1%shares_edge(cell2)) then + call sparse%addconnection(nr, mr, 1) + endif + enddo + enddo + enddo + enddo + ! + ! -- return + return + end subroutine vertexconnect + + subroutine set_mask(this, ipos, maskval) +! ****************************************************************************** +! set_mask -- routine to set a value in the mask array +! (which has the same shape as this%ja) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use MemoryManagerModule, only: mem_allocate + class(ConnectionsType) :: this + integer(I4B), intent(in) :: ipos + integer(I4B), intent(in) :: maskval + ! local + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + ! if we still point to this%ja, we first need to allocate space + if (associated(this%mask, this%ja)) then + call mem_allocate(this%mask, this%nja, 'MASK', this%cid) + ! and initialize with unmasked + do i = 1, this%nja + this%mask(i) = 1 + end do + end if + ! + ! -- set the mask value + this%mask(ipos) = maskVal + ! + ! -- return + return + end subroutine set_mask + + subroutine iac_to_ia(ia) +! ****************************************************************************** +! iac_to_ia -- convert an iac array into an ia array +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + 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) + enddo + do n = nodes + 1, 2, -1 + ia(n) = ia(n - 1) + 1 + enddo + ia(1) = 1 + ! + ! -- return + return + end subroutine iac_to_ia + +end module ConnectionsModule diff --git a/src/Model/ModelUtilities/DiscretizationBase.f90 b/src/Model/ModelUtilities/DiscretizationBase.f90 index aa2af180a7f..1beac64c251 100644 --- a/src/Model/ModelUtilities/DiscretizationBase.f90 +++ b/src/Model/ModelUtilities/DiscretizationBase.f90 @@ -1,1546 +1,1546 @@ -module BaseDisModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LENMODELNAME, LENORIGIN, LINELENGTH, DZERO - use SmoothingModule, only: sQuadraticSaturation - use ConnectionsModule, only: ConnectionsType - use InputOutputModule, only: URWORD, ubdsv1 - use SimModule, only: count_errors, store_error, & - store_error_unit, ustop - use BlockParserModule, only: BlockParserType - use MemoryManagerModule, only: mem_allocate - use TdisModule, only: kstp, kper, pertim, totim, delt - use TimeSeriesManagerModule, only: TimeSeriesManagerType - - implicit none - - private - public :: DisBaseType - - type :: DisBaseType - character(len=LENORIGIN), pointer :: origin => null() !origin name for mem allocation - character(len=LENMODELNAME), pointer :: name_model => null() !name of the model - integer(I4B), pointer :: inunit => null() !unit number for input file - integer(I4B), pointer :: iout => null() !unit number for output file - integer(I4B), pointer :: nodes => null() !number of nodes in solution - integer(I4B), pointer :: nodesuser => null() !number of user nodes (same as nodes for disu grid) - integer(I4B), pointer :: nja => null() !number of connections plus number of nodes - integer(I4B), pointer :: njas => null() !(nja-nodes)/2 - 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 - real(DP), pointer :: yorigin => null() ! y-position of the lower-left grid corner (default is 0.) - real(DP), pointer :: xorigin => null() ! x-position of the lower-left grid corner (default is 0.) - real(DP), pointer :: angrot => null() ! counter-clockwise rotation angle of the lower-left corner (default is 0.0) - integer(I4B), dimension(:), pointer, contiguous :: mshape => null() !shape of the model; (nodes) for DisBaseType - real(DP), dimension(:), pointer, contiguous :: top => null() !(size:nodes) cell top elevation - real(DP), dimension(:), pointer, contiguous :: bot => null() !(size:nodes) cell bottom elevation - real(DP), dimension(:), pointer, contiguous :: area => null() !(size:nodes) cell area, in plan view - type(ConnectionsType), pointer :: con => null() !connections object - type(BlockParserType) :: parser !object to read blocks - real(DP), dimension(:), pointer, contiguous :: dbuff => null() !helper double array of size nodesuser - integer(I4B), dimension(:), pointer, contiguous :: ibuff => null() !helper int array of size nodesuser - integer(I4B), dimension(:), pointer, contiguous :: nodereduced => null() ! (size:nodesuser)contains reduced nodenumber (size 0 if not reduced); -1 means vertical pass through, 0 is idomain = 0 - integer(I4B), dimension(:), pointer, contiguous :: nodeuser => null() ! (size:nodes) given a reduced nodenumber, provide the user nodenumber (size 0 if not reduced) - contains - procedure :: dis_df - procedure :: dis_ac - procedure :: dis_mc - procedure :: dis_ar - procedure :: dis_da - ! -- helper functions - ! - ! -- get_nodenumber is an overloaded integer function that will always - ! return the reduced nodenumber. For all grids, get_nodenumber can - ! be passed the user nodenumber. For some other grids, it can also - ! be passed an index. For dis3d the index is k, i, j, and for - ! disv the index is k, n. - generic :: get_nodenumber => get_nodenumber_idx1, & - get_nodenumber_idx2, & - get_nodenumber_idx3 - procedure :: get_nodenumber_idx1 - procedure :: get_nodenumber_idx2 - procedure :: get_nodenumber_idx3 - procedure :: get_nodeuser - procedure :: nodeu_to_string - procedure :: nodeu_to_array - procedure :: nodeu_from_string - procedure :: nodeu_from_cellid - procedure :: noder_from_string - procedure :: noder_from_cellid - procedure :: connection_normal - procedure :: connection_vector - procedure :: get_cellxy - procedure :: get_dis_type - procedure :: supports_layers - procedure :: allocate_scalars - procedure :: allocate_arrays - procedure :: get_ncpl - procedure :: get_cell_volume - procedure :: write_grb - ! - procedure :: read_int_array - procedure :: read_dbl_array - generic, public :: read_grid_array => read_int_array, read_dbl_array - procedure, public :: read_layer_array - procedure :: fill_int_array - procedure :: fill_dbl_array - generic, public :: fill_grid_array => fill_int_array, fill_dbl_array - procedure, public :: read_list - ! - procedure, public :: record_array - procedure, public :: record_connection_array - procedure, public :: noder_to_string - procedure, public :: noder_to_array - procedure, public :: record_srcdst_list_header - procedure, private :: record_srcdst_list_entry - generic, public :: record_mf6_list_entry => record_srcdst_list_entry - ! *** NOTE: REMOVE print_list_entry WHEN ALL USES OF THIS METHOD ARE - ! REMOVED FROM TRANSPORT - procedure, public :: print_list_entry - procedure, public :: nlarray_to_nodelist - procedure, public :: highest_active - procedure, public :: get_area - end type DisBaseType - - contains - - subroutine dis_df(this) -! ****************************************************************************** -! dis_df -- Read discretization information from DISU input file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(DisBaseType) :: this -! ------------------------------------------------------------------------------ - ! - call store_error('Program error: DisBaseType method dis_df not & - &implemented.') - call ustop() - ! - ! -- Return - return - end subroutine dis_df - - subroutine dis_ac(this, moffset, sparse) -! ****************************************************************************** -! dis_ac -- Add connections to sparse based on cell connectivity -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SparseModule, only: sparsematrix - ! -- dummy - class(DisBaseType) :: this - integer(I4B), intent(in) :: moffset - type(sparsematrix), intent(inout) :: sparse - ! -- local - integer(I4B) :: i, j, ipos, iglo, jglo -! ------------------------------------------------------------------------------ - ! - do i = 1, this%nodes - do ipos = this%con%ia(i), this%con%ia(i+1) - 1 - j = this%con%ja(ipos) - iglo = i + moffset - jglo = j + moffset - call sparse%addconnection(iglo, jglo, 1) - enddo - enddo - ! - ! -- Return - return - end subroutine dis_ac - - subroutine dis_mc(this, moffset, idxglo, iasln, jasln) -! ****************************************************************************** -! dis_mc -- Map the positions of cell connections in the numerical solution -! coefficient matrix. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(DisBaseType) :: this - integer(I4B), intent(in) :: moffset - integer(I4B), dimension(:), intent(inout) :: idxglo - integer(I4B), dimension(:), intent(in) :: iasln - integer(I4B), dimension(:), intent(in) :: jasln - ! -- local - integer(I4B) :: i, j, ipos, ipossln, iglo, jglo -! ------------------------------------------------------------------------------ - ! - do i = 1, this%nodes - iglo = i + moffset - do ipos = this%con%ia(i), this%con%ia(i + 1) - 1 - j = this%con%ja(ipos) - jglo = j + moffset - searchloop: do ipossln = iasln(iglo), iasln(iglo + 1) - 1 - if(jglo == jasln(ipossln)) then - idxglo(ipos) = ipossln - exit searchloop - endif - enddo searchloop - enddo - enddo - ! - ! -- Return - return - end subroutine dis_mc - - subroutine dis_ar(this, icelltype) -! ****************************************************************************** -! dis_ar -- Called from AR procedure. Only task is to write binary grid file. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(DisBaseType) :: this - integer(I4B), dimension(:), intent(in) :: icelltype - ! -- local - integer(I4B), dimension(:), allocatable :: ict - integer(I4B) :: nu, nr -! ------------------------------------------------------------------------------ - ! - ! -- Expand icelltype to full grid; fill with 0 if cell is excluded - allocate(ict(this%nodesuser)) - do nu = 1, this%nodesuser - nr = this%get_nodenumber(nu, 0) - if (nr > 0) then - ict(nu) = icelltype(nr) - else - ict(nu) = 0 - endif - enddo - ! - if (this%writegrb) call this%write_grb(ict) - ! - ! -- Return - return - end subroutine dis_ar - - subroutine write_grb(this, icelltype) -! ****************************************************************************** -! write_grb -- Called from AR procedure. Only task is to write binary grid file. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(DisBaseType) :: this - integer(I4B), dimension(:), intent(in) :: icelltype - ! -- local -! ------------------------------------------------------------------------------ - ! - ! - call store_error('Program error: DisBaseType method write_grb not & - &implemented.') - call ustop() - ! - ! -- Return - return - end subroutine write_grb - - subroutine dis_da(this) -! ****************************************************************************** -! dis_da -- Deallocate discretization object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(DisBaseType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Strings - deallocate(this%origin) - deallocate(this%name_model) - ! - ! -- Scalars - call mem_deallocate(this%inunit) - call mem_deallocate(this%iout) - call mem_deallocate(this%nodes) - call mem_deallocate(this%nodesuser) - call mem_deallocate(this%ndim) - call mem_deallocate(this%icondir) - call mem_deallocate(this%writegrb) - call mem_deallocate(this%xorigin) - call mem_deallocate(this%yorigin) - call mem_deallocate(this%angrot) - call mem_deallocate(this%nja) - call mem_deallocate(this%njas) - call mem_deallocate(this%lenuni) - ! - ! -- Arrays - call mem_deallocate(this%mshape) - call mem_deallocate(this%top) - call mem_deallocate(this%bot) - call mem_deallocate(this%area) - call mem_deallocate(this%dbuff) - call mem_deallocate(this%ibuff) - ! - ! -- Connections - call this%con%con_da() - deallocate(this%con) - ! - ! -- Return - return - end subroutine dis_da - - subroutine nodeu_to_string(this, nodeu, str) -! ****************************************************************************** -! nodeu_to_string -- Convert user node number to a string in the form of -! (nodenumber) or (k,i,j) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(DisBaseType) :: this - integer(I4B), intent(in) :: nodeu - character(len=*), intent(inout) :: str - ! -- local -! ------------------------------------------------------------------------------ - ! - call store_error('Program error: DisBaseType method nodeu_to_string not & - &implemented.') - call ustop() - ! - ! -- return - return - end subroutine nodeu_to_string - - subroutine nodeu_to_array(this, nodeu, arr) -! ****************************************************************************** -! nodeu_to_array -- Convert user node number to cellid and fill array with -! (nodenumber) or (k,j) or (k,i,j) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(DisBaseType) :: this - integer(I4B), intent(in) :: nodeu - integer(I4B), dimension(:), intent(inout) :: arr - ! -- local -! ------------------------------------------------------------------------------ - ! - call store_error('Program error: DisBaseType method nodeu_to_array not & - &implemented.') - call ustop() - ! - ! -- return - return - end subroutine nodeu_to_array - - function get_nodeuser(this, noder) result(nodenumber) -! ****************************************************************************** -! get_nodeuser -- Return the user nodenumber from the reduced node number -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - integer(I4B) :: nodenumber - ! -- dummy - class(DisBaseType) :: this - integer(I4B), intent(in) :: noder -! ------------------------------------------------------------------------------ - ! - if(this%nodes < this%nodesuser) then - nodenumber = this%nodeuser(noder) - else - nodenumber = noder - endif - ! - ! -- return - return - end function get_nodeuser - - function get_nodenumber_idx1(this, nodeu, icheck) result(nodenumber) -! ****************************************************************************** -! get_nodenumber -- Return a nodenumber from the user specified node number -! with an option to perform a check. This subroutine -! can be overridden by child classes to perform mapping -! to a model node number -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error - ! -- dummy - class(DisBaseType), intent(in) :: this - integer(I4B), intent(in) :: nodeu - integer(I4B), intent(in) :: icheck - ! -- local - integer(I4B) :: nodenumber -! ------------------------------------------------------------------------------ - ! - nodenumber = 0 - call store_error('Program error: get_nodenumber_idx1 not implemented.') - call ustop() - ! - ! -- return - return - end function get_nodenumber_idx1 - - function get_nodenumber_idx2(this, k, j, icheck) result(nodenumber) -! ****************************************************************************** -! get_nodenumber_idx2 -- This function should never be called. It must be -! overridden by a child class. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use SimModule, only: ustop, store_error - ! -- dummy - class(DisBaseType), intent(in) :: this - integer(I4B), intent(in) :: k, j - integer(I4B), intent(in) :: icheck - integer(I4B) :: nodenumber -! ------------------------------------------------------------------------------ - ! - nodenumber = 0 - call store_error('Program error: get_nodenumber_idx2 not implemented.') - call ustop() - ! - ! -- Return - return - end function get_nodenumber_idx2 - - function get_nodenumber_idx3(this, k, i, j, icheck) result(nodenumber) -! ****************************************************************************** -! get_nodenumber_idx3 -- This function will not be invoked for an unstructured -! model, but it may be from a Discretization3dType model. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use SimModule, only: ustop, store_error - ! -- dummy - class(DisBaseType), intent(in) :: this - integer(I4B), intent(in) :: k, i, j - integer(I4B), intent(in) :: icheck - integer(I4B) :: nodenumber -! ------------------------------------------------------------------------------ - ! - nodenumber = 0 - call store_error('Program error: get_nodenumber_idx3 not implemented.') - call ustop() - ! - ! -- Return - return - end function get_nodenumber_idx3 - - subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & - ipos) -! ****************************************************************************** -! connection_normal -- calculate the normal vector components for reduced -! nodenumber cell (noden) and its shared face with cell nodem. ihc is the -! horizontal connection flag. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: ustop, store_error - ! -- dummy - class(DisBaseType) :: this - integer(I4B), intent(in) :: noden - integer(I4B), intent(in) :: nodem - integer(I4B), intent(in) :: ihc - real(DP), intent(inout) :: xcomp - real(DP), intent(inout) :: ycomp - real(DP), intent(inout) :: zcomp - integer(I4B), intent(in) :: ipos -! ------------------------------------------------------------------------------ - ! - call store_error('Program error: connection_normal not implemented.') - call ustop() - ! - ! -- return - return - end subroutine connection_normal - - subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & - xcomp, ycomp, zcomp, conlen) -! ****************************************************************************** -! connection_vector -- calculate the unit vector components from reduced -! nodenumber cell (noden) to its neighbor cell (nodem). The saturation for -! for these cells are also required so that the vertical position of the cell -! cell centers can be calculated. ihc is the horizontal flag. Also return -! the straight-line connection length. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: ustop, store_error - ! -- dummy - class(DisBaseType) :: this - integer(I4B), intent(in) :: noden - integer(I4B), intent(in) :: nodem - logical, intent(in) :: nozee - real(DP), intent(in) :: satn - real(DP), intent(in) :: satm - integer(I4B), intent(in) :: ihc - real(DP), intent(inout) :: xcomp - real(DP), intent(inout) :: ycomp - real(DP), intent(inout) :: zcomp - real(DP), intent(inout) :: conlen - ! -- local -! ------------------------------------------------------------------------------ - ! - call store_error('Program error: connection_vector not implemented.') - call ustop() - ! - ! -- return - return - end subroutine connection_vector - - ! return x,y coordinate for a node - subroutine get_cellxy(this, node, xcell, ycell) - class(DisBaseType), intent(in) :: this - integer(I4B), intent(in) :: node - real(DP), intent(out) :: xcell, ycell - - ! suppress warning - xcell = -999999.0 - ycell = -999999.0 - - call store_error('Program error: get_cellxy not implemented.') - call ustop() - - end subroutine get_cellxy - - ! return discretization type - subroutine get_dis_type(this, dis_type) - class(DisBaseType), intent(in) :: this - character(len=*), intent(out) :: dis_type - - ! suppress warning - dis_type = "Not implemented" - - call store_error('Program error: get_dis_type not implemented.') - call ustop() - - end subroutine get_dis_type - - subroutine allocate_scalars(this, name_model) -! ****************************************************************************** -! allocate_scalars -- Allocate and initialize scalar variables in this class -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(DisBaseType) :: this - character(len=*), intent(in) :: name_model - ! -- local - character(len=LENORIGIN) :: origin -! ------------------------------------------------------------------------------ - ! - ! -- Assign origin name - origin = trim(adjustl(name_model)) // ' DIS' - ! - ! -- Allocate - allocate(this%origin) - allocate(this%name_model) - call mem_allocate(this%inunit, 'INUNIT', origin) - call mem_allocate(this%iout, 'IOUT', origin) - call mem_allocate(this%nodes, 'NODES', origin) - call mem_allocate(this%nodesuser, 'NODESUSER', origin) - call mem_allocate(this%ndim, 'NDIM', origin) - call mem_allocate(this%icondir, 'ICONDIR', origin) - call mem_allocate(this%writegrb, 'WRITEGRB', origin) - call mem_allocate(this%xorigin, 'XORIGIN', origin) - call mem_allocate(this%yorigin, 'YORIGIN', origin) - call mem_allocate(this%angrot, 'ANGROT', origin) - call mem_allocate(this%nja, 'NJA', origin) - call mem_allocate(this%njas, 'NJAS', origin) - call mem_allocate(this%lenuni, 'LENUNI', origin) - ! - ! -- Initialize - this%origin = origin - this%name_model = name_model - this%inunit = 0 - this%iout = 0 - this%nodes = 0 - this%nodesuser = 0 - this%ndim = 1 - this%icondir = 1 - this%writegrb = .true. - this%xorigin = DZERO - this%yorigin = DZERO - this%angrot = DZERO - this%nja = 0 - this%njas = 0 - this%lenuni = 0 - ! - ! -- Return - return - end subroutine allocate_scalars - - subroutine allocate_arrays(this) -! ****************************************************************************** -! allocate_arrays -- Read discretization information from file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(DisBaseType) :: this - integer :: isize -! ------------------------------------------------------------------------------ - ! - ! -- Allocate - call mem_allocate(this%mshape, this%ndim, 'MSHAPE', this%origin) - call mem_allocate(this%top, this%nodes, 'TOP', this%origin) - call mem_allocate(this%bot, this%nodes, 'BOT', this%origin) - call mem_allocate(this%area, this%nodes, 'AREA', this%origin) - ! - ! -- Initialize - this%mshape(1) = this%nodes - ! - ! -- Determine size of buff memory - if(this%nodes < this%nodesuser) then - isize = this%nodesuser - else - isize = this%nodes - endif - ! - ! -- Allocate the arrays - call mem_allocate(this%dbuff, isize, 'DBUFF', this%name_model) - call mem_allocate(this%ibuff, isize, 'IBUFF', this%name_model) - ! - ! -- Return - return - end subroutine allocate_arrays - - function nodeu_from_string(this, lloc, istart, istop, in, iout, line, & - flag_string, allow_zero) result(nodeu) -! ****************************************************************************** -! nodeu_from_string -- Receive a string and convert the string to a user -! nodenumber. The model is unstructured; just read user nodenumber. -! If flag_string argument is present and true, the first token in string -! is allowed to be a string (e.g. boundary name). In this case, if a string -! is encountered, return value as -2. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(DisBaseType) :: this - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout - character(len=*), intent(inout) :: line - logical, optional, intent(in) :: flag_string - logical, optional, intent(in) :: allow_zero - integer(I4B) :: nodeu - ! -- local -! ------------------------------------------------------------------------------ - ! - ! - nodeu = 0 - call store_error('Program error: DisBaseType method nodeu_from_string & - ¬ implemented.') - call ustop() - ! - ! -- return - return - end function nodeu_from_string - - function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & - allow_zero) result(nodeu) -! ****************************************************************************** -! nodeu_from_cellid -- Receive cellid as a string and convert the string to a -! user nodenumber. -! If flag_string argument is present and true, the first token in string -! is allowed to be a string (e.g. boundary name). In this case, if a string -! is encountered, return value as -2. -! If allow_zero argument is present and true, if all indices equal zero, the -! result can be zero. If allow_zero is false, a zero in any index causes an -! error. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(DisBaseType) :: this - character(len=*), intent(inout) :: cellid - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - logical, optional, intent(in) :: flag_string - logical, optional, intent(in) :: allow_zero - integer(I4B) :: nodeu -! ------------------------------------------------------------------------------ - ! - nodeu = 0 - call store_error('Program error: DisBaseType method nodeu_from_cellid & - ¬ implemented.') - call ustop() - ! - ! -- return - return - end function nodeu_from_cellid - - function noder_from_string(this, lloc, istart, istop, in, iout, line, & - flag_string) result(noder) -! ****************************************************************************** -! noder_from_string -- Receive a string and convert the string to a reduced -! nodenumber. The model is unstructured; just read user nodenumber. -! If flag_string argument is present and true, the first token in string -! is allowed to be a string (e.g. boundary name). In this case, if a string -! is encountered, return value as -2. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(DisBaseType) :: this - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout - character(len=*), intent(inout) :: line - logical, optional, intent(in) :: flag_string - integer(I4B) :: noder - ! -- local - integer(I4B) :: nodeu - character(len=LINELENGTH) :: ermsg, nodestr - logical :: flag_string_local -! ------------------------------------------------------------------------------ - ! - if (present(flag_string)) then - flag_string_local = flag_string - else - flag_string_local = .false. - endif - nodeu = this%nodeu_from_string(lloc, istart, istop, in, iout, line, & - flag_string_local) - ! - ! -- Convert user-based nodenumber to reduced node number - if (nodeu > 0) then - noder = this%get_nodenumber(nodeu, 0) - else - noder = nodeu - endif - if(noder <= 0 .and. .not. flag_string_local) then - call this%nodeu_to_string(nodeu, nodestr) - write(ermsg, *) & - ' Cell is outside active grid domain: ' // & - trim(adjustl(nodestr)) - call store_error(ermsg) - endif - ! - ! -- return - return - end function noder_from_string - - function noder_from_cellid(this, cellid, inunit, iout, flag_string, & - allow_zero) result(noder) -! ****************************************************************************** -! noder_from_cellid -- Receive cellid as a string and convert it to a reduced -! nodenumber. -! If flag_string argument is present and true, the first token in string -! is allowed to be a string (e.g. boundary name). In this case, if a string -! is encountered, return value as -2. -! If allow_zero argument is present and true, if all indices equal zero, the -! result can be zero. If allow_zero is false, a zero in any index causes an -! error. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - integer(I4B) :: noder - ! -- dummy - class(DisBaseType) :: this - character(len=*), intent(inout) :: cellid - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - logical, optional, intent(in) :: flag_string - logical, optional, intent(in) :: allow_zero - ! -- local - integer(I4B) :: nodeu - logical :: allowzerolocal - character(len=LINELENGTH) :: ermsg, nodestr - logical :: flag_string_local -! ------------------------------------------------------------------------------ - ! - if (present(flag_string)) then - flag_string_local = flag_string - else - flag_string_local = .false. - endif - if (present(allow_zero)) then - allowzerolocal = allow_zero - else - allowzerolocal = .false. - endif - ! - nodeu = this%nodeu_from_cellid(cellid, inunit, iout, flag_string_local, & - allowzerolocal) - ! - ! -- Convert user-based nodenumber to reduced node number - if (nodeu > 0) then - noder = this%get_nodenumber(nodeu, 0) - else - noder = nodeu - endif - if(noder <= 0 .and. .not. flag_string_local) then - call this%nodeu_to_string(nodeu, nodestr) - write(ermsg, *) & - ' Cell is outside active grid domain: ' // & - trim(adjustl(nodestr)) - call store_error(ermsg) - endif - ! - ! -- return - return - end function noder_from_cellid - - logical function supports_layers(this) -! ****************************************************************************** -! supports_layers -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(DisBaseType) :: this -! ------------------------------------------------------------------------------ - ! - ! - supports_layers = .false. - call store_error('Program error: DisBaseType method supports_layers not & - &implemented.') - call ustop() - return - end function supports_layers - - function get_ncpl(this) -! ****************************************************************************** -! get_ncpl -- Return number of cells per layer. This is nodes -! for a DISU grid, as there are no layers. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - integer(I4B) :: get_ncpl - ! -- dummy - class(DisBaseType) :: this -! ------------------------------------------------------------------------------ - ! - ! - get_ncpl = 0 - call store_error('Program error: DisBaseType method get_ncpl not & - &implemented.') - call ustop() - ! - ! -- Return - return - end function get_ncpl - - function get_cell_volume(this, n, x) -! ****************************************************************************** -! get_cell_volume -- Return volume of cell n based on x value passed. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - real(DP) :: get_cell_volume - ! -- dummy - class(DisBaseType) :: this - integer(I4B), intent(in) :: n - real(DP), intent(in) :: x - ! -- local - real(DP) :: tp - real(DP) :: bt - real(DP) :: sat - real(DP) :: thick -! ------------------------------------------------------------------------------ - ! - get_cell_volume = DZERO - tp = this%top(n) - bt = this%bot(n) - sat = sQuadraticSaturation(tp, bt, x) - thick = (tp - bt) * sat - get_cell_volume = this%area(n) * thick - ! - ! -- Return - return - end function get_cell_volume - - subroutine read_int_array(this, line, lloc, istart, istop, iout, in, & - iarray, aname) -! ****************************************************************************** -! read_int_array -- Read a GWF integer array -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(DisBaseType), intent(inout) :: this - character(len=*), intent(inout) :: line - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: iarray - character(len=*), intent(in) :: aname - ! -- local - character(len=LINELENGTH) :: ermsg -! ------------------------------------------------------------------------------ - ! - ermsg = 'Programmer error: read_int_array needs to be overridden & - &in any DIS type that extends DisBaseType' - call store_error(ermsg) - call ustop() - ! - ! -- return - return - end subroutine read_int_array - - subroutine read_dbl_array(this, line, lloc, istart, istop, iout, in, & - darray, aname) -! ****************************************************************************** -! read_dbl_array -- Read a GWF double precision array -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(DisBaseType), intent(inout) :: this - character(len=*), intent(inout) :: line - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout - real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray - character(len=*), intent(in) :: aname - ! -- local - character(len=LINELENGTH) :: ermsg -! ------------------------------------------------------------------------------ - ! - ermsg = 'Programmer error: read_dbl_array needs to be overridden & - &in any DIS type that extends DisBaseType' - call store_error(ermsg) - call ustop() - ! - ! -- return - return - end subroutine read_dbl_array - - subroutine fill_int_array(this, ibuff1, ibuff2) -! ****************************************************************************** -! fill_dbl_array -- Fill a GWF integer array -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(DisBaseType), intent(inout) :: this - integer(I4B), dimension(:), pointer, contiguous, intent(in) :: ibuff1 - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: ibuff2 - ! -- local - integer(I4B) :: nodeu - integer(I4B) :: noder -! ------------------------------------------------------------------------------ - do nodeu = 1, this%nodesuser - noder = this%get_nodenumber(nodeu, 0) - if(noder <= 0) cycle - ibuff2(noder) = ibuff1(nodeu) - end do - ! - ! -- return - return - end subroutine fill_int_array - - subroutine fill_dbl_array(this, buff1, buff2) -! ****************************************************************************** -! fill_dbl_array -- Fill a GWF double precision array -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(DisBaseType), intent(inout) :: this - real(DP), dimension(:), pointer, contiguous, intent(in) :: buff1 - real(DP), dimension(:), pointer, contiguous, intent(inout) :: buff2 - ! -- local - integer(I4B) :: nodeu - integer(I4B) :: noder -! ------------------------------------------------------------------------------ - do nodeu = 1, this%nodesuser - noder = this%get_nodenumber(nodeu, 0) - if(noder <= 0) cycle - buff2(noder) = buff1(nodeu) - end do - ! - ! -- return - return - end subroutine fill_dbl_array - - subroutine read_list(this, in, iout, iprpak, nlist, inamedbound, & - iauxmultcol, nodelist, rlist, auxvar, auxname, & - boundname, label, pkgname, tsManager, iscloc, & - indxconvertflux) -! ****************************************************************************** -! read_list -- Read a list using the list reader object. -! Convert user node numbers to reduced numbers. -! Terminate if any nodenumbers are within an inactive domain. -! Set up time series and multiply by iauxmultcol if it exists. -! Write the list to iout if iprpak is set. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LENBOUNDNAME, LINELENGTH - use ListReaderModule, only: ListReaderType - use SimModule, only: store_error, store_error_unit, count_errors, ustop - use InputOutputModule, only: urword - use TimeSeriesLinkModule, only: TimeSeriesLinkType - use TimeSeriesManagerModule, only: read_value_or_time_series - ! -- dummy - class(DisBaseType) :: this - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout - integer(I4B), intent(in) :: iprpak - integer(I4B), intent(inout) :: nlist - integer(I4B), intent(in) :: inamedbound - integer(I4B), intent(in) :: iauxmultcol - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: nodelist - real(DP), dimension(:,:), pointer, contiguous, intent(inout) :: rlist - real(DP), dimension(:,:), pointer, contiguous, intent(inout) :: auxvar - character(len=16), dimension(:), intent(inout) :: auxname - character(len=LENBOUNDNAME), dimension(:), pointer, contiguous, & - intent(inout) :: boundname - character(len=*), intent(in) :: label - character(len=*), intent(in) :: pkgName - type(TimeSeriesManagerType) :: tsManager - integer(I4B), intent(in) :: iscloc - integer(I4B), intent(in), optional :: indxconvertflux - ! -- local - integer(I4B) :: l, nerr - integer(I4B) :: nodeu, noder - character(len=LINELENGTH) :: errmsg, nodestr - integer(I4B) :: ii, jj - real(DP), pointer :: bndElem => null() - type(ListReaderType) :: lstrdobj - type(TimeSeriesLinkType), pointer :: tsLinkBnd => null() - type(TimeSeriesLinkType), pointer :: tsLinkAux => null() -! ------------------------------------------------------------------------------ - ! - ! -- Read the list - call lstrdobj%read_list(in, iout, nlist, inamedbound, this%mshape, & - nodelist, rlist, auxvar, auxname, boundname, label) - ! - ! -- Go through all locations where a text string was found instead of - ! a double precision value and make time-series links to rlist - if(lstrdobj%ntxtrlist > 0) then - do l = 1, lstrdobj%ntxtrlist - ii = lstrdobj%idxtxtrow(l) - jj = lstrdobj%idxtxtcol(l) - tsLinkBnd => NULL() - bndElem => rlist(jj, ii) - call read_value_or_time_series(lstrdobj%txtrlist(l), ii, jj, & - bndElem, pkgName, 'BND', tsManager, iprpak, tsLinkBnd) - if (associated(tsLinkBnd)) then - ! - ! -- If iauxmultcol is active and this column is the column - ! to be scaled, then assign tsLinkBnd%RMultiplier to auxvar - ! multiplier - if (iauxmultcol > 0 .and. jj == iscloc) then - tsLinkBnd%RMultiplier => auxvar(iauxmultcol, ii) - endif - ! - ! -- If boundaries are named, save the name in the link - if (lstrdobj%inamedbound == 1) then - tsLinkBnd%BndName = lstrdobj%boundname(tsLinkBnd%IRow) - endif - ! - ! -- if the value is a flux and needs to be converted to a flow - ! then set the tsLinkBnd appropriately - if (present(indxconvertflux)) then - if (indxconvertflux == jj) then - tsLinkBnd%convertflux = .true. - nodeu = nodelist(ii) - noder = this%get_nodenumber(nodeu, 0) - tsLinkBnd%CellArea = this%get_area(noder) - endif - endif - ! - endif - enddo - endif - ! - ! -- Make time-series substitutions for auxvar - if(lstrdobj%ntxtauxvar > 0) then - do l = 1, lstrdobj%ntxtauxvar - ii = lstrdobj%idxtxtauxrow(l) - jj = lstrdobj%idxtxtauxcol(l) - tsLinkAux => NULL() - bndElem => auxvar(jj, ii) - call read_value_or_time_series(lstrdobj%txtauxvar(l), ii, jj, & - bndElem, pkgName, 'AUX', tsManager, iprpak, tslinkAux) - if (lstrdobj%inamedbound == 1) then - if (associated(tsLinkAux)) then - tsLinkAux%BndName = lstrdobj%boundname(tsLinkAux%IRow) - endif - endif - enddo - endif - ! - ! -- Multiply rlist by the multiplier column in auxvar - if(iauxmultcol > 0) then - do l = 1, nlist - rlist(iscloc, l) = rlist(iscloc, l) * auxvar(iauxmultcol, l) - enddo - endif - ! - ! -- Write the list to iout if requested - if(iprpak /= 0) then - call lstrdobj%write_list() - endif - ! - ! -- Convert user nodenumbers to reduced nodenumbers, if necessary. - ! Conversion to reduced nodenumbers must be done last, after the - ! list is written so that correct indices are written to the list. - if(this%nodes < this%nodesuser) then - do l = 1, nlist - nodeu = nodelist(l) - noder = this%get_nodenumber(nodeu, 0) - if(noder <= 0) then - call this%nodeu_to_string(nodeu, nodestr) - write(errmsg, *) & - ' Cell is outside active grid domain: ' // & - trim(adjustl(nodestr)) - call store_error(errmsg) - endif - nodelist(l) = noder - enddo - ! - ! -- Check for errors and terminate if encountered - nerr = count_errors() - if(nerr > 0) then - write(errmsg, *) nerr, ' errors encountered.' - call store_error(errmsg) - call store_error_unit(in) - call ustop() - endif - endif - ! - ! -- return - end subroutine read_list - - subroutine read_layer_array(this, nodelist, darray, ncolbnd, maxbnd, & - icolbnd, aname, inunit, iout) -! ****************************************************************************** -! read_layer_array -- Read a 2d double array into col icolbnd of darray. -! For cells that are outside of the active domain, -! do not copy the array value into darray. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(DisBaseType) :: this - integer(I4B), intent(in) :: ncolbnd - integer(I4B), intent(in) :: maxbnd - integer(I4B), dimension(maxbnd) :: nodelist - real(DP), dimension(ncolbnd, maxbnd), intent(inout) :: darray - integer(I4B), intent(in) :: icolbnd - character(len=*), intent(in) :: aname - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - ! -- local - character(len=LINELENGTH) :: ermsg -! ------------------------------------------------------------------------------ - ! - ermsg = 'Programmer error: read_layer_array needs to be overridden & - &in any DIS type that extends DisBaseType' - call store_error(ermsg) - call ustop() - ! - ! -- return - end subroutine read_layer_array - - subroutine record_array(this, darray, iout, iprint, idataun, aname, & - cdatafmp, nvaluesp, nwidthp, editdesc, dinact) -! ****************************************************************************** -! record_array -- Record a double precision array. The array will be -! printed to an external file and/or written to an unformatted external file -! depending on the argument specifications. -! ****************************************************************************** -! -! SPECIFICATIONS: -! darray is the double precision array to record -! iout is the unit number for ascii output -! iprint is a flag indicating whether or not to print the array -! idataun is the unit number to which the array will be written in binary -! form; if negative then do not write by layers, write entire array -! aname is the text descriptor of the array -! cdatafmp is the fortran format for writing the array -! nvaluesp is the number of values per line for printing -! nwidthp is the width of the number for printing -! editdesc is the format type (I, G, F, S, E) -! dinact is the double precision value to use for cells that are excluded -! from the model domain -! ------------------------------------------------------------------------------ - ! -- dummy - class(DisBaseType), intent(inout) :: this - real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray - integer(I4B), intent(in) :: iout - integer(I4B), intent(in) :: iprint - integer(I4B), intent(in) :: idataun - character(len=*), intent(in) :: aname - character(len=*), intent(in) :: cdatafmp - integer(I4B), intent(in) :: nvaluesp - integer(I4B), intent(in) :: nwidthp - character(len=*), intent(in) :: editdesc - real(DP), intent(in) :: dinact - ! -- local - character(len=LINELENGTH) :: ermsg -! ------------------------------------------------------------------------------ - ! - ermsg = 'Programmer error: record_array needs to be overridden & - &in any DIS type that extends DisBaseType' - call store_error(ermsg) - call ustop() - ! - end subroutine record_array - - subroutine record_connection_array(this, flowja, ibinun, iout) -! ****************************************************************************** -! record_connection_array -- Record a connection-based double precision -! array for either a structured or an unstructured grid. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(DisBaseType) :: this - real(DP), dimension(:), intent(in) :: flowja - integer(I4B), intent(in) :: ibinun - integer(I4B), intent(in) :: iout - ! -- local - character(len=16), dimension(1) :: text - ! -- data - data text(1) /' FLOW-JA-FACE'/ -! ------------------------------------------------------------------------------ - ! - ! -- write full ja array - call ubdsv1(kstp, kper, text(1), ibinun, flowja, size(flowja), 1, 1, & - iout, delt, pertim, totim) - ! - ! -- return - return - end subroutine record_connection_array - - subroutine noder_to_string(this, noder, str) -! ****************************************************************************** -! noder_to_string -- Convert reduced node number to a string in the form of -! (nodenumber) or (k,i,j) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(DisBaseType) :: this - integer(I4B), intent(in) :: noder - character(len=*), intent(inout) :: str - ! -- local - integer(I4B) :: nodeu -! ------------------------------------------------------------------------------ - ! - nodeu = this%get_nodeuser(noder) - call this%nodeu_to_string(nodeu, str) - ! - ! -- return - return - end subroutine noder_to_string - - subroutine noder_to_array(this, noder, arr) -! ****************************************************************************** -! noder_to_array -- Convert reduced node number to cellid and fill array with -! (nodenumber) or (k,j) or (k,i,j) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(DisBaseType) :: this - integer(I4B), intent(in) :: noder - integer(I4B), dimension(:), intent(inout) :: arr - ! -- local - integer(I4B) :: nodeu -! ------------------------------------------------------------------------------ - ! - nodeu = this%get_nodeuser(noder) - call this%nodeu_to_array(nodeu, arr) - ! - ! -- return - return - end subroutine noder_to_array - - subroutine record_srcdst_list_header(this, text, textmodel, textpackage, & - dstmodel, dstpackage, naux, auxtxt, & - ibdchn, nlist, iout) -! ****************************************************************************** -! record_srcdst_list_header -- Record list header for imeth=6 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(DisBaseType) :: this - character(len=16), intent(in) :: text - character(len=16), intent(in) :: textmodel - character(len=16), intent(in) :: textpackage - character(len=16), intent(in) :: dstmodel - character(len=16), intent(in) :: dstpackage - integer(I4B), intent(in) :: naux - character(len=16), dimension(:), intent(in) :: auxtxt - integer(I4B), intent(in) :: ibdchn - integer(I4B), intent(in) :: nlist - integer(I4B), intent(in) :: iout - ! -- local - character(len=LINELENGTH) :: ermsg -! ------------------------------------------------------------------------------ - ! - ermsg = 'Programmer error: record_srcdst_list_header needs to be & - &overridden in any DIS type that extends DisBaseType' - call store_error(ermsg) - call ustop() - ! - ! -- return - return - end subroutine record_srcdst_list_header - - subroutine record_srcdst_list_entry(this, ibdchn, noder, noder2, q, & - naux, aux, olconv, olconv2) -! ****************************************************************************** -! record_srcdst_list_header -- Record list header -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: ubdsvd - ! -- dummy - class(DisBaseType) :: this - integer(I4B), intent(in) :: ibdchn - integer(I4B), intent(in) :: noder - integer(I4B), intent(in) :: noder2 - real(DP), intent(in) :: q - integer(I4B), intent(in) :: naux - real(DP), dimension(naux), intent(in) :: aux - logical, optional, intent(in) :: olconv - logical, optional, intent(in) :: olconv2 - ! -- local - logical :: lconv - logical :: lconv2 - integer(I4B) :: nodeu - integer(I4B) :: nodeu2 -! ------------------------------------------------------------------------------ - ! - ! -- Use ubdsvb to write list header - if (present(olconv)) then - lconv = olconv - else - lconv = .TRUE. - end if - if (lconv) then - nodeu = this%get_nodeuser(noder) - else - nodeu = noder - end if - if (present(olconv2)) then - lconv2 = olconv2 - else - lconv2 = .TRUE. - end if - if (lconv2) then - nodeu2 = this%get_nodeuser(noder2) - else - nodeu2 = noder2 - end if - call ubdsvd(ibdchn, nodeu, nodeu2, q, naux, aux) - ! - ! -- return - return - end subroutine record_srcdst_list_entry - - ! *** NOTE: REMOVE print_list_entry WHEN ALL USES OF THIS METHOD ARE - ! REMOVED FROM TRANSPORT - subroutine print_list_entry(this, l, noder, q, iout, boundname) -! ****************************************************************************** -! print_list_entry -- Print list budget entry -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: ubdsvb, get_ijk - use ConstantsModule, only: LENBOUNDNAME, LINELENGTH - ! -- dummy - class(DisBaseType), intent(in) :: this - integer(I4B), intent(in) :: l - integer(I4B), intent(in) :: noder - real(DP), intent(in) :: q - integer(I4B), intent(in) :: iout - character(len=*), intent(in), optional :: boundname - ! -- local - integer(I4B) :: nodeu - character(len=*), parameter :: fmt1 = & - "(1X,'BOUNDARY ',I8,' CELL ',A20,' RATE ', 1PG15.6,2x,A)" - character(len=LENBOUNDNAME) :: bname - character(len=LINELENGTH) :: nodestr -! ------------------------------------------------------------------------------ - ! - bname = '' - if (present(boundname)) bname = boundname - nodeu = this%get_nodeuser(noder) - call this%nodeu_to_string(nodeu, nodestr) - if (bname == '') then - write(iout, fmt1) l, trim(nodestr), q - else - write(iout, fmt1) l, trim(nodestr), q, trim(bname) - endif - ! - ! -- return - return - end subroutine print_list_entry - - subroutine nlarray_to_nodelist(this, nodelist, maxbnd, nbound, aname, & - inunit, iout) -! ****************************************************************************** -! nlarray_to_nodelist -- Read an integer array into nodelist. For structured -! model, integer array is layer number; for unstructured -! model, integer array is node number. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: ustop, store_error - use ConstantsModule, only: LINELENGTH - ! -- dummy - class(DisBaseType) :: this - integer(I4B), intent(in) :: maxbnd - integer(I4B), dimension(maxbnd), intent(inout) :: nodelist - integer(I4B), intent(inout) :: nbound - character(len=*), intent(in) :: aname - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - ! -- local - character(len=LINELENGTH) :: ermsg - ! - ermsg = 'Programmer error: nlarray_to_nodelist needs to be & - &overridden in any DIS type that extends DisBaseType' - call store_error(ermsg) - call ustop() - ! - ! -- return - return - end subroutine nlarray_to_nodelist - - subroutine highest_active(this, n, ibound) -! ****************************************************************************** -! highest_active -- Find the first highest active cell beneath cell n -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(DisBaseType) :: this - integer(I4B), intent(inout) :: n - integer(I4B), dimension(:), intent(in) :: ibound - ! -- locals - integer(I4B) :: m,ii,iis - logical done, bottomcell -! ------------------------------------------------------------------------------ - ! - ! -- Loop through connected cells until the highest active one (including a - ! constant head cell) is found. Return that cell as n. - done=.false. - do while(.not. done) - bottomcell = .true. - cloop: do ii = this%con%ia(n) + 1, this%con%ia(n+1)-1 - m = this%con%ja(ii) - iis = this%con%jas(ii) - if(this%con%ihc(iis) == 0 .and. m > n) then - ! - ! -- this cannot be a bottom cell - bottomcell = .false. - ! - ! -- vertical down - if(ibound(m) /= 0) then - n = m - done = .true. - exit cloop - else - n = m - exit cloop - endif - endif - enddo cloop - if(bottomcell) done = .true. - enddo - ! - ! -- return - return - end subroutine highest_active - - function get_area(this, node) result(area) -! ****************************************************************************** -! get_area -- Return the cell area for this node -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - real(DP) :: area - ! -- dummy - class(DisBaseType) :: this - integer(I4B), intent(in) :: node -! ------------------------------------------------------------------------------ - ! - ! -- Return the cell area - area = this%area(node) - ! - ! -- return - return - end function get_area - -end module BaseDisModule +module BaseDisModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: LENMODELNAME, LENORIGIN, LINELENGTH, DZERO + use SmoothingModule, only: sQuadraticSaturation + use ConnectionsModule, only: ConnectionsType + use InputOutputModule, only: URWORD, ubdsv1 + use SimModule, only: count_errors, store_error, & + store_error_unit, ustop + use BlockParserModule, only: BlockParserType + use MemoryManagerModule, only: mem_allocate + use TdisModule, only: kstp, kper, pertim, totim, delt + use TimeSeriesManagerModule, only: TimeSeriesManagerType + + implicit none + + private + public :: DisBaseType + + type :: DisBaseType + character(len=LENORIGIN), pointer :: origin => null() !origin name for mem allocation + character(len=LENMODELNAME), pointer :: name_model => null() !name of the model + integer(I4B), pointer :: inunit => null() !unit number for input file + integer(I4B), pointer :: iout => null() !unit number for output file + integer(I4B), pointer :: nodes => null() !number of nodes in solution + integer(I4B), pointer :: nodesuser => null() !number of user nodes (same as nodes for disu grid) + integer(I4B), pointer :: nja => null() !number of connections plus number of nodes + integer(I4B), pointer :: njas => null() !(nja-nodes)/2 + 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 + real(DP), pointer :: yorigin => null() ! y-position of the lower-left grid corner (default is 0.) + real(DP), pointer :: xorigin => null() ! x-position of the lower-left grid corner (default is 0.) + real(DP), pointer :: angrot => null() ! counter-clockwise rotation angle of the lower-left corner (default is 0.0) + integer(I4B), dimension(:), pointer, contiguous :: mshape => null() !shape of the model; (nodes) for DisBaseType + real(DP), dimension(:), pointer, contiguous :: top => null() !(size:nodes) cell top elevation + real(DP), dimension(:), pointer, contiguous :: bot => null() !(size:nodes) cell bottom elevation + real(DP), dimension(:), pointer, contiguous :: area => null() !(size:nodes) cell area, in plan view + type(ConnectionsType), pointer :: con => null() !connections object + type(BlockParserType) :: parser !object to read blocks + real(DP), dimension(:), pointer, contiguous :: dbuff => null() !helper double array of size nodesuser + integer(I4B), dimension(:), pointer, contiguous :: ibuff => null() !helper int array of size nodesuser + integer(I4B), dimension(:), pointer, contiguous :: nodereduced => null() ! (size:nodesuser)contains reduced nodenumber (size 0 if not reduced); -1 means vertical pass through, 0 is idomain = 0 + integer(I4B), dimension(:), pointer, contiguous :: nodeuser => null() ! (size:nodes) given a reduced nodenumber, provide the user nodenumber (size 0 if not reduced) + contains + procedure :: dis_df + procedure :: dis_ac + procedure :: dis_mc + procedure :: dis_ar + procedure :: dis_da + ! -- helper functions + ! + ! -- get_nodenumber is an overloaded integer function that will always + ! return the reduced nodenumber. For all grids, get_nodenumber can + ! be passed the user nodenumber. For some other grids, it can also + ! be passed an index. For dis3d the index is k, i, j, and for + ! disv the index is k, n. + generic :: get_nodenumber => get_nodenumber_idx1, & + get_nodenumber_idx2, & + get_nodenumber_idx3 + procedure :: get_nodenumber_idx1 + procedure :: get_nodenumber_idx2 + procedure :: get_nodenumber_idx3 + procedure :: get_nodeuser + procedure :: nodeu_to_string + procedure :: nodeu_to_array + procedure :: nodeu_from_string + procedure :: nodeu_from_cellid + procedure :: noder_from_string + procedure :: noder_from_cellid + procedure :: connection_normal + procedure :: connection_vector + procedure :: get_cellxy + procedure :: get_dis_type + procedure :: supports_layers + procedure :: allocate_scalars + procedure :: allocate_arrays + procedure :: get_ncpl + procedure :: get_cell_volume + procedure :: write_grb + ! + procedure :: read_int_array + procedure :: read_dbl_array + generic, public :: read_grid_array => read_int_array, read_dbl_array + procedure, public :: read_layer_array + procedure :: fill_int_array + procedure :: fill_dbl_array + generic, public :: fill_grid_array => fill_int_array, fill_dbl_array + procedure, public :: read_list + ! + procedure, public :: record_array + procedure, public :: record_connection_array + procedure, public :: noder_to_string + procedure, public :: noder_to_array + procedure, public :: record_srcdst_list_header + procedure, private :: record_srcdst_list_entry + generic, public :: record_mf6_list_entry => record_srcdst_list_entry + ! *** NOTE: REMOVE print_list_entry WHEN ALL USES OF THIS METHOD ARE + ! REMOVED FROM TRANSPORT + procedure, public :: print_list_entry + procedure, public :: nlarray_to_nodelist + procedure, public :: highest_active + procedure, public :: get_area + end type DisBaseType + + contains + + subroutine dis_df(this) +! ****************************************************************************** +! dis_df -- Read discretization information from DISU input file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(DisBaseType) :: this +! ------------------------------------------------------------------------------ + ! + call store_error('Program error: DisBaseType method dis_df not & + &implemented.') + call ustop() + ! + ! -- Return + return + end subroutine dis_df + + subroutine dis_ac(this, moffset, sparse) +! ****************************************************************************** +! dis_ac -- Add connections to sparse based on cell connectivity +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SparseModule, only: sparsematrix + ! -- dummy + class(DisBaseType) :: this + integer(I4B), intent(in) :: moffset + type(sparsematrix), intent(inout) :: sparse + ! -- local + integer(I4B) :: i, j, ipos, iglo, jglo +! ------------------------------------------------------------------------------ + ! + do i = 1, this%nodes + do ipos = this%con%ia(i), this%con%ia(i+1) - 1 + j = this%con%ja(ipos) + iglo = i + moffset + jglo = j + moffset + call sparse%addconnection(iglo, jglo, 1) + enddo + enddo + ! + ! -- Return + return + end subroutine dis_ac + + subroutine dis_mc(this, moffset, idxglo, iasln, jasln) +! ****************************************************************************** +! dis_mc -- Map the positions of cell connections in the numerical solution +! coefficient matrix. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(DisBaseType) :: this + integer(I4B), intent(in) :: moffset + integer(I4B), dimension(:), intent(inout) :: idxglo + integer(I4B), dimension(:), intent(in) :: iasln + integer(I4B), dimension(:), intent(in) :: jasln + ! -- local + integer(I4B) :: i, j, ipos, ipossln, iglo, jglo +! ------------------------------------------------------------------------------ + ! + do i = 1, this%nodes + iglo = i + moffset + do ipos = this%con%ia(i), this%con%ia(i + 1) - 1 + j = this%con%ja(ipos) + jglo = j + moffset + searchloop: do ipossln = iasln(iglo), iasln(iglo + 1) - 1 + if(jglo == jasln(ipossln)) then + idxglo(ipos) = ipossln + exit searchloop + endif + enddo searchloop + enddo + enddo + ! + ! -- Return + return + end subroutine dis_mc + + subroutine dis_ar(this, icelltype) +! ****************************************************************************** +! dis_ar -- Called from AR procedure. Only task is to write binary grid file. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(DisBaseType) :: this + integer(I4B), dimension(:), intent(in) :: icelltype + ! -- local + integer(I4B), dimension(:), allocatable :: ict + integer(I4B) :: nu, nr +! ------------------------------------------------------------------------------ + ! + ! -- Expand icelltype to full grid; fill with 0 if cell is excluded + allocate(ict(this%nodesuser)) + do nu = 1, this%nodesuser + nr = this%get_nodenumber(nu, 0) + if (nr > 0) then + ict(nu) = icelltype(nr) + else + ict(nu) = 0 + endif + enddo + ! + if (this%writegrb) call this%write_grb(ict) + ! + ! -- Return + return + end subroutine dis_ar + + subroutine write_grb(this, icelltype) +! ****************************************************************************** +! write_grb -- Called from AR procedure. Only task is to write binary grid file. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(DisBaseType) :: this + integer(I4B), dimension(:), intent(in) :: icelltype + ! -- local +! ------------------------------------------------------------------------------ + ! + ! + call store_error('Program error: DisBaseType method write_grb not & + &implemented.') + call ustop() + ! + ! -- Return + return + end subroutine write_grb + + subroutine dis_da(this) +! ****************************************************************************** +! dis_da -- Deallocate discretization object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(DisBaseType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Strings + deallocate(this%origin) + deallocate(this%name_model) + ! + ! -- Scalars + call mem_deallocate(this%inunit) + call mem_deallocate(this%iout) + call mem_deallocate(this%nodes) + call mem_deallocate(this%nodesuser) + call mem_deallocate(this%ndim) + call mem_deallocate(this%icondir) + call mem_deallocate(this%writegrb) + call mem_deallocate(this%xorigin) + call mem_deallocate(this%yorigin) + call mem_deallocate(this%angrot) + call mem_deallocate(this%nja) + call mem_deallocate(this%njas) + call mem_deallocate(this%lenuni) + ! + ! -- Arrays + call mem_deallocate(this%mshape) + call mem_deallocate(this%top) + call mem_deallocate(this%bot) + call mem_deallocate(this%area) + call mem_deallocate(this%dbuff) + call mem_deallocate(this%ibuff) + ! + ! -- Connections + call this%con%con_da() + deallocate(this%con) + ! + ! -- Return + return + end subroutine dis_da + + subroutine nodeu_to_string(this, nodeu, str) +! ****************************************************************************** +! nodeu_to_string -- Convert user node number to a string in the form of +! (nodenumber) or (k,i,j) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(DisBaseType) :: this + integer(I4B), intent(in) :: nodeu + character(len=*), intent(inout) :: str + ! -- local +! ------------------------------------------------------------------------------ + ! + call store_error('Program error: DisBaseType method nodeu_to_string not & + &implemented.') + call ustop() + ! + ! -- return + return + end subroutine nodeu_to_string + + subroutine nodeu_to_array(this, nodeu, arr) +! ****************************************************************************** +! nodeu_to_array -- Convert user node number to cellid and fill array with +! (nodenumber) or (k,j) or (k,i,j) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(DisBaseType) :: this + integer(I4B), intent(in) :: nodeu + integer(I4B), dimension(:), intent(inout) :: arr + ! -- local +! ------------------------------------------------------------------------------ + ! + call store_error('Program error: DisBaseType method nodeu_to_array not & + &implemented.') + call ustop() + ! + ! -- return + return + end subroutine nodeu_to_array + + function get_nodeuser(this, noder) result(nodenumber) +! ****************************************************************************** +! get_nodeuser -- Return the user nodenumber from the reduced node number +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + integer(I4B) :: nodenumber + ! -- dummy + class(DisBaseType) :: this + integer(I4B), intent(in) :: noder +! ------------------------------------------------------------------------------ + ! + if(this%nodes < this%nodesuser) then + nodenumber = this%nodeuser(noder) + else + nodenumber = noder + endif + ! + ! -- return + return + end function get_nodeuser + + function get_nodenumber_idx1(this, nodeu, icheck) result(nodenumber) +! ****************************************************************************** +! get_nodenumber -- Return a nodenumber from the user specified node number +! with an option to perform a check. This subroutine +! can be overridden by child classes to perform mapping +! to a model node number +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error + ! -- dummy + class(DisBaseType), intent(in) :: this + integer(I4B), intent(in) :: nodeu + integer(I4B), intent(in) :: icheck + ! -- local + integer(I4B) :: nodenumber +! ------------------------------------------------------------------------------ + ! + nodenumber = 0 + call store_error('Program error: get_nodenumber_idx1 not implemented.') + call ustop() + ! + ! -- return + return + end function get_nodenumber_idx1 + + function get_nodenumber_idx2(this, k, j, icheck) result(nodenumber) +! ****************************************************************************** +! get_nodenumber_idx2 -- This function should never be called. It must be +! overridden by a child class. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use SimModule, only: ustop, store_error + ! -- dummy + class(DisBaseType), intent(in) :: this + integer(I4B), intent(in) :: k, j + integer(I4B), intent(in) :: icheck + integer(I4B) :: nodenumber +! ------------------------------------------------------------------------------ + ! + nodenumber = 0 + call store_error('Program error: get_nodenumber_idx2 not implemented.') + call ustop() + ! + ! -- Return + return + end function get_nodenumber_idx2 + + function get_nodenumber_idx3(this, k, i, j, icheck) result(nodenumber) +! ****************************************************************************** +! get_nodenumber_idx3 -- This function will not be invoked for an unstructured +! model, but it may be from a Discretization3dType model. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use SimModule, only: ustop, store_error + ! -- dummy + class(DisBaseType), intent(in) :: this + integer(I4B), intent(in) :: k, i, j + integer(I4B), intent(in) :: icheck + integer(I4B) :: nodenumber +! ------------------------------------------------------------------------------ + ! + nodenumber = 0 + call store_error('Program error: get_nodenumber_idx3 not implemented.') + call ustop() + ! + ! -- Return + return + end function get_nodenumber_idx3 + + subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & + ipos) +! ****************************************************************************** +! connection_normal -- calculate the normal vector components for reduced +! nodenumber cell (noden) and its shared face with cell nodem. ihc is the +! horizontal connection flag. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: ustop, store_error + ! -- dummy + class(DisBaseType) :: this + integer(I4B), intent(in) :: noden + integer(I4B), intent(in) :: nodem + integer(I4B), intent(in) :: ihc + real(DP), intent(inout) :: xcomp + real(DP), intent(inout) :: ycomp + real(DP), intent(inout) :: zcomp + integer(I4B), intent(in) :: ipos +! ------------------------------------------------------------------------------ + ! + call store_error('Program error: connection_normal not implemented.') + call ustop() + ! + ! -- return + return + end subroutine connection_normal + + subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & + xcomp, ycomp, zcomp, conlen) +! ****************************************************************************** +! connection_vector -- calculate the unit vector components from reduced +! nodenumber cell (noden) to its neighbor cell (nodem). The saturation for +! for these cells are also required so that the vertical position of the cell +! cell centers can be calculated. ihc is the horizontal flag. Also return +! the straight-line connection length. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: ustop, store_error + ! -- dummy + class(DisBaseType) :: this + integer(I4B), intent(in) :: noden + integer(I4B), intent(in) :: nodem + logical, intent(in) :: nozee + real(DP), intent(in) :: satn + real(DP), intent(in) :: satm + integer(I4B), intent(in) :: ihc + real(DP), intent(inout) :: xcomp + real(DP), intent(inout) :: ycomp + real(DP), intent(inout) :: zcomp + real(DP), intent(inout) :: conlen + ! -- local +! ------------------------------------------------------------------------------ + ! + call store_error('Program error: connection_vector not implemented.') + call ustop() + ! + ! -- return + return + end subroutine connection_vector + + ! return x,y coordinate for a node + subroutine get_cellxy(this, node, xcell, ycell) + class(DisBaseType), intent(in) :: this + integer(I4B), intent(in) :: node + real(DP), intent(out) :: xcell, ycell + + ! suppress warning + xcell = -999999.0 + ycell = -999999.0 + + call store_error('Program error: get_cellxy not implemented.') + call ustop() + + end subroutine get_cellxy + + ! return discretization type + subroutine get_dis_type(this, dis_type) + class(DisBaseType), intent(in) :: this + character(len=*), intent(out) :: dis_type + + ! suppress warning + dis_type = "Not implemented" + + call store_error('Program error: get_dis_type not implemented.') + call ustop() + + end subroutine get_dis_type + + subroutine allocate_scalars(this, name_model) +! ****************************************************************************** +! allocate_scalars -- Allocate and initialize scalar variables in this class +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(DisBaseType) :: this + character(len=*), intent(in) :: name_model + ! -- local + character(len=LENORIGIN) :: origin +! ------------------------------------------------------------------------------ + ! + ! -- Assign origin name + origin = trim(adjustl(name_model)) // ' DIS' + ! + ! -- Allocate + allocate(this%origin) + allocate(this%name_model) + call mem_allocate(this%inunit, 'INUNIT', origin) + call mem_allocate(this%iout, 'IOUT', origin) + call mem_allocate(this%nodes, 'NODES', origin) + call mem_allocate(this%nodesuser, 'NODESUSER', origin) + call mem_allocate(this%ndim, 'NDIM', origin) + call mem_allocate(this%icondir, 'ICONDIR', origin) + call mem_allocate(this%writegrb, 'WRITEGRB', origin) + call mem_allocate(this%xorigin, 'XORIGIN', origin) + call mem_allocate(this%yorigin, 'YORIGIN', origin) + call mem_allocate(this%angrot, 'ANGROT', origin) + call mem_allocate(this%nja, 'NJA', origin) + call mem_allocate(this%njas, 'NJAS', origin) + call mem_allocate(this%lenuni, 'LENUNI', origin) + ! + ! -- Initialize + this%origin = origin + this%name_model = name_model + this%inunit = 0 + this%iout = 0 + this%nodes = 0 + this%nodesuser = 0 + this%ndim = 1 + this%icondir = 1 + this%writegrb = .true. + this%xorigin = DZERO + this%yorigin = DZERO + this%angrot = DZERO + this%nja = 0 + this%njas = 0 + this%lenuni = 0 + ! + ! -- Return + return + end subroutine allocate_scalars + + subroutine allocate_arrays(this) +! ****************************************************************************** +! allocate_arrays -- Read discretization information from file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(DisBaseType) :: this + integer :: isize +! ------------------------------------------------------------------------------ + ! + ! -- Allocate + call mem_allocate(this%mshape, this%ndim, 'MSHAPE', this%origin) + call mem_allocate(this%top, this%nodes, 'TOP', this%origin) + call mem_allocate(this%bot, this%nodes, 'BOT', this%origin) + call mem_allocate(this%area, this%nodes, 'AREA', this%origin) + ! + ! -- Initialize + this%mshape(1) = this%nodes + ! + ! -- Determine size of buff memory + if(this%nodes < this%nodesuser) then + isize = this%nodesuser + else + isize = this%nodes + endif + ! + ! -- Allocate the arrays + call mem_allocate(this%dbuff, isize, 'DBUFF', this%name_model) + call mem_allocate(this%ibuff, isize, 'IBUFF', this%name_model) + ! + ! -- Return + return + end subroutine allocate_arrays + + function nodeu_from_string(this, lloc, istart, istop, in, iout, line, & + flag_string, allow_zero) result(nodeu) +! ****************************************************************************** +! nodeu_from_string -- Receive a string and convert the string to a user +! nodenumber. The model is unstructured; just read user nodenumber. +! If flag_string argument is present and true, the first token in string +! is allowed to be a string (e.g. boundary name). In this case, if a string +! is encountered, return value as -2. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(DisBaseType) :: this + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout + character(len=*), intent(inout) :: line + logical, optional, intent(in) :: flag_string + logical, optional, intent(in) :: allow_zero + integer(I4B) :: nodeu + ! -- local +! ------------------------------------------------------------------------------ + ! + ! + nodeu = 0 + call store_error('Program error: DisBaseType method nodeu_from_string & + ¬ implemented.') + call ustop() + ! + ! -- return + return + end function nodeu_from_string + + function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & + allow_zero) result(nodeu) +! ****************************************************************************** +! nodeu_from_cellid -- Receive cellid as a string and convert the string to a +! user nodenumber. +! If flag_string argument is present and true, the first token in string +! is allowed to be a string (e.g. boundary name). In this case, if a string +! is encountered, return value as -2. +! If allow_zero argument is present and true, if all indices equal zero, the +! result can be zero. If allow_zero is false, a zero in any index causes an +! error. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(DisBaseType) :: this + character(len=*), intent(inout) :: cellid + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + logical, optional, intent(in) :: flag_string + logical, optional, intent(in) :: allow_zero + integer(I4B) :: nodeu +! ------------------------------------------------------------------------------ + ! + nodeu = 0 + call store_error('Program error: DisBaseType method nodeu_from_cellid & + ¬ implemented.') + call ustop() + ! + ! -- return + return + end function nodeu_from_cellid + + function noder_from_string(this, lloc, istart, istop, in, iout, line, & + flag_string) result(noder) +! ****************************************************************************** +! noder_from_string -- Receive a string and convert the string to a reduced +! nodenumber. The model is unstructured; just read user nodenumber. +! If flag_string argument is present and true, the first token in string +! is allowed to be a string (e.g. boundary name). In this case, if a string +! is encountered, return value as -2. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(DisBaseType) :: this + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout + character(len=*), intent(inout) :: line + logical, optional, intent(in) :: flag_string + integer(I4B) :: noder + ! -- local + integer(I4B) :: nodeu + character(len=LINELENGTH) :: ermsg, nodestr + logical :: flag_string_local +! ------------------------------------------------------------------------------ + ! + if (present(flag_string)) then + flag_string_local = flag_string + else + flag_string_local = .false. + endif + nodeu = this%nodeu_from_string(lloc, istart, istop, in, iout, line, & + flag_string_local) + ! + ! -- Convert user-based nodenumber to reduced node number + if (nodeu > 0) then + noder = this%get_nodenumber(nodeu, 0) + else + noder = nodeu + endif + if(noder <= 0 .and. .not. flag_string_local) then + call this%nodeu_to_string(nodeu, nodestr) + write(ermsg, *) & + ' Cell is outside active grid domain: ' // & + trim(adjustl(nodestr)) + call store_error(ermsg) + endif + ! + ! -- return + return + end function noder_from_string + + function noder_from_cellid(this, cellid, inunit, iout, flag_string, & + allow_zero) result(noder) +! ****************************************************************************** +! noder_from_cellid -- Receive cellid as a string and convert it to a reduced +! nodenumber. +! If flag_string argument is present and true, the first token in string +! is allowed to be a string (e.g. boundary name). In this case, if a string +! is encountered, return value as -2. +! If allow_zero argument is present and true, if all indices equal zero, the +! result can be zero. If allow_zero is false, a zero in any index causes an +! error. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + integer(I4B) :: noder + ! -- dummy + class(DisBaseType) :: this + character(len=*), intent(inout) :: cellid + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + logical, optional, intent(in) :: flag_string + logical, optional, intent(in) :: allow_zero + ! -- local + integer(I4B) :: nodeu + logical :: allowzerolocal + character(len=LINELENGTH) :: ermsg, nodestr + logical :: flag_string_local +! ------------------------------------------------------------------------------ + ! + if (present(flag_string)) then + flag_string_local = flag_string + else + flag_string_local = .false. + endif + if (present(allow_zero)) then + allowzerolocal = allow_zero + else + allowzerolocal = .false. + endif + ! + nodeu = this%nodeu_from_cellid(cellid, inunit, iout, flag_string_local, & + allowzerolocal) + ! + ! -- Convert user-based nodenumber to reduced node number + if (nodeu > 0) then + noder = this%get_nodenumber(nodeu, 0) + else + noder = nodeu + endif + if(noder <= 0 .and. .not. flag_string_local) then + call this%nodeu_to_string(nodeu, nodestr) + write(ermsg, *) & + ' Cell is outside active grid domain: ' // & + trim(adjustl(nodestr)) + call store_error(ermsg) + endif + ! + ! -- return + return + end function noder_from_cellid + + logical function supports_layers(this) +! ****************************************************************************** +! supports_layers +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(DisBaseType) :: this +! ------------------------------------------------------------------------------ + ! + ! + supports_layers = .false. + call store_error('Program error: DisBaseType method supports_layers not & + &implemented.') + call ustop() + return + end function supports_layers + + function get_ncpl(this) +! ****************************************************************************** +! get_ncpl -- Return number of cells per layer. This is nodes +! for a DISU grid, as there are no layers. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + integer(I4B) :: get_ncpl + ! -- dummy + class(DisBaseType) :: this +! ------------------------------------------------------------------------------ + ! + ! + get_ncpl = 0 + call store_error('Program error: DisBaseType method get_ncpl not & + &implemented.') + call ustop() + ! + ! -- Return + return + end function get_ncpl + + function get_cell_volume(this, n, x) +! ****************************************************************************** +! get_cell_volume -- Return volume of cell n based on x value passed. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + real(DP) :: get_cell_volume + ! -- dummy + class(DisBaseType) :: this + integer(I4B), intent(in) :: n + real(DP), intent(in) :: x + ! -- local + real(DP) :: tp + real(DP) :: bt + real(DP) :: sat + real(DP) :: thick +! ------------------------------------------------------------------------------ + ! + get_cell_volume = DZERO + tp = this%top(n) + bt = this%bot(n) + sat = sQuadraticSaturation(tp, bt, x) + thick = (tp - bt) * sat + get_cell_volume = this%area(n) * thick + ! + ! -- Return + return + end function get_cell_volume + + subroutine read_int_array(this, line, lloc, istart, istop, iout, in, & + iarray, aname) +! ****************************************************************************** +! read_int_array -- Read a GWF integer array +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(DisBaseType), intent(inout) :: this + character(len=*), intent(inout) :: line + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: iarray + character(len=*), intent(in) :: aname + ! -- local + character(len=LINELENGTH) :: ermsg +! ------------------------------------------------------------------------------ + ! + ermsg = 'Programmer error: read_int_array needs to be overridden & + &in any DIS type that extends DisBaseType' + call store_error(ermsg) + call ustop() + ! + ! -- return + return + end subroutine read_int_array + + subroutine read_dbl_array(this, line, lloc, istart, istop, iout, in, & + darray, aname) +! ****************************************************************************** +! read_dbl_array -- Read a GWF double precision array +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(DisBaseType), intent(inout) :: this + character(len=*), intent(inout) :: line + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout + real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray + character(len=*), intent(in) :: aname + ! -- local + character(len=LINELENGTH) :: ermsg +! ------------------------------------------------------------------------------ + ! + ermsg = 'Programmer error: read_dbl_array needs to be overridden & + &in any DIS type that extends DisBaseType' + call store_error(ermsg) + call ustop() + ! + ! -- return + return + end subroutine read_dbl_array + + subroutine fill_int_array(this, ibuff1, ibuff2) +! ****************************************************************************** +! fill_dbl_array -- Fill a GWF integer array +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(DisBaseType), intent(inout) :: this + integer(I4B), dimension(:), pointer, contiguous, intent(in) :: ibuff1 + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: ibuff2 + ! -- local + integer(I4B) :: nodeu + integer(I4B) :: noder +! ------------------------------------------------------------------------------ + do nodeu = 1, this%nodesuser + noder = this%get_nodenumber(nodeu, 0) + if(noder <= 0) cycle + ibuff2(noder) = ibuff1(nodeu) + end do + ! + ! -- return + return + end subroutine fill_int_array + + subroutine fill_dbl_array(this, buff1, buff2) +! ****************************************************************************** +! fill_dbl_array -- Fill a GWF double precision array +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(DisBaseType), intent(inout) :: this + real(DP), dimension(:), pointer, contiguous, intent(in) :: buff1 + real(DP), dimension(:), pointer, contiguous, intent(inout) :: buff2 + ! -- local + integer(I4B) :: nodeu + integer(I4B) :: noder +! ------------------------------------------------------------------------------ + do nodeu = 1, this%nodesuser + noder = this%get_nodenumber(nodeu, 0) + if(noder <= 0) cycle + buff2(noder) = buff1(nodeu) + end do + ! + ! -- return + return + end subroutine fill_dbl_array + + subroutine read_list(this, in, iout, iprpak, nlist, inamedbound, & + iauxmultcol, nodelist, rlist, auxvar, auxname, & + boundname, label, pkgname, tsManager, iscloc, & + indxconvertflux) +! ****************************************************************************** +! read_list -- Read a list using the list reader object. +! Convert user node numbers to reduced numbers. +! Terminate if any nodenumbers are within an inactive domain. +! Set up time series and multiply by iauxmultcol if it exists. +! Write the list to iout if iprpak is set. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LENBOUNDNAME, LINELENGTH + use ListReaderModule, only: ListReaderType + use SimModule, only: store_error, store_error_unit, count_errors, ustop + use InputOutputModule, only: urword + use TimeSeriesLinkModule, only: TimeSeriesLinkType + use TimeSeriesManagerModule, only: read_value_or_time_series + ! -- dummy + class(DisBaseType) :: this + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout + integer(I4B), intent(in) :: iprpak + integer(I4B), intent(inout) :: nlist + integer(I4B), intent(in) :: inamedbound + integer(I4B), intent(in) :: iauxmultcol + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: nodelist + real(DP), dimension(:,:), pointer, contiguous, intent(inout) :: rlist + real(DP), dimension(:,:), pointer, contiguous, intent(inout) :: auxvar + character(len=16), dimension(:), intent(inout) :: auxname + character(len=LENBOUNDNAME), dimension(:), pointer, contiguous, & + intent(inout) :: boundname + character(len=*), intent(in) :: label + character(len=*), intent(in) :: pkgName + type(TimeSeriesManagerType) :: tsManager + integer(I4B), intent(in) :: iscloc + integer(I4B), intent(in), optional :: indxconvertflux + ! -- local + integer(I4B) :: l, nerr + integer(I4B) :: nodeu, noder + character(len=LINELENGTH) :: errmsg, nodestr + integer(I4B) :: ii, jj + real(DP), pointer :: bndElem => null() + type(ListReaderType) :: lstrdobj + type(TimeSeriesLinkType), pointer :: tsLinkBnd => null() + type(TimeSeriesLinkType), pointer :: tsLinkAux => null() +! ------------------------------------------------------------------------------ + ! + ! -- Read the list + call lstrdobj%read_list(in, iout, nlist, inamedbound, this%mshape, & + nodelist, rlist, auxvar, auxname, boundname, label) + ! + ! -- Go through all locations where a text string was found instead of + ! a double precision value and make time-series links to rlist + if(lstrdobj%ntxtrlist > 0) then + do l = 1, lstrdobj%ntxtrlist + ii = lstrdobj%idxtxtrow(l) + jj = lstrdobj%idxtxtcol(l) + tsLinkBnd => NULL() + bndElem => rlist(jj, ii) + call read_value_or_time_series(lstrdobj%txtrlist(l), ii, jj, & + bndElem, pkgName, 'BND', tsManager, iprpak, tsLinkBnd) + if (associated(tsLinkBnd)) then + ! + ! -- If iauxmultcol is active and this column is the column + ! to be scaled, then assign tsLinkBnd%RMultiplier to auxvar + ! multiplier + if (iauxmultcol > 0 .and. jj == iscloc) then + tsLinkBnd%RMultiplier => auxvar(iauxmultcol, ii) + endif + ! + ! -- If boundaries are named, save the name in the link + if (lstrdobj%inamedbound == 1) then + tsLinkBnd%BndName = lstrdobj%boundname(tsLinkBnd%IRow) + endif + ! + ! -- if the value is a flux and needs to be converted to a flow + ! then set the tsLinkBnd appropriately + if (present(indxconvertflux)) then + if (indxconvertflux == jj) then + tsLinkBnd%convertflux = .true. + nodeu = nodelist(ii) + noder = this%get_nodenumber(nodeu, 0) + tsLinkBnd%CellArea = this%get_area(noder) + endif + endif + ! + endif + enddo + endif + ! + ! -- Make time-series substitutions for auxvar + if(lstrdobj%ntxtauxvar > 0) then + do l = 1, lstrdobj%ntxtauxvar + ii = lstrdobj%idxtxtauxrow(l) + jj = lstrdobj%idxtxtauxcol(l) + tsLinkAux => NULL() + bndElem => auxvar(jj, ii) + call read_value_or_time_series(lstrdobj%txtauxvar(l), ii, jj, & + bndElem, pkgName, 'AUX', tsManager, iprpak, tslinkAux) + if (lstrdobj%inamedbound == 1) then + if (associated(tsLinkAux)) then + tsLinkAux%BndName = lstrdobj%boundname(tsLinkAux%IRow) + endif + endif + enddo + endif + ! + ! -- Multiply rlist by the multiplier column in auxvar + if(iauxmultcol > 0) then + do l = 1, nlist + rlist(iscloc, l) = rlist(iscloc, l) * auxvar(iauxmultcol, l) + enddo + endif + ! + ! -- Write the list to iout if requested + if(iprpak /= 0) then + call lstrdobj%write_list() + endif + ! + ! -- Convert user nodenumbers to reduced nodenumbers, if necessary. + ! Conversion to reduced nodenumbers must be done last, after the + ! list is written so that correct indices are written to the list. + if(this%nodes < this%nodesuser) then + do l = 1, nlist + nodeu = nodelist(l) + noder = this%get_nodenumber(nodeu, 0) + if(noder <= 0) then + call this%nodeu_to_string(nodeu, nodestr) + write(errmsg, *) & + ' Cell is outside active grid domain: ' // & + trim(adjustl(nodestr)) + call store_error(errmsg) + endif + nodelist(l) = noder + enddo + ! + ! -- Check for errors and terminate if encountered + nerr = count_errors() + if(nerr > 0) then + write(errmsg, *) nerr, ' errors encountered.' + call store_error(errmsg) + call store_error_unit(in) + call ustop() + endif + endif + ! + ! -- return + end subroutine read_list + + subroutine read_layer_array(this, nodelist, darray, ncolbnd, maxbnd, & + icolbnd, aname, inunit, iout) +! ****************************************************************************** +! read_layer_array -- Read a 2d double array into col icolbnd of darray. +! For cells that are outside of the active domain, +! do not copy the array value into darray. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(DisBaseType) :: this + integer(I4B), intent(in) :: ncolbnd + integer(I4B), intent(in) :: maxbnd + integer(I4B), dimension(maxbnd) :: nodelist + real(DP), dimension(ncolbnd, maxbnd), intent(inout) :: darray + integer(I4B), intent(in) :: icolbnd + character(len=*), intent(in) :: aname + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + ! -- local + character(len=LINELENGTH) :: ermsg +! ------------------------------------------------------------------------------ + ! + ermsg = 'Programmer error: read_layer_array needs to be overridden & + &in any DIS type that extends DisBaseType' + call store_error(ermsg) + call ustop() + ! + ! -- return + end subroutine read_layer_array + + subroutine record_array(this, darray, iout, iprint, idataun, aname, & + cdatafmp, nvaluesp, nwidthp, editdesc, dinact) +! ****************************************************************************** +! record_array -- Record a double precision array. The array will be +! printed to an external file and/or written to an unformatted external file +! depending on the argument specifications. +! ****************************************************************************** +! +! SPECIFICATIONS: +! darray is the double precision array to record +! iout is the unit number for ascii output +! iprint is a flag indicating whether or not to print the array +! idataun is the unit number to which the array will be written in binary +! form; if negative then do not write by layers, write entire array +! aname is the text descriptor of the array +! cdatafmp is the fortran format for writing the array +! nvaluesp is the number of values per line for printing +! nwidthp is the width of the number for printing +! editdesc is the format type (I, G, F, S, E) +! dinact is the double precision value to use for cells that are excluded +! from the model domain +! ------------------------------------------------------------------------------ + ! -- dummy + class(DisBaseType), intent(inout) :: this + real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray + integer(I4B), intent(in) :: iout + integer(I4B), intent(in) :: iprint + integer(I4B), intent(in) :: idataun + character(len=*), intent(in) :: aname + character(len=*), intent(in) :: cdatafmp + integer(I4B), intent(in) :: nvaluesp + integer(I4B), intent(in) :: nwidthp + character(len=*), intent(in) :: editdesc + real(DP), intent(in) :: dinact + ! -- local + character(len=LINELENGTH) :: ermsg +! ------------------------------------------------------------------------------ + ! + ermsg = 'Programmer error: record_array needs to be overridden & + &in any DIS type that extends DisBaseType' + call store_error(ermsg) + call ustop() + ! + end subroutine record_array + + subroutine record_connection_array(this, flowja, ibinun, iout) +! ****************************************************************************** +! record_connection_array -- Record a connection-based double precision +! array for either a structured or an unstructured grid. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(DisBaseType) :: this + real(DP), dimension(:), intent(in) :: flowja + integer(I4B), intent(in) :: ibinun + integer(I4B), intent(in) :: iout + ! -- local + character(len=16), dimension(1) :: text + ! -- data + data text(1) /' FLOW-JA-FACE'/ +! ------------------------------------------------------------------------------ + ! + ! -- write full ja array + call ubdsv1(kstp, kper, text(1), ibinun, flowja, size(flowja), 1, 1, & + iout, delt, pertim, totim) + ! + ! -- return + return + end subroutine record_connection_array + + subroutine noder_to_string(this, noder, str) +! ****************************************************************************** +! noder_to_string -- Convert reduced node number to a string in the form of +! (nodenumber) or (k,i,j) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(DisBaseType) :: this + integer(I4B), intent(in) :: noder + character(len=*), intent(inout) :: str + ! -- local + integer(I4B) :: nodeu +! ------------------------------------------------------------------------------ + ! + nodeu = this%get_nodeuser(noder) + call this%nodeu_to_string(nodeu, str) + ! + ! -- return + return + end subroutine noder_to_string + + subroutine noder_to_array(this, noder, arr) +! ****************************************************************************** +! noder_to_array -- Convert reduced node number to cellid and fill array with +! (nodenumber) or (k,j) or (k,i,j) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(DisBaseType) :: this + integer(I4B), intent(in) :: noder + integer(I4B), dimension(:), intent(inout) :: arr + ! -- local + integer(I4B) :: nodeu +! ------------------------------------------------------------------------------ + ! + nodeu = this%get_nodeuser(noder) + call this%nodeu_to_array(nodeu, arr) + ! + ! -- return + return + end subroutine noder_to_array + + subroutine record_srcdst_list_header(this, text, textmodel, textpackage, & + dstmodel, dstpackage, naux, auxtxt, & + ibdchn, nlist, iout) +! ****************************************************************************** +! record_srcdst_list_header -- Record list header for imeth=6 +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(DisBaseType) :: this + character(len=16), intent(in) :: text + character(len=16), intent(in) :: textmodel + character(len=16), intent(in) :: textpackage + character(len=16), intent(in) :: dstmodel + character(len=16), intent(in) :: dstpackage + integer(I4B), intent(in) :: naux + character(len=16), dimension(:), intent(in) :: auxtxt + integer(I4B), intent(in) :: ibdchn + integer(I4B), intent(in) :: nlist + integer(I4B), intent(in) :: iout + ! -- local + character(len=LINELENGTH) :: ermsg +! ------------------------------------------------------------------------------ + ! + ermsg = 'Programmer error: record_srcdst_list_header needs to be & + &overridden in any DIS type that extends DisBaseType' + call store_error(ermsg) + call ustop() + ! + ! -- return + return + end subroutine record_srcdst_list_header + + subroutine record_srcdst_list_entry(this, ibdchn, noder, noder2, q, & + naux, aux, olconv, olconv2) +! ****************************************************************************** +! record_srcdst_list_header -- Record list header +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: ubdsvd + ! -- dummy + class(DisBaseType) :: this + integer(I4B), intent(in) :: ibdchn + integer(I4B), intent(in) :: noder + integer(I4B), intent(in) :: noder2 + real(DP), intent(in) :: q + integer(I4B), intent(in) :: naux + real(DP), dimension(naux), intent(in) :: aux + logical, optional, intent(in) :: olconv + logical, optional, intent(in) :: olconv2 + ! -- local + logical :: lconv + logical :: lconv2 + integer(I4B) :: nodeu + integer(I4B) :: nodeu2 +! ------------------------------------------------------------------------------ + ! + ! -- Use ubdsvb to write list header + if (present(olconv)) then + lconv = olconv + else + lconv = .TRUE. + end if + if (lconv) then + nodeu = this%get_nodeuser(noder) + else + nodeu = noder + end if + if (present(olconv2)) then + lconv2 = olconv2 + else + lconv2 = .TRUE. + end if + if (lconv2) then + nodeu2 = this%get_nodeuser(noder2) + else + nodeu2 = noder2 + end if + call ubdsvd(ibdchn, nodeu, nodeu2, q, naux, aux) + ! + ! -- return + return + end subroutine record_srcdst_list_entry + + ! *** NOTE: REMOVE print_list_entry WHEN ALL USES OF THIS METHOD ARE + ! REMOVED FROM TRANSPORT + subroutine print_list_entry(this, l, noder, q, iout, boundname) +! ****************************************************************************** +! print_list_entry -- Print list budget entry +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: ubdsvb, get_ijk + use ConstantsModule, only: LENBOUNDNAME, LINELENGTH + ! -- dummy + class(DisBaseType), intent(in) :: this + integer(I4B), intent(in) :: l + integer(I4B), intent(in) :: noder + real(DP), intent(in) :: q + integer(I4B), intent(in) :: iout + character(len=*), intent(in), optional :: boundname + ! -- local + integer(I4B) :: nodeu + character(len=*), parameter :: fmt1 = & + "(1X,'BOUNDARY ',I8,' CELL ',A20,' RATE ', 1PG15.6,2x,A)" + character(len=LENBOUNDNAME) :: bname + character(len=LINELENGTH) :: nodestr +! ------------------------------------------------------------------------------ + ! + bname = '' + if (present(boundname)) bname = boundname + nodeu = this%get_nodeuser(noder) + call this%nodeu_to_string(nodeu, nodestr) + if (bname == '') then + write(iout, fmt1) l, trim(nodestr), q + else + write(iout, fmt1) l, trim(nodestr), q, trim(bname) + endif + ! + ! -- return + return + end subroutine print_list_entry + + subroutine nlarray_to_nodelist(this, nodelist, maxbnd, nbound, aname, & + inunit, iout) +! ****************************************************************************** +! nlarray_to_nodelist -- Read an integer array into nodelist. For structured +! model, integer array is layer number; for unstructured +! model, integer array is node number. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: ustop, store_error + use ConstantsModule, only: LINELENGTH + ! -- dummy + class(DisBaseType) :: this + integer(I4B), intent(in) :: maxbnd + integer(I4B), dimension(maxbnd), intent(inout) :: nodelist + integer(I4B), intent(inout) :: nbound + character(len=*), intent(in) :: aname + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + ! -- local + character(len=LINELENGTH) :: ermsg + ! + ermsg = 'Programmer error: nlarray_to_nodelist needs to be & + &overridden in any DIS type that extends DisBaseType' + call store_error(ermsg) + call ustop() + ! + ! -- return + return + end subroutine nlarray_to_nodelist + + subroutine highest_active(this, n, ibound) +! ****************************************************************************** +! highest_active -- Find the first highest active cell beneath cell n +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(DisBaseType) :: this + integer(I4B), intent(inout) :: n + integer(I4B), dimension(:), intent(in) :: ibound + ! -- locals + integer(I4B) :: m,ii,iis + logical done, bottomcell +! ------------------------------------------------------------------------------ + ! + ! -- Loop through connected cells until the highest active one (including a + ! constant head cell) is found. Return that cell as n. + done=.false. + do while(.not. done) + bottomcell = .true. + cloop: do ii = this%con%ia(n) + 1, this%con%ia(n+1)-1 + m = this%con%ja(ii) + iis = this%con%jas(ii) + if(this%con%ihc(iis) == 0 .and. m > n) then + ! + ! -- this cannot be a bottom cell + bottomcell = .false. + ! + ! -- vertical down + if(ibound(m) /= 0) then + n = m + done = .true. + exit cloop + else + n = m + exit cloop + endif + endif + enddo cloop + if(bottomcell) done = .true. + enddo + ! + ! -- return + return + end subroutine highest_active + + function get_area(this, node) result(area) +! ****************************************************************************** +! get_area -- Return the cell area for this node +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + real(DP) :: area + ! -- dummy + class(DisBaseType) :: this + integer(I4B), intent(in) :: node +! ------------------------------------------------------------------------------ + ! + ! -- Return the cell area + area = this%area(node) + ! + ! -- return + return + end function get_area + +end module BaseDisModule diff --git a/src/Model/ModelUtilities/DisvGeom.f90 b/src/Model/ModelUtilities/DisvGeom.f90 index 2d8d4c2b2ca..c433f5f215f 100644 --- a/src/Model/ModelUtilities/DisvGeom.f90 +++ b/src/Model/ModelUtilities/DisvGeom.f90 @@ -1,494 +1,494 @@ -module DisvGeom - - use KindModule, only: DP, I4B - use InputOutputModule, only: get_node, get_jk - implicit none - private - public :: DisvGeomType - public :: line_unit_vector - - type DisvGeomType - integer(I4B) :: k - integer(I4B) :: j - integer(I4B) :: nodeusr - integer(I4B) :: nodered - integer(I4B) :: nlay - integer(I4B) :: ncpl - logical :: reduced - integer(I4B) :: nodes ! number of reduced nodes; nodes = nlay *ncpl when grid is NOT reduced - real(DP) :: top - real(DP) :: bot - real(DP), pointer, dimension(:) :: top_grid => null() - real(DP), pointer, dimension(:) :: bot_grid => null() - integer(I4B), pointer, dimension(:) :: iavert => null() - integer(I4B), pointer, dimension(:) :: javert => null() - real(DP), pointer, dimension(:, :) :: vertex_grid => null() - real(DP), pointer, dimension(:, :) :: cellxy_grid => null() - integer(I4B), pointer, dimension(:, :) :: nodereduced => null() ! nodered = nodereduced(nodeusr) - integer(I4B), pointer, dimension(:) :: nodeuser => null() ! nodeusr = nodesuser(nodered) - contains - procedure :: init - generic :: set => set_kj, set_nodered - procedure :: set_kj - procedure :: set_nodered - procedure :: cell_setup - procedure :: cprops - procedure :: edge_normal - procedure :: connection_vector - procedure :: shares_edge - procedure :: get_area - end type DisvGeomType - - contains - - subroutine init(this, nlay, ncpl, nodes, top_grid, bot_grid, iavert, & - javert, vertex_grid, cellxy_grid, nodereduced, nodeuser) - class(DisvGeomType) :: this - integer(I4B), intent(in) :: nlay - integer(I4B), intent(in) :: ncpl - integer(I4B), intent(in) :: nodes - real(DP), dimension(nodes), target :: top_grid - real(DP), dimension(nodes), target :: bot_grid - integer(I4B), dimension(:), target :: iavert - integer(I4B), dimension(:), target :: javert - real(DP), dimension(:, :), target :: vertex_grid - real(DP), dimension(:, :), target :: cellxy_grid - integer(I4B), dimension(ncpl, nlay), target :: nodereduced - integer(I4B), dimension(nodes), target :: nodeuser - ! -- local - integer(I4B) :: nodesuser - this%nlay = nlay - this%ncpl = ncpl - this%nodes = nodes - this%top_grid => top_grid - this%bot_grid => bot_grid - this%iavert => iavert - this%javert => javert - this%vertex_grid => vertex_grid - this%cellxy_grid => cellxy_grid - this%nodereduced => nodereduced - this%nodeuser => nodeuser - nodesuser = ncpl * nlay - if(nodes < nodesuser) then - this%reduced = .true. - else - this%reduced = .false. - endif - end subroutine init - - subroutine set_kj(this, k, j) - class(DisvGeomType) :: this - integer(I4B), intent(in) :: k - integer(I4B), intent(in) :: j - this%k = k - this%j = j - this%nodeusr = get_node(k, 1, j, this%nlay, 1, this%ncpl) - if(this%reduced) then - this%nodered = this%nodereduced(k, j) - else - this%nodered = this%nodeusr - endif - call this%cell_setup() - return - end subroutine set_kj - - subroutine set_nodered(this, nodered) - class(DisvGeomType) :: this - integer(I4B), intent(in) :: nodered - this%nodered = nodered - if(this%reduced) then - this%nodeusr = this%nodeuser(nodered) - else - this%nodeusr = nodered - endif - call get_jk(this%nodeusr, this%ncpl, this%nlay, this%j, this%k) - call this%cell_setup() - return - end subroutine set_nodered - - subroutine cell_setup(this) - class(DisvGeomType) :: this - this%top = this%top_grid(this%nodered) - this%bot = this%bot_grid(this%nodered) - end subroutine cell_setup - - subroutine cprops(this, cell2, hwva, cl1, cl2, ax, ihc) - ! -- module - use ConstantsModule, only: DZERO, DHALF, DONE - class(DisvGeomType) :: this - type(DisvGeomType) :: cell2 - real(DP), intent(out) :: hwva - real(DP), intent(out) :: cl1 - real(DP), intent(out) :: cl2 - real(DP), intent(out) :: ax - integer(I4B), intent(out) :: ihc - ! -- local - integer(I4B) :: ivert1, ivert2 - integer(I4B) :: istart1, istart2, istop1, istop2 - real(DP) :: x0, y0, x1, y1, x2, y2 - ! - if(this%j == cell2%j) then - ! - ! -- Cells share same j index, so must be a vertical connection - ihc = 0 - hwva = this%get_area() - cl1 = DHALF * (this%top - this%bot) - cl2 = DHALF * (cell2%top - cell2%bot) - ax = DZERO - else - ! - ! -- Must be horizontal connection - ihc = 1 - istart1 = this%iavert(this%j) - istop1 = this%iavert(this%j + 1) - 1 - istart2 = cell2%iavert(cell2%j) - istop2 = this%iavert(cell2%j + 1) - 1 - call shared_edge(this%javert(istart1:istop1), & - this%javert(istart2:istop2), & - ivert1, ivert2) - if(ivert1 == 0 .or. ivert2 == 0) then - ! - ! -- Cells do not share an edge - hwva = DZERO - cl1 = DONE - cl2 = DONE - else - x1 = this%vertex_grid(1, ivert1) - y1 = this%vertex_grid(2, ivert1) - x2 = this%vertex_grid(1, ivert2) - y2 = this%vertex_grid(2, ivert2) - hwva = distance(x1, y1, x2, y2) - ! - ! -- cl1 - x0 = this%cellxy_grid(1, this%j) - y0 = this%cellxy_grid(2, this%j) - cl1 = distance_normal(x0, y0, x1, y1, x2, y2) - ! - ! -- cl2 - x0 = this%cellxy_grid(1, cell2%j) - y0 = this%cellxy_grid(2, cell2%j) - cl2 = distance_normal(x0, y0, x1, y1, x2, y2) - ! - ! -- anglex - x1 = this%vertex_grid(1, ivert1) - y1 = this%vertex_grid(2, ivert1) - x2 = this%vertex_grid(1, ivert2) - y2 = this%vertex_grid(2, ivert2) - ax = anglex(x1, y1, x2, y2) - endif - endif - return - end subroutine cprops - - subroutine edge_normal(this, cell2, xcomp, ycomp) - ! return the x and y components of an outward normal - ! facing vector - ! -- module - use ConstantsModule, only: DZERO, DHALF, DONE - ! -- dummy - class(DisvGeomType) :: this - type(DisvGeomType) :: cell2 - real(DP), intent(out) :: xcomp - real(DP), intent(out) :: ycomp - ! -- local - integer(I4B) :: ivert1, ivert2 - integer(I4B) :: istart1, istart2, istop1, istop2 - real(DP) :: x1, y1, x2, y2 - ! - istart1 = this%iavert(this%j) - istop1 = this%iavert(this%j + 1) - 1 - istart2 = cell2%iavert(cell2%j) - istop2 = this%iavert(cell2%j + 1) - 1 - call shared_edge(this%javert(istart1:istop1), & - this%javert(istart2:istop2), & - ivert1, ivert2) - x1 = this%vertex_grid(1, ivert1) - y1 = this%vertex_grid(2, ivert1) - x2 = this%vertex_grid(1, ivert2) - y2 = this%vertex_grid(2, ivert2) - ! - call line_unit_normal(x1, y1, x2, y2, xcomp, ycomp) - return - end subroutine edge_normal - - subroutine connection_vector(this, cell2, nozee, satn, satm, xcomp, & - ycomp, zcomp, conlen) - ! return the x y and z components of a unit vector that points - ! from the center of this to the center of cell2, and the - ! straight-line connection length - ! -- module - use ConstantsModule, only: DZERO, DHALF, DONE - ! -- dummy - class(DisvGeomType) :: this - type(DisvGeomType) :: cell2 - logical, intent(in) :: nozee - real(DP), intent(in) :: satn - real(DP), intent(in) :: satm - real(DP), intent(out) :: xcomp - real(DP), intent(out) :: ycomp - real(DP), intent(out) :: zcomp - real(DP), intent(out) :: conlen - ! -- local - real(DP) :: x1, y1, z1, x2, y2, z2 - ! - x1 = this%cellxy_grid(1, this%j) - y1 = this%cellxy_grid(2, this%j) - x2 = this%cellxy_grid(1, cell2%j) - y2 = this%cellxy_grid(2, cell2%j) - if (nozee) then - z1 = DZERO - z2 = DZERO - else - z1 = this%bot + DHALF * satn * (this%top - this%bot) - z2 = cell2%bot + DHALF * satm * (cell2%top - cell2%bot) - end if - ! - call line_unit_vector(x1, y1, z1, x2, y2, z2, xcomp, ycomp, zcomp, & - conlen) - return - end subroutine connection_vector - - function shares_edge(this, cell2) result(l) -! ****************************************************************************** -! shares_edge -- Return true if this shares a horizontal edge with cell2 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(DisvGeomType) :: this - type(DisvGeomType) :: cell2 - logical l - integer(I4B) :: istart1, istop1, istart2, istop2 - integer(I4B) :: ivert1, ivert2 -! ------------------------------------------------------------------------------ - istart1 = this%iavert(this%j) - istop1 = this%iavert(this%j + 1) - 1 - istart2 = cell2%iavert(cell2%j) - istop2 = this%iavert(cell2%j + 1) - 1 - call shared_edge(this%javert(istart1:istop1), & - this%javert(istart2:istop2), & - ivert1, ivert2) - l = .true. - if(ivert1 == 0 .or. ivert2 == 0) then - l = .false. - endif - return - end function shares_edge - - subroutine shared_edge(ivlist1, ivlist2, ivert1, ivert2) -! ****************************************************************************** -! shared_edge -- Find two common vertices shared by cell1 and cell2. -! ivert1 and ivert2 will return with 0 if there are -! no shared edges. Proceed forward through ivlist1 and -! backward through ivlist2 as a clockwise face in cell1 -! must correspond to a counter clockwise face in cell2 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - integer(I4B), dimension(:) :: ivlist1 - integer(I4B), dimension(:) :: ivlist2 - integer(I4B), intent(out) :: ivert1 - integer(I4B), intent(out) :: ivert2 - integer(I4B) :: nv1 - integer(I4B) :: nv2 - integer(I4B) :: il1 - integer(I4B) :: il2 - logical :: found -! ------------------------------------------------------------------------------ - ! - found = .false. - nv1 = size(ivlist1) - nv2 = size(ivlist2) - ivert1 = 0 - ivert2 = 0 - outerloop: do il1 = 1, nv1 - 1 - do il2 = nv2, 2, -1 - if(ivlist1(il1) == ivlist2(il2) .and. & - ivlist1(il1 + 1) == ivlist2(il2 - 1)) then - found = .true. - ivert1 = ivlist1(il1) - ivert2 = ivlist1(il1 + 1) - exit outerloop - endif - enddo - if(found) exit - enddo outerloop - end subroutine shared_edge - - function get_area(this) result(area) -! ****************************************************************************** -! get_cell2d_area -- Calculate and return the area of the cell -! a = 1/2 *[(x1*y2 + x2*y3 + x3*y4 + ... + xn*y1) - -! (x2*y1 + x3*y2 + x4*y3 + ... + x1*yn)] -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- module - use ConstantsModule, only: DZERO, DHALF - ! -- dummy - class(DisvGeomType) :: this - ! -- return - real(DP) :: area - ! -- local - integer(I4B) :: ivert - integer(I4B) :: nvert - integer(I4B) :: icount - real(DP) :: x - real(DP) :: y -! ------------------------------------------------------------------------------ - ! - area = DZERO - nvert = this%iavert(this%j + 1) - this%iavert(this%j) - icount = 1 - do ivert = this%iavert(this%j), this%iavert(this%j + 1) - 1 - x = this%vertex_grid(1, this%javert(ivert)) - if(icount < nvert) then - y = this%vertex_grid(2, this%javert(ivert + 1)) - else - y = this%vertex_grid(2, this%javert(this%iavert(this%j))) - endif - area = area + x * y - icount = icount + 1 - enddo - ! - icount = 1 - do ivert = this%iavert(this%j), this%iavert(this%j + 1) - 1 - y = this%vertex_grid(2, this%javert(ivert)) - if(icount < nvert) then - x = this%vertex_grid(1, this%javert(ivert + 1)) - else - x = this%vertex_grid(1, this%javert(this%iavert(this%j))) - endif - area = area - x * y - icount = icount + 1 - enddo - ! - area = abs(area) * DHALF - ! - ! -- return - return - end function get_area - - function anglex(x1, y1, x2, y2) result(ax) -! ****************************************************************************** -! anglex -- Calculate the angle that the x-axis makes with a line that is -! normal to the two points. This assumes that vertices are numbered -! clockwise so that the angle is for the normal outward of cell n. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: DZERO, DTWO, DPI - real(DP), intent(in) :: x1 - real(DP), intent(in) :: x2 - real(DP), intent(in) :: y1 - real(DP), intent(in) :: y2 - real(DP) :: ax - real(DP) :: dx - real(DP) :: dy -! ------------------------------------------------------------------------------ - dx = x2 - x1 - dy = y2 - y1 - ax = atan2(dx, -dy) - if(ax < DZERO) ax = DTWO * DPI + ax - return - end function anglex - - function distance(x1, y1, x2, y2) result(d) -! ****************************************************************************** -! distance -- Calculate distance between two points -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - real(DP), intent(in) :: x1 - real(DP), intent(in) :: x2 - real(DP), intent(in) :: y1 - real(DP), intent(in) :: y2 - real(DP) :: d -! ------------------------------------------------------------------------------ - d = (x1 - x2) ** 2 + (y1 - y2) ** 2 - d = sqrt(d) - return - end function distance - - function distance_normal(x0, y0, x1, y1, x2, y2) result(d) -! ****************************************************************************** -! distance_normal -- Calculate normal distance from point (x0, y0) to line -! defined by two points, (x1, y1), (x2, y2) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - real(DP), intent(in) :: x0 - real(DP), intent(in) :: y0 - real(DP), intent(in) :: x1 - real(DP), intent(in) :: y1 - real(DP), intent(in) :: x2 - real(DP), intent(in) :: y2 - real(DP) :: d -! ------------------------------------------------------------------------------ - d = abs((x2 - x1) * (y1 - y0) - (x1 - x0) * (y2 - y1)) - d = d / distance(x1, y1, x2, y2) - return - end function distance_normal - - subroutine line_unit_normal(x0, y0, x1, y1, xcomp, ycomp) -! ****************************************************************************** -! line_unit_normal -- Calculate the normal vector components (xcomp and ycomp) -! for a line defined by two points, (x0, y0), (x1, y1) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - real(DP), intent(in) :: x0 - real(DP), intent(in) :: y0 - real(DP), intent(in) :: x1 - real(DP), intent(in) :: y1 - real(DP), intent(out) :: xcomp - real(DP), intent(out) :: ycomp - real(DP) :: dx, dy, vmag -! ------------------------------------------------------------------------------ - dx = x1 - x0 - dy = y1 - y0 - vmag = sqrt(dx ** 2 + dy ** 2) - xcomp = -dy / vmag - ycomp = dx / vmag - return - end subroutine line_unit_normal - - subroutine line_unit_vector(x0, y0, z0, x1, y1, z1, & - xcomp, ycomp, zcomp, vmag) -! ****************************************************************************** -! line_unit_vector -- Calculate the vector components (xcomp, ycomp, and zcomp) -! for a line defined by two points, (x0, y0, z0), (x1, y1, z1). Also return -! the magnitude of the original vector, vmag. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - real(DP), intent(in) :: x0 - real(DP), intent(in) :: y0 - real(DP), intent(in) :: z0 - real(DP), intent(in) :: x1 - real(DP), intent(in) :: y1 - real(DP), intent(in) :: z1 - real(DP), intent(out) :: xcomp - real(DP), intent(out) :: ycomp - real(DP), intent(out) :: zcomp - real(DP) :: dx, dy, dz, vmag -! ------------------------------------------------------------------------------ - dx = x1 - x0 - dy = y1 - y0 - dz = z1 - z0 - vmag = sqrt(dx ** 2 + dy ** 2 + dz ** 2) - xcomp = dx / vmag - ycomp = dy / vmag - zcomp = dz / vmag - return - end subroutine line_unit_vector - - +module DisvGeom + + use KindModule, only: DP, I4B + use InputOutputModule, only: get_node, get_jk + implicit none + private + public :: DisvGeomType + public :: line_unit_vector + + type DisvGeomType + integer(I4B) :: k + integer(I4B) :: j + integer(I4B) :: nodeusr + integer(I4B) :: nodered + integer(I4B) :: nlay + integer(I4B) :: ncpl + logical :: reduced + integer(I4B) :: nodes ! number of reduced nodes; nodes = nlay *ncpl when grid is NOT reduced + real(DP) :: top + real(DP) :: bot + real(DP), pointer, dimension(:) :: top_grid => null() + real(DP), pointer, dimension(:) :: bot_grid => null() + integer(I4B), pointer, dimension(:) :: iavert => null() + integer(I4B), pointer, dimension(:) :: javert => null() + real(DP), pointer, dimension(:, :) :: vertex_grid => null() + real(DP), pointer, dimension(:, :) :: cellxy_grid => null() + integer(I4B), pointer, dimension(:, :) :: nodereduced => null() ! nodered = nodereduced(nodeusr) + integer(I4B), pointer, dimension(:) :: nodeuser => null() ! nodeusr = nodesuser(nodered) + contains + procedure :: init + generic :: set => set_kj, set_nodered + procedure :: set_kj + procedure :: set_nodered + procedure :: cell_setup + procedure :: cprops + procedure :: edge_normal + procedure :: connection_vector + procedure :: shares_edge + procedure :: get_area + end type DisvGeomType + + contains + + subroutine init(this, nlay, ncpl, nodes, top_grid, bot_grid, iavert, & + javert, vertex_grid, cellxy_grid, nodereduced, nodeuser) + class(DisvGeomType) :: this + integer(I4B), intent(in) :: nlay + integer(I4B), intent(in) :: ncpl + integer(I4B), intent(in) :: nodes + real(DP), dimension(nodes), target :: top_grid + real(DP), dimension(nodes), target :: bot_grid + integer(I4B), dimension(:), target :: iavert + integer(I4B), dimension(:), target :: javert + real(DP), dimension(:, :), target :: vertex_grid + real(DP), dimension(:, :), target :: cellxy_grid + integer(I4B), dimension(ncpl, nlay), target :: nodereduced + integer(I4B), dimension(nodes), target :: nodeuser + ! -- local + integer(I4B) :: nodesuser + this%nlay = nlay + this%ncpl = ncpl + this%nodes = nodes + this%top_grid => top_grid + this%bot_grid => bot_grid + this%iavert => iavert + this%javert => javert + this%vertex_grid => vertex_grid + this%cellxy_grid => cellxy_grid + this%nodereduced => nodereduced + this%nodeuser => nodeuser + nodesuser = ncpl * nlay + if(nodes < nodesuser) then + this%reduced = .true. + else + this%reduced = .false. + endif + end subroutine init + + subroutine set_kj(this, k, j) + class(DisvGeomType) :: this + integer(I4B), intent(in) :: k + integer(I4B), intent(in) :: j + this%k = k + this%j = j + this%nodeusr = get_node(k, 1, j, this%nlay, 1, this%ncpl) + if(this%reduced) then + this%nodered = this%nodereduced(k, j) + else + this%nodered = this%nodeusr + endif + call this%cell_setup() + return + end subroutine set_kj + + subroutine set_nodered(this, nodered) + class(DisvGeomType) :: this + integer(I4B), intent(in) :: nodered + this%nodered = nodered + if(this%reduced) then + this%nodeusr = this%nodeuser(nodered) + else + this%nodeusr = nodered + endif + call get_jk(this%nodeusr, this%ncpl, this%nlay, this%j, this%k) + call this%cell_setup() + return + end subroutine set_nodered + + subroutine cell_setup(this) + class(DisvGeomType) :: this + this%top = this%top_grid(this%nodered) + this%bot = this%bot_grid(this%nodered) + end subroutine cell_setup + + subroutine cprops(this, cell2, hwva, cl1, cl2, ax, ihc) + ! -- module + use ConstantsModule, only: DZERO, DHALF, DONE + class(DisvGeomType) :: this + type(DisvGeomType) :: cell2 + real(DP), intent(out) :: hwva + real(DP), intent(out) :: cl1 + real(DP), intent(out) :: cl2 + real(DP), intent(out) :: ax + integer(I4B), intent(out) :: ihc + ! -- local + integer(I4B) :: ivert1, ivert2 + integer(I4B) :: istart1, istart2, istop1, istop2 + real(DP) :: x0, y0, x1, y1, x2, y2 + ! + if(this%j == cell2%j) then + ! + ! -- Cells share same j index, so must be a vertical connection + ihc = 0 + hwva = this%get_area() + cl1 = DHALF * (this%top - this%bot) + cl2 = DHALF * (cell2%top - cell2%bot) + ax = DZERO + else + ! + ! -- Must be horizontal connection + ihc = 1 + istart1 = this%iavert(this%j) + istop1 = this%iavert(this%j + 1) - 1 + istart2 = cell2%iavert(cell2%j) + istop2 = this%iavert(cell2%j + 1) - 1 + call shared_edge(this%javert(istart1:istop1), & + this%javert(istart2:istop2), & + ivert1, ivert2) + if(ivert1 == 0 .or. ivert2 == 0) then + ! + ! -- Cells do not share an edge + hwva = DZERO + cl1 = DONE + cl2 = DONE + else + x1 = this%vertex_grid(1, ivert1) + y1 = this%vertex_grid(2, ivert1) + x2 = this%vertex_grid(1, ivert2) + y2 = this%vertex_grid(2, ivert2) + hwva = distance(x1, y1, x2, y2) + ! + ! -- cl1 + x0 = this%cellxy_grid(1, this%j) + y0 = this%cellxy_grid(2, this%j) + cl1 = distance_normal(x0, y0, x1, y1, x2, y2) + ! + ! -- cl2 + x0 = this%cellxy_grid(1, cell2%j) + y0 = this%cellxy_grid(2, cell2%j) + cl2 = distance_normal(x0, y0, x1, y1, x2, y2) + ! + ! -- anglex + x1 = this%vertex_grid(1, ivert1) + y1 = this%vertex_grid(2, ivert1) + x2 = this%vertex_grid(1, ivert2) + y2 = this%vertex_grid(2, ivert2) + ax = anglex(x1, y1, x2, y2) + endif + endif + return + end subroutine cprops + + subroutine edge_normal(this, cell2, xcomp, ycomp) + ! return the x and y components of an outward normal + ! facing vector + ! -- module + use ConstantsModule, only: DZERO, DHALF, DONE + ! -- dummy + class(DisvGeomType) :: this + type(DisvGeomType) :: cell2 + real(DP), intent(out) :: xcomp + real(DP), intent(out) :: ycomp + ! -- local + integer(I4B) :: ivert1, ivert2 + integer(I4B) :: istart1, istart2, istop1, istop2 + real(DP) :: x1, y1, x2, y2 + ! + istart1 = this%iavert(this%j) + istop1 = this%iavert(this%j + 1) - 1 + istart2 = cell2%iavert(cell2%j) + istop2 = this%iavert(cell2%j + 1) - 1 + call shared_edge(this%javert(istart1:istop1), & + this%javert(istart2:istop2), & + ivert1, ivert2) + x1 = this%vertex_grid(1, ivert1) + y1 = this%vertex_grid(2, ivert1) + x2 = this%vertex_grid(1, ivert2) + y2 = this%vertex_grid(2, ivert2) + ! + call line_unit_normal(x1, y1, x2, y2, xcomp, ycomp) + return + end subroutine edge_normal + + subroutine connection_vector(this, cell2, nozee, satn, satm, xcomp, & + ycomp, zcomp, conlen) + ! return the x y and z components of a unit vector that points + ! from the center of this to the center of cell2, and the + ! straight-line connection length + ! -- module + use ConstantsModule, only: DZERO, DHALF, DONE + ! -- dummy + class(DisvGeomType) :: this + type(DisvGeomType) :: cell2 + logical, intent(in) :: nozee + real(DP), intent(in) :: satn + real(DP), intent(in) :: satm + real(DP), intent(out) :: xcomp + real(DP), intent(out) :: ycomp + real(DP), intent(out) :: zcomp + real(DP), intent(out) :: conlen + ! -- local + real(DP) :: x1, y1, z1, x2, y2, z2 + ! + x1 = this%cellxy_grid(1, this%j) + y1 = this%cellxy_grid(2, this%j) + x2 = this%cellxy_grid(1, cell2%j) + y2 = this%cellxy_grid(2, cell2%j) + if (nozee) then + z1 = DZERO + z2 = DZERO + else + z1 = this%bot + DHALF * satn * (this%top - this%bot) + z2 = cell2%bot + DHALF * satm * (cell2%top - cell2%bot) + end if + ! + call line_unit_vector(x1, y1, z1, x2, y2, z2, xcomp, ycomp, zcomp, & + conlen) + return + end subroutine connection_vector + + function shares_edge(this, cell2) result(l) +! ****************************************************************************** +! shares_edge -- Return true if this shares a horizontal edge with cell2 +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(DisvGeomType) :: this + type(DisvGeomType) :: cell2 + logical l + integer(I4B) :: istart1, istop1, istart2, istop2 + integer(I4B) :: ivert1, ivert2 +! ------------------------------------------------------------------------------ + istart1 = this%iavert(this%j) + istop1 = this%iavert(this%j + 1) - 1 + istart2 = cell2%iavert(cell2%j) + istop2 = this%iavert(cell2%j + 1) - 1 + call shared_edge(this%javert(istart1:istop1), & + this%javert(istart2:istop2), & + ivert1, ivert2) + l = .true. + if(ivert1 == 0 .or. ivert2 == 0) then + l = .false. + endif + return + end function shares_edge + + subroutine shared_edge(ivlist1, ivlist2, ivert1, ivert2) +! ****************************************************************************** +! shared_edge -- Find two common vertices shared by cell1 and cell2. +! ivert1 and ivert2 will return with 0 if there are +! no shared edges. Proceed forward through ivlist1 and +! backward through ivlist2 as a clockwise face in cell1 +! must correspond to a counter clockwise face in cell2 +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + integer(I4B), dimension(:) :: ivlist1 + integer(I4B), dimension(:) :: ivlist2 + integer(I4B), intent(out) :: ivert1 + integer(I4B), intent(out) :: ivert2 + integer(I4B) :: nv1 + integer(I4B) :: nv2 + integer(I4B) :: il1 + integer(I4B) :: il2 + logical :: found +! ------------------------------------------------------------------------------ + ! + found = .false. + nv1 = size(ivlist1) + nv2 = size(ivlist2) + ivert1 = 0 + ivert2 = 0 + outerloop: do il1 = 1, nv1 - 1 + do il2 = nv2, 2, -1 + if(ivlist1(il1) == ivlist2(il2) .and. & + ivlist1(il1 + 1) == ivlist2(il2 - 1)) then + found = .true. + ivert1 = ivlist1(il1) + ivert2 = ivlist1(il1 + 1) + exit outerloop + endif + enddo + if(found) exit + enddo outerloop + end subroutine shared_edge + + function get_area(this) result(area) +! ****************************************************************************** +! get_cell2d_area -- Calculate and return the area of the cell +! a = 1/2 *[(x1*y2 + x2*y3 + x3*y4 + ... + xn*y1) - +! (x2*y1 + x3*y2 + x4*y3 + ... + x1*yn)] +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- module + use ConstantsModule, only: DZERO, DHALF + ! -- dummy + class(DisvGeomType) :: this + ! -- return + real(DP) :: area + ! -- local + integer(I4B) :: ivert + integer(I4B) :: nvert + integer(I4B) :: icount + real(DP) :: x + real(DP) :: y +! ------------------------------------------------------------------------------ + ! + area = DZERO + nvert = this%iavert(this%j + 1) - this%iavert(this%j) + icount = 1 + do ivert = this%iavert(this%j), this%iavert(this%j + 1) - 1 + x = this%vertex_grid(1, this%javert(ivert)) + if(icount < nvert) then + y = this%vertex_grid(2, this%javert(ivert + 1)) + else + y = this%vertex_grid(2, this%javert(this%iavert(this%j))) + endif + area = area + x * y + icount = icount + 1 + enddo + ! + icount = 1 + do ivert = this%iavert(this%j), this%iavert(this%j + 1) - 1 + y = this%vertex_grid(2, this%javert(ivert)) + if(icount < nvert) then + x = this%vertex_grid(1, this%javert(ivert + 1)) + else + x = this%vertex_grid(1, this%javert(this%iavert(this%j))) + endif + area = area - x * y + icount = icount + 1 + enddo + ! + area = abs(area) * DHALF + ! + ! -- return + return + end function get_area + + function anglex(x1, y1, x2, y2) result(ax) +! ****************************************************************************** +! anglex -- Calculate the angle that the x-axis makes with a line that is +! normal to the two points. This assumes that vertices are numbered +! clockwise so that the angle is for the normal outward of cell n. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: DZERO, DTWO, DPI + real(DP), intent(in) :: x1 + real(DP), intent(in) :: x2 + real(DP), intent(in) :: y1 + real(DP), intent(in) :: y2 + real(DP) :: ax + real(DP) :: dx + real(DP) :: dy +! ------------------------------------------------------------------------------ + dx = x2 - x1 + dy = y2 - y1 + ax = atan2(dx, -dy) + if(ax < DZERO) ax = DTWO * DPI + ax + return + end function anglex + + function distance(x1, y1, x2, y2) result(d) +! ****************************************************************************** +! distance -- Calculate distance between two points +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + real(DP), intent(in) :: x1 + real(DP), intent(in) :: x2 + real(DP), intent(in) :: y1 + real(DP), intent(in) :: y2 + real(DP) :: d +! ------------------------------------------------------------------------------ + d = (x1 - x2) ** 2 + (y1 - y2) ** 2 + d = sqrt(d) + return + end function distance + + function distance_normal(x0, y0, x1, y1, x2, y2) result(d) +! ****************************************************************************** +! distance_normal -- Calculate normal distance from point (x0, y0) to line +! defined by two points, (x1, y1), (x2, y2) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + real(DP), intent(in) :: x0 + real(DP), intent(in) :: y0 + real(DP), intent(in) :: x1 + real(DP), intent(in) :: y1 + real(DP), intent(in) :: x2 + real(DP), intent(in) :: y2 + real(DP) :: d +! ------------------------------------------------------------------------------ + d = abs((x2 - x1) * (y1 - y0) - (x1 - x0) * (y2 - y1)) + d = d / distance(x1, y1, x2, y2) + return + end function distance_normal + + subroutine line_unit_normal(x0, y0, x1, y1, xcomp, ycomp) +! ****************************************************************************** +! line_unit_normal -- Calculate the normal vector components (xcomp and ycomp) +! for a line defined by two points, (x0, y0), (x1, y1) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + real(DP), intent(in) :: x0 + real(DP), intent(in) :: y0 + real(DP), intent(in) :: x1 + real(DP), intent(in) :: y1 + real(DP), intent(out) :: xcomp + real(DP), intent(out) :: ycomp + real(DP) :: dx, dy, vmag +! ------------------------------------------------------------------------------ + dx = x1 - x0 + dy = y1 - y0 + vmag = sqrt(dx ** 2 + dy ** 2) + xcomp = -dy / vmag + ycomp = dx / vmag + return + end subroutine line_unit_normal + + subroutine line_unit_vector(x0, y0, z0, x1, y1, z1, & + xcomp, ycomp, zcomp, vmag) +! ****************************************************************************** +! line_unit_vector -- Calculate the vector components (xcomp, ycomp, and zcomp) +! for a line defined by two points, (x0, y0, z0), (x1, y1, z1). Also return +! the magnitude of the original vector, vmag. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + real(DP), intent(in) :: x0 + real(DP), intent(in) :: y0 + real(DP), intent(in) :: z0 + real(DP), intent(in) :: x1 + real(DP), intent(in) :: y1 + real(DP), intent(in) :: z1 + real(DP), intent(out) :: xcomp + real(DP), intent(out) :: ycomp + real(DP), intent(out) :: zcomp + real(DP) :: dx, dy, dz, vmag +! ------------------------------------------------------------------------------ + dx = x1 - x0 + dy = y1 - y0 + dz = z1 - z0 + vmag = sqrt(dx ** 2 + dy ** 2 + dz ** 2) + xcomp = dx / vmag + ycomp = dy / vmag + zcomp = dz / vmag + return + end subroutine line_unit_vector + + end module DisvGeom \ No newline at end of file diff --git a/src/Model/ModelUtilities/Mover.f90 b/src/Model/ModelUtilities/Mover.f90 index fe39a9c9326..d2801e67afc 100644 --- a/src/Model/ModelUtilities/Mover.f90 +++ b/src/Model/ModelUtilities/Mover.f90 @@ -1,405 +1,405 @@ -module MvrModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LENMODELNAME, LENPACKAGENAME, LINELENGTH, & - LENBUDTXT, LENAUXNAME, LENBOUNDNAME, DZERO, DONE, & - LENORIGIN - use PackageMoverModule, only: PackageMoverType - - implicit none - private - public :: MvrType - - character(len=12), dimension(4) :: mvrtypes = & - [character(len=12) :: 'FACTOR', 'EXCESS', 'THRESHOLD', 'UPTO'] - - type MvrType - character(len=LENMODELNAME+LENPACKAGENAME+1) :: pname1 = '' !provider package name - character(len=LENMODELNAME+LENPACKAGENAME+1) :: pname2 = '' !receiver package name - integer(I4B) :: irch1 = 0 !provider reach number - integer(I4B) :: irch2 = 0 !receiver reach number - integer(I4B) :: imvrtype = 0 !mover type (1, 2, 3, 4) corresponds to mvrtypes - real(DP) :: value = DZERO !factor or rate depending on mvrtype - real(DP) :: qpold = DZERO !provider rate from last time step - real(DP) :: qpactual = DZERO !rate provided to the receiver - real(DP) :: qanew = DZERO !rate available at time of providing - real(DP) :: qaold = DZERO !rate available fromtime step - real(DP), pointer :: qtformvr_ptr => null() !pointer to total available flow (qtformvr) - real(DP), pointer :: qformvr_ptr => null() !pointer to available flow after consumed (qformvr) - real(DP), pointer :: qtomvr_ptr => null() !pointer to provider flow rate (qtomvr) - real(DP), pointer :: qfrommvr_ptr => null() !pointer to receiver flow rate (qfrommvr) - contains - procedure :: set - procedure :: set_qpold - procedure :: echo - procedure :: advance - procedure :: fc - procedure :: qrcalc - procedure :: writeflow - end type MvrType - - contains - - subroutine set(this, line, inunit, iout, mname, pakorigins, pakmovers) -! ****************************************************************************** -! set -- Setup mvr object -! If mname == '', then read mname out of line. pakorigins is an array -! of strings, which are model names and package names. The mover -! entries must be in pakorigins, or this routine will terminate with -! an error. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: urword, extract_idnum_or_bndname - use SimModule, only: ustop, store_error, store_error_unit, count_errors - ! -- dummy - class(MvrType) :: this - character(len=*), intent(inout) :: line - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - character(len=LENMODELNAME), intent(in) :: mname - character(len=LENORIGIN+1), & - dimension(:), pointer, contiguous :: pakorigins - type(PackageMoverType), dimension(:), pointer, contiguous :: pakmovers - ! -- local - integer(I4B) :: lloc, istart, istop, ival - real(DP) :: rval - real(DP), dimension(:), pointer, contiguous :: temp_ptr => null() - character(len=LINELENGTH) :: errmsg - character(len=LENBOUNDNAME) :: bndname - logical :: mnamel, found - integer(I4B) :: i - integer(I4B) :: ipakloc1, ipakloc2 -! ------------------------------------------------------------------------------ - ! - ! -- Check for valid mname and set logical mnamel flag - if(mname == '') then - mnamel = .false. - else - mnamel = .true. - endif - ! - ! -- Set lloc for line - lloc = 1 - ! - ! -- Construct provider name, which is modelname followed by packagename - if(mnamel) then - this%pname1 = trim(adjustl(mname)) - else - call urword(line, lloc, istart, istop, 1, ival, rval, iout, inunit) - this%pname1 = line(istart:istop) - endif - call urword(line, lloc, istart, istop, 1, ival, rval, iout, inunit) - this%pname1 = trim(this%pname1) // ' ' // line(istart:istop) - ! - ! -- Read id for the provider - call extract_idnum_or_bndname(line, lloc, istart, istop, ival, bndname) - this%irch1 = ival - ! - ! -- Construct receiver name, which is modelname followed by packagename - if(mnamel) then - this%pname2 = trim(adjustl(mname)) - else - call urword(line, lloc, istart, istop, 1, ival, rval, iout, inunit) - this%pname2 = line(istart:istop) - endif - call urword(line, lloc, istart, istop, 1, ival, rval, iout, inunit) - this%pname2 = trim(this%pname2) // ' ' // line(istart:istop) - ! - ! -- Read id for the receiver - call extract_idnum_or_bndname(line, lloc, istart, istop, ival, bndname) - this%irch2 = ival - ! - ! -- Read mover type - call urword(line, lloc, istart, istop, 1, ival, rval, iout, inunit) - select case(line(istart:istop)) - case('FACTOR') - this%imvrtype = 1 - case('EXCESS') - this%imvrtype = 2 - case('THRESHOLD') - this%imvrtype = 3 - case('UPTO') - this%imvrtype = 4 - case default - call store_error('ERROR. INVALID MOVER TYPE: '//trim(line(istart:istop)) ) - call store_error_unit(inunit) - call ustop() - end select - ! - ! -- Read mover value - call urword(line, lloc, istart, istop, 3, ival, rval, iout, inunit) - this%value = rval - ! - ! -- initialize values to zero - call this%set_qpold(DZERO) - ! - ! -- Check to make sure provider and receiver are not the same - if(this%pname1 == this%pname2 .and. this%irch1 == this%irch2) then - call store_error('ERROR. PROVIDER AND RECEIVER ARE THE SAME: '// & - trim(line)) - call store_error_unit(inunit) - call ustop() - endif - ! - ! -- Check to make sure pname1 and pname2 are both listed in pakorigins - ! pname1 is the provider package; pname2 is the receiver package - found = .false. - ipakloc1 = 0 - do i = 1, size(pakorigins) - if (this%pname1 == pakorigins(i)) then - found = .true. - ipakloc1 = i - exit - endif - end do - if (.not. found) then - call store_error('MOVER CAPABILITY NOT ACTIVATED IN '//this%pname1) - call store_error('ADD "MOVER" KEYWORD TO PACKAGE OPTIONS BLOCK.') - end if - found = .false. - ipakloc2 = 0 - do i = 1, size(pakorigins) - if (this%pname2 == pakorigins(i)) then - found = .true. - ipakloc2 = i - exit - endif - end do - if (.not. found) then - call store_error('MOVER CAPABILITY NOT ACTIVATED IN '//this%pname2) - call store_error('ADD "MOVER" KEYWORD TO PACKAGE OPTIONS BLOCK.') - end if - if (count_errors() > 0) then - call store_error_unit(inunit) - call ustop() - end if - ! - ! -- Set pointer to QTOMVR array in the provider boundary package - temp_ptr => pakmovers(ipakloc1)%qtomvr - if(this%irch1 < 1 .or. this%irch1 > size(temp_ptr)) then - call store_error('ERROR. PROVIDER ID < 1 OR GREATER THAN PACKAGE SIZE ') - write(errmsg, '(4x,a,i0,a,i0)') 'PROVIDER ID = ', this%irch1, & - '; PACKAGE SIZE = ', size(temp_ptr) - call store_error(trim(errmsg)) - call store_error_unit(inunit) - call ustop() - endif - this%qtomvr_ptr => temp_ptr(this%irch1) - ! - ! -- Set pointer to QFORMVR array in the provider boundary package - temp_ptr => pakmovers(ipakloc1)%qformvr - this%qformvr_ptr => temp_ptr(this%irch1) - ! - ! -- Set pointer to QTFORMVR array in the provider boundary package - temp_ptr => pakmovers(ipakloc1)%qtformvr - this%qtformvr_ptr => temp_ptr(this%irch1) - ! - ! -- Set pointer to QFROMMVR array in the receiver boundary package - temp_ptr => pakmovers(ipakloc2)%qfrommvr - if(this%irch2 < 1 .or. this%irch2 > size(temp_ptr)) then - call store_error('ERROR. RECEIVER ID < 1 OR GREATER THAN PACKAGE SIZE ') - write(errmsg, '(4x,a,i0,a,i0)') 'RECEIVER ID = ', this%irch2, & - '; PACKAGE SIZE = ', size(temp_ptr) - call store_error(trim(errmsg)) - call store_error_unit(inunit) - call ustop() - endif - this%qfrommvr_ptr => temp_ptr(this%irch2) - ! - ! -- return - return - end subroutine set - - subroutine set_qpold(this, value) -! ****************************************************************************** -! set_qpold -- Set the value of qpold -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(MvrType) :: this - real(DP), intent(in) :: value - ! -- local -! ------------------------------------------------------------------------------ - ! - this%qpold = value - ! - ! -- return - return - end subroutine set_qpold - - subroutine echo(this, iout) -! ****************************************************************************** -! echo -- Write the mover info that was read from file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(MvrType) :: this - integer(I4B), intent(in) :: iout - ! -- local -! ------------------------------------------------------------------------------ - ! - write(iout, '(4x, a, a, a, i0)') 'FROM PACKAGE: ', trim(this%pname1), & - ' FROM ID: ', this%irch1 - write(iout, '(4x, a, a, a, i0)') 'TO PACKAGE: ', trim(this%pname2), & - ' TO ID: ', this%irch2 - write(iout, '(4x, a, a, a, 1pg15.6,/)') 'MOVER TYPE: ', & - trim(mvrtypes(this%imvrtype)), ' ', this%value - ! - ! -- return - return - end subroutine echo - - subroutine advance(this) -! ****************************************************************************** -! advance -- Advance the mover -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(MvrType) :: this - ! -- local -! ------------------------------------------------------------------------------ - ! - this%qpold = this%qpactual - this%qaold = this%qanew - ! - ! -- return - return - end subroutine advance - - subroutine fc(this, omega) -! ****************************************************************************** -! fc -- formulate coefficients -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(MvrType) :: this - real(DP), intent(in) :: omega - ! -- local - real(DP) :: qanew, qtanew, qpnew, qpactual -! ------------------------------------------------------------------------------ - ! - ! -- Set qa and this%qanew equal to available water in package (qtomvr) - qanew = this%qformvr_ptr - qtanew = this%qtformvr_ptr - this%qanew = qanew - ! - ! -- Using the mover rules, calculate how much of the available water will - ! be provided from the mover to the receiver. - qpnew = this%qrcalc(qanew, qtanew) - ! - ! -- Calculate weighted value for qpactual using qpnew and qpold - qpactual = omega * qpnew - ! - ! -- Store qpactual - this%qpactual = qpactual - ! - ! -- Add the calculated qpactual term directly into the receiver package - ! qfrommvr array. - this%qfrommvr_ptr = this%qfrommvr_ptr + qpactual - ! - ! -- Add the calculated qpactual term directly into the provider package - ! qtomvr array. - this%qtomvr_ptr = this%qtomvr_ptr + qpactual - ! - ! -- Reduce the amount of water that is available in the provider package - ! qformvr array. - this%qformvr_ptr = this%qformvr_ptr - qpactual - ! - ! -- return - return - end subroutine fc - - function qrcalc(this, qa, qta) result(qr) -! ****************************************************************************** -! qrcalc -- Calculate the rate of water provided to the receiver -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - real(DP) :: qr - ! -- dummy - class(MvrType) :: this - real(DP), intent(in) :: qa - real(DP), intent(in) :: qta - ! -- local -! ------------------------------------------------------------------------------ - ! -- Using the mover rules, calculate how much of the available water will - ! go to the receiver. - qr = DZERO - ! -- Calculate qr - select case (this%imvrtype) - case(1) - ! -- FACTOR uses total available to make calculation, and then - ! limits qr by consumed available - if(qta > DZERO) qr = qta * this%value - qr = min(qr, qa) - case(2) - ! -- EXCESS - if(qa > this%value) then - qr = qa - this%value - else - qr = DZERO - endif - case(3) - ! -- THRESHOLD - if(this%value > qa) then - qr = DZERO - else - qr = this%value - endif - case(4) - ! -- UPTO - if(qa > this%value) then - qr = this%value - else - qr = qa - endif - end select - ! - ! -- return - return - end function qrcalc - - subroutine writeflow(this, iout) -! ****************************************************************************** -! writeflow -- Write mover flow information -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(MvrType) :: this - integer(I4B), intent(in) :: iout - ! -- local - character(len=*), parameter :: fmt = & - "(1x, a, ' ID ', i0, ' AVAILABLE ', 1(1pg15.6), " // & - "' PROVIDED ', 1(1pg15.6), ' TO ', a, ' ID ', i0)" -! ------------------------------------------------------------------------------ - ! - write(iout, fmt) trim(this%pname1), this%irch1, this%qanew, this%qpactual, & - trim(this%pname2), this%irch2 - ! - ! -- return - return - end subroutine writeflow - -end module MvrModule - +module MvrModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: LENMODELNAME, LENPACKAGENAME, LINELENGTH, & + LENBUDTXT, LENAUXNAME, LENBOUNDNAME, DZERO, DONE, & + LENORIGIN + use PackageMoverModule, only: PackageMoverType + + implicit none + private + public :: MvrType + + character(len=12), dimension(4) :: mvrtypes = & + [character(len=12) :: 'FACTOR', 'EXCESS', 'THRESHOLD', 'UPTO'] + + type MvrType + character(len=LENMODELNAME+LENPACKAGENAME+1) :: pname1 = '' !provider package name + character(len=LENMODELNAME+LENPACKAGENAME+1) :: pname2 = '' !receiver package name + integer(I4B) :: irch1 = 0 !provider reach number + integer(I4B) :: irch2 = 0 !receiver reach number + integer(I4B) :: imvrtype = 0 !mover type (1, 2, 3, 4) corresponds to mvrtypes + real(DP) :: value = DZERO !factor or rate depending on mvrtype + real(DP) :: qpold = DZERO !provider rate from last time step + real(DP) :: qpactual = DZERO !rate provided to the receiver + real(DP) :: qanew = DZERO !rate available at time of providing + real(DP) :: qaold = DZERO !rate available fromtime step + real(DP), pointer :: qtformvr_ptr => null() !pointer to total available flow (qtformvr) + real(DP), pointer :: qformvr_ptr => null() !pointer to available flow after consumed (qformvr) + real(DP), pointer :: qtomvr_ptr => null() !pointer to provider flow rate (qtomvr) + real(DP), pointer :: qfrommvr_ptr => null() !pointer to receiver flow rate (qfrommvr) + contains + procedure :: set + procedure :: set_qpold + procedure :: echo + procedure :: advance + procedure :: fc + procedure :: qrcalc + procedure :: writeflow + end type MvrType + + contains + + subroutine set(this, line, inunit, iout, mname, pakorigins, pakmovers) +! ****************************************************************************** +! set -- Setup mvr object +! If mname == '', then read mname out of line. pakorigins is an array +! of strings, which are model names and package names. The mover +! entries must be in pakorigins, or this routine will terminate with +! an error. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: urword, extract_idnum_or_bndname + use SimModule, only: ustop, store_error, store_error_unit, count_errors + ! -- dummy + class(MvrType) :: this + character(len=*), intent(inout) :: line + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + character(len=LENMODELNAME), intent(in) :: mname + character(len=LENORIGIN+1), & + dimension(:), pointer, contiguous :: pakorigins + type(PackageMoverType), dimension(:), pointer, contiguous :: pakmovers + ! -- local + integer(I4B) :: lloc, istart, istop, ival + real(DP) :: rval + real(DP), dimension(:), pointer, contiguous :: temp_ptr => null() + character(len=LINELENGTH) :: errmsg + character(len=LENBOUNDNAME) :: bndname + logical :: mnamel, found + integer(I4B) :: i + integer(I4B) :: ipakloc1, ipakloc2 +! ------------------------------------------------------------------------------ + ! + ! -- Check for valid mname and set logical mnamel flag + if(mname == '') then + mnamel = .false. + else + mnamel = .true. + endif + ! + ! -- Set lloc for line + lloc = 1 + ! + ! -- Construct provider name, which is modelname followed by packagename + if(mnamel) then + this%pname1 = trim(adjustl(mname)) + else + call urword(line, lloc, istart, istop, 1, ival, rval, iout, inunit) + this%pname1 = line(istart:istop) + endif + call urword(line, lloc, istart, istop, 1, ival, rval, iout, inunit) + this%pname1 = trim(this%pname1) // ' ' // line(istart:istop) + ! + ! -- Read id for the provider + call extract_idnum_or_bndname(line, lloc, istart, istop, ival, bndname) + this%irch1 = ival + ! + ! -- Construct receiver name, which is modelname followed by packagename + if(mnamel) then + this%pname2 = trim(adjustl(mname)) + else + call urword(line, lloc, istart, istop, 1, ival, rval, iout, inunit) + this%pname2 = line(istart:istop) + endif + call urword(line, lloc, istart, istop, 1, ival, rval, iout, inunit) + this%pname2 = trim(this%pname2) // ' ' // line(istart:istop) + ! + ! -- Read id for the receiver + call extract_idnum_or_bndname(line, lloc, istart, istop, ival, bndname) + this%irch2 = ival + ! + ! -- Read mover type + call urword(line, lloc, istart, istop, 1, ival, rval, iout, inunit) + select case(line(istart:istop)) + case('FACTOR') + this%imvrtype = 1 + case('EXCESS') + this%imvrtype = 2 + case('THRESHOLD') + this%imvrtype = 3 + case('UPTO') + this%imvrtype = 4 + case default + call store_error('ERROR. INVALID MOVER TYPE: '//trim(line(istart:istop)) ) + call store_error_unit(inunit) + call ustop() + end select + ! + ! -- Read mover value + call urword(line, lloc, istart, istop, 3, ival, rval, iout, inunit) + this%value = rval + ! + ! -- initialize values to zero + call this%set_qpold(DZERO) + ! + ! -- Check to make sure provider and receiver are not the same + if(this%pname1 == this%pname2 .and. this%irch1 == this%irch2) then + call store_error('ERROR. PROVIDER AND RECEIVER ARE THE SAME: '// & + trim(line)) + call store_error_unit(inunit) + call ustop() + endif + ! + ! -- Check to make sure pname1 and pname2 are both listed in pakorigins + ! pname1 is the provider package; pname2 is the receiver package + found = .false. + ipakloc1 = 0 + do i = 1, size(pakorigins) + if (this%pname1 == pakorigins(i)) then + found = .true. + ipakloc1 = i + exit + endif + end do + if (.not. found) then + call store_error('MOVER CAPABILITY NOT ACTIVATED IN '//this%pname1) + call store_error('ADD "MOVER" KEYWORD TO PACKAGE OPTIONS BLOCK.') + end if + found = .false. + ipakloc2 = 0 + do i = 1, size(pakorigins) + if (this%pname2 == pakorigins(i)) then + found = .true. + ipakloc2 = i + exit + endif + end do + if (.not. found) then + call store_error('MOVER CAPABILITY NOT ACTIVATED IN '//this%pname2) + call store_error('ADD "MOVER" KEYWORD TO PACKAGE OPTIONS BLOCK.') + end if + if (count_errors() > 0) then + call store_error_unit(inunit) + call ustop() + end if + ! + ! -- Set pointer to QTOMVR array in the provider boundary package + temp_ptr => pakmovers(ipakloc1)%qtomvr + if(this%irch1 < 1 .or. this%irch1 > size(temp_ptr)) then + call store_error('ERROR. PROVIDER ID < 1 OR GREATER THAN PACKAGE SIZE ') + write(errmsg, '(4x,a,i0,a,i0)') 'PROVIDER ID = ', this%irch1, & + '; PACKAGE SIZE = ', size(temp_ptr) + call store_error(trim(errmsg)) + call store_error_unit(inunit) + call ustop() + endif + this%qtomvr_ptr => temp_ptr(this%irch1) + ! + ! -- Set pointer to QFORMVR array in the provider boundary package + temp_ptr => pakmovers(ipakloc1)%qformvr + this%qformvr_ptr => temp_ptr(this%irch1) + ! + ! -- Set pointer to QTFORMVR array in the provider boundary package + temp_ptr => pakmovers(ipakloc1)%qtformvr + this%qtformvr_ptr => temp_ptr(this%irch1) + ! + ! -- Set pointer to QFROMMVR array in the receiver boundary package + temp_ptr => pakmovers(ipakloc2)%qfrommvr + if(this%irch2 < 1 .or. this%irch2 > size(temp_ptr)) then + call store_error('ERROR. RECEIVER ID < 1 OR GREATER THAN PACKAGE SIZE ') + write(errmsg, '(4x,a,i0,a,i0)') 'RECEIVER ID = ', this%irch2, & + '; PACKAGE SIZE = ', size(temp_ptr) + call store_error(trim(errmsg)) + call store_error_unit(inunit) + call ustop() + endif + this%qfrommvr_ptr => temp_ptr(this%irch2) + ! + ! -- return + return + end subroutine set + + subroutine set_qpold(this, value) +! ****************************************************************************** +! set_qpold -- Set the value of qpold +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(MvrType) :: this + real(DP), intent(in) :: value + ! -- local +! ------------------------------------------------------------------------------ + ! + this%qpold = value + ! + ! -- return + return + end subroutine set_qpold + + subroutine echo(this, iout) +! ****************************************************************************** +! echo -- Write the mover info that was read from file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(MvrType) :: this + integer(I4B), intent(in) :: iout + ! -- local +! ------------------------------------------------------------------------------ + ! + write(iout, '(4x, a, a, a, i0)') 'FROM PACKAGE: ', trim(this%pname1), & + ' FROM ID: ', this%irch1 + write(iout, '(4x, a, a, a, i0)') 'TO PACKAGE: ', trim(this%pname2), & + ' TO ID: ', this%irch2 + write(iout, '(4x, a, a, a, 1pg15.6,/)') 'MOVER TYPE: ', & + trim(mvrtypes(this%imvrtype)), ' ', this%value + ! + ! -- return + return + end subroutine echo + + subroutine advance(this) +! ****************************************************************************** +! advance -- Advance the mover +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(MvrType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + this%qpold = this%qpactual + this%qaold = this%qanew + ! + ! -- return + return + end subroutine advance + + subroutine fc(this, omega) +! ****************************************************************************** +! fc -- formulate coefficients +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(MvrType) :: this + real(DP), intent(in) :: omega + ! -- local + real(DP) :: qanew, qtanew, qpnew, qpactual +! ------------------------------------------------------------------------------ + ! + ! -- Set qa and this%qanew equal to available water in package (qtomvr) + qanew = this%qformvr_ptr + qtanew = this%qtformvr_ptr + this%qanew = qanew + ! + ! -- Using the mover rules, calculate how much of the available water will + ! be provided from the mover to the receiver. + qpnew = this%qrcalc(qanew, qtanew) + ! + ! -- Calculate weighted value for qpactual using qpnew and qpold + qpactual = omega * qpnew + ! + ! -- Store qpactual + this%qpactual = qpactual + ! + ! -- Add the calculated qpactual term directly into the receiver package + ! qfrommvr array. + this%qfrommvr_ptr = this%qfrommvr_ptr + qpactual + ! + ! -- Add the calculated qpactual term directly into the provider package + ! qtomvr array. + this%qtomvr_ptr = this%qtomvr_ptr + qpactual + ! + ! -- Reduce the amount of water that is available in the provider package + ! qformvr array. + this%qformvr_ptr = this%qformvr_ptr - qpactual + ! + ! -- return + return + end subroutine fc + + function qrcalc(this, qa, qta) result(qr) +! ****************************************************************************** +! qrcalc -- Calculate the rate of water provided to the receiver +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + real(DP) :: qr + ! -- dummy + class(MvrType) :: this + real(DP), intent(in) :: qa + real(DP), intent(in) :: qta + ! -- local +! ------------------------------------------------------------------------------ + ! -- Using the mover rules, calculate how much of the available water will + ! go to the receiver. + qr = DZERO + ! -- Calculate qr + select case (this%imvrtype) + case(1) + ! -- FACTOR uses total available to make calculation, and then + ! limits qr by consumed available + if(qta > DZERO) qr = qta * this%value + qr = min(qr, qa) + case(2) + ! -- EXCESS + if(qa > this%value) then + qr = qa - this%value + else + qr = DZERO + endif + case(3) + ! -- THRESHOLD + if(this%value > qa) then + qr = DZERO + else + qr = this%value + endif + case(4) + ! -- UPTO + if(qa > this%value) then + qr = this%value + else + qr = qa + endif + end select + ! + ! -- return + return + end function qrcalc + + subroutine writeflow(this, iout) +! ****************************************************************************** +! writeflow -- Write mover flow information +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(MvrType) :: this + integer(I4B), intent(in) :: iout + ! -- local + character(len=*), parameter :: fmt = & + "(1x, a, ' ID ', i0, ' AVAILABLE ', 1(1pg15.6), " // & + "' PROVIDED ', 1(1pg15.6), ' TO ', a, ' ID ', i0)" +! ------------------------------------------------------------------------------ + ! + write(iout, fmt) trim(this%pname1), this%irch1, this%qanew, this%qpactual, & + trim(this%pname2), this%irch2 + ! + ! -- return + return + end subroutine writeflow + +end module MvrModule + diff --git a/src/Model/ModelUtilities/PackageMover.f90 b/src/Model/ModelUtilities/PackageMover.f90 index 7996ce76752..f3d1dc51f2a 100644 --- a/src/Model/ModelUtilities/PackageMover.f90 +++ b/src/Model/ModelUtilities/PackageMover.f90 @@ -1,199 +1,199 @@ -module PackageMoverModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LENORIGIN, DZERO - use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_setptr, & - mem_deallocate - - implicit none - private - public :: PackageMoverType - public :: set_packagemover_pointer - public :: nulllify_packagemover_pointer - - type PackageMoverType - - character(len=LENORIGIN) :: origin - integer, pointer :: nproviders - integer, pointer :: nreceivers - real(DP), dimension(:), pointer, contiguous :: qtformvr => null() - real(DP), dimension(:), pointer, contiguous :: qformvr => null() - real(DP), dimension(:), pointer, contiguous :: qtomvr => null() - real(DP), dimension(:), pointer, contiguous :: qfrommvr => null() - - contains - procedure :: ar - procedure :: ad - procedure :: cf - procedure :: fc - procedure :: da - procedure :: allocate_scalars - procedure :: allocate_arrays - procedure :: get_qfrommvr - procedure :: get_qtomvr - procedure :: accumulate_qformvr - - end type PackageMoverType - - contains - - subroutine set_packagemover_pointer(packagemover, origin) - type(PackageMoverType), intent(inout) :: packagemover - character(len=*), intent(in) :: origin - packagemover%origin = origin - call mem_setptr(packagemover%nproviders, 'NPROVIDERS', origin) - call mem_setptr(packagemover%nreceivers, 'NRECEIVERS', origin) - call mem_setptr(packagemover%qtformvr, 'QTFORMVR', origin) - call mem_setptr(packagemover%qformvr, 'QFORMVR', origin) - call mem_setptr(packagemover%qtomvr, 'QTOMVR', origin) - call mem_setptr(packagemover%qfrommvr, 'QFROMMVR', origin) - end subroutine set_packagemover_pointer - - subroutine nulllify_packagemover_pointer(packagemover) - type(PackageMoverType), intent(inout) :: packagemover - packagemover%origin = '' - packagemover%nproviders => null() - packagemover%nreceivers => null() - packagemover%qtformvr => null() - packagemover%qformvr => null() - packagemover%qtomvr => null() - packagemover%qfrommvr => null() - end subroutine nulllify_packagemover_pointer - - subroutine ar(this, nproviders, nreceivers, origin) - class(PackageMoverType) :: this - integer, intent(in) :: nproviders - integer, intent(in) :: nreceivers - character(len=*), intent(in) :: origin - ! - call this%allocate_scalars(origin) - this%nproviders = nproviders - this%nreceivers = nreceivers - ! - call this%allocate_arrays() - ! - ! -- return - return - end subroutine ar - - subroutine ad(this) - class(PackageMoverType) :: this - integer :: i - ! - ! -- set qtomvr and qformvr to zero - do i = 1, this%nproviders - this%qtomvr(i) = DZERO - this%qformvr(i) = DZERO - enddo - ! - ! -- return - return - end subroutine ad - - subroutine cf(this) - class(PackageMoverType) :: this - integer :: i - ! - ! -- set frommvr and qtomvr to zero - do i = 1, this%nreceivers - this%qfrommvr(i) = DZERO - enddo - do i = 1, this%nproviders - this%qtomvr(i) = DZERO - this%qtformvr(i) = this%qformvr(i) - enddo - ! - ! -- return - return - end subroutine cf - - subroutine fc(this) - class(PackageMoverType) :: this - integer :: i - ! - ! -- set formvr to zero - do i = 1, this%nproviders - this%qformvr(i) = DZERO - enddo - ! - ! -- return - return - end subroutine fc - - subroutine da(this) - class(PackageMoverType) :: this - ! - ! -- arrays - call mem_deallocate(this%qtformvr) - call mem_deallocate(this%qformvr) - call mem_deallocate(this%qtomvr) - call mem_deallocate(this%qfrommvr) - ! - ! -- scalars - call mem_deallocate(this%nproviders) - call mem_deallocate(this%nreceivers) - ! - ! -- return - return - end subroutine da - - subroutine allocate_scalars(this, origin) - class(PackageMoverType) :: this - character(len=*), intent(in) :: origin - ! - call mem_allocate(this%nproviders, 'NPROVIDERS', origin) - call mem_allocate(this%nreceivers, 'NRECEIVERS', origin) - ! - this%nproviders = 0 - this%nreceivers = 0 - this%origin = origin - ! - ! -- return - return - end subroutine allocate_scalars - - subroutine allocate_arrays(this) - class(PackageMoverType) :: this - integer(I4B) :: i - ! - call mem_allocate(this%qtformvr, this%nproviders, 'QTFORMVR', this%origin) - call mem_allocate(this%qformvr, this%nproviders, 'QFORMVR', this%origin) - call mem_allocate(this%qtomvr, this%nproviders, 'QTOMVR', this%origin) - call mem_allocate(this%qfrommvr, this%nreceivers, 'QFROMMVR', this%origin) - ! - ! -- initialize - do i = 1, this%nproviders - this%qtformvr(i) = DZERO - this%qformvr(i) = DZERO - this%qtomvr(i) = DZERO - enddo - do i = 1, this%nreceivers - this%qfrommvr(i) = DZERO - enddo - ! - ! -- return - return - end subroutine allocate_arrays - - function get_qfrommvr(this, ireceiver) result(qfrommvr) - class(PackageMoverType) :: this - real(DP) :: qfrommvr - integer, intent(in) :: ireceiver - qfrommvr = this%qfrommvr(ireceiver) - end function get_qfrommvr - - function get_qtomvr(this, iprovider) result(qtomvr) - class(PackageMoverType) :: this - real(DP) :: qtomvr - integer, intent(in) :: iprovider - qtomvr = this%qtomvr(iprovider) - end function get_qtomvr - - subroutine accumulate_qformvr(this, iprovider, qformvr) - class(PackageMoverType) :: this - integer, intent(in) :: iprovider - real(DP), intent(in) :: qformvr - this%qformvr(iprovider) = this%qformvr(iprovider) + qformvr - end subroutine accumulate_qformvr - +module PackageMoverModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: LENORIGIN, DZERO + use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_setptr, & + mem_deallocate + + implicit none + private + public :: PackageMoverType + public :: set_packagemover_pointer + public :: nulllify_packagemover_pointer + + type PackageMoverType + + character(len=LENORIGIN) :: origin + integer, pointer :: nproviders + integer, pointer :: nreceivers + real(DP), dimension(:), pointer, contiguous :: qtformvr => null() + real(DP), dimension(:), pointer, contiguous :: qformvr => null() + real(DP), dimension(:), pointer, contiguous :: qtomvr => null() + real(DP), dimension(:), pointer, contiguous :: qfrommvr => null() + + contains + procedure :: ar + procedure :: ad + procedure :: cf + procedure :: fc + procedure :: da + procedure :: allocate_scalars + procedure :: allocate_arrays + procedure :: get_qfrommvr + procedure :: get_qtomvr + procedure :: accumulate_qformvr + + end type PackageMoverType + + contains + + subroutine set_packagemover_pointer(packagemover, origin) + type(PackageMoverType), intent(inout) :: packagemover + character(len=*), intent(in) :: origin + packagemover%origin = origin + call mem_setptr(packagemover%nproviders, 'NPROVIDERS', origin) + call mem_setptr(packagemover%nreceivers, 'NRECEIVERS', origin) + call mem_setptr(packagemover%qtformvr, 'QTFORMVR', origin) + call mem_setptr(packagemover%qformvr, 'QFORMVR', origin) + call mem_setptr(packagemover%qtomvr, 'QTOMVR', origin) + call mem_setptr(packagemover%qfrommvr, 'QFROMMVR', origin) + end subroutine set_packagemover_pointer + + subroutine nulllify_packagemover_pointer(packagemover) + type(PackageMoverType), intent(inout) :: packagemover + packagemover%origin = '' + packagemover%nproviders => null() + packagemover%nreceivers => null() + packagemover%qtformvr => null() + packagemover%qformvr => null() + packagemover%qtomvr => null() + packagemover%qfrommvr => null() + end subroutine nulllify_packagemover_pointer + + subroutine ar(this, nproviders, nreceivers, origin) + class(PackageMoverType) :: this + integer, intent(in) :: nproviders + integer, intent(in) :: nreceivers + character(len=*), intent(in) :: origin + ! + call this%allocate_scalars(origin) + this%nproviders = nproviders + this%nreceivers = nreceivers + ! + call this%allocate_arrays() + ! + ! -- return + return + end subroutine ar + + subroutine ad(this) + class(PackageMoverType) :: this + integer :: i + ! + ! -- set qtomvr and qformvr to zero + do i = 1, this%nproviders + this%qtomvr(i) = DZERO + this%qformvr(i) = DZERO + enddo + ! + ! -- return + return + end subroutine ad + + subroutine cf(this) + class(PackageMoverType) :: this + integer :: i + ! + ! -- set frommvr and qtomvr to zero + do i = 1, this%nreceivers + this%qfrommvr(i) = DZERO + enddo + do i = 1, this%nproviders + this%qtomvr(i) = DZERO + this%qtformvr(i) = this%qformvr(i) + enddo + ! + ! -- return + return + end subroutine cf + + subroutine fc(this) + class(PackageMoverType) :: this + integer :: i + ! + ! -- set formvr to zero + do i = 1, this%nproviders + this%qformvr(i) = DZERO + enddo + ! + ! -- return + return + end subroutine fc + + subroutine da(this) + class(PackageMoverType) :: this + ! + ! -- arrays + call mem_deallocate(this%qtformvr) + call mem_deallocate(this%qformvr) + call mem_deallocate(this%qtomvr) + call mem_deallocate(this%qfrommvr) + ! + ! -- scalars + call mem_deallocate(this%nproviders) + call mem_deallocate(this%nreceivers) + ! + ! -- return + return + end subroutine da + + subroutine allocate_scalars(this, origin) + class(PackageMoverType) :: this + character(len=*), intent(in) :: origin + ! + call mem_allocate(this%nproviders, 'NPROVIDERS', origin) + call mem_allocate(this%nreceivers, 'NRECEIVERS', origin) + ! + this%nproviders = 0 + this%nreceivers = 0 + this%origin = origin + ! + ! -- return + return + end subroutine allocate_scalars + + subroutine allocate_arrays(this) + class(PackageMoverType) :: this + integer(I4B) :: i + ! + call mem_allocate(this%qtformvr, this%nproviders, 'QTFORMVR', this%origin) + call mem_allocate(this%qformvr, this%nproviders, 'QFORMVR', this%origin) + call mem_allocate(this%qtomvr, this%nproviders, 'QTOMVR', this%origin) + call mem_allocate(this%qfrommvr, this%nreceivers, 'QFROMMVR', this%origin) + ! + ! -- initialize + do i = 1, this%nproviders + this%qtformvr(i) = DZERO + this%qformvr(i) = DZERO + this%qtomvr(i) = DZERO + enddo + do i = 1, this%nreceivers + this%qfrommvr(i) = DZERO + enddo + ! + ! -- return + return + end subroutine allocate_arrays + + function get_qfrommvr(this, ireceiver) result(qfrommvr) + class(PackageMoverType) :: this + real(DP) :: qfrommvr + integer, intent(in) :: ireceiver + qfrommvr = this%qfrommvr(ireceiver) + end function get_qfrommvr + + function get_qtomvr(this, iprovider) result(qtomvr) + class(PackageMoverType) :: this + real(DP) :: qtomvr + integer, intent(in) :: iprovider + qtomvr = this%qtomvr(iprovider) + end function get_qtomvr + + subroutine accumulate_qformvr(this, iprovider, qformvr) + class(PackageMoverType) :: this + integer, intent(in) :: iprovider + real(DP), intent(in) :: qformvr + this%qformvr(iprovider) = this%qformvr(iprovider) + qformvr + end subroutine accumulate_qformvr + end module PackageMoverModule \ No newline at end of file diff --git a/src/Model/ModelUtilities/UzfCellGroup.f90 b/src/Model/ModelUtilities/UzfCellGroup.f90 index 200d6bce94b..5b74088251d 100644 --- a/src/Model/ModelUtilities/UzfCellGroup.f90 +++ b/src/Model/ModelUtilities/UzfCellGroup.f90 @@ -1,2428 +1,2428 @@ -module UzfCellGroupModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, DEM30, DEM20, DEM15, DEM14, DEM12, DEM10, & - DEM9, DEM7, DEM6, DEM5, DEM4, DEM3, DHALF, DONE, & - DTWO, DTHREE, DEP20 - use SmoothingModule - use TdisModule, only: ITMUNI, delt, kper - - implicit none - private - public :: UzfCellGroupType - - type :: UzfCellGroupType - integer(I4B) :: imem_manager - real(DP), pointer, dimension(:), contiguous :: thtr => null() - real(DP), pointer, dimension(:), contiguous :: thts => null() - real(DP), pointer, dimension(:), contiguous :: thti => null() - real(DP), pointer, dimension(:), contiguous :: eps => null() - real(DP), pointer, dimension(:), contiguous :: extwc => null() - real(DP), pointer, dimension(:), contiguous :: ha => null() - real(DP), pointer, dimension(:), contiguous :: hroot => null() - real(DP), pointer, dimension(:), contiguous :: rootact => null() - real(DP), pointer, dimension(:), contiguous :: etact => null() - real(DP), dimension(:, :), pointer, contiguous :: uzspst => null() - real(DP), dimension(:, :), pointer, contiguous :: uzthst => null() - real(DP), dimension(:, :), pointer, contiguous :: uzflst => null() - real(DP), dimension(:, :), pointer, contiguous :: uzdpst => null() - integer(I4B), pointer, dimension(:), contiguous :: nwavst => null() - real(DP), pointer, dimension(:), contiguous :: uzolsflx => null() - real(DP), pointer, dimension(:), contiguous :: uzstor => null() - real(DP), pointer, dimension(:), contiguous :: delstor => null() - real(DP), pointer, dimension(:), contiguous :: totflux => null() - real(DP), pointer, dimension(:), contiguous :: vflow => null() - integer(I4B), pointer, dimension(:), contiguous :: nwav => null() - integer(I4B), pointer, dimension(:), contiguous :: ntrail => null() - real(DP), pointer, dimension(:), contiguous :: sinf => null() - real(DP), pointer, dimension(:), contiguous :: finf => null() - real(DP), pointer, dimension(:), contiguous :: pet => null() - real(DP), pointer, dimension(:), contiguous :: petmax => null() - real(DP), pointer, dimension(:), contiguous :: extdp => null() - real(DP), pointer, dimension(:), contiguous :: extdpuz => null() - real(DP), pointer, dimension(:), contiguous :: finf_rej => null() - real(DP), pointer, dimension(:), contiguous :: gwet => null() - real(DP), pointer, dimension(:), contiguous :: uzfarea => null() - real(DP), pointer, dimension(:), contiguous :: cellarea => null() - real(DP), pointer, dimension(:), contiguous :: celtop => null() - real(DP), pointer, dimension(:), contiguous :: celbot => null() - real(DP), pointer, dimension(:), contiguous :: landtop => null() - real(DP), pointer, dimension(:), contiguous :: cvlm1 => null() - real(DP), pointer, dimension(:), contiguous :: watab => null() - real(DP), pointer, dimension(:), contiguous :: watabold => null() - real(DP), pointer, dimension(:), contiguous :: vks => null() - real(DP), pointer, dimension(:), contiguous :: surfdep => null() - real(DP), pointer, dimension(:), contiguous :: surflux => null() - real(DP), pointer, dimension(:), contiguous :: surfluxbelow => null() - real(DP), pointer, dimension(:), contiguous :: surfseep => null() - real(DP), pointer, dimension(:), contiguous :: gwpet => null() - integer(I4B), pointer, dimension(:), contiguous :: landflag => null() - integer(I4B), pointer, dimension(:), contiguous :: ivertcon => null() - contains - procedure :: init - procedure :: setdata - procedure :: sethead - procedure :: setdatauzfarea - procedure :: setdatafinf - procedure :: setdataet - procedure :: setdataetwc - procedure :: setdataetha - procedure :: setwaves - procedure :: wave_shift - procedure :: routewaves - procedure :: uzflow - procedure :: addrech - procedure :: trailwav - procedure :: leadwav - procedure :: advance - procedure :: formulate - procedure :: budget - procedure :: unsat_stor - procedure :: update_wav - procedure :: simgwet - procedure :: caph - procedure :: rate_et_z - procedure :: uzet - procedure :: uz_rise - procedure :: vertcellflow - procedure :: rejfinf - procedure :: gwseep - procedure :: setbelowpet - procedure :: dealloc - end type UzfCellGroupType -! - contains -! -! ------------------------------------------------------------------------------ - - subroutine init(this, ncells, nwav, origin) -! ****************************************************************************** -! init -- allocate and set uzf object variables -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(UzfCellGroupType) :: this - integer(I4B), intent(in) :: nwav - integer(I4B), intent(in) :: ncells - character(len=*), intent(in), optional :: origin - ! -- local - integer(I4B) :: icell -! ------------------------------------------------------------------------------ - ! - ! -- Use mem_allocate if origin is passed in, otherwise it's a temp object - if (present(origin)) then - this%imem_manager = 1 - call mem_allocate(this%uzdpst, nwav, ncells, 'UZDPST', origin) - call mem_allocate(this%uzthst, nwav, ncells, 'UZTHST', origin) - call mem_allocate(this%uzflst, nwav, ncells, 'UZFLST', origin) - call mem_allocate(this%uzspst, nwav, ncells, 'UZSPST', origin) - call mem_allocate(this%nwavst, ncells, 'NWAVST', origin) - call mem_allocate(this%uzolsflx, ncells, 'UZOLSFLX', origin) - call mem_allocate(this%thtr, ncells, 'THTR', origin) - call mem_allocate(this%thts, ncells, 'THTS', origin) - call mem_allocate(this%thti, ncells, 'THTI', origin) - call mem_allocate(this%eps, ncells, 'EPS', origin) - call mem_allocate(this%ha, ncells, 'HA', origin) - call mem_allocate(this%hroot, ncells, 'HROOT', origin) - call mem_allocate(this%rootact, ncells, 'ROOTACT', origin) - call mem_allocate(this%extwc, ncells, 'EXTWC', origin) - call mem_allocate(this%etact, ncells, 'ETACT', origin) - call mem_allocate(this%nwav, ncells, 'NWAV', origin) - call mem_allocate(this%ntrail, ncells, 'NTRAIL', origin) - call mem_allocate(this%uzstor, ncells, 'UZSTOR', origin) - call mem_allocate(this%delstor, ncells, 'DELSTOR', origin) - call mem_allocate(this%totflux, ncells, 'TOTFLUX', origin) - call mem_allocate(this%vflow, ncells, 'VFLOW', origin) - call mem_allocate(this%sinf, ncells, 'SINF', origin) - call mem_allocate(this%finf, ncells, 'FINF', origin) - call mem_allocate(this%finf_rej, ncells, 'FINF_REJ', origin) - call mem_allocate(this%gwet, ncells, 'GWET', origin) - call mem_allocate(this%uzfarea, ncells, 'UZFAREA', origin) - call mem_allocate(this%cellarea, ncells, 'CELLAREA', origin) - call mem_allocate(this%celtop, ncells, 'CELTOP', origin) - call mem_allocate(this%celbot, ncells, 'CELBOT', origin) - call mem_allocate(this%landtop, ncells, 'LANDTOP', origin) - call mem_allocate(this%cvlm1, ncells, 'CVLM1', origin) - call mem_allocate(this%watab, ncells, 'WATAB', origin) - call mem_allocate(this%watabold, ncells, 'WATABOLD', origin) - call mem_allocate(this%surfdep, ncells, 'SURFDEP', origin) - call mem_allocate(this%vks, ncells, 'VKS', origin) - call mem_allocate(this%surflux, ncells, 'SURFLUX', origin) - call mem_allocate(this%surfluxbelow, ncells, 'SURFLUXBELOW', origin) - call mem_allocate(this%surfseep, ncells, 'SURFSEEP', origin) - call mem_allocate(this%gwpet, ncells, 'GWPET', origin) - call mem_allocate(this%pet, ncells, 'PET', origin) - call mem_allocate(this%petmax, ncells, 'PETMAX', origin) - call mem_allocate(this%extdp, ncells, 'EXTDP', origin) - call mem_allocate(this%extdpuz, ncells, 'EXTDPUZ', origin) - call mem_allocate(this%landflag, ncells, 'LANDFLAG', origin) - call mem_allocate(this%ivertcon, ncells, 'IVERTCON', origin) - else - this%imem_manager = 0 - allocate(this%uzdpst(nwav, ncells)) - allocate(this%uzthst(nwav, ncells)) - allocate(this%uzflst(nwav, ncells)) - allocate(this%uzspst(nwav, ncells)) - allocate(this%nwavst(ncells)) - allocate(this%uzolsflx(ncells)) - allocate(this%thtr(ncells)) - allocate(this%thts(ncells)) - allocate(this%thti(ncells)) - allocate(this%eps(ncells)) - allocate(this%ha(ncells)) - allocate(this%hroot(ncells)) - allocate(this%rootact(ncells)) - allocate(this%extwc(ncells)) - allocate(this%etact(ncells)) - allocate(this%nwav(ncells)) - allocate(this%ntrail(ncells)) - allocate(this%uzstor(ncells)) - allocate(this%delstor(ncells)) - allocate(this%totflux(ncells)) - allocate(this%vflow(ncells)) - allocate(this%sinf(ncells)) - allocate(this%finf(ncells)) - allocate(this%finf_rej(ncells)) - allocate(this%gwet(ncells)) - allocate(this%uzfarea(ncells)) - allocate(this%cellarea(ncells)) - allocate(this%celtop(ncells)) - allocate(this%celbot(ncells)) - allocate(this%landtop(ncells)) - allocate(this%cvlm1(ncells)) - allocate(this%watab(ncells)) - allocate(this%watabold(ncells)) - allocate(this%surfdep(ncells)) - allocate(this%vks(ncells)) - allocate(this%surflux(ncells)) - allocate(this%surfluxbelow(ncells)) - allocate(this%surfseep(ncells)) - allocate(this%gwpet(ncells)) - allocate(this%pet(ncells)) - allocate(this%petmax(ncells)) - allocate(this%extdp(ncells)) - allocate(this%extdpuz(ncells)) - allocate(this%landflag(ncells)) - allocate(this%ivertcon(ncells)) - end if - do icell = 1, ncells - this%uzdpst(:, icell) = DZERO - this%uzthst(:, icell) = DZERO - this%uzflst(:, icell) = DZERO - this%uzspst(:, icell) = DZERO - this%nwavst(icell) = 1 - this%uzolsflx(icell) = DZERO - this%thtr(icell) = DZERO - this%thts(icell) = DZERO - this%thti(icell) = DZERO - this%eps(icell) = DZERO - this%ha(icell) = DZERO - this%hroot(icell) = DZERO - this%rootact(icell) = DZERO - this%extwc(icell) = DZERO - this%etact(icell) = DZERO - this%nwav(icell) = nwav - this%ntrail(icell) = 0 - this%uzstor(icell) = DZERO - this%delstor(icell) = DZERO - this%totflux(icell) = DZERO - this%vflow(icell) = DZERO - this%sinf(icell) = DZERO - this%finf(icell) = DZERO - this%finf_rej(icell) = DZERO - this%gwet(icell) = DZERO - this%uzfarea(icell) = DZERO - this%cellarea(icell) = DZERO - this%celtop(icell) = DZERO - this%celbot(icell) = DZERO - this%landtop(icell) = DZERO - this%cvlm1(icell) = DZERO - this%watab(icell) = DZERO - this%watabold(icell) = DZERO - this%surfdep(icell) = DZERO - this%vks(icell) = DZERO - this%surflux(icell) = DZERO - this%surfluxbelow(icell) = DZERO - this%surfseep(icell) = DZERO - this%gwpet(icell) = DZERO - this%pet(icell) = DZERO - this%petmax(icell) = DZERO - this%extdp(icell) = DZERO - this%extdpuz(icell) = DZERO - this%landflag(icell) = 0 - this%ivertcon(icell) = 0 - end do - ! - ! -- return - return - end subroutine init - - subroutine dealloc(this) -! ****************************************************************************** -! dealloc -- deallocate uzf object variables -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(UzfCellGroupType) :: this - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- deallocate based on whether or not memory manager was used - if (this%imem_manager == 0) then - deallocate(this%uzdpst) - deallocate(this%uzthst) - deallocate(this%uzflst) - deallocate(this%uzspst) - deallocate(this%nwavst) - deallocate(this%uzolsflx) - deallocate(this%thtr) - deallocate(this%thts) - deallocate(this%thti) - deallocate(this%eps) - deallocate(this%ha) - deallocate(this%hroot) - deallocate(this%rootact) - deallocate(this%extwc) - deallocate(this%etact) - deallocate(this%nwav) - deallocate(this%ntrail) - deallocate(this%uzstor) - deallocate(this%delstor) - deallocate(this%totflux) - deallocate(this%vflow) - deallocate(this%sinf) - deallocate(this%finf) - deallocate(this%finf_rej) - deallocate(this%gwet) - deallocate(this%uzfarea) - deallocate(this%cellarea) - deallocate(this%celtop) - deallocate(this%celbot) - deallocate(this%landtop) - deallocate(this%cvlm1) - deallocate(this%watab) - deallocate(this%watabold) - deallocate(this%surfdep) - deallocate(this%vks) - deallocate(this%surflux) - deallocate(this%surfluxbelow) - deallocate(this%surfseep) - deallocate(this%gwpet) - deallocate(this%pet) - deallocate(this%petmax) - deallocate(this%extdp) - deallocate(this%extdpuz) - deallocate(this%landflag) - deallocate(this%ivertcon) - else - call mem_deallocate(this%uzdpst) - call mem_deallocate(this%uzthst) - call mem_deallocate(this%uzflst) - call mem_deallocate(this%uzspst) - call mem_deallocate(this%nwavst) - call mem_deallocate(this%uzolsflx) - call mem_deallocate(this%thtr) - call mem_deallocate(this%thts) - call mem_deallocate(this%thti) - call mem_deallocate(this%eps) - call mem_deallocate(this%ha) - call mem_deallocate(this%hroot) - call mem_deallocate(this%rootact) - call mem_deallocate(this%extwc) - call mem_deallocate(this%etact) - call mem_deallocate(this%nwav) - call mem_deallocate(this%ntrail) - call mem_deallocate(this%uzstor) - call mem_deallocate(this%delstor) - call mem_deallocate(this%totflux) - call mem_deallocate(this%vflow) - call mem_deallocate(this%sinf) - call mem_deallocate(this%finf) - call mem_deallocate(this%finf_rej) - call mem_deallocate(this%gwet) - call mem_deallocate(this%uzfarea) - call mem_deallocate(this%cellarea) - call mem_deallocate(this%celtop) - call mem_deallocate(this%celbot) - call mem_deallocate(this%landtop) - call mem_deallocate(this%cvlm1) - call mem_deallocate(this%watab) - call mem_deallocate(this%watabold) - call mem_deallocate(this%surfdep) - call mem_deallocate(this%vks) - call mem_deallocate(this%surflux) - call mem_deallocate(this%surfluxbelow) - call mem_deallocate(this%surfseep) - call mem_deallocate(this%gwpet) - call mem_deallocate(this%pet) - call mem_deallocate(this%petmax) - call mem_deallocate(this%extdp) - call mem_deallocate(this%extdpuz) - call mem_deallocate(this%landflag) - call mem_deallocate(this%ivertcon) - end if - ! - ! -- return - return - end subroutine dealloc - - subroutine setdata(this, icell, area, top, bot, surfdep, vks, thtr, thts, & - thti, eps, ntrail, landflag, ivertcon) -! ****************************************************************************** -! setdata -- set uzf object material properties -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(UzfCellGroupType) :: this - integer(I4B), intent(in) :: icell - real(DP), intent(in) :: area - real(DP), intent(in) :: top - real(DP), intent(in) :: bot - real(DP), intent(in) :: surfdep - real(DP), intent(in) :: vks - real(DP), intent(in) :: thtr - real(DP), intent(in) :: thts - real(DP), intent(in) :: thti - real(DP), intent(in) :: eps - integer(I4B), intent(in) :: ntrail - integer(I4B), intent(in) :: landflag - integer(I4B), intent(in) :: ivertcon -! ------------------------------------------------------------------------------ - ! - ! -- set the values for uzf cell icell - this%landflag(icell) = landflag - this%ivertcon(icell) = ivertcon - this%surfdep(icell) = surfdep - this%uzfarea(icell) = area - this%cellarea(icell) = area - if (this%landflag(icell) == 1) then - this%celtop(icell) = top - DHALF * this%surfdep(icell) - else - this%celtop(icell) = top - end if - this%celbot(icell) = bot - this%vks(icell) = vks - this%thtr(icell) = thtr - this%thts(icell) = thts - this%thti(icell) = thti - this%eps(icell) = eps - this%ntrail(icell) = ntrail - this%pet(icell) = DZERO - this%extdp(icell) = DZERO - this%extwc(icell) = DZERO - this%ha(icell) = DZERO - this%hroot(icell) = DZERO - end subroutine setdata - - subroutine sethead(this, icell, hgwf) -! ****************************************************************************** -! sethead -- set uzf object material properties -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(UzfCellGroupType) :: this - integer(I4B), intent(in) :: icell - real(DP), intent(in) :: hgwf -! ------------------------------------------------------------------------------ - ! - ! -- set initial head - this%watab(icell) = this%celbot(icell) - if (hgwf > this%celbot(icell)) this%watab(icell) = hgwf - if (this%watab(icell) > this%celtop(icell)) & - this%watab(icell) = this%celtop(icell) - this%watabold(icell) = this%watab(icell) - end subroutine sethead - - subroutine setdatafinf(this, icell, finf) -! ****************************************************************************** -! setdatafinf -- set infiltration -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(UzfCellGroupType) :: this - integer(I4B), intent(in) :: icell - real(DP), intent(in) :: finf -! ------------------------------------------------------------------------------ - if (this%landflag(icell) == 1) then - this%sinf(icell) = finf - this%finf(icell) = finf - else - this%sinf(icell) = DZERO - this%finf(icell) = DZERO - end if - this%finf_rej(icell) = DZERO - this%surflux(icell) = DZERO - this%surfluxbelow(icell) = DZERO - end subroutine setdatafinf - - subroutine setdatauzfarea(this, icell, areamult) -! ****************************************************************************** -! setdatauzfarea -- set uzfarea using cellarea and areamult -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(UzfCellGroupType) :: this - integer(I4B), intent(in) :: icell - real(DP), intent(in) :: areamult -! ------------------------------------------------------------------------------ - ! - ! -- set uzf area - this%uzfarea(icell) = this%cellarea(icell) * areamult - ! - ! -- return - return - end subroutine setdatauzfarea - -! ------------------------------------------------------------------------------ -! - subroutine setdataet(this, icell, jbelow, pet, extdp) -! ****************************************************************************** -! setdataet -- set unsat. et variables -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(UzfCellGroupType) :: this - integer(I4B), intent(in) :: icell - integer(I4B), intent(in) :: jbelow - real(DP), intent(in) :: pet - real(DP), intent(in) :: extdp - ! -- local - real(DP) :: thick -! ------------------------------------------------------------------------------ - if (this%landflag(icell) == 1) then - this%pet(icell) = pet - this%gwpet(icell) = pet - else - this%pet(icell) = DZERO - this%gwpet(icell) = DZERO - end if - thick = this%celtop(icell) - this%celbot(icell) - this%extdp(icell) = extdp - if (this%landflag(icell) > 0) then - this%landtop(icell) = this%celtop(icell) - this%petmax(icell) = this%pet(icell) - end if - ! - ! -- set uz extinction depth - if (this%landtop(icell) - this%extdp(icell) < this%celbot(icell)) then - this%extdpuz(icell) = thick - else - this%extdpuz(icell) = this%celtop(icell) - & - (this%landtop(icell) - this%extdp(icell)) - end if - if (this%extdpuz(icell) < DZERO) this%extdpuz(icell) = DZERO - if (this%extdpuz(icell) > DEM7 .and. this%extdp(icell) < DEM7) & - this%extdp(icell) = this%extdpuz(icell) - ! - ! -- set pet for underlying cell - if (jbelow > 0) then - this%landtop(jbelow) = this%landtop(icell) - this%petmax(jbelow) = this%petmax(icell) - end if - ! - ! -- return - return - end subroutine setdataet - - subroutine setbelowpet(this, icell, jbelow, aet) -! ****************************************************************************** -! setbelowpet -- subtract aet from pet to calculate residual et -! for deeper cells -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(UzfCellGroupType) :: this - integer(I4B), intent(in) :: icell - integer(I4B), intent(in) :: jbelow - real(DP), intent(in) :: aet - ! -- dummy - real(DP) :: pet -! ------------------------------------------------------------------------------ - pet = DZERO - if (this%extdpuz(jbelow) > DEM3) then - pet = this%petmax(icell) - aet - if (pet < DZERO) pet = DZERO - end if - this%pet(jbelow) = pet - ! - ! -- return - return - end subroutine setbelowpet - - subroutine setdataetwc(this, icell, jbelow, extwc) -! ****************************************************************************** -! setdataetwc -- set extinction water content -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(UzfCellGroupType) :: this - integer(I4B), intent(in) :: icell - integer(I4B), intent(in) :: jbelow - real(DP), intent(in) :: extwc -! ------------------------------------------------------------------------------ - ! - ! -- set extinction water content - this%extwc(icell) = extwc - if (jbelow > 0) this%extwc(jbelow) = extwc - ! - ! -- return - return - end subroutine setdataetwc - - subroutine setdataetha(this, icell, jbelow, ha, hroot, rootact) -! ****************************************************************************** -! setdataetha -- set variables for head-based unsat. flow -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(UzfCellGroupType) :: this - integer(I4B), intent(in) :: icell - integer(I4B), intent(in) :: jbelow - real(DP), intent(in) :: ha - real(DP), intent(in) :: hroot - real(DP), intent(in) :: rootact -! ------------------------------------------------------------------------------ - ! - ! -- set variables - this%ha(icell) = ha - this%hroot(icell) = hroot - this%rootact(icell) = rootact - if (jbelow > 0) then - this%ha(jbelow) = ha - this%hroot(jbelow) = hroot - this%rootact(jbelow) = rootact - end if - ! - ! -- return - return - end subroutine setdataetha - - subroutine advance(this, icell) -! ****************************************************************************** -! advance -- set variables to advance to new time step. nothing yet. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(UzfCellGroupType) :: this - integer(I4B), intent(in) :: icell -! ------------------------------------------------------------------------------ - ! - ! -- set variables - this%surfseep(icell) = DZERO - ! - ! -- return - return - end subroutine advance - - subroutine formulate(this, thiswork, jbelow, icell, totfluxtot, ietflag, & - issflag, iseepflag, trhs, thcof, hgwf, & - hgwfml1, cvv, deriv, qfrommvr, qformvr, ierr, sumaet, & - ivertflag) -! ****************************************************************************** -! formulate -- formulate the unsaturated flow object, calculate terms for -! gwf equation -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: delt - ! -- dummy - class(UzfCellGroupType) :: this - type(UzfCellGroupType) :: thiswork - integer(I4B), intent(in) :: jbelow - integer(I4B), intent(in) :: icell - integer(I4B), intent(in) :: ietflag - integer(I4B), intent(in) :: iseepflag - integer(I4B), intent(in) :: issflag - integer(I4B), intent(in) :: ivertflag - integer(I4B), intent(inout) :: ierr - real(DP), intent(in) :: hgwf - real(DP), intent(in) :: hgwfml1 - real(DP), intent(in) :: cvv - real(DP), intent(in) :: qfrommvr - real(DP), intent(inout) :: trhs - real(DP), intent(inout) :: thcof - real(DP), intent(inout) :: qformvr - real(DP), intent(inout) :: sumaet - real(DP), intent(inout) :: totfluxtot - real(DP), intent(inout) :: deriv - ! -- local - real(DP) :: test, scale, seep, finfact, derivfinf - real(DP) :: trhsfinf, thcoffinf, trhsseep, thcofseep, deriv1, deriv2 -! ------------------------------------------------------------------------------ - totfluxtot = DZERO - trhsfinf = DZERO - thcoffinf = DZERO - trhsseep = DZERO - thcofseep = DZERO - this%finf_rej(icell) = DZERO - this%surflux(icell) = this%finf(icell) + qfrommvr / this%uzfarea(icell) - this%surfseep(icell) = DZERO - seep = DZERO - finfact = DZERO - deriv1 = DZERO - deriv2 = DZERO - derivfinf = DZERO - this%watab(icell) = hgwf - this%etact(icell) = DZERO - this%surfluxbelow(icell) = DZERO - ! - ! -- set pet for gw when there is no UZ. - this%gwpet(icell) = this%pet(icell) - if(ivertflag > 0) then - this%finf(jbelow) = DZERO - end if - ! - ! -- save wave states for resetting after iteration. - this%watab(icell) = hgwf - call thiswork%wave_shift(this, 1, icell, 0, 1, this%nwavst(icell), 1) - if (this%watab(icell) > this%celtop(icell)) & - this%watab(icell) = this%celtop(icell) - ! - if (this%ivertcon(icell) > 0) then - if (this%watab(icell) < this%celbot(icell)) & - this%watab(icell) = this%celbot(icell) - end if - ! - ! -- add water from mover to applied infiltration. - if (this%surflux(icell) > this%vks(icell)) then - this%surflux(icell) = this%vks(icell) - end if - ! - ! -- saturation excess rejected infiltration - if (this%landflag(icell) == 1) then - call this%rejfinf(icell, deriv1, hgwf, trhsfinf, thcoffinf, finfact) - this%surflux(icell) = finfact - end if - ! - ! -- calculate rejected infiltration - this%finf_rej(icell) = this%finf(icell) + & - (qfrommvr / this%uzfarea(icell)) - this%surflux(icell) - if (iseepflag > 0 .and. this%landflag(icell) == 1) then - ! - ! -- calculate groundwater discharge - call this%gwseep(icell, deriv2, scale, hgwf, trhsseep, thcofseep, seep) - this%surfseep(icell) = seep - end if - ! - ! -- route water through unsat zone, calc. storage change and recharge - ! - test = this%watab(icell) - if (this%watabold(icell) - test < -DEM15) test = this%watabold(icell) - if (this%celtop(icell) - test > DEM15) then - if (issflag == 0) then - call this%routewaves(totfluxtot, delt, ietflag, icell, ierr) - if (ierr > 0) return - call this%uz_rise(icell, totfluxtot) - this%totflux(icell) = totfluxtot - if (ietflag > 0 .and. this%ivertcon(icell) > 0) then - this%pet(jbelow) = this%pet(jbelow) - this%etact(icell) - if (this%pet(jbelow) < DEM15) this%pet(jbelow) = DEM15 - end if - if (this%ivertcon(icell) > 0) then - call this%addrech(icell, jbelow, hgwf, trhsfinf, thcoffinf, derivfinf, delt, 0) - end if - else - this%totflux(icell) = this%surflux(icell) * delt - totfluxtot = this%surflux(icell) * delt - end if - thcoffinf = DZERO - trhsfinf = this%totflux(icell) * this%uzfarea(icell) / delt - else - this%totflux(icell) = this%surflux(icell) * delt - totfluxtot = this%surflux(icell) * delt - end if - deriv = deriv1 + deriv2 + derivfinf - trhs = trhsfinf + trhsseep - thcof = thcoffinf + thcofseep - ! - ! -- add spring flow and rejected infiltration to mover - qformvr = this%surfseep(icell) + this%finf_rej(icell) * this%uzfarea(icell) - ! - ! -- reset waves to previous state for next iteration - call this%wave_shift(thiswork, icell, 1, 0, 1, thiswork%nwavst(1), 1) - ! - ! -- distribute PET to deeper cells - sumaet = sumaet + this%etact(icell) - if(this%ivertcon(icell) > 0) then - if (ietflag > 0) then - call this%setbelowpet(icell, jbelow, sumaet) - end if - end if - end subroutine formulate - - subroutine budget(this, jbelow, icell, totfluxtot, rfinf, rin, rout, & - rsto, ret, retgw, rgwseep, rvflux, ietflag, iseepflag, & - issflag, hgwf, hgwfml1, cvv, numobs, obs_num, & - obs_depth, obs_theta, qfrommvr, qformvr, qgwformvr, & - sumaet, ierr) -! ****************************************************************************** -! budget -- save unsat. conditions at end of time step, calculate budget -! terms -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: delt - ! -- dummy - class(UzfCellGroupType) :: this - integer(I4B), intent(in) :: jbelow - integer(I4B), intent(in) :: icell - integer(I4B), intent(in) :: ietflag - integer(I4B), intent(in) :: iseepflag - integer(I4B), intent(in) :: issflag - integer(I4B), intent(inout) :: ierr - integer(I4B), intent(in) :: numobs - integer(I4B), dimension(:),intent(in) :: obs_num - real(DP),dimension(:),intent(in) :: obs_depth - real(DP),dimension(:),intent(inout) :: obs_theta - real(DP), intent(in) :: hgwf - real(DP), intent(in) :: hgwfml1 - real(DP), intent(in) :: cvv - real(DP), intent(in) :: qfrommvr - real(DP), intent(inout) :: rfinf - real(DP), intent(inout) :: rin - real(DP), intent(inout) :: qformvr - real(DP), intent(inout) :: sumaet - real(DP), intent(inout) :: qgwformvr - real(DP), intent(inout) :: rout - real(DP), intent(inout) :: rsto - real(DP), intent(inout) :: ret - real(DP), intent(inout) :: retgw - real(DP), intent(inout) :: rgwseep - real(DP), intent(inout) :: rvflux - real(DP), intent(inout) :: totfluxtot - ! -- dummy - real(DP) :: test, deriv, scale, seep, finfact - real(DP) :: f1, f2, d1, d2 - real(DP) :: trhsfinf, thcoffinf, trhsseep, thcofseep - integer(I4B) :: i, j -! ------------------------------------------------------------------------------ - ! - ! -- initialize - totfluxtot = DZERO - trhsfinf = DZERO - thcoffinf = DZERO - trhsseep = DZERO - thcofseep = DZERO - this%finf_rej = DZERO - this%surflux(icell) = this%finf(icell) + qfrommvr / this%uzfarea(icell) - this%watab(icell) = hgwf - this%vflow(icell) = DZERO - this%surfseep(icell) = DZERO - seep = DZERO - finfact = DZERO - this%etact(icell) = DZERO - this%surfluxbelow(icell) = DZERO - sumaet = DZERO - ! - ! -- set pet for gw when there is no UZ. - this%gwpet(icell) = this%pet(icell) - if (this%ivertcon(icell) > 0) then - this%finf(jbelow) = dzero - if (this%watab(icell) < this%celbot(icell)) & - this%watab(icell) = this%celbot(icell) - end if - if (this%watab(icell) > this%celtop(icell)) & - this%watab(icell) = this%celtop(icell) - if (this%surflux(icell) > this%vks(icell)) then - this%surflux(icell) = this%vks(icell) - end if - ! - ! -- infiltration excess -- rejected infiltration - if (this%landflag(icell) == 1) then - call rejfinf(this, icell, deriv, hgwf, trhsfinf, thcoffinf, finfact) - this%surflux(icell) = finfact - if (finfact < this%finf(icell)) then - this%surflux(icell) = finfact - end if - end if - ! - ! -- calculate rejected infiltration - this%finf_rej(icell) = this%finf(icell) + & - (qfrommvr / this%uzfarea(icell)) - this%surflux(icell) - ! - ! -- groundwater discharge - if (iseepflag > 0 .and. this%landflag(icell) == 1) then - call this%gwseep(icell, deriv, scale, hgwf, trhsseep, thcofseep, seep) - this%surfseep(icell) = seep - rgwseep = rgwseep + this%surfseep(icell) - end if - ! - ! sat. to unsat. zone exchange. - !if (this%landflag == 0 .and. issflag == 0) then - ! call this%vertcellflow(ipos,ttrhs,hgwf,hgwfml1,cvv) - !end if - !rvflux = rvflux + this%vflow - ! - ! -- route unsaturated flow, calc. storage change and recharge - test = this%watab(icell) - if (this%watabold(icell) - test < -DEM15) test = this%watabold(icell) - if (this%celtop(icell) - test > DEM15) then - if (issflag == 0) then - call this%routewaves(totfluxtot, delt, ietflag, icell, ierr) - if (ierr > 0) return - call this%uz_rise(icell, totfluxtot) - this%totflux(icell) = totfluxtot - if (this%ivertcon(icell) > 0) then - call this%addrech(icell, jbelow, hgwf, trhsfinf, thcoffinf, & - deriv, delt, 1) - end if - else - this%totflux(icell) = this%surflux(icell) * delt - totfluxtot = this%surflux(icell) * delt - end if - thcoffinf = dzero - trhsfinf = this%totflux(icell) * this%uzfarea(icell) / delt - call this%update_wav(icell, delt, rout, rsto, ret, ietflag, issflag, 0) - else - call this%update_wav(icell, delt, rout, rsto, ret, ietflag, issflag, 1) - totfluxtot = this%surflux(icell) * delt - this%totflux(icell) = this%surflux(icell) * delt - end if - rfinf = rfinf + this%sinf(icell) * this%uzfarea(icell) - rin = rin + this%surflux(icell) * this%uzfarea(icell) - & - this%surfluxbelow(icell) * this%uzfarea(icell) - ! - ! -- add spring flow and rejected infiltration to mover - qformvr = this%finf_rej(icell) * this%uzfarea(icell) - qgwformvr = this%surfseep(icell) - ! - ! -- process for observations - do i = 1, numobs - j = obs_num(i) - if (this%watab(icell) < this%celtop(icell)) then - if (this%celtop(icell) - obs_depth(j) > this%watab(icell)) then - d1 = obs_depth(j) - DEM3 - d2 = obs_depth(j) + DEM3 - f1 = this%unsat_stor(icell, d1) - f2 = this%unsat_stor(icell, d2) - obs_theta(j) = this%thtr(icell) + (f2 - f1) / (d2 - d1) - else - obs_theta(j) = this%thts(icell) - end if - else - obs_theta(j) = this%thts(icell) - end if - end do - ! - ! -- distribute residual PET to deeper cells - sumaet = sumaet + this%etact(icell) - if (this%ivertcon(icell) > 0) then - if (ietflag > 0) then - call this%setbelowpet(icell, jbelow, sumaet) - end if - end if - ! - ! -- return - return - end subroutine budget - - subroutine vertcellflow(this, icell, trhs, hgwf, hgwfml1, cvv) -! ****************************************************************************** -! vertcellflow -- calculate exchange from sat. to unsat. zones -! subroutine not used until sat to unsat flow is supported -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(UzfCellGroupType) :: this - integer(I4B), intent(in) :: icell - real(DP), intent(in) :: hgwf - real(DP), intent(in) :: hgwfml1 - real(DP), intent(in) :: cvv - real(DP), intent(inout) :: trhs - ! -- dummy - real(DP) :: Qv, maxvflow, h1, h2, test -! ------------------------------------------------------------------------------ - this%vflow(icell) = DZERO - this%finf(icell) = DZERO - trhs = DZERO - h1 = hgwfml1 - h2 = hgwf - test = this%watab(icell) - if (this%watabold(icell) - test < -DEM30) test = this%watabold(icell) - if (this%celtop(icell) - test > DEM30) then - ! - ! calc. downward flow using GWF heads and conductance - Qv = cvv * (h1 - h2) - if (Qv > DEM30) then - this%vflow(icell) = Qv - this%surflux(icell) = this%vflow(icell) / this%uzfarea(icell) - maxvflow = this%vks(icell) * this%uzfarea(icell) - if (this%vflow(icell) - maxvflow > DEM9) then - this%surflux(icell) = this%vks(icell) - trhs = this%vflow(icell) - maxvflow - this%vflow(icell) = maxvflow - end if - end if - end if - ! - ! -- return - return - end subroutine vertcellflow - - subroutine addrech(this, icell, jbelow, hgwf, trhs, thcof, deriv, delt, it) -! ****************************************************************************** -! addrech -- add recharge or infiltration to cells -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(UzfCellGroupType) :: this - integer(I4B), intent(in) :: icell - integer(I4B), intent(in) :: jbelow - integer(I4B), intent(in) :: it - real(DP), intent(inout) :: trhs - real(DP), intent(inout) :: thcof - real(DP), intent(inout) :: deriv - real(DP), intent(in) :: delt - real(DP), intent(in) :: hgwf - ! -- local - real(DP) :: fcheck - real(DP) :: x, scale, range -! ------------------------------------------------------------------------------ - ! - ! -- initialize - range = DEM5 - deriv = DZERO - thcof = DZERO - trhs = this%uzfarea(icell) * this%totflux(icell) / delt - if (this%totflux(icell) < DEM14) return - scale = DONE - ! - ! -- smoothly reduce flow between cells when head close to cell top - x = hgwf - (this%celbot(icell) - range) - call sSCurve(x, range, deriv, scale) - deriv = this%uzfarea(icell) * deriv * this%totflux(icell) / delt - this%finf(jbelow) = (DONE - scale) * this%totflux(icell) / delt - fcheck = this%finf(jbelow) - this%vks(jbelow) - ! - ! -- reduce flow between cells when vks is too small - if (fcheck < DEM14) fcheck = DZERO - this%finf(jbelow) = this%finf(jbelow) - fcheck - this%surfluxbelow(icell) = this%finf(jbelow) - this%totflux(icell) = scale * this%totflux(icell) + fcheck * delt - trhs = this%uzfarea(icell) * this%totflux(icell) / delt - ! - ! -- return - return - end subroutine addrech - - subroutine rejfinf(this, icell, deriv, hgwf, trhs, thcof, finfact) -! ****************************************************************************** -! rejfinf -- reject applied infiltration due to low vks -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(UzfCellGroupType) :: this - integer(I4B), intent(in) :: icell - real(DP), intent(inout) :: deriv - real(DP), intent(inout) :: finfact - real(DP), intent(inout) :: thcof - real(DP), intent(inout) :: trhs - real(DP), intent(in) :: hgwf - ! -- local - real(DP) :: x, range, scale, q -! ------------------------------------------------------------------------------ - range = this%surfdep(icell) - q = this%surflux(icell) - finfact = q - trhs = finfact * this%uzfarea(icell) - x = this%celtop(icell) - hgwf - call sLinear(x, range, deriv, scale) - deriv = -q * deriv * this%uzfarea(icell) * scale - if (scale < DONE) then - finfact = q * scale - trhs = finfact * this%uzfarea(icell) * this%celtop(icell) / range - thcof = finfact * this%uzfarea(icell) / range - end if - ! - ! -- return - return - end subroutine rejfinf - - subroutine gwseep(this, icell, deriv, scale, hgwf, trhs, thcof, seep) -! ****************************************************************************** -! gwseep -- calc. groudwater discharge to land surface -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(UzfCellGroupType) :: this - integer(I4B), intent(in) :: icell - real(DP), intent(inout) :: deriv - real(DP), intent(inout) :: trhs - real(DP), intent(inout) :: thcof - real(DP), intent(inout) :: seep - real(DP), intent(out) :: scale - real(DP), intent(in) :: hgwf - ! -- local - real(DP) :: x, range, y, deriv1, d1, d2, Q -! ------------------------------------------------------------------------------ - seep = DZERO - deriv = DZERO - deriv1 = DZERO - d1 = DZERO - d2 = DZERO - scale = DZERO - Q = this%uzfarea(icell) * this%vks(icell) - range = this%surfdep(icell) - x = hgwf - this%celtop(icell) - call sCubicLinear(x, range, deriv1, y) - scale = y - seep = scale * Q * (hgwf - this%celtop(icell)) / range - trhs = scale * Q * this%celtop(icell) / range - thcof = -scale * Q / range - d1 = -deriv1 * Q * x / range - d2 = -scale * Q / range - deriv = d1 + d2 - if (seep < DZERO) then - seep = DZERO - deriv = DZERO - trhs = DZERO - thcof = DZERO - end if - ! - ! -- return - return - end subroutine gwseep - - subroutine simgwet(this, igwetflag, icell, hgwf, trhs, thcof, et, det) -! ****************************************************************************** -! simgwet -- calc. gwf et using residual uzf pet -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(UzfCellGroupType) :: this - integer(I4B), intent(in) :: igwetflag - integer(I4B), intent(in) :: icell - real(DP), intent(in) :: hgwf - real(DP), intent(inout) :: trhs - real(DP), intent(inout) :: thcof - real(DP), intent(inout) :: det - real(DP), intent(inout) :: et - ! -- local - real(DP) :: s, x, c -! ------------------------------------------------------------------------------ - ! - this%gwet(icell) = DZERO - s = this%landtop(icell) - x = this%extdp(icell) - c = this%gwpet(icell) - if (x < DEM6) return - if (igwetflag == 1) then - et = etfunc_lin(s, x, c, det, trhs, thcof, hgwf, & - this%celtop(icell), this%celbot(icell)) - else if (igwetflag == 2) then - et = etfunc_nlin(s, x, c, det, trhs, thcof, hgwf) - end if - this%gwet(icell) = et * this%uzfarea(icell) - trhs = -trhs * this%uzfarea(icell) - thcof = thcof * this%uzfarea(icell) - ! - ! -- return - return - end subroutine simgwet - - function etfunc_lin(s, x, c, det, trhs, thcof, hgwf, celtop, celbot) -! ****************************************************************************** -! etfunc_lin -- calc. gwf et using linear ET function from mf-2005 -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - real(DP) :: etfunc_lin - ! -- dummy - real(DP), intent(in) :: s - real(DP), intent(in) :: x - real(DP), intent(in) :: c - real(DP), intent(inout) :: det - real(DP), intent(inout) :: trhs - real(DP), intent(inout) :: thcof - real(DP), intent(in) :: hgwf - real(DP), intent(in) :: celtop - real(DP), intent(in) :: celbot - ! -- local - real(DP) :: etgw - real(DP) :: range - real(DP) :: depth, scale, thick -! ------------------------------------------------------------------------------ - ! - ! -- Between ET surface and extinction depth - trhs = DZERO - thcof = DZERO - det = DZERO - if (hgwf > (s-x) .and. hgwf < s) THEN - etgw = (c * (hgwf - (s - x)) / x) - if (etgw > c) then - etgw = c - else - trhs = c - c * s / x - thcof = -c / x - etgw = trhs - (thcof * hgwf) - end if - ! - ! -- Above land surface - else if (hgwf >= s) then - trhs = c - etgw = c - ! - ! Below extinction depth - else - etgw = DZERO - end if - ! - ! -- calculate rate - depth = hgwf - (s - x) - thick = celtop - celbot - if (depth > thick) depth = thick - if (depth < dzero) depth = dzero - range = DEM4 * x - call sCubic(depth, range, det, scale) - etgw = scale * etgw - det = -det * etgw - etfunc_lin = etgw - ! - ! -- return - return - end function etfunc_lin - - - function etfunc_nlin(s, x, c, det, trhs, thcof, hgwf) -! ****************************************************************************** -! etfunc_nlin -- Square-wave ET function with smoothing at extinction depth -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - real(DP) :: etfunc_nlin - ! -- dummy - real(DP), intent(in) :: s - real(DP), intent(in) :: x - real(DP), intent(in) :: c - real(DP), intent(inout) :: det - real(DP), intent(inout) :: trhs - real(DP), intent(inout) :: thcof - real(DP), intent(in) :: hgwf - ! -- local - real(DP) :: etgw - real(DP) :: range - real(DP) :: depth, scale -! ------------------------------------------------------------------------------ - det = DZERO - trhs = DZERO - thcof = DZERO - depth = hgwf - (s - x) - if (depth < DZERO) depth = DZERO - etgw = c - range = DEM3 * x - call sCubic(depth, range, det, scale) - etgw = etgw * scale - trhs = -etgw - det = -det * etgw - etfunc_nlin = etgw - ! - ! -- return - return - end function etfunc_nlin - - subroutine uz_rise(this, icell, totfluxtot) -! ****************************************************************************** -! uz_rise -- calculate recharge due to a rise in the gwf head -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(UzfCellGroupType) :: this - integer(I4B), intent(in) :: icell - real(DP), intent(inout) :: totfluxtot - ! -- local - real(DP) :: fm1, fm2, d1 -! ------------------------------------------------------------------------------ - ! - ! -- additional recharge from a rising water table - if (this%watab(icell) - this%watabold(icell) > DEM30) then - d1 = this%celtop(icell) - this%watabold(icell) - fm1 = this%unsat_stor(icell, d1) - d1 = this%celtop(icell) - this%watab(icell) - fm2 = this%unsat_stor(icell, d1) - totfluxtot = totfluxtot + (fm1 - fm2) - end if - ! - ! -- return - return - end subroutine uz_rise - - subroutine setwaves(this, icell) -! ****************************************************************************** -! setwaves -- reset waves to default values at start of simulation -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(UzfCellGroupType) :: this - ! -- local - integer(I4B), intent(in) :: icell - real(DP) :: bottom, top - integer(I4B) :: jk - real(DP) :: thick -! ------------------------------------------------------------------------------ - ! - ! -- initialize - this%uzstor(icell) = DZERO - this%delstor(icell) = DZERO - this%totflux(icell) = DZERO - this%nwavst(icell) = 1 - this%uzdpst(:, icell) = DZERO - thick = this%celtop(icell) - this%watab(icell) - do jk = 1, this%nwav(icell) - this%uzthst(jk, icell) = this%thtr(icell) - end do - ! - ! -- initialize waves for first stress period - if (thick > DZERO) then - this%uzdpst(1, icell) = thick - this%uzthst(1, icell) = this%thti(icell) - top = this%uzthst(1, icell) - this%thtr(icell) - if (top < DZERO) top = DZERO - bottom = this%thts(icell) - this%thtr(icell) - if (bottom < DZERO) bottom = DZERO - this%uzflst(1, icell) = this%vks(icell) * (top / bottom) ** this%eps(icell) - if (this%uzthst(1, icell) < this%thtr(icell)) & - this%uzthst(1, icell) = this%thtr(icell) - ! - ! -- calculate water stored in the unsaturated zone - if (top > DZERO) then - this%uzstor(icell) = this%uzdpst(1, icell) * top * this%uzfarea(icell) - this%uzspst(1, icell) = DZERO - this%uzolsflx(icell) = this%uzflst(1, icell) - else - this%uzstor(icell) = DZERO - this%uzflst(1, icell) = DZERO - this%uzspst(1, icell) = DZERO - this%uzolsflx(icell) = DZERO - end if - ! - ! no unsaturated zone - else - this%uzflst(1, icell) = DZERO - this%uzdpst(1, icell) = DZERO - this%uzspst(1, icell) = DZERO - this%uzthst(1, icell) = this%thtr(icell) - this%uzstor(icell) = DZERO - this%uzolsflx(icell) = this%finf(icell) - end if - ! - ! -- return - return - end subroutine - - subroutine routewaves(this, totfluxtot, delt, ietflag, icell, ierr) -! ****************************************************************************** -! routewaves -- prepare and route waves over time step -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! - ! -- dummy - class(UzfCellGroupType) :: this - real(DP), intent(inout) :: totfluxtot - real(DP), intent(in) :: delt - integer(I4B), intent(in) :: ietflag - integer(I4B), intent(in) :: icell - integer(I4B), intent(inout) :: ierr - ! -- local - real(DP) :: thick, thickold - integer(I4B) :: idelt, iwav, ik -! ------------------------------------------------------------------------------ - ! - ! -- initialize - this%totflux(icell) = DZERO - this%etact(icell) = DZERO - thick = this%celtop(icell) - this%watab(icell) - thickold = this%celtop(icell) - this%watabold(icell) - ! - ! -- no uz, clear waves - if (thickold < DZERO) then - do iwav = 1, 6 - this%uzthst(iwav, icell) = this%thtr(icell) - this%uzdpst(iwav, icell) = DZERO - this%uzspst(iwav, icell) = DZERO - this%uzflst(iwav, icell) = DZERO - this%nwavst(icell) = 1 - end do - end if - idelt = 1 - do ik = 1, idelt - call this%uzflow(thick, thickold, delt, ietflag, icell, ierr) - if (ierr > 0) return - totfluxtot = totfluxtot + this%totflux(icell) - end do - ! - ! -- set residual pet after uz et - this%gwpet(icell) = this%pet(icell) - this%etact(icell) / delt - if (this%gwpet(icell) < DZERO) this%gwpet(icell) = DZERO - ! - ! -- return - return - end subroutine routewaves - - subroutine wave_shift(this, this2, icell, icell2, shft, strt, stp, cntr) -! ****************************************************************************** -! wave_shift -- copy waves or shift waves in arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class (UzfCellGroupType) :: this - type (UzfCellGroupType) :: this2 - integer(I4B), intent(in) :: icell - integer(I4B), intent(in) :: icell2 - integer(I4B), intent(in) :: shft - integer(I4B), intent(in) :: strt - integer(I4B), intent(in) :: stp - integer(I4B), intent(in) :: cntr - ! -- local - integer(I4B) :: j -! ------------------------------------------------------------------------------ - ! - ! -- copy waves from one uzf cell group to another - do j = strt, stp, cntr - this%uzthst(j, icell) = this2%uzthst(j + shft, icell2) - this%uzdpst(j, icell) = this2%uzdpst(j + shft, icell2) - this%uzflst(j, icell) = this2%uzflst(j + shft, icell2) - this%uzspst(j, icell) = this2%uzspst(j + shft, icell2) - end do - this%nwavst(icell) = this2%nwavst(icell2) - ! - ! -- return - return - end subroutine - - subroutine uzflow(this, thick, thickold, delt, ietflag, icell, ierr) -! ****************************************************************************** -! uzflow -- moc solution for kinematic wave equation -! ****************************************************************************** -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class (UzfCellGroupType) :: this - real(DP), intent(inout) :: thickold - real(DP), intent(inout) :: thick - real(DP), intent(in) :: delt - integer(I4B), intent(in) :: ietflag - integer(I4B), intent(in) :: icell - integer(I4B), intent(inout) :: ierr - ! -- local - real(DP) :: ffcheck, time, feps1, feps2 - real(DP) :: thetadif, thetab, fluxb, oldsflx - integer(I4B) :: itrailflg, itester -! ------------------------------------------------------------------------------ - time = DZERO - this%totflux(icell) = DZERO - itrailflg = 0 - oldsflx = this%uzflst(this%nwavst(icell), icell) - call factors(feps1, feps2) - ! - ! -- check for falling or rising water table - if ((thick - thickold) > feps1) then - thetadif = abs(this%uzthst(1, icell) - this%thtr(icell)) - if (thetadif > DEM6) then - call this%wave_shift(this, icell, icell, -1, this%nwavst(icell) + 1, 2, -1) - if (this%uzdpst(2, icell) < DEM30) & - this%uzdpst(2, icell) = (this%ntrail(icell) + DTWO) * DEM6 - if (this%uzthst(2, icell) > this%thtr(icell)) then - this%uzspst(2, icell) = this%uzflst(2, icell) / & - (this%uzthst(2, icell) - this%thtr(icell)) - else - this%uzspst(2, icell) = DZERO - end if - this%uzthst(1, icell) = this%thtr(icell) - this%uzflst(1, icell) = DZERO - this%uzspst(1, icell) = DZERO - this%uzdpst(1, icell) = thick - this%nwavst(icell) = this%nwavst(icell) + 1 - if (this%nwavst(icell) >= this%nwav(icell)) then - ! -- too many waves error - ierr = 1 - return - end if - else - this%uzdpst(1, icell) = thick - end if - end if - thetab = this%uzthst(1, icell) - fluxb = this%uzflst(1, icell) - this%totflux(icell) = DZERO - itester = 0 - ffcheck = (this%surflux(icell)-this%uzflst(this%nwavst(icell), icell)) - ! - ! -- increase new waves in infiltration changes - if (ffcheck > feps2 .OR. ffcheck < -feps2) then - this%nwavst(icell) = this%nwavst(icell) + 1 - if (this%nwavst(icell) >= this%nwav(icell)) then - ! - ! -- too many waves error - ierr = 1 - return - end if - else if (this%nwavst(icell) == 1) then - itester = 1 - end if - if (this%nwavst(icell) > 1) then - if (ffcheck < -feps2) then - call this%trailwav(icell, ierr) - if (ierr > 0) return - itrailflg = 1 - end if - call this%leadwav(time, itester, itrailflg, thetab, fluxb, ffcheck, & - feps2, delt, icell) - end if - if (itester == 1) then - this%totflux(icell) = this%totflux(icell) + & - (delt - time) * this%uzflst(1, icell) - time = DZERO - itester = 0 - end if - ! - ! -- simulate et - if (ietflag > 0) call this%uzet(icell, delt, ietflag, ierr) - if (ierr > 0) return - ! - ! -- return - return - end subroutine uzflow - - subroutine factors(feps1, feps2) -! ****************************************************************************** -! factors----calculate unit specific tolerances -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - real(DP), intent(out) :: feps1 - real(DP), intent(out) :: feps2 - real(DP) :: factor1 - real(DP) :: factor2 -! ------------------------------------------------------------------------------ - ! - ! calculate constants for uzflow - factor1 = DONE - factor2 = DONE - feps1 = DEM9 - feps2 = DEM9 - if (ITMUNI == 1) then - factor1 = DONE / 86400.D0 - else if (ITMUNI == 2) then - factor1 = DONE / 1440.D0 - else if (ITMUNI == 3) then - factor1 = DONE / 24.0D0 - else if (ITMUNI == 5) then - factor1 = 365.0D0 - end if - factor2 = DONE / 0.3048 - feps1 = feps1 * factor1 * factor2 - feps2 = feps2 * factor1 * factor2 - ! - ! -- return - return - end subroutine factors - - subroutine trailwav(this, icell, ierr) -! ****************************************************************************** -! trailwav----create and set trail waves -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class (UzfCellGroupType) :: this - integer(I4B), intent(in) :: icell - integer(I4B), intent(inout) :: ierr - ! -- local - real(DP) :: smoist, smoistinc, ftrail, eps_m1 - real(DP) :: thtsrinv - real(DP) :: flux1, flux2, theta1, theta2 - real(DP) :: fnuminc - integer(I4B) :: j, jj, jk, nwavstm1 -! ------------------------------------------------------------------------------ - ! - ! -- initialize - eps_m1 = dble(this%eps(icell)) - DONE - thtsrinv = DONE / (this%thts(icell) - this%thtr(icell)) - nwavstm1 = this%nwavst(icell) - 1 - ! - ! -- initialize trailwaves - smoist = (((this%surflux(icell) / this%vks(icell)) ** & - (DONE / this%eps(icell))) * & - (this%thts(icell) - this%thtr(icell))) + this%thtr(icell) - if (this%uzthst(nwavstm1, icell) - smoist > DEM9) then - fnuminc = DZERO - do jk = 1, this%ntrail(icell) - fnuminc = fnuminc + float(jk) - end do - smoistinc = (this%uzthst(nwavstm1, icell) - smoist) / (fnuminc - DONE) - jj = this%ntrail(icell) - ftrail = dble(this%ntrail(icell)) + DONE - do j = this%nwavst(icell), this%nwavst(icell) + this%ntrail(icell) - 1 - if (j > this%nwav(icell)) then - ! -- too many waves error - ierr = 1 - return - end if - if (j > this%nwavst(icell)) then - this%uzthst(j, icell) = this%uzthst(j - 1, icell) & - - ((ftrail - float(jj)) * smoistinc) - else - this%uzthst(j, icell) = this%uzthst(j - 1, icell) - DEM9 - end if - jj = jj - 1 - if (this%uzthst(j, icell) <= this%thtr(icell) + DEM9) & - this%uzthst(j, icell) = this%thtr(icell) + DEM9 - this%uzflst(j, icell) = this%vks(icell) * & - (((this%uzthst(j, icell) - this%thtr(icell)) * thtsrinv) ** & - this%eps(icell)) - theta2 = this%uzthst(j - 1, icell) - flux2 = this%uzflst(j - 1, icell) - flux1 = this%uzflst(j, icell) - theta1 = this%uzthst(j, icell) - this%uzspst(j, icell) = leadspeed(theta1, theta2, flux1, & - flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & - this%vks(icell)) - this%uzdpst(j, icell) = DZERO - if (j == this%nwavst(icell)) then - this%uzdpst(j, icell) = this%uzdpst(j, icell) + (this%ntrail(icell) + 1) * DEM9 - else - this%uzdpst(j, icell) = this%uzdpst(j - 1, icell) - DEM9 - end if - end do - this%nwavst(icell) = this%nwavst(icell) + this%ntrail(icell) - 1 - if (this%nwavst(icell) >= this%nwav(icell)) then - ! -- too many waves error - ierr = 1 - return - end if - else - this%uzdpst(this%nwavst, icell) = DZERO - this%uzflst(this%nwavst, icell) = this%vks(icell) * & - (((this%uzthst(this%nwavst, icell) - this%thtr(icell)) * & - thtsrinv) ** this%eps(icell)) - this%uzthst(this%nwavst, icell) = smoist - theta2 = this%uzthst(this%nwavst(icell) - 1, icell) - flux2 = this%uzflst(this%nwavst(icell) - 1, icell) - flux1 = this%uzflst(this%nwavst(icell), icell) - theta1 = this%uzthst(this%nwavst(icell), icell) - this%uzspst(this%nwavst(icell), icell) = leadspeed(theta1, theta2, flux1, & - flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & - this%vks(icell)) - end if - ! - ! -- return - return - end subroutine trailwav - - subroutine leadwav(this, time, itester, itrailflg, thetab, fluxb, & - ffcheck, feps2, delt, icell) -! ****************************************************************************** -! leadwav----create a lead wave and route over time step -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class (UzfCellGroupType) :: this - real(DP), intent(inout) :: thetab - real(DP), intent(inout) :: fluxb - real(DP), intent(in) :: feps2 - real(DP), intent(inout) :: time - integer(I4B), intent(inout) :: itester - integer(I4B), intent(inout) :: itrailflg - real(DP), intent(inout) :: ffcheck - real(DP), intent(in) :: delt - integer(I4B), intent(in) :: icell - ! -- local - real(DP) :: bottomtime, shortest, fcheck - real(DP) :: eps_m1, timenew, bottom, timedt - real(DP) :: thtsrinv, diff, fluxhld2 - real(DP) :: flux1, flux2, theta1, theta2, ftest - real(DP), allocatable, dimension(:) :: checktime - integer(I4B) :: iflx, iremove, j, l - integer(I4B) :: nwavp1, jshort - integer(I4B), allocatable, dimension(:) :: more -! ------------------------------------------------------------------------------ - allocate(checktime(this%nwavst(icell))) - allocate(more(this%nwavst(icell))) - ftest = DZERO - eps_m1 = dble(this%eps(icell)) - DONE - thtsrinv = DONE / (this%thts(icell) - this%thtr(icell)) - ! - ! -- initialize new wave - if (itrailflg == 0) then - if (ffcheck > feps2) then - this%uzflst(this%nwavst(icell), icell) = this%surflux(icell) - if (this%uzflst(this%nwavst(icell), icell) < DEM30) & - this%uzflst(this%nwavst(icell), icell) = DZERO - this%uzthst(this%nwavst(icell), icell) = & - (((this%uzflst(this%nwavst(icell), icell) / this%vks(icell)) ** & - (DONE / this%eps(icell))) * (this%thts(icell) - this%thtr(icell))) & - + this%thtr(icell) - theta2 = this%uzthst(this%nwavst(icell), icell) - flux2 = this%uzflst(this%nwavst(icell), icell) - flux1 = this%uzflst(this%nwavst(icell) - 1, icell) - theta1 = this%uzthst(this%nwavst(icell) - 1, icell) - this%uzspst(this%nwavst(icell), icell) = leadspeed(theta1, theta2, flux1, & - flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & - this%vks(icell)) - this%uzdpst(this%nwavst(icell), icell) = DZERO - end if - end if - ! - ! -- route all waves and interception of waves over times step - diff = DONE - timedt = DZERO - iflx = 0 - fluxhld2 = this%uzflst(1, icell) - if (this%nwavst(icell) == 0) itester = 1 - if (itester /= 1) then - do while (diff > DEM6) - nwavp1 = this%nwavst(icell) + 1 - timedt = delt - Time - do j = 1, this%nwavst(icell) - checktime(j) = DEP20 - more(j) = 0 - end do - shortest = timedt - if (this%nwavst(icell) > 2) then - j = 2 - ! - ! -- calculate time until wave overtakes wave ahead - nwavp1 = this%nwavst(icell) + 1 - do while (j < nwavp1) - ftest = this%uzspst(j - 1, icell) - this%uzspst(j, icell) - if (abs(ftest) > DEM30) then - checktime(j) = (this%uzdpst(j, icell) - this%uzdpst(j - 1, icell)) / ftest - if (checktime(j) < DEM30) checktime(j) = DEP20 - end if - j = j + 1 - end do - end if - ! - ! - calc time until wave reaches bottom of cell - bottomtime = DEP20 - if (this%nwavst(icell) > 1) then - if (this%uzspst(2, icell) > DZERO) then - bottom = this%uzspst(2, icell) - if (bottom < DEM15) bottom = DEM15 - bottomtime = (this%uzdpst(1, icell) - this%uzdpst(2, icell)) / bottom - if (bottomtime < DZERO) bottomtime = DEM12 - end if - end if - ! - ! -- calc time for wave interception - jshort = 0 - do j = this%nwavst(icell), 3, -1 - if (shortest - checktime(j) > -DEM9) then - more(j) = 1 - jshort = j - shortest = checktime(j) - end if - end do - do j = 3, this%nwavst(icell) - if (shortest - checktime(j) < DEM9) then - if (j /= jshort) more(j) = 0 - end if - end do - ! - ! -- what happens first, waves hits bottom or interception - iremove = 0 - timenew = Time - fcheck = (Time + shortest) - delt - if (shortest < DEM7) fcheck = -DONE - if (bottomtime < shortest .AND. Time + bottomtime < delt) then - j = 2 - do while (j < nwavp1) - ! - ! -- route waves - this%uzdpst(j, icell) = this%uzdpst(j, icell) + & - this%uzspst(j, icell) * bottomtime - j = j + 1 - end do - fluxb = this%uzflst(2, icell) - thetab = this%uzthst(2, icell) - iflx = 1 - call this%wave_shift(this, icell, icell, 1, 1, this%nwavst(icell) - 1, 1) - iremove = 1 - timenew = time + bottomtime - this%uzspst(1, icell) = DZERO - ! - ! -- do waves intercept before end of time step - else if (fcheck < DZERO .AND. this%nwavst(icell) > 2) then - j = 2 - do while (j < nwavp1) - this%uzdpst(j, icell) = this%uzdpst(j, icell) + & - this%uzspst(j, icell) * shortest - j = j + 1 - end do - ! - ! -- combine waves that intercept, remove a wave - j = 3 - l = j - do while (j < this%nwavst(icell) + 1) - if (more(j) == 1) then - l = j - theta2 = this%uzthst(j, icell) - flux2 = this%uzflst(j, icell) - if (j == 3) then - flux1 = fluxb - theta1 = thetab - else - flux1 = this%uzflst(j - 2, icell) - theta1 = this%uzthst(j - 2, icell) - end if - this%uzspst(j, icell) = leadspeed(theta1, theta2, flux1, & - flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & - this%vks(icell)) - ! - ! -- update waves - call this%wave_shift(this, icell, icell, 1, l - 1, this%nwavst(icell) - 1, 1) - l = this%nwavst(icell) + 1 - iremove = iremove + 1 - end if - j = j + 1 - end do - timenew = timenew + shortest - ! - ! -- calc. total flux to bottom during remaining time in step - else - j = 2 - do while (j < nwavp1) - this%uzdpst(j, icell) = this%uzdpst(j, icell) + & - this%uzspst(j, icell) * timedt - j = j + 1 - end do - timenew = delt - end if - this%totflux(icell) = this%totflux(icell) + fluxhld2 * (timenew - time) - if (iflx == 1) then - fluxhld2 = this%uzflst(1, icell) - iflx = 0 - end if - ! - ! -- remove dead waves - this%nwavst(icell) = this%nwavst(icell) - iremove - time = timenew - diff = delt - Time - if (this%nwavst(icell) == 1) then - itester = 1 - exit - end if - end do - end if - deallocate(checktime) - deallocate(more) - ! - ! -- return - return - end subroutine leadwav - - function leadspeed(theta1, theta2, flux1, flux2, thts, thtr, eps, vks) -! ****************************************************************************** -! leadspeed----calculates waves speed from dflux/dtheta -! ****************************************************************************** -! SPECIFICATIONS: -! -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - real(DP) :: leadspeed - ! -- dummy - real(DP), intent(in) :: theta1 - real(DP), intent(in) :: theta2 - real(DP), intent(in) :: flux1 - real(DP), intent(inout) :: flux2 - real(DP), intent(in) :: thts - real(DP), intent(in) :: thtr - real(DP), intent(in) :: eps - real(DP), intent(in) :: vks - ! -- local - real(DP) :: comp1, comp2, thsrinv, epsfksths - real(DP) :: eps_m1, fhold, comp3 -! ------------------------------------------------------------------------------ - ! - eps_m1 = eps - DONE - thsrinv = DONE / (thts - thtr) - epsfksths = eps * vks * thsrinv - comp1 = theta2 - theta1 - comp2 = abs(flux2 - flux1) - comp3 = theta1 - thtr - if (comp2 < DEM15) flux2 = flux1 + DEM15 - if (abs(comp1) < DEM30) then - if (comp3 > DEM30) fhold = (comp3 * thsrinv) ** eps - if (fhold < DEM30) fhold = DEM30 - leadspeed = epsfksths * (fhold ** eps_m1) - else - leadspeed = (flux2 - flux1) / (theta2 - theta1) - end if - if (leadspeed < DEM30) leadspeed = DEM30 - ! - ! -- return - return - end function leadspeed - - function unsat_stor(this, icell, d1) -! ****************************************************************************** -! unsat_stor---- sums up mobile water over depth interval -! ****************************************************************************** -! SPECIFICATIONS: -! -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - real(DP) :: unsat_stor - ! -- dummy - class (UzfCellGroupType) :: this - integer(I4B), intent(in) :: icell - real(DP), intent(inout) :: d1 - ! -- local - real(DP) :: fm - integer(I4B) :: j, k, nwavm1, jj -! ------------------------------------------------------------------------------ - fm = DZERO - j = this%nwavst(icell) + 1 - k = this%nwavst(icell) - nwavm1 = k - 1 - if (d1 > this%uzdpst(1, icell)) d1 = this%uzdpst(1, icell) - ! - ! -- find deepest wave above depth d1, counter held as j - do while (k > 0) - if (this%uzdpst(k, icell) - d1 < -DEM30) j = k - k = k - 1 - end do - if (j > this%nwavst(icell)) then - fm = fm + (this%uzthst(this%nwavst(icell), icell) - this%thtr(icell)) * d1 - elseif (this%nwavst(icell) > 1) then - if (j > 1) then - fm = fm + (this%uzthst(j - 1, icell) - this%thtr(icell)) & - * (d1 - this%uzdpst(j, icell)) - end if - do jj = j, nwavm1 - fm = fm + (this%uzthst(jj, icell) - this%thtr(icell)) & - * (this%uzdpst(jj, icell) & - - this%uzdpst(jj + 1, icell)) - end do - fm = fm + (this%uzthst(this%nwavst(icell), icell) - this%thtr(icell)) & - * (this%uzdpst(this%nwavst(icell), icell)) - else - fm = fm + (this%uzthst(1, icell) - this%thtr(icell)) * d1 - end if - unsat_stor = fm - end function unsat_stor - - subroutine update_wav(this, icell, delt, rout, rsto, ret, etflg, iss, itest) -! ****************************************************************************** -! update_wav -- update to new state of uz at end of time step -! ****************************************************************************** -! SPECIFICATIONS: -! -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class (UzfCellGroupType) :: this - integer(I4B), intent(in) :: icell - integer(I4B), intent(in) :: etflg - integer(I4B), intent(in) :: itest - integer(I4B), intent(in) :: iss - real(DP), intent(in) :: delt - real(DP), intent(inout) :: rout - real(DP), intent(inout) :: rsto - real(DP), intent(inout) :: ret - ! -- local - real(DP) :: uzstorhold, bot, fm, depthsave, top - real(DP) :: thick, thtsrinv - integer(I4B) :: nwavhld, k, j -! ------------------------------------------------------------------------------ - ! - bot = this%watab(icell) - top = this%celtop(icell) - thick = top - bot - nwavhld = this%nwavst(icell) - if (itest == 1) then - this%uzflst(1, icell) = DZERO - this%uzthst(1, icell) = this%thtr(icell) - this%delstor(icell) = - this%uzstor(icell) - this%uzstor(icell) = DZERO - uzstorhold = DZERO - rout = rout + this%totflux(icell) * this%uzfarea(icell) / delt - return - end if - if (iss == 1) then - if (this%thts(icell) - this%thtr(icell) < DEM7) then - thtsrinv = DONE / DEM7 - else - thtsrinv = DONE / (this%thts(icell) - this%thtr(icell)) - end if - this%totflux(icell) = this%surflux(icell) * delt - this%watabold(icell) = this%watab(icell) - this%uzthst(1, icell) = this%thti(icell) - this%uzflst(1, icell) = this%vks(icell) * (((this%uzthst(1, icell) - this%thtr(icell)) & - * thtsrinv) ** this%eps(icell)) - this%uzdpst(1, icell) = thick - this%uzspst(1, icell) = thick - this%nwavst(icell) = 1 - this%uzstor(icell) = thick * (this%thti(icell) - this%thtr(icell)) * this%uzfarea(icell) - this%delstor(icell) = DZERO - rout = rout + this%totflux(icell) * this%uzfarea(icell) / delt - else - ! - ! -- water table rises through waves - if (this%watab(icell) - this%watabold(icell) > DEM30) then - depthsave = this%uzdpst(1, icell) - j = 0 - k = this%nwavst(icell) - do while (k > 0) - if (this%uzdpst(k, icell) - thick < -DEM30) j = k - k = k - 1 - end do - this%uzdpst(1, icell) = thick - if (j > 1) then - this%uzspst(1, icell) = DZERO - this%nwavst(icell) = this%nwavst(icell) - j + 2 - this%uzthst(1, icell) = this%uzthst(j - 1, icell) - this%uzflst(1, icell) = this%uzflst(j - 1, icell) - if (j > 2) call this%wave_shift(this, icell, icell, j-2, 2, nwavhld - (j - 2), 1) - elseif (j == 0) then - this%uzspst(1, icell) = DZERO - this%uzthst(1, icell) = this%uzthst(this%nwavst(icell), icell) - this%uzflst(1, icell) = this%uzflst(this%nwavst(icell), icell) - this%nwavst(icell) = 1 - end if - end if - ! - ! -- calculate new unsat. storage - if (thick > DZERO) then - fm = this%unsat_stor(icell, thick) - uzstorhold = this%uzstor(icell) - this%uzstor(icell) = fm * this%uzfarea(icell) - this%delstor(icell) = this%uzstor(icell) - uzstorhold - else - this%uzspst(1, icell) = DZERO - this%nwavst(icell) = 1 - this%uzthst(1, icell) = this%thtr(icell) - this%uzflst(1, icell) = DZERO - this%delstor(icell) = -this%uzstor(icell) - this%uzstor(icell) = DZERO - uzstorhold = DZERO - end if - this%watabold(icell) = this%watab(icell) - rout = rout + this%totflux(icell) * this%uzfarea(icell) / delt - rsto = rsto + this%delstor(icell) / delt - if (etflg > 0) ret = ret + this%etact(icell) * this%uzfarea(icell) / delt - end if - end subroutine update_wav - - subroutine uzet(this, icell, delt, ietflag, ierr) -! ****************************************************************************** -! uzet -- remove water from uz due to et -! ****************************************************************************** -! SPECIFICATIONS: -! -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class (UzfCellGroupType) :: this - integer(I4B), intent(in) :: icell - real(DP), intent(in) :: delt - integer(I4B), intent(in) :: ietflag - integer(I4B), intent(inout) :: ierr - ! -- local - type(UzfCellGroupType) :: uzfktemp - real(DP) :: diff,thetaout,fm,st - real(DP) :: thtsrinv,epsfksthts,fmp - real(DP) :: fktho,theta1,theta2,flux1,flux2 - real(DP) :: hcap,ha,factor,tho,depth - real(DP) :: extwc1,petsub - integer(I4B) :: i,j,jhold,jk,kj,kk,numadd,k,nwv,itest -! ------------------------------------------------------------------------------ - ! - ! -- initialize - this%etact = DZERO - if (this%extdpuz(icell) < DEM7) return - petsub = this%rootact(icell) * this%pet(icell) * this%extdpuz(icell) / this%extdp(icell) - thetaout = delt * petsub / this%extdp(icell) - if (ietflag == 1) thetaout = delt * this%pet(icell) / this%extdp(icell) - if (thetaout < DEM10) return - depth = this%uzdpst(1, icell) - st = this%unsat_stor(icell, depth) - if (st < DEM4) return - ! - ! -- allocate temporary wave storage. - ha = this%ha(icell) - nwv = this%nwavst(icell) - itest = 0 - call uzfktemp%init(1, nwv) - ! - ! store original wave characteristics - call uzfktemp%wave_shift(this, 1, icell, 0, 1, nwv, 1) - factor = DONE - this%etact = DZERO - if (this%thts(icell) - this%thtr(icell) < DEM7) then - thtsrinv = 1.0 / DEM7 - else - thtsrinv = DONE / (this%thts(icell) - this%thtr(icell)) - end if - epsfksthts = this%eps(icell) * this%vks(icell) * thtsrinv - this%etact(icell) = DZERO - fmp = DZERO - extwc1 = this%extwc(icell) - this%thtr(icell) - if (extwc1 < DEM6) extwc1 = DEM7 - numadd = 0 - fm = st - k = 0 - ! - ! -- loop for reducing aet to pet when et is head dependent - do while (itest == 0) - k = k + 1 - if (k > 1 .AND. ABS(fmp - petsub) > DEM5 * petsub) factor = factor / (fm / petsub) - ! - ! -- one wave shallower than extdp - if (this%nwavst(icell) == 1 .AND. this%uzdpst(1, icell) <= this%extdpuz(icell)) then - if (ietflag == 2) then - tho = this%uzthst(1, icell) - fktho = this%uzflst(1, icell) - hcap = this%caph(icell, tho) - thetaout = this%rate_et_z(icell, factor, fktho, hcap) - end if - if ((this%uzthst(1, icell) - thetaout) > this%thtr(icell) + extwc1) then - this%uzthst(1, icell) = this%uzthst(1, icell) - thetaout - this%uzflst(1, icell) = this%vks(icell) * (((this%uzthst(1, icell) - & - this%thtr(icell)) * thtsrinv) ** this%eps(icell)) - else if (this%uzthst(1, icell) > this%thtr(icell) + extwc1) then - this%uzthst(1, icell) = this%thtr(icell) + extwc1 - this%uzflst(1, icell) = this%vks(icell) * (((this%uzthst(1, icell) - & - this%thtr(icell)) * thtsrinv) ** this%eps(icell)) - end if - ! - ! -- all waves shallower than extinction depth - else if (this%nwavst(icell) > 1 .AND. this%uzdpst(this%nwavst(icell), icell) > this%extdpuz(icell)) then - if (ietflag == 2) then - tho = this%uzthst(this%nwavst(icell), icell) - fktho = this%uzflst(this%nwavst(icell), icell) - hcap = this%caph(icell, tho) - thetaout = this%rate_et_z(icell, factor, fktho, hcap) - end if - if (this%uzthst(this%nwavst(icell), icell) - thetaout > this%thtr(icell) + extwc1) then - this%uzthst(this%nwavst(icell) + 1, icell) = this%uzthst(this%nwavst(icell), icell) - thetaout - numadd = 1 - else if (this%uzthst(this%nwavst(icell), icell) > this%thtr(icell) + extwc1) then - this%uzthst(this%nwavst(icell) + 1, icell) = this%thtr(icell) + extwc1 - numadd = 1 - end if - if (numadd == 1) then - this%uzflst(this%nwavst(icell) + 1, icell) = this%vks(icell) * & - (((this%uzthst(this%nwavst(icell) + 1, icell) - & - this%thtr(icell)) * thtsrinv) ** this%eps(icell)) - theta2 = this%uzthst(this%nwavst(icell) + 1, icell) - flux2 = this%uzflst(this%nwavst(icell) + 1, icell) - flux1 = this%uzflst(this%nwavst(icell), icell) - theta1 = this%uzthst(this%nwavst(icell), icell) - this%uzspst(this%nwavst(icell) + 1, icell) = leadspeed(theta1, theta2, flux1, & - flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & - this%vks(icell)) - this%uzdpst(this%nwavst(icell) + 1, icell) = this%extdpuz(icell) - this%nwavst(icell) = this%nwavst(icell) + 1 - if (this%nwavst(icell) > this%nwav(icell)) then - ! - ! -- too many waves error, deallocate temp arrays and return - ierr = 1 - goto 500 - end if - else - numadd = 0 - end if - ! - ! -- one wave below extinction depth - else if (this%nwavst(icell) == 1) then - if (ietflag == 2) then - tho = this%uzthst(1, icell) - fktho = this%uzflst(1, icell) - hcap = this%caph(icell, tho) - thetaout = this%rate_et_z(icell, factor, fktho, hcap) - end if - if ((this%uzthst(1, icell) - thetaout) > this%thtr(icell) + extwc1) then - if (thetaout > DEM30) then - this%uzthst(2, icell) = this%uzthst(1, icell) - thetaout - this%uzflst(2, icell) = this%vks(icell) * (((this%uzthst(2, icell) - this%thtr(icell)) * & - thtsrinv) ** this%eps(icell)) - this%uzdpst(2, icell) = this%extdpuz(icell) - theta2 = this%uzthst(2, icell) - flux2 = this%uzflst(2, icell) - flux1 = this%uzflst(1, icell) - theta1 = this%uzthst(1, icell) - this%uzspst(2, icell) = leadspeed(theta1, theta2, flux1, & - flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & - this%vks(icell)) - this%nwavst(icell) = this%nwavst(icell) + 1 - if (this%nwavst(icell) > this%nwav(icell)) then - ! - ! -- too many waves error - ierr = 1 - goto 500 - end if - end if - else if (this%uzthst(1, icell) > this%thtr(icell) + extwc1) then - if (thetaout > DEM30) then - this%uzthst(2, icell) = this%thtr(icell) + extwc1 - this%uzflst(2, icell) = this%vks(icell) * (((this%uzthst(2, icell) - & - this%thtr(icell)) * thtsrinv) ** this%eps(icell)) - this%uzdpst(2, icell) = this%extdpuz(icell) - theta2 = this%uzthst(2, icell) - flux2 = this%uzflst(2, icell) - flux1 = this%uzflst(1, icell) - theta1 = this%uzthst(1, icell) - this%uzspst(2, icell) = leadspeed(theta1, theta2, flux1, & - flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & - this%vks(icell)) - this%nwavst(icell) = this%nwavst(icell) + 1 - if (this%nwavst(icell) > this%nwav(icell)) then - ! - ! -- too many waves error - ierr = 1 - goto 500 - end if - end if - end if - else - ! - ! -- extinction depth splits waves - if (this%uzdpst(1, icell) - this%extdpuz(icell) > DEM7) then - j = 2 - jk = 0 - ! - ! -- locate extinction depth between waves - do while (jk == 0) - diff = this%uzdpst(j, icell) - this%extdpuz(icell) - if (diff > dzero) then - j = j + 1 - else - jk = 1 - end if - end do - kk = j - if (this%uzthst(j, icell) > this%thtr(icell) + extwc1) then - ! - ! -- create a wave at extinction depth - if (abs(diff) > DEM5) then - call this%wave_shift(this, icell, icell, -1, this%nwavst(icell) + 1, j, -1) - this%uzdpst(j, icell) = this%extdpuz(icell) - this%nwavst(icell) = this%nwavst(icell) + 1 - if (this%nwavst(icell) > this%nwav(icell)) then - ! - ! -- too many waves error - ierr = 1 - goto 500 - end if - end if - kk = j - else - jhold = this%nwavst(icell) - i = j + 1 - do while (i < this%nwavst(icell)) - if (this%uzthst(i, icell) > this%thtr(icell) + extwc1) then - jhold = i - i = this%nwavst(icell) + 1 - end if - i = i + 1 - end do - j = jhold - kk = jhold - end if - else - kk = 1 - end if - ! - ! -- all waves above extinction depth - do while (kk <= this%nwavst(icell)) - if (ietflag==2) then - tho = this%uzthst(kk, icell) - fktho = this%uzflst(kk, icell) - hcap = this%caph(icell, tho) - thetaout = this%rate_et_z(icell, factor, fktho, hcap) - end if - if (this%uzthst(kk, icell) > this%thtr(icell) + extwc1) then - if (this%uzthst(kk, icell) - thetaout > this%thtr(icell) + extwc1) then - this%uzthst(kk, icell) = this%uzthst(kk, icell) - thetaout - else if (this%uzthst(kk, icell) > this%thtr(icell) + extwc1) then - this%uzthst(kk, icell) = this%thtr(icell) + extwc1 - end if - if (kk == 1) then - this%uzflst(kk, icell) = this%vks(icell) * (((this%uzthst(kk, icell) - & - this%thtr(icell)) * thtsrinv) ** this%eps(icell)) - end if - if (kk > 1) then - flux1 = this%vks(icell) * ((this%uzthst(kk - 1, icell) - & - this%thtr(icell)) * thtsrinv) ** this%eps(icell) - flux2 = this%vks(icell) * ((this%uzthst(kk, icell) - this%thtr(icell)) * & - thtsrinv) ** this%eps(icell) - this%uzflst(kk, icell) = flux2 - theta2 = this%uzthst(kk, icell) - theta1 = this%uzthst(kk - 1, icell) - this%uzspst(kk, icell) = leadspeed(theta1, theta2, flux1, & - flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & - this%vks(icell)) - end if - end if - kk = kk + 1 - end do - end if - ! - ! -- calculate aet - kj = 1 - do while (kj <= this%nwavst(icell) - 1) - if (abs(this%uzthst(kj, icell) - this%uzthst(kj + 1, icell)) < DEM6) then - call this%wave_shift(this, icell, icell, 1, kj + 1, this%nwavst(icell) - 1, 1) - kj = kj - 1 - this%nwavst(icell) = this%nwavst(icell) - 1 - end if - kj = kj + 1 - end do - depth = this%uzdpst(1, icell) - fm = this%unsat_stor(icell, depth) - this%etact(icell) = st - fm - fm = this%etact(icell) / delt - if (this%etact(icell) < dzero) then - call this%wave_shift(uzfktemp, icell, 1, 0, 1, nwv, 1) - this%nwavst(icell) = nwv - this%etact(icell) = DZERO - elseif (petsub - fm < -DEM15 .AND. ietflag == 2) then - ! - ! -- aet greater than pet, reset and try again - call this%wave_shift(uzfktemp, icell, 1, 0, 1, nwv, 1) - this%nwavst(icell) = nwv - this%etact = DZERO - else - itest = 1 - end if - ! - ! -- end aet-pet loop for head dependent et - fmp = fm - if (k > 100) then - itest = 1 - elseif (ietflag < 2) then - fmp = petsub - itest = 1 - end if - end do -500 continue - return - end subroutine uzet - - function caph(this, icell, tho) -! ****************************************************************************** -! caph---- calculate capillary pressure head from B-C equation -! ****************************************************************************** -! SPECIFICATIONS: -! -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class (UzfCellGroupType) :: this - integer(I4B), intent(in) :: icell - real(DP), intent(in) :: tho - ! -- local - real(DP) :: caph,lambda,star -! ------------------------------------------------------------------------------ - caph = -DEM6 - star = (tho - this%thtr(icell)) / (this%thts(icell) - this%thtr(icell)) - if (star < DEM15) star = DEM15 - lambda = DTWO / (this%eps(icell) - DTHREE) - if (star > DEM15) then - if (tho - this%thts(icell) < DEM15) then - caph = this%ha(icell) * star ** (-DONE / lambda) - else - caph = DZERO - end if - end if - end function caph - - function rate_et_z(this, icell, factor, fktho, h) -! ****************************************************************************** -! rate_et_z---- capillary pressure based uz et -! ****************************************************************************** -! SPECIFICATIONS: -! -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - real(DP) :: rate_et_z - ! -- dummy - class (UzfCellGroupType) :: this - integer(I4B), intent(in) :: icell - real(DP), intent(in) :: factor, fktho, h - ! -- local -! ---------------------------------------------------------------------- - rate_et_z = factor * fktho * (h - this%hroot(icell)) - if (rate_et_z < DZERO) rate_et_z = DZERO - end function rate_et_z - +module UzfCellGroupModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, DEM30, DEM20, DEM15, DEM14, DEM12, DEM10, & + DEM9, DEM7, DEM6, DEM5, DEM4, DEM3, DHALF, DONE, & + DTWO, DTHREE, DEP20 + use SmoothingModule + use TdisModule, only: ITMUNI, delt, kper + + implicit none + private + public :: UzfCellGroupType + + type :: UzfCellGroupType + integer(I4B) :: imem_manager + real(DP), pointer, dimension(:), contiguous :: thtr => null() + real(DP), pointer, dimension(:), contiguous :: thts => null() + real(DP), pointer, dimension(:), contiguous :: thti => null() + real(DP), pointer, dimension(:), contiguous :: eps => null() + real(DP), pointer, dimension(:), contiguous :: extwc => null() + real(DP), pointer, dimension(:), contiguous :: ha => null() + real(DP), pointer, dimension(:), contiguous :: hroot => null() + real(DP), pointer, dimension(:), contiguous :: rootact => null() + real(DP), pointer, dimension(:), contiguous :: etact => null() + real(DP), dimension(:, :), pointer, contiguous :: uzspst => null() + real(DP), dimension(:, :), pointer, contiguous :: uzthst => null() + real(DP), dimension(:, :), pointer, contiguous :: uzflst => null() + real(DP), dimension(:, :), pointer, contiguous :: uzdpst => null() + integer(I4B), pointer, dimension(:), contiguous :: nwavst => null() + real(DP), pointer, dimension(:), contiguous :: uzolsflx => null() + real(DP), pointer, dimension(:), contiguous :: uzstor => null() + real(DP), pointer, dimension(:), contiguous :: delstor => null() + real(DP), pointer, dimension(:), contiguous :: totflux => null() + real(DP), pointer, dimension(:), contiguous :: vflow => null() + integer(I4B), pointer, dimension(:), contiguous :: nwav => null() + integer(I4B), pointer, dimension(:), contiguous :: ntrail => null() + real(DP), pointer, dimension(:), contiguous :: sinf => null() + real(DP), pointer, dimension(:), contiguous :: finf => null() + real(DP), pointer, dimension(:), contiguous :: pet => null() + real(DP), pointer, dimension(:), contiguous :: petmax => null() + real(DP), pointer, dimension(:), contiguous :: extdp => null() + real(DP), pointer, dimension(:), contiguous :: extdpuz => null() + real(DP), pointer, dimension(:), contiguous :: finf_rej => null() + real(DP), pointer, dimension(:), contiguous :: gwet => null() + real(DP), pointer, dimension(:), contiguous :: uzfarea => null() + real(DP), pointer, dimension(:), contiguous :: cellarea => null() + real(DP), pointer, dimension(:), contiguous :: celtop => null() + real(DP), pointer, dimension(:), contiguous :: celbot => null() + real(DP), pointer, dimension(:), contiguous :: landtop => null() + real(DP), pointer, dimension(:), contiguous :: cvlm1 => null() + real(DP), pointer, dimension(:), contiguous :: watab => null() + real(DP), pointer, dimension(:), contiguous :: watabold => null() + real(DP), pointer, dimension(:), contiguous :: vks => null() + real(DP), pointer, dimension(:), contiguous :: surfdep => null() + real(DP), pointer, dimension(:), contiguous :: surflux => null() + real(DP), pointer, dimension(:), contiguous :: surfluxbelow => null() + real(DP), pointer, dimension(:), contiguous :: surfseep => null() + real(DP), pointer, dimension(:), contiguous :: gwpet => null() + integer(I4B), pointer, dimension(:), contiguous :: landflag => null() + integer(I4B), pointer, dimension(:), contiguous :: ivertcon => null() + contains + procedure :: init + procedure :: setdata + procedure :: sethead + procedure :: setdatauzfarea + procedure :: setdatafinf + procedure :: setdataet + procedure :: setdataetwc + procedure :: setdataetha + procedure :: setwaves + procedure :: wave_shift + procedure :: routewaves + procedure :: uzflow + procedure :: addrech + procedure :: trailwav + procedure :: leadwav + procedure :: advance + procedure :: formulate + procedure :: budget + procedure :: unsat_stor + procedure :: update_wav + procedure :: simgwet + procedure :: caph + procedure :: rate_et_z + procedure :: uzet + procedure :: uz_rise + procedure :: vertcellflow + procedure :: rejfinf + procedure :: gwseep + procedure :: setbelowpet + procedure :: dealloc + end type UzfCellGroupType +! + contains +! +! ------------------------------------------------------------------------------ + + subroutine init(this, ncells, nwav, origin) +! ****************************************************************************** +! init -- allocate and set uzf object variables +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(UzfCellGroupType) :: this + integer(I4B), intent(in) :: nwav + integer(I4B), intent(in) :: ncells + character(len=*), intent(in), optional :: origin + ! -- local + integer(I4B) :: icell +! ------------------------------------------------------------------------------ + ! + ! -- Use mem_allocate if origin is passed in, otherwise it's a temp object + if (present(origin)) then + this%imem_manager = 1 + call mem_allocate(this%uzdpst, nwav, ncells, 'UZDPST', origin) + call mem_allocate(this%uzthst, nwav, ncells, 'UZTHST', origin) + call mem_allocate(this%uzflst, nwav, ncells, 'UZFLST', origin) + call mem_allocate(this%uzspst, nwav, ncells, 'UZSPST', origin) + call mem_allocate(this%nwavst, ncells, 'NWAVST', origin) + call mem_allocate(this%uzolsflx, ncells, 'UZOLSFLX', origin) + call mem_allocate(this%thtr, ncells, 'THTR', origin) + call mem_allocate(this%thts, ncells, 'THTS', origin) + call mem_allocate(this%thti, ncells, 'THTI', origin) + call mem_allocate(this%eps, ncells, 'EPS', origin) + call mem_allocate(this%ha, ncells, 'HA', origin) + call mem_allocate(this%hroot, ncells, 'HROOT', origin) + call mem_allocate(this%rootact, ncells, 'ROOTACT', origin) + call mem_allocate(this%extwc, ncells, 'EXTWC', origin) + call mem_allocate(this%etact, ncells, 'ETACT', origin) + call mem_allocate(this%nwav, ncells, 'NWAV', origin) + call mem_allocate(this%ntrail, ncells, 'NTRAIL', origin) + call mem_allocate(this%uzstor, ncells, 'UZSTOR', origin) + call mem_allocate(this%delstor, ncells, 'DELSTOR', origin) + call mem_allocate(this%totflux, ncells, 'TOTFLUX', origin) + call mem_allocate(this%vflow, ncells, 'VFLOW', origin) + call mem_allocate(this%sinf, ncells, 'SINF', origin) + call mem_allocate(this%finf, ncells, 'FINF', origin) + call mem_allocate(this%finf_rej, ncells, 'FINF_REJ', origin) + call mem_allocate(this%gwet, ncells, 'GWET', origin) + call mem_allocate(this%uzfarea, ncells, 'UZFAREA', origin) + call mem_allocate(this%cellarea, ncells, 'CELLAREA', origin) + call mem_allocate(this%celtop, ncells, 'CELTOP', origin) + call mem_allocate(this%celbot, ncells, 'CELBOT', origin) + call mem_allocate(this%landtop, ncells, 'LANDTOP', origin) + call mem_allocate(this%cvlm1, ncells, 'CVLM1', origin) + call mem_allocate(this%watab, ncells, 'WATAB', origin) + call mem_allocate(this%watabold, ncells, 'WATABOLD', origin) + call mem_allocate(this%surfdep, ncells, 'SURFDEP', origin) + call mem_allocate(this%vks, ncells, 'VKS', origin) + call mem_allocate(this%surflux, ncells, 'SURFLUX', origin) + call mem_allocate(this%surfluxbelow, ncells, 'SURFLUXBELOW', origin) + call mem_allocate(this%surfseep, ncells, 'SURFSEEP', origin) + call mem_allocate(this%gwpet, ncells, 'GWPET', origin) + call mem_allocate(this%pet, ncells, 'PET', origin) + call mem_allocate(this%petmax, ncells, 'PETMAX', origin) + call mem_allocate(this%extdp, ncells, 'EXTDP', origin) + call mem_allocate(this%extdpuz, ncells, 'EXTDPUZ', origin) + call mem_allocate(this%landflag, ncells, 'LANDFLAG', origin) + call mem_allocate(this%ivertcon, ncells, 'IVERTCON', origin) + else + this%imem_manager = 0 + allocate(this%uzdpst(nwav, ncells)) + allocate(this%uzthst(nwav, ncells)) + allocate(this%uzflst(nwav, ncells)) + allocate(this%uzspst(nwav, ncells)) + allocate(this%nwavst(ncells)) + allocate(this%uzolsflx(ncells)) + allocate(this%thtr(ncells)) + allocate(this%thts(ncells)) + allocate(this%thti(ncells)) + allocate(this%eps(ncells)) + allocate(this%ha(ncells)) + allocate(this%hroot(ncells)) + allocate(this%rootact(ncells)) + allocate(this%extwc(ncells)) + allocate(this%etact(ncells)) + allocate(this%nwav(ncells)) + allocate(this%ntrail(ncells)) + allocate(this%uzstor(ncells)) + allocate(this%delstor(ncells)) + allocate(this%totflux(ncells)) + allocate(this%vflow(ncells)) + allocate(this%sinf(ncells)) + allocate(this%finf(ncells)) + allocate(this%finf_rej(ncells)) + allocate(this%gwet(ncells)) + allocate(this%uzfarea(ncells)) + allocate(this%cellarea(ncells)) + allocate(this%celtop(ncells)) + allocate(this%celbot(ncells)) + allocate(this%landtop(ncells)) + allocate(this%cvlm1(ncells)) + allocate(this%watab(ncells)) + allocate(this%watabold(ncells)) + allocate(this%surfdep(ncells)) + allocate(this%vks(ncells)) + allocate(this%surflux(ncells)) + allocate(this%surfluxbelow(ncells)) + allocate(this%surfseep(ncells)) + allocate(this%gwpet(ncells)) + allocate(this%pet(ncells)) + allocate(this%petmax(ncells)) + allocate(this%extdp(ncells)) + allocate(this%extdpuz(ncells)) + allocate(this%landflag(ncells)) + allocate(this%ivertcon(ncells)) + end if + do icell = 1, ncells + this%uzdpst(:, icell) = DZERO + this%uzthst(:, icell) = DZERO + this%uzflst(:, icell) = DZERO + this%uzspst(:, icell) = DZERO + this%nwavst(icell) = 1 + this%uzolsflx(icell) = DZERO + this%thtr(icell) = DZERO + this%thts(icell) = DZERO + this%thti(icell) = DZERO + this%eps(icell) = DZERO + this%ha(icell) = DZERO + this%hroot(icell) = DZERO + this%rootact(icell) = DZERO + this%extwc(icell) = DZERO + this%etact(icell) = DZERO + this%nwav(icell) = nwav + this%ntrail(icell) = 0 + this%uzstor(icell) = DZERO + this%delstor(icell) = DZERO + this%totflux(icell) = DZERO + this%vflow(icell) = DZERO + this%sinf(icell) = DZERO + this%finf(icell) = DZERO + this%finf_rej(icell) = DZERO + this%gwet(icell) = DZERO + this%uzfarea(icell) = DZERO + this%cellarea(icell) = DZERO + this%celtop(icell) = DZERO + this%celbot(icell) = DZERO + this%landtop(icell) = DZERO + this%cvlm1(icell) = DZERO + this%watab(icell) = DZERO + this%watabold(icell) = DZERO + this%surfdep(icell) = DZERO + this%vks(icell) = DZERO + this%surflux(icell) = DZERO + this%surfluxbelow(icell) = DZERO + this%surfseep(icell) = DZERO + this%gwpet(icell) = DZERO + this%pet(icell) = DZERO + this%petmax(icell) = DZERO + this%extdp(icell) = DZERO + this%extdpuz(icell) = DZERO + this%landflag(icell) = 0 + this%ivertcon(icell) = 0 + end do + ! + ! -- return + return + end subroutine init + + subroutine dealloc(this) +! ****************************************************************************** +! dealloc -- deallocate uzf object variables +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(UzfCellGroupType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- deallocate based on whether or not memory manager was used + if (this%imem_manager == 0) then + deallocate(this%uzdpst) + deallocate(this%uzthst) + deallocate(this%uzflst) + deallocate(this%uzspst) + deallocate(this%nwavst) + deallocate(this%uzolsflx) + deallocate(this%thtr) + deallocate(this%thts) + deallocate(this%thti) + deallocate(this%eps) + deallocate(this%ha) + deallocate(this%hroot) + deallocate(this%rootact) + deallocate(this%extwc) + deallocate(this%etact) + deallocate(this%nwav) + deallocate(this%ntrail) + deallocate(this%uzstor) + deallocate(this%delstor) + deallocate(this%totflux) + deallocate(this%vflow) + deallocate(this%sinf) + deallocate(this%finf) + deallocate(this%finf_rej) + deallocate(this%gwet) + deallocate(this%uzfarea) + deallocate(this%cellarea) + deallocate(this%celtop) + deallocate(this%celbot) + deallocate(this%landtop) + deallocate(this%cvlm1) + deallocate(this%watab) + deallocate(this%watabold) + deallocate(this%surfdep) + deallocate(this%vks) + deallocate(this%surflux) + deallocate(this%surfluxbelow) + deallocate(this%surfseep) + deallocate(this%gwpet) + deallocate(this%pet) + deallocate(this%petmax) + deallocate(this%extdp) + deallocate(this%extdpuz) + deallocate(this%landflag) + deallocate(this%ivertcon) + else + call mem_deallocate(this%uzdpst) + call mem_deallocate(this%uzthst) + call mem_deallocate(this%uzflst) + call mem_deallocate(this%uzspst) + call mem_deallocate(this%nwavst) + call mem_deallocate(this%uzolsflx) + call mem_deallocate(this%thtr) + call mem_deallocate(this%thts) + call mem_deallocate(this%thti) + call mem_deallocate(this%eps) + call mem_deallocate(this%ha) + call mem_deallocate(this%hroot) + call mem_deallocate(this%rootact) + call mem_deallocate(this%extwc) + call mem_deallocate(this%etact) + call mem_deallocate(this%nwav) + call mem_deallocate(this%ntrail) + call mem_deallocate(this%uzstor) + call mem_deallocate(this%delstor) + call mem_deallocate(this%totflux) + call mem_deallocate(this%vflow) + call mem_deallocate(this%sinf) + call mem_deallocate(this%finf) + call mem_deallocate(this%finf_rej) + call mem_deallocate(this%gwet) + call mem_deallocate(this%uzfarea) + call mem_deallocate(this%cellarea) + call mem_deallocate(this%celtop) + call mem_deallocate(this%celbot) + call mem_deallocate(this%landtop) + call mem_deallocate(this%cvlm1) + call mem_deallocate(this%watab) + call mem_deallocate(this%watabold) + call mem_deallocate(this%surfdep) + call mem_deallocate(this%vks) + call mem_deallocate(this%surflux) + call mem_deallocate(this%surfluxbelow) + call mem_deallocate(this%surfseep) + call mem_deallocate(this%gwpet) + call mem_deallocate(this%pet) + call mem_deallocate(this%petmax) + call mem_deallocate(this%extdp) + call mem_deallocate(this%extdpuz) + call mem_deallocate(this%landflag) + call mem_deallocate(this%ivertcon) + end if + ! + ! -- return + return + end subroutine dealloc + + subroutine setdata(this, icell, area, top, bot, surfdep, vks, thtr, thts, & + thti, eps, ntrail, landflag, ivertcon) +! ****************************************************************************** +! setdata -- set uzf object material properties +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(UzfCellGroupType) :: this + integer(I4B), intent(in) :: icell + real(DP), intent(in) :: area + real(DP), intent(in) :: top + real(DP), intent(in) :: bot + real(DP), intent(in) :: surfdep + real(DP), intent(in) :: vks + real(DP), intent(in) :: thtr + real(DP), intent(in) :: thts + real(DP), intent(in) :: thti + real(DP), intent(in) :: eps + integer(I4B), intent(in) :: ntrail + integer(I4B), intent(in) :: landflag + integer(I4B), intent(in) :: ivertcon +! ------------------------------------------------------------------------------ + ! + ! -- set the values for uzf cell icell + this%landflag(icell) = landflag + this%ivertcon(icell) = ivertcon + this%surfdep(icell) = surfdep + this%uzfarea(icell) = area + this%cellarea(icell) = area + if (this%landflag(icell) == 1) then + this%celtop(icell) = top - DHALF * this%surfdep(icell) + else + this%celtop(icell) = top + end if + this%celbot(icell) = bot + this%vks(icell) = vks + this%thtr(icell) = thtr + this%thts(icell) = thts + this%thti(icell) = thti + this%eps(icell) = eps + this%ntrail(icell) = ntrail + this%pet(icell) = DZERO + this%extdp(icell) = DZERO + this%extwc(icell) = DZERO + this%ha(icell) = DZERO + this%hroot(icell) = DZERO + end subroutine setdata + + subroutine sethead(this, icell, hgwf) +! ****************************************************************************** +! sethead -- set uzf object material properties +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(UzfCellGroupType) :: this + integer(I4B), intent(in) :: icell + real(DP), intent(in) :: hgwf +! ------------------------------------------------------------------------------ + ! + ! -- set initial head + this%watab(icell) = this%celbot(icell) + if (hgwf > this%celbot(icell)) this%watab(icell) = hgwf + if (this%watab(icell) > this%celtop(icell)) & + this%watab(icell) = this%celtop(icell) + this%watabold(icell) = this%watab(icell) + end subroutine sethead + + subroutine setdatafinf(this, icell, finf) +! ****************************************************************************** +! setdatafinf -- set infiltration +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(UzfCellGroupType) :: this + integer(I4B), intent(in) :: icell + real(DP), intent(in) :: finf +! ------------------------------------------------------------------------------ + if (this%landflag(icell) == 1) then + this%sinf(icell) = finf + this%finf(icell) = finf + else + this%sinf(icell) = DZERO + this%finf(icell) = DZERO + end if + this%finf_rej(icell) = DZERO + this%surflux(icell) = DZERO + this%surfluxbelow(icell) = DZERO + end subroutine setdatafinf + + subroutine setdatauzfarea(this, icell, areamult) +! ****************************************************************************** +! setdatauzfarea -- set uzfarea using cellarea and areamult +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(UzfCellGroupType) :: this + integer(I4B), intent(in) :: icell + real(DP), intent(in) :: areamult +! ------------------------------------------------------------------------------ + ! + ! -- set uzf area + this%uzfarea(icell) = this%cellarea(icell) * areamult + ! + ! -- return + return + end subroutine setdatauzfarea + +! ------------------------------------------------------------------------------ +! + subroutine setdataet(this, icell, jbelow, pet, extdp) +! ****************************************************************************** +! setdataet -- set unsat. et variables +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(UzfCellGroupType) :: this + integer(I4B), intent(in) :: icell + integer(I4B), intent(in) :: jbelow + real(DP), intent(in) :: pet + real(DP), intent(in) :: extdp + ! -- local + real(DP) :: thick +! ------------------------------------------------------------------------------ + if (this%landflag(icell) == 1) then + this%pet(icell) = pet + this%gwpet(icell) = pet + else + this%pet(icell) = DZERO + this%gwpet(icell) = DZERO + end if + thick = this%celtop(icell) - this%celbot(icell) + this%extdp(icell) = extdp + if (this%landflag(icell) > 0) then + this%landtop(icell) = this%celtop(icell) + this%petmax(icell) = this%pet(icell) + end if + ! + ! -- set uz extinction depth + if (this%landtop(icell) - this%extdp(icell) < this%celbot(icell)) then + this%extdpuz(icell) = thick + else + this%extdpuz(icell) = this%celtop(icell) - & + (this%landtop(icell) - this%extdp(icell)) + end if + if (this%extdpuz(icell) < DZERO) this%extdpuz(icell) = DZERO + if (this%extdpuz(icell) > DEM7 .and. this%extdp(icell) < DEM7) & + this%extdp(icell) = this%extdpuz(icell) + ! + ! -- set pet for underlying cell + if (jbelow > 0) then + this%landtop(jbelow) = this%landtop(icell) + this%petmax(jbelow) = this%petmax(icell) + end if + ! + ! -- return + return + end subroutine setdataet + + subroutine setbelowpet(this, icell, jbelow, aet) +! ****************************************************************************** +! setbelowpet -- subtract aet from pet to calculate residual et +! for deeper cells +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(UzfCellGroupType) :: this + integer(I4B), intent(in) :: icell + integer(I4B), intent(in) :: jbelow + real(DP), intent(in) :: aet + ! -- dummy + real(DP) :: pet +! ------------------------------------------------------------------------------ + pet = DZERO + if (this%extdpuz(jbelow) > DEM3) then + pet = this%petmax(icell) - aet + if (pet < DZERO) pet = DZERO + end if + this%pet(jbelow) = pet + ! + ! -- return + return + end subroutine setbelowpet + + subroutine setdataetwc(this, icell, jbelow, extwc) +! ****************************************************************************** +! setdataetwc -- set extinction water content +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(UzfCellGroupType) :: this + integer(I4B), intent(in) :: icell + integer(I4B), intent(in) :: jbelow + real(DP), intent(in) :: extwc +! ------------------------------------------------------------------------------ + ! + ! -- set extinction water content + this%extwc(icell) = extwc + if (jbelow > 0) this%extwc(jbelow) = extwc + ! + ! -- return + return + end subroutine setdataetwc + + subroutine setdataetha(this, icell, jbelow, ha, hroot, rootact) +! ****************************************************************************** +! setdataetha -- set variables for head-based unsat. flow +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(UzfCellGroupType) :: this + integer(I4B), intent(in) :: icell + integer(I4B), intent(in) :: jbelow + real(DP), intent(in) :: ha + real(DP), intent(in) :: hroot + real(DP), intent(in) :: rootact +! ------------------------------------------------------------------------------ + ! + ! -- set variables + this%ha(icell) = ha + this%hroot(icell) = hroot + this%rootact(icell) = rootact + if (jbelow > 0) then + this%ha(jbelow) = ha + this%hroot(jbelow) = hroot + this%rootact(jbelow) = rootact + end if + ! + ! -- return + return + end subroutine setdataetha + + subroutine advance(this, icell) +! ****************************************************************************** +! advance -- set variables to advance to new time step. nothing yet. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(UzfCellGroupType) :: this + integer(I4B), intent(in) :: icell +! ------------------------------------------------------------------------------ + ! + ! -- set variables + this%surfseep(icell) = DZERO + ! + ! -- return + return + end subroutine advance + + subroutine formulate(this, thiswork, jbelow, icell, totfluxtot, ietflag, & + issflag, iseepflag, trhs, thcof, hgwf, & + hgwfml1, cvv, deriv, qfrommvr, qformvr, ierr, sumaet, & + ivertflag) +! ****************************************************************************** +! formulate -- formulate the unsaturated flow object, calculate terms for +! gwf equation +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: delt + ! -- dummy + class(UzfCellGroupType) :: this + type(UzfCellGroupType) :: thiswork + integer(I4B), intent(in) :: jbelow + integer(I4B), intent(in) :: icell + integer(I4B), intent(in) :: ietflag + integer(I4B), intent(in) :: iseepflag + integer(I4B), intent(in) :: issflag + integer(I4B), intent(in) :: ivertflag + integer(I4B), intent(inout) :: ierr + real(DP), intent(in) :: hgwf + real(DP), intent(in) :: hgwfml1 + real(DP), intent(in) :: cvv + real(DP), intent(in) :: qfrommvr + real(DP), intent(inout) :: trhs + real(DP), intent(inout) :: thcof + real(DP), intent(inout) :: qformvr + real(DP), intent(inout) :: sumaet + real(DP), intent(inout) :: totfluxtot + real(DP), intent(inout) :: deriv + ! -- local + real(DP) :: test, scale, seep, finfact, derivfinf + real(DP) :: trhsfinf, thcoffinf, trhsseep, thcofseep, deriv1, deriv2 +! ------------------------------------------------------------------------------ + totfluxtot = DZERO + trhsfinf = DZERO + thcoffinf = DZERO + trhsseep = DZERO + thcofseep = DZERO + this%finf_rej(icell) = DZERO + this%surflux(icell) = this%finf(icell) + qfrommvr / this%uzfarea(icell) + this%surfseep(icell) = DZERO + seep = DZERO + finfact = DZERO + deriv1 = DZERO + deriv2 = DZERO + derivfinf = DZERO + this%watab(icell) = hgwf + this%etact(icell) = DZERO + this%surfluxbelow(icell) = DZERO + ! + ! -- set pet for gw when there is no UZ. + this%gwpet(icell) = this%pet(icell) + if(ivertflag > 0) then + this%finf(jbelow) = DZERO + end if + ! + ! -- save wave states for resetting after iteration. + this%watab(icell) = hgwf + call thiswork%wave_shift(this, 1, icell, 0, 1, this%nwavst(icell), 1) + if (this%watab(icell) > this%celtop(icell)) & + this%watab(icell) = this%celtop(icell) + ! + if (this%ivertcon(icell) > 0) then + if (this%watab(icell) < this%celbot(icell)) & + this%watab(icell) = this%celbot(icell) + end if + ! + ! -- add water from mover to applied infiltration. + if (this%surflux(icell) > this%vks(icell)) then + this%surflux(icell) = this%vks(icell) + end if + ! + ! -- saturation excess rejected infiltration + if (this%landflag(icell) == 1) then + call this%rejfinf(icell, deriv1, hgwf, trhsfinf, thcoffinf, finfact) + this%surflux(icell) = finfact + end if + ! + ! -- calculate rejected infiltration + this%finf_rej(icell) = this%finf(icell) + & + (qfrommvr / this%uzfarea(icell)) - this%surflux(icell) + if (iseepflag > 0 .and. this%landflag(icell) == 1) then + ! + ! -- calculate groundwater discharge + call this%gwseep(icell, deriv2, scale, hgwf, trhsseep, thcofseep, seep) + this%surfseep(icell) = seep + end if + ! + ! -- route water through unsat zone, calc. storage change and recharge + ! + test = this%watab(icell) + if (this%watabold(icell) - test < -DEM15) test = this%watabold(icell) + if (this%celtop(icell) - test > DEM15) then + if (issflag == 0) then + call this%routewaves(totfluxtot, delt, ietflag, icell, ierr) + if (ierr > 0) return + call this%uz_rise(icell, totfluxtot) + this%totflux(icell) = totfluxtot + if (ietflag > 0 .and. this%ivertcon(icell) > 0) then + this%pet(jbelow) = this%pet(jbelow) - this%etact(icell) + if (this%pet(jbelow) < DEM15) this%pet(jbelow) = DEM15 + end if + if (this%ivertcon(icell) > 0) then + call this%addrech(icell, jbelow, hgwf, trhsfinf, thcoffinf, derivfinf, delt, 0) + end if + else + this%totflux(icell) = this%surflux(icell) * delt + totfluxtot = this%surflux(icell) * delt + end if + thcoffinf = DZERO + trhsfinf = this%totflux(icell) * this%uzfarea(icell) / delt + else + this%totflux(icell) = this%surflux(icell) * delt + totfluxtot = this%surflux(icell) * delt + end if + deriv = deriv1 + deriv2 + derivfinf + trhs = trhsfinf + trhsseep + thcof = thcoffinf + thcofseep + ! + ! -- add spring flow and rejected infiltration to mover + qformvr = this%surfseep(icell) + this%finf_rej(icell) * this%uzfarea(icell) + ! + ! -- reset waves to previous state for next iteration + call this%wave_shift(thiswork, icell, 1, 0, 1, thiswork%nwavst(1), 1) + ! + ! -- distribute PET to deeper cells + sumaet = sumaet + this%etact(icell) + if(this%ivertcon(icell) > 0) then + if (ietflag > 0) then + call this%setbelowpet(icell, jbelow, sumaet) + end if + end if + end subroutine formulate + + subroutine budget(this, jbelow, icell, totfluxtot, rfinf, rin, rout, & + rsto, ret, retgw, rgwseep, rvflux, ietflag, iseepflag, & + issflag, hgwf, hgwfml1, cvv, numobs, obs_num, & + obs_depth, obs_theta, qfrommvr, qformvr, qgwformvr, & + sumaet, ierr) +! ****************************************************************************** +! budget -- save unsat. conditions at end of time step, calculate budget +! terms +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: delt + ! -- dummy + class(UzfCellGroupType) :: this + integer(I4B), intent(in) :: jbelow + integer(I4B), intent(in) :: icell + integer(I4B), intent(in) :: ietflag + integer(I4B), intent(in) :: iseepflag + integer(I4B), intent(in) :: issflag + integer(I4B), intent(inout) :: ierr + integer(I4B), intent(in) :: numobs + integer(I4B), dimension(:),intent(in) :: obs_num + real(DP),dimension(:),intent(in) :: obs_depth + real(DP),dimension(:),intent(inout) :: obs_theta + real(DP), intent(in) :: hgwf + real(DP), intent(in) :: hgwfml1 + real(DP), intent(in) :: cvv + real(DP), intent(in) :: qfrommvr + real(DP), intent(inout) :: rfinf + real(DP), intent(inout) :: rin + real(DP), intent(inout) :: qformvr + real(DP), intent(inout) :: sumaet + real(DP), intent(inout) :: qgwformvr + real(DP), intent(inout) :: rout + real(DP), intent(inout) :: rsto + real(DP), intent(inout) :: ret + real(DP), intent(inout) :: retgw + real(DP), intent(inout) :: rgwseep + real(DP), intent(inout) :: rvflux + real(DP), intent(inout) :: totfluxtot + ! -- dummy + real(DP) :: test, deriv, scale, seep, finfact + real(DP) :: f1, f2, d1, d2 + real(DP) :: trhsfinf, thcoffinf, trhsseep, thcofseep + integer(I4B) :: i, j +! ------------------------------------------------------------------------------ + ! + ! -- initialize + totfluxtot = DZERO + trhsfinf = DZERO + thcoffinf = DZERO + trhsseep = DZERO + thcofseep = DZERO + this%finf_rej = DZERO + this%surflux(icell) = this%finf(icell) + qfrommvr / this%uzfarea(icell) + this%watab(icell) = hgwf + this%vflow(icell) = DZERO + this%surfseep(icell) = DZERO + seep = DZERO + finfact = DZERO + this%etact(icell) = DZERO + this%surfluxbelow(icell) = DZERO + sumaet = DZERO + ! + ! -- set pet for gw when there is no UZ. + this%gwpet(icell) = this%pet(icell) + if (this%ivertcon(icell) > 0) then + this%finf(jbelow) = dzero + if (this%watab(icell) < this%celbot(icell)) & + this%watab(icell) = this%celbot(icell) + end if + if (this%watab(icell) > this%celtop(icell)) & + this%watab(icell) = this%celtop(icell) + if (this%surflux(icell) > this%vks(icell)) then + this%surflux(icell) = this%vks(icell) + end if + ! + ! -- infiltration excess -- rejected infiltration + if (this%landflag(icell) == 1) then + call rejfinf(this, icell, deriv, hgwf, trhsfinf, thcoffinf, finfact) + this%surflux(icell) = finfact + if (finfact < this%finf(icell)) then + this%surflux(icell) = finfact + end if + end if + ! + ! -- calculate rejected infiltration + this%finf_rej(icell) = this%finf(icell) + & + (qfrommvr / this%uzfarea(icell)) - this%surflux(icell) + ! + ! -- groundwater discharge + if (iseepflag > 0 .and. this%landflag(icell) == 1) then + call this%gwseep(icell, deriv, scale, hgwf, trhsseep, thcofseep, seep) + this%surfseep(icell) = seep + rgwseep = rgwseep + this%surfseep(icell) + end if + ! + ! sat. to unsat. zone exchange. + !if (this%landflag == 0 .and. issflag == 0) then + ! call this%vertcellflow(ipos,ttrhs,hgwf,hgwfml1,cvv) + !end if + !rvflux = rvflux + this%vflow + ! + ! -- route unsaturated flow, calc. storage change and recharge + test = this%watab(icell) + if (this%watabold(icell) - test < -DEM15) test = this%watabold(icell) + if (this%celtop(icell) - test > DEM15) then + if (issflag == 0) then + call this%routewaves(totfluxtot, delt, ietflag, icell, ierr) + if (ierr > 0) return + call this%uz_rise(icell, totfluxtot) + this%totflux(icell) = totfluxtot + if (this%ivertcon(icell) > 0) then + call this%addrech(icell, jbelow, hgwf, trhsfinf, thcoffinf, & + deriv, delt, 1) + end if + else + this%totflux(icell) = this%surflux(icell) * delt + totfluxtot = this%surflux(icell) * delt + end if + thcoffinf = dzero + trhsfinf = this%totflux(icell) * this%uzfarea(icell) / delt + call this%update_wav(icell, delt, rout, rsto, ret, ietflag, issflag, 0) + else + call this%update_wav(icell, delt, rout, rsto, ret, ietflag, issflag, 1) + totfluxtot = this%surflux(icell) * delt + this%totflux(icell) = this%surflux(icell) * delt + end if + rfinf = rfinf + this%sinf(icell) * this%uzfarea(icell) + rin = rin + this%surflux(icell) * this%uzfarea(icell) - & + this%surfluxbelow(icell) * this%uzfarea(icell) + ! + ! -- add spring flow and rejected infiltration to mover + qformvr = this%finf_rej(icell) * this%uzfarea(icell) + qgwformvr = this%surfseep(icell) + ! + ! -- process for observations + do i = 1, numobs + j = obs_num(i) + if (this%watab(icell) < this%celtop(icell)) then + if (this%celtop(icell) - obs_depth(j) > this%watab(icell)) then + d1 = obs_depth(j) - DEM3 + d2 = obs_depth(j) + DEM3 + f1 = this%unsat_stor(icell, d1) + f2 = this%unsat_stor(icell, d2) + obs_theta(j) = this%thtr(icell) + (f2 - f1) / (d2 - d1) + else + obs_theta(j) = this%thts(icell) + end if + else + obs_theta(j) = this%thts(icell) + end if + end do + ! + ! -- distribute residual PET to deeper cells + sumaet = sumaet + this%etact(icell) + if (this%ivertcon(icell) > 0) then + if (ietflag > 0) then + call this%setbelowpet(icell, jbelow, sumaet) + end if + end if + ! + ! -- return + return + end subroutine budget + + subroutine vertcellflow(this, icell, trhs, hgwf, hgwfml1, cvv) +! ****************************************************************************** +! vertcellflow -- calculate exchange from sat. to unsat. zones +! subroutine not used until sat to unsat flow is supported +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(UzfCellGroupType) :: this + integer(I4B), intent(in) :: icell + real(DP), intent(in) :: hgwf + real(DP), intent(in) :: hgwfml1 + real(DP), intent(in) :: cvv + real(DP), intent(inout) :: trhs + ! -- dummy + real(DP) :: Qv, maxvflow, h1, h2, test +! ------------------------------------------------------------------------------ + this%vflow(icell) = DZERO + this%finf(icell) = DZERO + trhs = DZERO + h1 = hgwfml1 + h2 = hgwf + test = this%watab(icell) + if (this%watabold(icell) - test < -DEM30) test = this%watabold(icell) + if (this%celtop(icell) - test > DEM30) then + ! + ! calc. downward flow using GWF heads and conductance + Qv = cvv * (h1 - h2) + if (Qv > DEM30) then + this%vflow(icell) = Qv + this%surflux(icell) = this%vflow(icell) / this%uzfarea(icell) + maxvflow = this%vks(icell) * this%uzfarea(icell) + if (this%vflow(icell) - maxvflow > DEM9) then + this%surflux(icell) = this%vks(icell) + trhs = this%vflow(icell) - maxvflow + this%vflow(icell) = maxvflow + end if + end if + end if + ! + ! -- return + return + end subroutine vertcellflow + + subroutine addrech(this, icell, jbelow, hgwf, trhs, thcof, deriv, delt, it) +! ****************************************************************************** +! addrech -- add recharge or infiltration to cells +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(UzfCellGroupType) :: this + integer(I4B), intent(in) :: icell + integer(I4B), intent(in) :: jbelow + integer(I4B), intent(in) :: it + real(DP), intent(inout) :: trhs + real(DP), intent(inout) :: thcof + real(DP), intent(inout) :: deriv + real(DP), intent(in) :: delt + real(DP), intent(in) :: hgwf + ! -- local + real(DP) :: fcheck + real(DP) :: x, scale, range +! ------------------------------------------------------------------------------ + ! + ! -- initialize + range = DEM5 + deriv = DZERO + thcof = DZERO + trhs = this%uzfarea(icell) * this%totflux(icell) / delt + if (this%totflux(icell) < DEM14) return + scale = DONE + ! + ! -- smoothly reduce flow between cells when head close to cell top + x = hgwf - (this%celbot(icell) - range) + call sSCurve(x, range, deriv, scale) + deriv = this%uzfarea(icell) * deriv * this%totflux(icell) / delt + this%finf(jbelow) = (DONE - scale) * this%totflux(icell) / delt + fcheck = this%finf(jbelow) - this%vks(jbelow) + ! + ! -- reduce flow between cells when vks is too small + if (fcheck < DEM14) fcheck = DZERO + this%finf(jbelow) = this%finf(jbelow) - fcheck + this%surfluxbelow(icell) = this%finf(jbelow) + this%totflux(icell) = scale * this%totflux(icell) + fcheck * delt + trhs = this%uzfarea(icell) * this%totflux(icell) / delt + ! + ! -- return + return + end subroutine addrech + + subroutine rejfinf(this, icell, deriv, hgwf, trhs, thcof, finfact) +! ****************************************************************************** +! rejfinf -- reject applied infiltration due to low vks +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(UzfCellGroupType) :: this + integer(I4B), intent(in) :: icell + real(DP), intent(inout) :: deriv + real(DP), intent(inout) :: finfact + real(DP), intent(inout) :: thcof + real(DP), intent(inout) :: trhs + real(DP), intent(in) :: hgwf + ! -- local + real(DP) :: x, range, scale, q +! ------------------------------------------------------------------------------ + range = this%surfdep(icell) + q = this%surflux(icell) + finfact = q + trhs = finfact * this%uzfarea(icell) + x = this%celtop(icell) - hgwf + call sLinear(x, range, deriv, scale) + deriv = -q * deriv * this%uzfarea(icell) * scale + if (scale < DONE) then + finfact = q * scale + trhs = finfact * this%uzfarea(icell) * this%celtop(icell) / range + thcof = finfact * this%uzfarea(icell) / range + end if + ! + ! -- return + return + end subroutine rejfinf + + subroutine gwseep(this, icell, deriv, scale, hgwf, trhs, thcof, seep) +! ****************************************************************************** +! gwseep -- calc. groudwater discharge to land surface +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(UzfCellGroupType) :: this + integer(I4B), intent(in) :: icell + real(DP), intent(inout) :: deriv + real(DP), intent(inout) :: trhs + real(DP), intent(inout) :: thcof + real(DP), intent(inout) :: seep + real(DP), intent(out) :: scale + real(DP), intent(in) :: hgwf + ! -- local + real(DP) :: x, range, y, deriv1, d1, d2, Q +! ------------------------------------------------------------------------------ + seep = DZERO + deriv = DZERO + deriv1 = DZERO + d1 = DZERO + d2 = DZERO + scale = DZERO + Q = this%uzfarea(icell) * this%vks(icell) + range = this%surfdep(icell) + x = hgwf - this%celtop(icell) + call sCubicLinear(x, range, deriv1, y) + scale = y + seep = scale * Q * (hgwf - this%celtop(icell)) / range + trhs = scale * Q * this%celtop(icell) / range + thcof = -scale * Q / range + d1 = -deriv1 * Q * x / range + d2 = -scale * Q / range + deriv = d1 + d2 + if (seep < DZERO) then + seep = DZERO + deriv = DZERO + trhs = DZERO + thcof = DZERO + end if + ! + ! -- return + return + end subroutine gwseep + + subroutine simgwet(this, igwetflag, icell, hgwf, trhs, thcof, et, det) +! ****************************************************************************** +! simgwet -- calc. gwf et using residual uzf pet +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(UzfCellGroupType) :: this + integer(I4B), intent(in) :: igwetflag + integer(I4B), intent(in) :: icell + real(DP), intent(in) :: hgwf + real(DP), intent(inout) :: trhs + real(DP), intent(inout) :: thcof + real(DP), intent(inout) :: det + real(DP), intent(inout) :: et + ! -- local + real(DP) :: s, x, c +! ------------------------------------------------------------------------------ + ! + this%gwet(icell) = DZERO + s = this%landtop(icell) + x = this%extdp(icell) + c = this%gwpet(icell) + if (x < DEM6) return + if (igwetflag == 1) then + et = etfunc_lin(s, x, c, det, trhs, thcof, hgwf, & + this%celtop(icell), this%celbot(icell)) + else if (igwetflag == 2) then + et = etfunc_nlin(s, x, c, det, trhs, thcof, hgwf) + end if + this%gwet(icell) = et * this%uzfarea(icell) + trhs = -trhs * this%uzfarea(icell) + thcof = thcof * this%uzfarea(icell) + ! + ! -- return + return + end subroutine simgwet + + function etfunc_lin(s, x, c, det, trhs, thcof, hgwf, celtop, celbot) +! ****************************************************************************** +! etfunc_lin -- calc. gwf et using linear ET function from mf-2005 +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + real(DP) :: etfunc_lin + ! -- dummy + real(DP), intent(in) :: s + real(DP), intent(in) :: x + real(DP), intent(in) :: c + real(DP), intent(inout) :: det + real(DP), intent(inout) :: trhs + real(DP), intent(inout) :: thcof + real(DP), intent(in) :: hgwf + real(DP), intent(in) :: celtop + real(DP), intent(in) :: celbot + ! -- local + real(DP) :: etgw + real(DP) :: range + real(DP) :: depth, scale, thick +! ------------------------------------------------------------------------------ + ! + ! -- Between ET surface and extinction depth + trhs = DZERO + thcof = DZERO + det = DZERO + if (hgwf > (s-x) .and. hgwf < s) THEN + etgw = (c * (hgwf - (s - x)) / x) + if (etgw > c) then + etgw = c + else + trhs = c - c * s / x + thcof = -c / x + etgw = trhs - (thcof * hgwf) + end if + ! + ! -- Above land surface + else if (hgwf >= s) then + trhs = c + etgw = c + ! + ! Below extinction depth + else + etgw = DZERO + end if + ! + ! -- calculate rate + depth = hgwf - (s - x) + thick = celtop - celbot + if (depth > thick) depth = thick + if (depth < dzero) depth = dzero + range = DEM4 * x + call sCubic(depth, range, det, scale) + etgw = scale * etgw + det = -det * etgw + etfunc_lin = etgw + ! + ! -- return + return + end function etfunc_lin + + + function etfunc_nlin(s, x, c, det, trhs, thcof, hgwf) +! ****************************************************************************** +! etfunc_nlin -- Square-wave ET function with smoothing at extinction depth +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + real(DP) :: etfunc_nlin + ! -- dummy + real(DP), intent(in) :: s + real(DP), intent(in) :: x + real(DP), intent(in) :: c + real(DP), intent(inout) :: det + real(DP), intent(inout) :: trhs + real(DP), intent(inout) :: thcof + real(DP), intent(in) :: hgwf + ! -- local + real(DP) :: etgw + real(DP) :: range + real(DP) :: depth, scale +! ------------------------------------------------------------------------------ + det = DZERO + trhs = DZERO + thcof = DZERO + depth = hgwf - (s - x) + if (depth < DZERO) depth = DZERO + etgw = c + range = DEM3 * x + call sCubic(depth, range, det, scale) + etgw = etgw * scale + trhs = -etgw + det = -det * etgw + etfunc_nlin = etgw + ! + ! -- return + return + end function etfunc_nlin + + subroutine uz_rise(this, icell, totfluxtot) +! ****************************************************************************** +! uz_rise -- calculate recharge due to a rise in the gwf head +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(UzfCellGroupType) :: this + integer(I4B), intent(in) :: icell + real(DP), intent(inout) :: totfluxtot + ! -- local + real(DP) :: fm1, fm2, d1 +! ------------------------------------------------------------------------------ + ! + ! -- additional recharge from a rising water table + if (this%watab(icell) - this%watabold(icell) > DEM30) then + d1 = this%celtop(icell) - this%watabold(icell) + fm1 = this%unsat_stor(icell, d1) + d1 = this%celtop(icell) - this%watab(icell) + fm2 = this%unsat_stor(icell, d1) + totfluxtot = totfluxtot + (fm1 - fm2) + end if + ! + ! -- return + return + end subroutine uz_rise + + subroutine setwaves(this, icell) +! ****************************************************************************** +! setwaves -- reset waves to default values at start of simulation +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(UzfCellGroupType) :: this + ! -- local + integer(I4B), intent(in) :: icell + real(DP) :: bottom, top + integer(I4B) :: jk + real(DP) :: thick +! ------------------------------------------------------------------------------ + ! + ! -- initialize + this%uzstor(icell) = DZERO + this%delstor(icell) = DZERO + this%totflux(icell) = DZERO + this%nwavst(icell) = 1 + this%uzdpst(:, icell) = DZERO + thick = this%celtop(icell) - this%watab(icell) + do jk = 1, this%nwav(icell) + this%uzthst(jk, icell) = this%thtr(icell) + end do + ! + ! -- initialize waves for first stress period + if (thick > DZERO) then + this%uzdpst(1, icell) = thick + this%uzthst(1, icell) = this%thti(icell) + top = this%uzthst(1, icell) - this%thtr(icell) + if (top < DZERO) top = DZERO + bottom = this%thts(icell) - this%thtr(icell) + if (bottom < DZERO) bottom = DZERO + this%uzflst(1, icell) = this%vks(icell) * (top / bottom) ** this%eps(icell) + if (this%uzthst(1, icell) < this%thtr(icell)) & + this%uzthst(1, icell) = this%thtr(icell) + ! + ! -- calculate water stored in the unsaturated zone + if (top > DZERO) then + this%uzstor(icell) = this%uzdpst(1, icell) * top * this%uzfarea(icell) + this%uzspst(1, icell) = DZERO + this%uzolsflx(icell) = this%uzflst(1, icell) + else + this%uzstor(icell) = DZERO + this%uzflst(1, icell) = DZERO + this%uzspst(1, icell) = DZERO + this%uzolsflx(icell) = DZERO + end if + ! + ! no unsaturated zone + else + this%uzflst(1, icell) = DZERO + this%uzdpst(1, icell) = DZERO + this%uzspst(1, icell) = DZERO + this%uzthst(1, icell) = this%thtr(icell) + this%uzstor(icell) = DZERO + this%uzolsflx(icell) = this%finf(icell) + end if + ! + ! -- return + return + end subroutine + + subroutine routewaves(this, totfluxtot, delt, ietflag, icell, ierr) +! ****************************************************************************** +! routewaves -- prepare and route waves over time step +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! + ! -- dummy + class(UzfCellGroupType) :: this + real(DP), intent(inout) :: totfluxtot + real(DP), intent(in) :: delt + integer(I4B), intent(in) :: ietflag + integer(I4B), intent(in) :: icell + integer(I4B), intent(inout) :: ierr + ! -- local + real(DP) :: thick, thickold + integer(I4B) :: idelt, iwav, ik +! ------------------------------------------------------------------------------ + ! + ! -- initialize + this%totflux(icell) = DZERO + this%etact(icell) = DZERO + thick = this%celtop(icell) - this%watab(icell) + thickold = this%celtop(icell) - this%watabold(icell) + ! + ! -- no uz, clear waves + if (thickold < DZERO) then + do iwav = 1, 6 + this%uzthst(iwav, icell) = this%thtr(icell) + this%uzdpst(iwav, icell) = DZERO + this%uzspst(iwav, icell) = DZERO + this%uzflst(iwav, icell) = DZERO + this%nwavst(icell) = 1 + end do + end if + idelt = 1 + do ik = 1, idelt + call this%uzflow(thick, thickold, delt, ietflag, icell, ierr) + if (ierr > 0) return + totfluxtot = totfluxtot + this%totflux(icell) + end do + ! + ! -- set residual pet after uz et + this%gwpet(icell) = this%pet(icell) - this%etact(icell) / delt + if (this%gwpet(icell) < DZERO) this%gwpet(icell) = DZERO + ! + ! -- return + return + end subroutine routewaves + + subroutine wave_shift(this, this2, icell, icell2, shft, strt, stp, cntr) +! ****************************************************************************** +! wave_shift -- copy waves or shift waves in arrays +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class (UzfCellGroupType) :: this + type (UzfCellGroupType) :: this2 + integer(I4B), intent(in) :: icell + integer(I4B), intent(in) :: icell2 + integer(I4B), intent(in) :: shft + integer(I4B), intent(in) :: strt + integer(I4B), intent(in) :: stp + integer(I4B), intent(in) :: cntr + ! -- local + integer(I4B) :: j +! ------------------------------------------------------------------------------ + ! + ! -- copy waves from one uzf cell group to another + do j = strt, stp, cntr + this%uzthst(j, icell) = this2%uzthst(j + shft, icell2) + this%uzdpst(j, icell) = this2%uzdpst(j + shft, icell2) + this%uzflst(j, icell) = this2%uzflst(j + shft, icell2) + this%uzspst(j, icell) = this2%uzspst(j + shft, icell2) + end do + this%nwavst(icell) = this2%nwavst(icell2) + ! + ! -- return + return + end subroutine + + subroutine uzflow(this, thick, thickold, delt, ietflag, icell, ierr) +! ****************************************************************************** +! uzflow -- moc solution for kinematic wave equation +! ****************************************************************************** +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class (UzfCellGroupType) :: this + real(DP), intent(inout) :: thickold + real(DP), intent(inout) :: thick + real(DP), intent(in) :: delt + integer(I4B), intent(in) :: ietflag + integer(I4B), intent(in) :: icell + integer(I4B), intent(inout) :: ierr + ! -- local + real(DP) :: ffcheck, time, feps1, feps2 + real(DP) :: thetadif, thetab, fluxb, oldsflx + integer(I4B) :: itrailflg, itester +! ------------------------------------------------------------------------------ + time = DZERO + this%totflux(icell) = DZERO + itrailflg = 0 + oldsflx = this%uzflst(this%nwavst(icell), icell) + call factors(feps1, feps2) + ! + ! -- check for falling or rising water table + if ((thick - thickold) > feps1) then + thetadif = abs(this%uzthst(1, icell) - this%thtr(icell)) + if (thetadif > DEM6) then + call this%wave_shift(this, icell, icell, -1, this%nwavst(icell) + 1, 2, -1) + if (this%uzdpst(2, icell) < DEM30) & + this%uzdpst(2, icell) = (this%ntrail(icell) + DTWO) * DEM6 + if (this%uzthst(2, icell) > this%thtr(icell)) then + this%uzspst(2, icell) = this%uzflst(2, icell) / & + (this%uzthst(2, icell) - this%thtr(icell)) + else + this%uzspst(2, icell) = DZERO + end if + this%uzthst(1, icell) = this%thtr(icell) + this%uzflst(1, icell) = DZERO + this%uzspst(1, icell) = DZERO + this%uzdpst(1, icell) = thick + this%nwavst(icell) = this%nwavst(icell) + 1 + if (this%nwavst(icell) >= this%nwav(icell)) then + ! -- too many waves error + ierr = 1 + return + end if + else + this%uzdpst(1, icell) = thick + end if + end if + thetab = this%uzthst(1, icell) + fluxb = this%uzflst(1, icell) + this%totflux(icell) = DZERO + itester = 0 + ffcheck = (this%surflux(icell)-this%uzflst(this%nwavst(icell), icell)) + ! + ! -- increase new waves in infiltration changes + if (ffcheck > feps2 .OR. ffcheck < -feps2) then + this%nwavst(icell) = this%nwavst(icell) + 1 + if (this%nwavst(icell) >= this%nwav(icell)) then + ! + ! -- too many waves error + ierr = 1 + return + end if + else if (this%nwavst(icell) == 1) then + itester = 1 + end if + if (this%nwavst(icell) > 1) then + if (ffcheck < -feps2) then + call this%trailwav(icell, ierr) + if (ierr > 0) return + itrailflg = 1 + end if + call this%leadwav(time, itester, itrailflg, thetab, fluxb, ffcheck, & + feps2, delt, icell) + end if + if (itester == 1) then + this%totflux(icell) = this%totflux(icell) + & + (delt - time) * this%uzflst(1, icell) + time = DZERO + itester = 0 + end if + ! + ! -- simulate et + if (ietflag > 0) call this%uzet(icell, delt, ietflag, ierr) + if (ierr > 0) return + ! + ! -- return + return + end subroutine uzflow + + subroutine factors(feps1, feps2) +! ****************************************************************************** +! factors----calculate unit specific tolerances +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + real(DP), intent(out) :: feps1 + real(DP), intent(out) :: feps2 + real(DP) :: factor1 + real(DP) :: factor2 +! ------------------------------------------------------------------------------ + ! + ! calculate constants for uzflow + factor1 = DONE + factor2 = DONE + feps1 = DEM9 + feps2 = DEM9 + if (ITMUNI == 1) then + factor1 = DONE / 86400.D0 + else if (ITMUNI == 2) then + factor1 = DONE / 1440.D0 + else if (ITMUNI == 3) then + factor1 = DONE / 24.0D0 + else if (ITMUNI == 5) then + factor1 = 365.0D0 + end if + factor2 = DONE / 0.3048 + feps1 = feps1 * factor1 * factor2 + feps2 = feps2 * factor1 * factor2 + ! + ! -- return + return + end subroutine factors + + subroutine trailwav(this, icell, ierr) +! ****************************************************************************** +! trailwav----create and set trail waves +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class (UzfCellGroupType) :: this + integer(I4B), intent(in) :: icell + integer(I4B), intent(inout) :: ierr + ! -- local + real(DP) :: smoist, smoistinc, ftrail, eps_m1 + real(DP) :: thtsrinv + real(DP) :: flux1, flux2, theta1, theta2 + real(DP) :: fnuminc + integer(I4B) :: j, jj, jk, nwavstm1 +! ------------------------------------------------------------------------------ + ! + ! -- initialize + eps_m1 = dble(this%eps(icell)) - DONE + thtsrinv = DONE / (this%thts(icell) - this%thtr(icell)) + nwavstm1 = this%nwavst(icell) - 1 + ! + ! -- initialize trailwaves + smoist = (((this%surflux(icell) / this%vks(icell)) ** & + (DONE / this%eps(icell))) * & + (this%thts(icell) - this%thtr(icell))) + this%thtr(icell) + if (this%uzthst(nwavstm1, icell) - smoist > DEM9) then + fnuminc = DZERO + do jk = 1, this%ntrail(icell) + fnuminc = fnuminc + float(jk) + end do + smoistinc = (this%uzthst(nwavstm1, icell) - smoist) / (fnuminc - DONE) + jj = this%ntrail(icell) + ftrail = dble(this%ntrail(icell)) + DONE + do j = this%nwavst(icell), this%nwavst(icell) + this%ntrail(icell) - 1 + if (j > this%nwav(icell)) then + ! -- too many waves error + ierr = 1 + return + end if + if (j > this%nwavst(icell)) then + this%uzthst(j, icell) = this%uzthst(j - 1, icell) & + - ((ftrail - float(jj)) * smoistinc) + else + this%uzthst(j, icell) = this%uzthst(j - 1, icell) - DEM9 + end if + jj = jj - 1 + if (this%uzthst(j, icell) <= this%thtr(icell) + DEM9) & + this%uzthst(j, icell) = this%thtr(icell) + DEM9 + this%uzflst(j, icell) = this%vks(icell) * & + (((this%uzthst(j, icell) - this%thtr(icell)) * thtsrinv) ** & + this%eps(icell)) + theta2 = this%uzthst(j - 1, icell) + flux2 = this%uzflst(j - 1, icell) + flux1 = this%uzflst(j, icell) + theta1 = this%uzthst(j, icell) + this%uzspst(j, icell) = leadspeed(theta1, theta2, flux1, & + flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & + this%vks(icell)) + this%uzdpst(j, icell) = DZERO + if (j == this%nwavst(icell)) then + this%uzdpst(j, icell) = this%uzdpst(j, icell) + (this%ntrail(icell) + 1) * DEM9 + else + this%uzdpst(j, icell) = this%uzdpst(j - 1, icell) - DEM9 + end if + end do + this%nwavst(icell) = this%nwavst(icell) + this%ntrail(icell) - 1 + if (this%nwavst(icell) >= this%nwav(icell)) then + ! -- too many waves error + ierr = 1 + return + end if + else + this%uzdpst(this%nwavst, icell) = DZERO + this%uzflst(this%nwavst, icell) = this%vks(icell) * & + (((this%uzthst(this%nwavst, icell) - this%thtr(icell)) * & + thtsrinv) ** this%eps(icell)) + this%uzthst(this%nwavst, icell) = smoist + theta2 = this%uzthst(this%nwavst(icell) - 1, icell) + flux2 = this%uzflst(this%nwavst(icell) - 1, icell) + flux1 = this%uzflst(this%nwavst(icell), icell) + theta1 = this%uzthst(this%nwavst(icell), icell) + this%uzspst(this%nwavst(icell), icell) = leadspeed(theta1, theta2, flux1, & + flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & + this%vks(icell)) + end if + ! + ! -- return + return + end subroutine trailwav + + subroutine leadwav(this, time, itester, itrailflg, thetab, fluxb, & + ffcheck, feps2, delt, icell) +! ****************************************************************************** +! leadwav----create a lead wave and route over time step +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class (UzfCellGroupType) :: this + real(DP), intent(inout) :: thetab + real(DP), intent(inout) :: fluxb + real(DP), intent(in) :: feps2 + real(DP), intent(inout) :: time + integer(I4B), intent(inout) :: itester + integer(I4B), intent(inout) :: itrailflg + real(DP), intent(inout) :: ffcheck + real(DP), intent(in) :: delt + integer(I4B), intent(in) :: icell + ! -- local + real(DP) :: bottomtime, shortest, fcheck + real(DP) :: eps_m1, timenew, bottom, timedt + real(DP) :: thtsrinv, diff, fluxhld2 + real(DP) :: flux1, flux2, theta1, theta2, ftest + real(DP), allocatable, dimension(:) :: checktime + integer(I4B) :: iflx, iremove, j, l + integer(I4B) :: nwavp1, jshort + integer(I4B), allocatable, dimension(:) :: more +! ------------------------------------------------------------------------------ + allocate(checktime(this%nwavst(icell))) + allocate(more(this%nwavst(icell))) + ftest = DZERO + eps_m1 = dble(this%eps(icell)) - DONE + thtsrinv = DONE / (this%thts(icell) - this%thtr(icell)) + ! + ! -- initialize new wave + if (itrailflg == 0) then + if (ffcheck > feps2) then + this%uzflst(this%nwavst(icell), icell) = this%surflux(icell) + if (this%uzflst(this%nwavst(icell), icell) < DEM30) & + this%uzflst(this%nwavst(icell), icell) = DZERO + this%uzthst(this%nwavst(icell), icell) = & + (((this%uzflst(this%nwavst(icell), icell) / this%vks(icell)) ** & + (DONE / this%eps(icell))) * (this%thts(icell) - this%thtr(icell))) & + + this%thtr(icell) + theta2 = this%uzthst(this%nwavst(icell), icell) + flux2 = this%uzflst(this%nwavst(icell), icell) + flux1 = this%uzflst(this%nwavst(icell) - 1, icell) + theta1 = this%uzthst(this%nwavst(icell) - 1, icell) + this%uzspst(this%nwavst(icell), icell) = leadspeed(theta1, theta2, flux1, & + flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & + this%vks(icell)) + this%uzdpst(this%nwavst(icell), icell) = DZERO + end if + end if + ! + ! -- route all waves and interception of waves over times step + diff = DONE + timedt = DZERO + iflx = 0 + fluxhld2 = this%uzflst(1, icell) + if (this%nwavst(icell) == 0) itester = 1 + if (itester /= 1) then + do while (diff > DEM6) + nwavp1 = this%nwavst(icell) + 1 + timedt = delt - Time + do j = 1, this%nwavst(icell) + checktime(j) = DEP20 + more(j) = 0 + end do + shortest = timedt + if (this%nwavst(icell) > 2) then + j = 2 + ! + ! -- calculate time until wave overtakes wave ahead + nwavp1 = this%nwavst(icell) + 1 + do while (j < nwavp1) + ftest = this%uzspst(j - 1, icell) - this%uzspst(j, icell) + if (abs(ftest) > DEM30) then + checktime(j) = (this%uzdpst(j, icell) - this%uzdpst(j - 1, icell)) / ftest + if (checktime(j) < DEM30) checktime(j) = DEP20 + end if + j = j + 1 + end do + end if + ! + ! - calc time until wave reaches bottom of cell + bottomtime = DEP20 + if (this%nwavst(icell) > 1) then + if (this%uzspst(2, icell) > DZERO) then + bottom = this%uzspst(2, icell) + if (bottom < DEM15) bottom = DEM15 + bottomtime = (this%uzdpst(1, icell) - this%uzdpst(2, icell)) / bottom + if (bottomtime < DZERO) bottomtime = DEM12 + end if + end if + ! + ! -- calc time for wave interception + jshort = 0 + do j = this%nwavst(icell), 3, -1 + if (shortest - checktime(j) > -DEM9) then + more(j) = 1 + jshort = j + shortest = checktime(j) + end if + end do + do j = 3, this%nwavst(icell) + if (shortest - checktime(j) < DEM9) then + if (j /= jshort) more(j) = 0 + end if + end do + ! + ! -- what happens first, waves hits bottom or interception + iremove = 0 + timenew = Time + fcheck = (Time + shortest) - delt + if (shortest < DEM7) fcheck = -DONE + if (bottomtime < shortest .AND. Time + bottomtime < delt) then + j = 2 + do while (j < nwavp1) + ! + ! -- route waves + this%uzdpst(j, icell) = this%uzdpst(j, icell) + & + this%uzspst(j, icell) * bottomtime + j = j + 1 + end do + fluxb = this%uzflst(2, icell) + thetab = this%uzthst(2, icell) + iflx = 1 + call this%wave_shift(this, icell, icell, 1, 1, this%nwavst(icell) - 1, 1) + iremove = 1 + timenew = time + bottomtime + this%uzspst(1, icell) = DZERO + ! + ! -- do waves intercept before end of time step + else if (fcheck < DZERO .AND. this%nwavst(icell) > 2) then + j = 2 + do while (j < nwavp1) + this%uzdpst(j, icell) = this%uzdpst(j, icell) + & + this%uzspst(j, icell) * shortest + j = j + 1 + end do + ! + ! -- combine waves that intercept, remove a wave + j = 3 + l = j + do while (j < this%nwavst(icell) + 1) + if (more(j) == 1) then + l = j + theta2 = this%uzthst(j, icell) + flux2 = this%uzflst(j, icell) + if (j == 3) then + flux1 = fluxb + theta1 = thetab + else + flux1 = this%uzflst(j - 2, icell) + theta1 = this%uzthst(j - 2, icell) + end if + this%uzspst(j, icell) = leadspeed(theta1, theta2, flux1, & + flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & + this%vks(icell)) + ! + ! -- update waves + call this%wave_shift(this, icell, icell, 1, l - 1, this%nwavst(icell) - 1, 1) + l = this%nwavst(icell) + 1 + iremove = iremove + 1 + end if + j = j + 1 + end do + timenew = timenew + shortest + ! + ! -- calc. total flux to bottom during remaining time in step + else + j = 2 + do while (j < nwavp1) + this%uzdpst(j, icell) = this%uzdpst(j, icell) + & + this%uzspst(j, icell) * timedt + j = j + 1 + end do + timenew = delt + end if + this%totflux(icell) = this%totflux(icell) + fluxhld2 * (timenew - time) + if (iflx == 1) then + fluxhld2 = this%uzflst(1, icell) + iflx = 0 + end if + ! + ! -- remove dead waves + this%nwavst(icell) = this%nwavst(icell) - iremove + time = timenew + diff = delt - Time + if (this%nwavst(icell) == 1) then + itester = 1 + exit + end if + end do + end if + deallocate(checktime) + deallocate(more) + ! + ! -- return + return + end subroutine leadwav + + function leadspeed(theta1, theta2, flux1, flux2, thts, thtr, eps, vks) +! ****************************************************************************** +! leadspeed----calculates waves speed from dflux/dtheta +! ****************************************************************************** +! SPECIFICATIONS: +! +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + real(DP) :: leadspeed + ! -- dummy + real(DP), intent(in) :: theta1 + real(DP), intent(in) :: theta2 + real(DP), intent(in) :: flux1 + real(DP), intent(inout) :: flux2 + real(DP), intent(in) :: thts + real(DP), intent(in) :: thtr + real(DP), intent(in) :: eps + real(DP), intent(in) :: vks + ! -- local + real(DP) :: comp1, comp2, thsrinv, epsfksths + real(DP) :: eps_m1, fhold, comp3 +! ------------------------------------------------------------------------------ + ! + eps_m1 = eps - DONE + thsrinv = DONE / (thts - thtr) + epsfksths = eps * vks * thsrinv + comp1 = theta2 - theta1 + comp2 = abs(flux2 - flux1) + comp3 = theta1 - thtr + if (comp2 < DEM15) flux2 = flux1 + DEM15 + if (abs(comp1) < DEM30) then + if (comp3 > DEM30) fhold = (comp3 * thsrinv) ** eps + if (fhold < DEM30) fhold = DEM30 + leadspeed = epsfksths * (fhold ** eps_m1) + else + leadspeed = (flux2 - flux1) / (theta2 - theta1) + end if + if (leadspeed < DEM30) leadspeed = DEM30 + ! + ! -- return + return + end function leadspeed + + function unsat_stor(this, icell, d1) +! ****************************************************************************** +! unsat_stor---- sums up mobile water over depth interval +! ****************************************************************************** +! SPECIFICATIONS: +! +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + real(DP) :: unsat_stor + ! -- dummy + class (UzfCellGroupType) :: this + integer(I4B), intent(in) :: icell + real(DP), intent(inout) :: d1 + ! -- local + real(DP) :: fm + integer(I4B) :: j, k, nwavm1, jj +! ------------------------------------------------------------------------------ + fm = DZERO + j = this%nwavst(icell) + 1 + k = this%nwavst(icell) + nwavm1 = k - 1 + if (d1 > this%uzdpst(1, icell)) d1 = this%uzdpst(1, icell) + ! + ! -- find deepest wave above depth d1, counter held as j + do while (k > 0) + if (this%uzdpst(k, icell) - d1 < -DEM30) j = k + k = k - 1 + end do + if (j > this%nwavst(icell)) then + fm = fm + (this%uzthst(this%nwavst(icell), icell) - this%thtr(icell)) * d1 + elseif (this%nwavst(icell) > 1) then + if (j > 1) then + fm = fm + (this%uzthst(j - 1, icell) - this%thtr(icell)) & + * (d1 - this%uzdpst(j, icell)) + end if + do jj = j, nwavm1 + fm = fm + (this%uzthst(jj, icell) - this%thtr(icell)) & + * (this%uzdpst(jj, icell) & + - this%uzdpst(jj + 1, icell)) + end do + fm = fm + (this%uzthst(this%nwavst(icell), icell) - this%thtr(icell)) & + * (this%uzdpst(this%nwavst(icell), icell)) + else + fm = fm + (this%uzthst(1, icell) - this%thtr(icell)) * d1 + end if + unsat_stor = fm + end function unsat_stor + + subroutine update_wav(this, icell, delt, rout, rsto, ret, etflg, iss, itest) +! ****************************************************************************** +! update_wav -- update to new state of uz at end of time step +! ****************************************************************************** +! SPECIFICATIONS: +! +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class (UzfCellGroupType) :: this + integer(I4B), intent(in) :: icell + integer(I4B), intent(in) :: etflg + integer(I4B), intent(in) :: itest + integer(I4B), intent(in) :: iss + real(DP), intent(in) :: delt + real(DP), intent(inout) :: rout + real(DP), intent(inout) :: rsto + real(DP), intent(inout) :: ret + ! -- local + real(DP) :: uzstorhold, bot, fm, depthsave, top + real(DP) :: thick, thtsrinv + integer(I4B) :: nwavhld, k, j +! ------------------------------------------------------------------------------ + ! + bot = this%watab(icell) + top = this%celtop(icell) + thick = top - bot + nwavhld = this%nwavst(icell) + if (itest == 1) then + this%uzflst(1, icell) = DZERO + this%uzthst(1, icell) = this%thtr(icell) + this%delstor(icell) = - this%uzstor(icell) + this%uzstor(icell) = DZERO + uzstorhold = DZERO + rout = rout + this%totflux(icell) * this%uzfarea(icell) / delt + return + end if + if (iss == 1) then + if (this%thts(icell) - this%thtr(icell) < DEM7) then + thtsrinv = DONE / DEM7 + else + thtsrinv = DONE / (this%thts(icell) - this%thtr(icell)) + end if + this%totflux(icell) = this%surflux(icell) * delt + this%watabold(icell) = this%watab(icell) + this%uzthst(1, icell) = this%thti(icell) + this%uzflst(1, icell) = this%vks(icell) * (((this%uzthst(1, icell) - this%thtr(icell)) & + * thtsrinv) ** this%eps(icell)) + this%uzdpst(1, icell) = thick + this%uzspst(1, icell) = thick + this%nwavst(icell) = 1 + this%uzstor(icell) = thick * (this%thti(icell) - this%thtr(icell)) * this%uzfarea(icell) + this%delstor(icell) = DZERO + rout = rout + this%totflux(icell) * this%uzfarea(icell) / delt + else + ! + ! -- water table rises through waves + if (this%watab(icell) - this%watabold(icell) > DEM30) then + depthsave = this%uzdpst(1, icell) + j = 0 + k = this%nwavst(icell) + do while (k > 0) + if (this%uzdpst(k, icell) - thick < -DEM30) j = k + k = k - 1 + end do + this%uzdpst(1, icell) = thick + if (j > 1) then + this%uzspst(1, icell) = DZERO + this%nwavst(icell) = this%nwavst(icell) - j + 2 + this%uzthst(1, icell) = this%uzthst(j - 1, icell) + this%uzflst(1, icell) = this%uzflst(j - 1, icell) + if (j > 2) call this%wave_shift(this, icell, icell, j-2, 2, nwavhld - (j - 2), 1) + elseif (j == 0) then + this%uzspst(1, icell) = DZERO + this%uzthst(1, icell) = this%uzthst(this%nwavst(icell), icell) + this%uzflst(1, icell) = this%uzflst(this%nwavst(icell), icell) + this%nwavst(icell) = 1 + end if + end if + ! + ! -- calculate new unsat. storage + if (thick > DZERO) then + fm = this%unsat_stor(icell, thick) + uzstorhold = this%uzstor(icell) + this%uzstor(icell) = fm * this%uzfarea(icell) + this%delstor(icell) = this%uzstor(icell) - uzstorhold + else + this%uzspst(1, icell) = DZERO + this%nwavst(icell) = 1 + this%uzthst(1, icell) = this%thtr(icell) + this%uzflst(1, icell) = DZERO + this%delstor(icell) = -this%uzstor(icell) + this%uzstor(icell) = DZERO + uzstorhold = DZERO + end if + this%watabold(icell) = this%watab(icell) + rout = rout + this%totflux(icell) * this%uzfarea(icell) / delt + rsto = rsto + this%delstor(icell) / delt + if (etflg > 0) ret = ret + this%etact(icell) * this%uzfarea(icell) / delt + end if + end subroutine update_wav + + subroutine uzet(this, icell, delt, ietflag, ierr) +! ****************************************************************************** +! uzet -- remove water from uz due to et +! ****************************************************************************** +! SPECIFICATIONS: +! +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class (UzfCellGroupType) :: this + integer(I4B), intent(in) :: icell + real(DP), intent(in) :: delt + integer(I4B), intent(in) :: ietflag + integer(I4B), intent(inout) :: ierr + ! -- local + type(UzfCellGroupType) :: uzfktemp + real(DP) :: diff,thetaout,fm,st + real(DP) :: thtsrinv,epsfksthts,fmp + real(DP) :: fktho,theta1,theta2,flux1,flux2 + real(DP) :: hcap,ha,factor,tho,depth + real(DP) :: extwc1,petsub + integer(I4B) :: i,j,jhold,jk,kj,kk,numadd,k,nwv,itest +! ------------------------------------------------------------------------------ + ! + ! -- initialize + this%etact = DZERO + if (this%extdpuz(icell) < DEM7) return + petsub = this%rootact(icell) * this%pet(icell) * this%extdpuz(icell) / this%extdp(icell) + thetaout = delt * petsub / this%extdp(icell) + if (ietflag == 1) thetaout = delt * this%pet(icell) / this%extdp(icell) + if (thetaout < DEM10) return + depth = this%uzdpst(1, icell) + st = this%unsat_stor(icell, depth) + if (st < DEM4) return + ! + ! -- allocate temporary wave storage. + ha = this%ha(icell) + nwv = this%nwavst(icell) + itest = 0 + call uzfktemp%init(1, nwv) + ! + ! store original wave characteristics + call uzfktemp%wave_shift(this, 1, icell, 0, 1, nwv, 1) + factor = DONE + this%etact = DZERO + if (this%thts(icell) - this%thtr(icell) < DEM7) then + thtsrinv = 1.0 / DEM7 + else + thtsrinv = DONE / (this%thts(icell) - this%thtr(icell)) + end if + epsfksthts = this%eps(icell) * this%vks(icell) * thtsrinv + this%etact(icell) = DZERO + fmp = DZERO + extwc1 = this%extwc(icell) - this%thtr(icell) + if (extwc1 < DEM6) extwc1 = DEM7 + numadd = 0 + fm = st + k = 0 + ! + ! -- loop for reducing aet to pet when et is head dependent + do while (itest == 0) + k = k + 1 + if (k > 1 .AND. ABS(fmp - petsub) > DEM5 * petsub) factor = factor / (fm / petsub) + ! + ! -- one wave shallower than extdp + if (this%nwavst(icell) == 1 .AND. this%uzdpst(1, icell) <= this%extdpuz(icell)) then + if (ietflag == 2) then + tho = this%uzthst(1, icell) + fktho = this%uzflst(1, icell) + hcap = this%caph(icell, tho) + thetaout = this%rate_et_z(icell, factor, fktho, hcap) + end if + if ((this%uzthst(1, icell) - thetaout) > this%thtr(icell) + extwc1) then + this%uzthst(1, icell) = this%uzthst(1, icell) - thetaout + this%uzflst(1, icell) = this%vks(icell) * (((this%uzthst(1, icell) - & + this%thtr(icell)) * thtsrinv) ** this%eps(icell)) + else if (this%uzthst(1, icell) > this%thtr(icell) + extwc1) then + this%uzthst(1, icell) = this%thtr(icell) + extwc1 + this%uzflst(1, icell) = this%vks(icell) * (((this%uzthst(1, icell) - & + this%thtr(icell)) * thtsrinv) ** this%eps(icell)) + end if + ! + ! -- all waves shallower than extinction depth + else if (this%nwavst(icell) > 1 .AND. this%uzdpst(this%nwavst(icell), icell) > this%extdpuz(icell)) then + if (ietflag == 2) then + tho = this%uzthst(this%nwavst(icell), icell) + fktho = this%uzflst(this%nwavst(icell), icell) + hcap = this%caph(icell, tho) + thetaout = this%rate_et_z(icell, factor, fktho, hcap) + end if + if (this%uzthst(this%nwavst(icell), icell) - thetaout > this%thtr(icell) + extwc1) then + this%uzthst(this%nwavst(icell) + 1, icell) = this%uzthst(this%nwavst(icell), icell) - thetaout + numadd = 1 + else if (this%uzthst(this%nwavst(icell), icell) > this%thtr(icell) + extwc1) then + this%uzthst(this%nwavst(icell) + 1, icell) = this%thtr(icell) + extwc1 + numadd = 1 + end if + if (numadd == 1) then + this%uzflst(this%nwavst(icell) + 1, icell) = this%vks(icell) * & + (((this%uzthst(this%nwavst(icell) + 1, icell) - & + this%thtr(icell)) * thtsrinv) ** this%eps(icell)) + theta2 = this%uzthst(this%nwavst(icell) + 1, icell) + flux2 = this%uzflst(this%nwavst(icell) + 1, icell) + flux1 = this%uzflst(this%nwavst(icell), icell) + theta1 = this%uzthst(this%nwavst(icell), icell) + this%uzspst(this%nwavst(icell) + 1, icell) = leadspeed(theta1, theta2, flux1, & + flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & + this%vks(icell)) + this%uzdpst(this%nwavst(icell) + 1, icell) = this%extdpuz(icell) + this%nwavst(icell) = this%nwavst(icell) + 1 + if (this%nwavst(icell) > this%nwav(icell)) then + ! + ! -- too many waves error, deallocate temp arrays and return + ierr = 1 + goto 500 + end if + else + numadd = 0 + end if + ! + ! -- one wave below extinction depth + else if (this%nwavst(icell) == 1) then + if (ietflag == 2) then + tho = this%uzthst(1, icell) + fktho = this%uzflst(1, icell) + hcap = this%caph(icell, tho) + thetaout = this%rate_et_z(icell, factor, fktho, hcap) + end if + if ((this%uzthst(1, icell) - thetaout) > this%thtr(icell) + extwc1) then + if (thetaout > DEM30) then + this%uzthst(2, icell) = this%uzthst(1, icell) - thetaout + this%uzflst(2, icell) = this%vks(icell) * (((this%uzthst(2, icell) - this%thtr(icell)) * & + thtsrinv) ** this%eps(icell)) + this%uzdpst(2, icell) = this%extdpuz(icell) + theta2 = this%uzthst(2, icell) + flux2 = this%uzflst(2, icell) + flux1 = this%uzflst(1, icell) + theta1 = this%uzthst(1, icell) + this%uzspst(2, icell) = leadspeed(theta1, theta2, flux1, & + flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & + this%vks(icell)) + this%nwavst(icell) = this%nwavst(icell) + 1 + if (this%nwavst(icell) > this%nwav(icell)) then + ! + ! -- too many waves error + ierr = 1 + goto 500 + end if + end if + else if (this%uzthst(1, icell) > this%thtr(icell) + extwc1) then + if (thetaout > DEM30) then + this%uzthst(2, icell) = this%thtr(icell) + extwc1 + this%uzflst(2, icell) = this%vks(icell) * (((this%uzthst(2, icell) - & + this%thtr(icell)) * thtsrinv) ** this%eps(icell)) + this%uzdpst(2, icell) = this%extdpuz(icell) + theta2 = this%uzthst(2, icell) + flux2 = this%uzflst(2, icell) + flux1 = this%uzflst(1, icell) + theta1 = this%uzthst(1, icell) + this%uzspst(2, icell) = leadspeed(theta1, theta2, flux1, & + flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & + this%vks(icell)) + this%nwavst(icell) = this%nwavst(icell) + 1 + if (this%nwavst(icell) > this%nwav(icell)) then + ! + ! -- too many waves error + ierr = 1 + goto 500 + end if + end if + end if + else + ! + ! -- extinction depth splits waves + if (this%uzdpst(1, icell) - this%extdpuz(icell) > DEM7) then + j = 2 + jk = 0 + ! + ! -- locate extinction depth between waves + do while (jk == 0) + diff = this%uzdpst(j, icell) - this%extdpuz(icell) + if (diff > dzero) then + j = j + 1 + else + jk = 1 + end if + end do + kk = j + if (this%uzthst(j, icell) > this%thtr(icell) + extwc1) then + ! + ! -- create a wave at extinction depth + if (abs(diff) > DEM5) then + call this%wave_shift(this, icell, icell, -1, this%nwavst(icell) + 1, j, -1) + this%uzdpst(j, icell) = this%extdpuz(icell) + this%nwavst(icell) = this%nwavst(icell) + 1 + if (this%nwavst(icell) > this%nwav(icell)) then + ! + ! -- too many waves error + ierr = 1 + goto 500 + end if + end if + kk = j + else + jhold = this%nwavst(icell) + i = j + 1 + do while (i < this%nwavst(icell)) + if (this%uzthst(i, icell) > this%thtr(icell) + extwc1) then + jhold = i + i = this%nwavst(icell) + 1 + end if + i = i + 1 + end do + j = jhold + kk = jhold + end if + else + kk = 1 + end if + ! + ! -- all waves above extinction depth + do while (kk <= this%nwavst(icell)) + if (ietflag==2) then + tho = this%uzthst(kk, icell) + fktho = this%uzflst(kk, icell) + hcap = this%caph(icell, tho) + thetaout = this%rate_et_z(icell, factor, fktho, hcap) + end if + if (this%uzthst(kk, icell) > this%thtr(icell) + extwc1) then + if (this%uzthst(kk, icell) - thetaout > this%thtr(icell) + extwc1) then + this%uzthst(kk, icell) = this%uzthst(kk, icell) - thetaout + else if (this%uzthst(kk, icell) > this%thtr(icell) + extwc1) then + this%uzthst(kk, icell) = this%thtr(icell) + extwc1 + end if + if (kk == 1) then + this%uzflst(kk, icell) = this%vks(icell) * (((this%uzthst(kk, icell) - & + this%thtr(icell)) * thtsrinv) ** this%eps(icell)) + end if + if (kk > 1) then + flux1 = this%vks(icell) * ((this%uzthst(kk - 1, icell) - & + this%thtr(icell)) * thtsrinv) ** this%eps(icell) + flux2 = this%vks(icell) * ((this%uzthst(kk, icell) - this%thtr(icell)) * & + thtsrinv) ** this%eps(icell) + this%uzflst(kk, icell) = flux2 + theta2 = this%uzthst(kk, icell) + theta1 = this%uzthst(kk - 1, icell) + this%uzspst(kk, icell) = leadspeed(theta1, theta2, flux1, & + flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & + this%vks(icell)) + end if + end if + kk = kk + 1 + end do + end if + ! + ! -- calculate aet + kj = 1 + do while (kj <= this%nwavst(icell) - 1) + if (abs(this%uzthst(kj, icell) - this%uzthst(kj + 1, icell)) < DEM6) then + call this%wave_shift(this, icell, icell, 1, kj + 1, this%nwavst(icell) - 1, 1) + kj = kj - 1 + this%nwavst(icell) = this%nwavst(icell) - 1 + end if + kj = kj + 1 + end do + depth = this%uzdpst(1, icell) + fm = this%unsat_stor(icell, depth) + this%etact(icell) = st - fm + fm = this%etact(icell) / delt + if (this%etact(icell) < dzero) then + call this%wave_shift(uzfktemp, icell, 1, 0, 1, nwv, 1) + this%nwavst(icell) = nwv + this%etact(icell) = DZERO + elseif (petsub - fm < -DEM15 .AND. ietflag == 2) then + ! + ! -- aet greater than pet, reset and try again + call this%wave_shift(uzfktemp, icell, 1, 0, 1, nwv, 1) + this%nwavst(icell) = nwv + this%etact = DZERO + else + itest = 1 + end if + ! + ! -- end aet-pet loop for head dependent et + fmp = fm + if (k > 100) then + itest = 1 + elseif (ietflag < 2) then + fmp = petsub + itest = 1 + end if + end do +500 continue + return + end subroutine uzet + + function caph(this, icell, tho) +! ****************************************************************************** +! caph---- calculate capillary pressure head from B-C equation +! ****************************************************************************** +! SPECIFICATIONS: +! +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class (UzfCellGroupType) :: this + integer(I4B), intent(in) :: icell + real(DP), intent(in) :: tho + ! -- local + real(DP) :: caph,lambda,star +! ------------------------------------------------------------------------------ + caph = -DEM6 + star = (tho - this%thtr(icell)) / (this%thts(icell) - this%thtr(icell)) + if (star < DEM15) star = DEM15 + lambda = DTWO / (this%eps(icell) - DTHREE) + if (star > DEM15) then + if (tho - this%thts(icell) < DEM15) then + caph = this%ha(icell) * star ** (-DONE / lambda) + else + caph = DZERO + end if + end if + end function caph + + function rate_et_z(this, icell, factor, fktho, h) +! ****************************************************************************** +! rate_et_z---- capillary pressure based uz et +! ****************************************************************************** +! SPECIFICATIONS: +! +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + real(DP) :: rate_et_z + ! -- dummy + class (UzfCellGroupType) :: this + integer(I4B), intent(in) :: icell + real(DP), intent(in) :: factor, fktho, h + ! -- local +! ---------------------------------------------------------------------- + rate_et_z = factor * fktho * (h - this%hroot(icell)) + if (rate_et_z < DZERO) rate_et_z = DZERO + end function rate_et_z + end module UzfCellGroupModule \ No newline at end of file diff --git a/src/Model/ModelUtilities/Xt3dAlgorithm.f90 b/src/Model/ModelUtilities/Xt3dAlgorithm.f90 index cde050ee054..9fbda46f6bc 100644 --- a/src/Model/ModelUtilities/Xt3dAlgorithm.f90 +++ b/src/Model/ModelUtilities/Xt3dAlgorithm.f90 @@ -1,532 +1,532 @@ -! -! -- Mathematical core of the XT3D method. -! -module Xt3dAlgorithmModule - - use KindModule, only: DP, I4B - implicit none - - contains - - subroutine qconds(nnbrmx,nnbr0,inbr0,il01,vc0,vn0,dl0,dl0n,ck0, & - nnbr1,inbr1,il10,vc1,vn1,dl1,dl1n,ck1,ar01,ar10, & - vcthresh,allhc0,allhc1,chat01,chati0,chat1j) -! ****************************************************************************** -! -!.....Compute the "conductances" in the normal-flux expression for an -! interface (modflow-usg version). The cell on one side of -! the interface is "cell 0", and the one on the other side is -! "cell 1". -! -! nnbrmx = maximum number of neighbors allowed for a cell. -! nnbr0 = number of neighbors (local connections) for cell 0. -! inbr0 = array with the list of neighbors for cell 0. -! il01 = local node number of cell 1 with respect to cell 0. -! vc0 = array of connection unit-vectors for cell 0 with its -! neighbors. -! vn0 = array of unit normal vectors for cell 0's interfaces. -! dl0 = array of lengths contributed by cell 0 to its -! connections with its neighbors. -! dl0n = array of lengths contributed by cell 0's neighbors to -! their connections with cell 0. -! ck0 = conductivity tensor for cell 0. -! nnbr1 = number of neighbors (local connections) for cell 1. -! inbr1 = array with the list of neighbors for cell 1. -! il10 = local node number of cell 0 with respect to cell 1. -! vc1 = array of connection unit-vectors for cell 1 with its -! neighbors. -! vn1 = array of unit normal vectors for cell 1's interfaces. -! dl1 = array of lengths contributed by cell 1 to its -! connections with its neighbors. -! dl1n = array of lengths contributed by cell 1's neighbors to -! their connections with cell 1. -! ck1 = conductivity tensor for cell1. -! ar01 = area of interface (0,1). -! ar10 = area of interface (1,0). -! chat01 = "conductance" for connection (0,1). -! chati0 = array of "conductances" for connections of cell 0. -! (zero for connection with cell 1, as this connection is -! already covered by chat01.) -! chat1j = array of "conductances" for connections of cell 1. -! (zero for connection with cell 0., as this connection is -! already covered by chat01.) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - integer(I4B) :: nnbrmx - integer(I4B) :: nnbr0 - integer(I4B), dimension(nnbrmx) :: inbr0 - integer(I4B) :: il01 - real(DP), dimension(nnbrmx, 3) :: vc0 - real(DP), dimension(nnbrmx, 3) :: vn0 - real(DP), dimension(nnbrmx) :: dl0 - real(DP), dimension(nnbrmx) :: dl0n - real(DP), dimension(3, 3) :: ck0 - integer(I4B) :: nnbr1 - integer(I4B), dimension(nnbrmx) :: inbr1 - integer(I4B) :: il10 - real(DP), dimension(nnbrmx) :: vc1 - real(DP), dimension(nnbrmx) :: vn1 - real(DP), dimension(nnbrmx) :: dl1 - real(DP), dimension(nnbrmx) :: dl1n - real(DP), dimension(3, 3) :: ck1 - real(DP) :: ar01 - real(DP) :: ar10 - real(DP) :: vcthresh - logical :: allhc0 - logical :: allhc1 - real(DP) :: chat01 - real(DP), dimension(nnbrmx) :: chati0 - real(DP), dimension(nnbrmx) :: chat1j - ! -- local - integer(I4B) :: i1 - integer(I4B) :: i - real(DP) :: ahat0 - real(DP) :: ahat1 - real(DP) :: wght1 - real(DP) :: wght0 - real(DP), dimension(nnbrmx) :: bhat0 - real(DP), dimension(nnbrmx) :: bhat1 -! ------------------------------------------------------------------------------ -! -!.....Set the global cell number for cell 1, as found in the neighbor -! list for cell 0. It is assumed that cells 0 and 1 are both -! active, or else this subroutine would not have been called. - i1 = inbr0(il01) -! -!.....If area ar01 is zero (in which case ar10 is also zero, since -! this can only happen here in the case of Newton), then the -! "conductances" are all zero. - if (ar01.eq.0d0) then - chat01 = 0d0 - do i=1,nnbrmx - chati0(i) = 0d0 - chat1j(i) = 0d0 - enddo -!.....Else compute "conductances." - else -!........Compute contributions from cell 0. - call abhats(nnbrmx,nnbr0,inbr0,il01,vc0,vn0,dl0,dl0n,ck0, & - vcthresh,allhc0,ar01,ahat0,bhat0) -!........Compute contributions from cell 1. - call abhats(nnbrmx,nnbr1,inbr1,il10,vc1,vn1,dl1,dl1n,ck1, & - vcthresh,allhc1,ar10,ahat1,bhat1) -!........Compute "conductances" based on the two flux estimates. - wght1 = ahat0/(ahat0 + ahat1) - wght0 = 1d0 - wght1 - chat01 = wght1*ahat1 - do i=1,nnbrmx - chati0(i) = wght0*bhat0(i) - chat1j(i) = wght1*bhat1(i) - enddo - end if -! - return - end subroutine qconds - - subroutine abhats(nnbrmx,nnbr,inbr,il01,vc,vn,dl0,dln,ck, & - vcthresh,allhc,ar01,ahat,bhat) -! ****************************************************************************** -!.....Compute "ahat" and "bhat" coefficients for one side of an -! interface. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - integer(I4B) :: nnbrmx - integer(I4B) :: nnbr - integer(I4B), dimension(nnbrmx) :: inbr - integer(I4B) :: il01 - real(DP), dimension(nnbrmx, 3) :: vc - real(DP), dimension(nnbrmx, 3) :: vn - real(DP), dimension(nnbrmx) :: dl0 - real(DP), dimension(nnbrmx) :: dln - real(DP), dimension(3, 3) :: ck - real(DP) :: vcthresh - logical :: allhc - real(DP) :: ar01 - real(DP) :: ahat - real(DP), dimension(nnbrmx) :: bhat - ! -- local - logical :: iscomp - real(DP), dimension(nnbrmx, 3) :: vccde - real(DP), dimension(3, 3) :: rmat - real(DP), dimension(3) :: sigma - real(DP), dimension(nnbrmx) :: bd - real(DP), dimension(nnbrmx) :: be - real(DP), dimension(nnbrmx) :: betad - real(DP), dimension(nnbrmx) :: betae - integer(I4B) :: iml0 - integer(I4B) :: il - real(DP) :: acd - real(DP) :: add - real(DP) :: aed - real(DP) :: ace - real(DP) :: aee - real(DP) :: ade - real(DP) :: determ - real(DP) :: oodet - real(DP) :: alphad - real(DP) :: alphae - real(DP) :: dl0il -! ------------------------------------------------------------------------------ -! -!.....Determine the basis vectors for local "(c, d, e)" coordinates -! associated with the connection between cells 0 and 1, and -! set the rotation matrix that transforms vectors from model -! coordinates to (c, d, e) coordinates. (If no active -! connection is found that has a non-negligible component -! perpendicular to the primary connection, ilmo=0 is returned.) - call getrot(nnbrmx,nnbr,inbr,vc,il01,rmat,iml0) -! -!.....If no active connection with a non-negligible perpendicular -! component, assume no perpendicular gradient and base gradient -! solely on the primary connection. Otherwise, proceed with -! basing weights on information from neighboring connections. - if (iml0.eq.0) then -! -!........Compute ahat and bhat coefficients assuming perpendicular -! components of gradient are zero. - sigma(1) = dot_product(vn(il01, :), matmul(ck, rmat(:, 1))) - ahat = sigma(1) / dl0(il01) - bhat = 0d0 -! - else -! -!........Transform local connection unit-vectors from model coordinates -! to "(c, d, e)" coordinates associated with the connection -! between cells 0 and 1. - call tranvc(nnbrmx,nnbr,rmat,vc,vccde) -! -!........Get "a" and "b" weights for first perpendicular direction. - call abwts(nnbrmx,nnbr,inbr,il01,2,vccde, & - vcthresh,dl0,dln,acd,add,aed,bd) -! -!........If all neighboring connections are user-designated as -! horizontal, or if none have a non-negligible component in -! the second perpendicular direction, assume zero gradient in -! the second perpendicular direction. Otherwise, get "a" and -! "b" weights for second perpendicular direction based on -! neighboring connections. - if (allhc) then - ace = 0d0 - aee = 1d0 - ade = 0d0 - be = 0d0 - else - iscomp = .false. - do il = 1, nnbr - if ((il == il01) .or. (inbr(il) == 0)) then - cycle - else if (dabs(vccde(il, 3)) > 1d-10) then - iscomp = .true. - exit - end if - end do - if (iscomp) then - call abwts(nnbrmx,nnbr,inbr,il01,3,vccde, & - vcthresh,dl0,dln,ace,aee,ade,be) - else - ace = 0d0 - aee = 1d0 - ade = 0d0 - be = 0d0 - end if - end if -! -!........Compute alpha and beta coefficients. - determ = add * aee - ade * aed - oodet = 1d0 / determ - alphad = (acd * aee - ace * aed) * oodet - alphae = (ace * add - acd * ade) * oodet - betad = 0d0 - betae = 0d0 - do il = 1, nnbr -!...........If this is connection (0,1) or inactive, skip. - if ((il == il01) .or. (inbr(il) == 0)) cycle - betad(il) = (bd(il) * aee - be(il) * aed) * oodet - betae(il) = (be(il) * add - bd(il) * ade) * oodet - end do -! -!........Compute sigma coefficients. - sigma = matmul(vn(il01, :), matmul(ck, rmat)) -! -!........Compute ahat and bhat coefficients. - ahat = (sigma(1) - sigma(2) * alphad - sigma(3) * alphae) / dl0(il01) - bhat = 0d0 - do il = 1, nnbr -!...........If this is connection (0,1) or inactive, skip. - if ((il == il01) .or. (inbr(il) == 0)) cycle - dl0il = dl0(il) + dln(il) - bhat(il) = (sigma(2) * betad(il) + sigma(3) * betae(il)) / dl0il - end do -!........Set the bhat for connection (0,1) to zero here, since we have -! been skipping it in our do loops to avoiding explicitly -! computing it. This will carry through to the corresponding -! chati0 and chat1j value, so that they too are zero. - bhat(il01) = 0d0 -! - end if -! -!.....Multiply by area. - ahat = ahat * ar01 - bhat = bhat * ar01 -! - return - end subroutine abhats - - subroutine getrot(nnbrmx,nnbr,inbr,vc,il01,rmat,iml0) -! ****************************************************************************** -!.....Compute the matrix that rotates the model-coordinate axes to -! the "(c, d, e)-coordinate" axes associated with a connection. -! This is also the matrix that transforms the components of a vector -! from (c, d, e) coordinates to model coordinates. [Its transpose -! transforms from model to (c, d, e) coordinates.] -! -! vcc = unit vector for the primary connection, in model -! coordinates. -! vcd = unit vector for the first perpendicular direction, -! in model coordinates. -! vce = unit vector for the second perpendicular direction, -! in model coordinates. -! vcmax = unit vector for the connection with the maximum -! component perpendicular to the primary connection, -! in model coordinates. -! rmat = rotation matrix from model to (c, d, e) coordinates. -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - integer(I4B) :: nnbrmx - integer(I4B) :: nnbr - integer(I4B), dimension(nnbrmx) :: inbr - real(DP), dimension(nnbrmx, 3) :: vc - integer(I4B) :: il01 - real(DP), dimension(3, 3) :: rmat - integer(I4B) :: iml0 - ! -- local - real(DP), dimension(3) :: vcc - real(DP), dimension(3) :: vcd - real(DP), dimension(3) :: vce - real(DP), dimension(3) :: vcmax - integer(I4B) :: il - real(DP) :: acmpmn - real(DP) :: cmp - real(DP) :: acmp - real(DP) :: cmpmn -! ------------------------------------------------------------------------------ -! -!.....set vcc. - vcc(:) = vc(il01,:) -! -!.....Set vcmax. (If no connection has a perpendicular component -! greater than some tiny threshold, return with iml0=0 and -! the first column of rmat set to vcc -- the other columns -! are not needed.) - acmpmn = 1d0 - 1d-10 - iml0 = 0 - do il = 1, nnbr - if ((il.eq.il01).or.(inbr(il).eq.0)) then - cycle - else - cmp = dot_product(vc(il,:), vcc) - acmp = dabs(cmp) - if (acmp.lt.acmpmn) then - cmpmn = cmp - acmpmn = acmp - iml0 = il - end if - end if - enddo - if (iml0 == 0) then - rmat(:,1) = vcc(:) - goto 999 - else - vcmax(:) = vc(iml0,:) - end if -! -!.....Set the first perpendicular direction as the direction that is -! coplanar with vcc and vcmax and perpendicular to vcc. - vcd = vcmax - cmpmn * vcc - vcd = vcd / dsqrt(1d0 - cmpmn * cmpmn) -! -!.....Set the second perpendicular direction as the cross product of -! the primary and first-perpendicular directions. - vce(1) = vcc(2)*vcd(3) - vcc(3)*vcd(2) - vce(2) = vcc(3)*vcd(1) - vcc(1)*vcd(3) - vce(3) = vcc(1)*vcd(2) - vcc(2)*vcd(1) -! -!.....Set the rotation matrix as the matrix with vcc, vcd, and vce -! as its columns. - rmat(:,1) = vcc(:) - rmat(:,2) = vcd(:) - rmat(:,3) = vce(:) -! -999 return - end subroutine getrot - - subroutine tranvc(nnbrmx,nnbrs,rmat,vc,vccde) -! ****************************************************************************** -!.....Transform local connection unit-vectors from model coordinates -! to "(c, d, e)" coordinates associated with a connection. -! -! nnbrs = number of neighbors (local connections) -! rmat = rotation matrix from (c, d, e) to model coordinates. -! vc = array of connection unit-vectors with respect to model -! coordinates. -! vccde = array of connection unit-vectors with respect to -! (c, d, e) coordinates. -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - integer(I4B) :: nnbrmx - integer(I4B) :: nnbrs - real(DP), dimension(3, 3) :: rmat - real(DP), dimension(nnbrmx, 3) :: vc - real(DP), dimension(nnbrmx, 3) :: vccde - ! -- local - integer(I4B) :: il -! ------------------------------------------------------------------------------ -! -!.....Loop over the local connections, transforming the unit vectors. -! Note that we are multiplying by the transpose of the -! rotation matrix so that the transformation is from model -! to (c, d, e) coordinates. - do il = 1, nnbrs - vccde(il,:) = matmul(transpose(rmat), vc(il,:)) - enddo -! - return - end subroutine tranvc - - subroutine abwts(nnbrmx,nnbr,inbr,il01,nde1,vccde, & - vcthresh,dl0,dln,acd,add,aed,bd) -! ****************************************************************************** -!.....Compute "a" and "b" weights for the local connections with respect -! to the perpendicular direction of primary interest. -! -! nde1 = number that indicates the perpendicular direction of -! primary interest on this call: "d" (2) or "e" (3). -! vccde = array of connection unit-vectors with respect to -! (c, d, e) coordinates. -! bd = array of "b" weights. -! aed = "a" weight that goes on the matrix side of the 2x2 -! problem. -! acd = "a" weight that goes on the right-hand side of the -! 2x2 problem. -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - integer(I4B) :: nnbrmx - integer(I4B) :: nnbr - integer(I4B), dimension(nnbrmx) :: inbr - integer(I4B) :: il01 - integer(I4B) :: nde1 - real(DP), dimension(nnbrmx, 3) :: vccde - real(DP) :: vcthresh - real(DP), dimension(nnbrmx) :: dl0 - real(DP), dimension(nnbrmx) :: dln - real(DP) :: acd - real(DP) :: add - real(DP) :: aed - real(DP), dimension(nnbrmx) :: bd - ! -- local - integer(I4B) :: nde2 - integer(I4B) :: il - real(DP) :: vcmx - real(DP) :: dlm - real(DP) :: cosang - real(DP) :: dl4wt - real(DP) :: fact - real(DP) :: dsum - real(DP) :: oodsum - real(DP) :: fatten - real(DP), dimension(nnbrmx) :: omwt -! ------------------------------------------------------------------------------ -! -!.....Set the perpendicular direction of secondary interest. - nde2 = 5 - nde1 -! -!.....Begin computing "omega" weights. - omwt = 0d0 - dsum = 0d0 - vcmx = 0d0 - do il = 1, nnbr -!........if this is connection (0,1) or inactive, skip. - if ((il.eq.il01).or.(inbr(il).eq.0)) cycle - vcmx = max(dabs(vccde(il,nde1)), vcmx) - dlm = 5d-1*(dl0(il) + dln(il)) -!...........Distance-based weighting. dl4wt is the distance between -! the point supplying the gradient information and the -! point at which the flux is being estimated. Could be -! coded as a special case of resistance-based weighting -! (by setting the conductivity matrix to be the identity -! matrix), but this is more efficient. - cosang = vccde(il,1) - dl4wt = dsqrt(dlm*dlm + dl0(il01)*dl0(il01) & - - 2d0*dlm*dl0(il01)*cosang) - omwt(il) = dabs(vccde(il,nde1))*dl4wt - dsum = dsum + omwt(il) - end do -! -!.....Finish computing non-normalized "omega" weights. [Add a -! tiny bit to dsum so that the normalized omega weight later -! evaluates to (essentially) 1 in the case of a single relevant -! connection, avoiding 0/0.] - dsum = dsum + 1d-10*dsum - do il = 1, nnbr -!........If this is connection (0,1) or inactive, skip. - if ((il.eq.il01).or.(inbr(il).eq.0)) cycle - fact = dsum - omwt(il) - omwt(il) = fact*dabs(vccde(il,nde1)) - end do -! -!.....Compute "b" weights. - bd = 0d0 - dsum = 0d0 - do il = 1, nnbr -!........If this is connection (0,1) or inactive, skip. - if ((il.eq.il01).or.(inbr(il).eq.0)) cycle - bd(il) = omwt(il)*sign(1d0,vccde(il,nde1)) - dsum = dsum + omwt(il)*dabs(vccde(il,nde1)) - end do - oodsum = 1d0/dsum - do il = 1, nnbr -!........If this is connection (0,1) or inactive, skip. - if ((il.eq.il01).or.(inbr(il).eq.0)) cycle - bd(il) = bd(il)*oodsum - end do -! -!.....Compute "a" weights. - add = 1d0 - acd = 0d0 - aed = 0d0 - do il = 1, nnbr -!........If this is connection (0,1) or inactive, skip. - if ((il.eq.il01).or.(inbr(il).eq.0)) cycle - acd = acd + bd(il)*vccde(il,1) - aed = aed + bd(il)*vccde(il,nde2) - end do -! -!.....Apply attenuation function to acd, aed, and bd. - if (vcmx.lt.vcthresh) then - fatten = vcmx/vcthresh - acd = acd*fatten - aed = aed*fatten - bd = bd*fatten - end if -! - end subroutine abwts -! -end module Xt3dAlgorithmModule +! +! -- Mathematical core of the XT3D method. +! +module Xt3dAlgorithmModule + + use KindModule, only: DP, I4B + implicit none + + contains + + subroutine qconds(nnbrmx,nnbr0,inbr0,il01,vc0,vn0,dl0,dl0n,ck0, & + nnbr1,inbr1,il10,vc1,vn1,dl1,dl1n,ck1,ar01,ar10, & + vcthresh,allhc0,allhc1,chat01,chati0,chat1j) +! ****************************************************************************** +! +!.....Compute the "conductances" in the normal-flux expression for an +! interface (modflow-usg version). The cell on one side of +! the interface is "cell 0", and the one on the other side is +! "cell 1". +! +! nnbrmx = maximum number of neighbors allowed for a cell. +! nnbr0 = number of neighbors (local connections) for cell 0. +! inbr0 = array with the list of neighbors for cell 0. +! il01 = local node number of cell 1 with respect to cell 0. +! vc0 = array of connection unit-vectors for cell 0 with its +! neighbors. +! vn0 = array of unit normal vectors for cell 0's interfaces. +! dl0 = array of lengths contributed by cell 0 to its +! connections with its neighbors. +! dl0n = array of lengths contributed by cell 0's neighbors to +! their connections with cell 0. +! ck0 = conductivity tensor for cell 0. +! nnbr1 = number of neighbors (local connections) for cell 1. +! inbr1 = array with the list of neighbors for cell 1. +! il10 = local node number of cell 0 with respect to cell 1. +! vc1 = array of connection unit-vectors for cell 1 with its +! neighbors. +! vn1 = array of unit normal vectors for cell 1's interfaces. +! dl1 = array of lengths contributed by cell 1 to its +! connections with its neighbors. +! dl1n = array of lengths contributed by cell 1's neighbors to +! their connections with cell 1. +! ck1 = conductivity tensor for cell1. +! ar01 = area of interface (0,1). +! ar10 = area of interface (1,0). +! chat01 = "conductance" for connection (0,1). +! chati0 = array of "conductances" for connections of cell 0. +! (zero for connection with cell 1, as this connection is +! already covered by chat01.) +! chat1j = array of "conductances" for connections of cell 1. +! (zero for connection with cell 0., as this connection is +! already covered by chat01.) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + integer(I4B) :: nnbrmx + integer(I4B) :: nnbr0 + integer(I4B), dimension(nnbrmx) :: inbr0 + integer(I4B) :: il01 + real(DP), dimension(nnbrmx, 3) :: vc0 + real(DP), dimension(nnbrmx, 3) :: vn0 + real(DP), dimension(nnbrmx) :: dl0 + real(DP), dimension(nnbrmx) :: dl0n + real(DP), dimension(3, 3) :: ck0 + integer(I4B) :: nnbr1 + integer(I4B), dimension(nnbrmx) :: inbr1 + integer(I4B) :: il10 + real(DP), dimension(nnbrmx) :: vc1 + real(DP), dimension(nnbrmx) :: vn1 + real(DP), dimension(nnbrmx) :: dl1 + real(DP), dimension(nnbrmx) :: dl1n + real(DP), dimension(3, 3) :: ck1 + real(DP) :: ar01 + real(DP) :: ar10 + real(DP) :: vcthresh + logical :: allhc0 + logical :: allhc1 + real(DP) :: chat01 + real(DP), dimension(nnbrmx) :: chati0 + real(DP), dimension(nnbrmx) :: chat1j + ! -- local + integer(I4B) :: i1 + integer(I4B) :: i + real(DP) :: ahat0 + real(DP) :: ahat1 + real(DP) :: wght1 + real(DP) :: wght0 + real(DP), dimension(nnbrmx) :: bhat0 + real(DP), dimension(nnbrmx) :: bhat1 +! ------------------------------------------------------------------------------ +! +!.....Set the global cell number for cell 1, as found in the neighbor +! list for cell 0. It is assumed that cells 0 and 1 are both +! active, or else this subroutine would not have been called. + i1 = inbr0(il01) +! +!.....If area ar01 is zero (in which case ar10 is also zero, since +! this can only happen here in the case of Newton), then the +! "conductances" are all zero. + if (ar01.eq.0d0) then + chat01 = 0d0 + do i=1,nnbrmx + chati0(i) = 0d0 + chat1j(i) = 0d0 + enddo +!.....Else compute "conductances." + else +!........Compute contributions from cell 0. + call abhats(nnbrmx,nnbr0,inbr0,il01,vc0,vn0,dl0,dl0n,ck0, & + vcthresh,allhc0,ar01,ahat0,bhat0) +!........Compute contributions from cell 1. + call abhats(nnbrmx,nnbr1,inbr1,il10,vc1,vn1,dl1,dl1n,ck1, & + vcthresh,allhc1,ar10,ahat1,bhat1) +!........Compute "conductances" based on the two flux estimates. + wght1 = ahat0/(ahat0 + ahat1) + wght0 = 1d0 - wght1 + chat01 = wght1*ahat1 + do i=1,nnbrmx + chati0(i) = wght0*bhat0(i) + chat1j(i) = wght1*bhat1(i) + enddo + end if +! + return + end subroutine qconds + + subroutine abhats(nnbrmx,nnbr,inbr,il01,vc,vn,dl0,dln,ck, & + vcthresh,allhc,ar01,ahat,bhat) +! ****************************************************************************** +!.....Compute "ahat" and "bhat" coefficients for one side of an +! interface. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + integer(I4B) :: nnbrmx + integer(I4B) :: nnbr + integer(I4B), dimension(nnbrmx) :: inbr + integer(I4B) :: il01 + real(DP), dimension(nnbrmx, 3) :: vc + real(DP), dimension(nnbrmx, 3) :: vn + real(DP), dimension(nnbrmx) :: dl0 + real(DP), dimension(nnbrmx) :: dln + real(DP), dimension(3, 3) :: ck + real(DP) :: vcthresh + logical :: allhc + real(DP) :: ar01 + real(DP) :: ahat + real(DP), dimension(nnbrmx) :: bhat + ! -- local + logical :: iscomp + real(DP), dimension(nnbrmx, 3) :: vccde + real(DP), dimension(3, 3) :: rmat + real(DP), dimension(3) :: sigma + real(DP), dimension(nnbrmx) :: bd + real(DP), dimension(nnbrmx) :: be + real(DP), dimension(nnbrmx) :: betad + real(DP), dimension(nnbrmx) :: betae + integer(I4B) :: iml0 + integer(I4B) :: il + real(DP) :: acd + real(DP) :: add + real(DP) :: aed + real(DP) :: ace + real(DP) :: aee + real(DP) :: ade + real(DP) :: determ + real(DP) :: oodet + real(DP) :: alphad + real(DP) :: alphae + real(DP) :: dl0il +! ------------------------------------------------------------------------------ +! +!.....Determine the basis vectors for local "(c, d, e)" coordinates +! associated with the connection between cells 0 and 1, and +! set the rotation matrix that transforms vectors from model +! coordinates to (c, d, e) coordinates. (If no active +! connection is found that has a non-negligible component +! perpendicular to the primary connection, ilmo=0 is returned.) + call getrot(nnbrmx,nnbr,inbr,vc,il01,rmat,iml0) +! +!.....If no active connection with a non-negligible perpendicular +! component, assume no perpendicular gradient and base gradient +! solely on the primary connection. Otherwise, proceed with +! basing weights on information from neighboring connections. + if (iml0.eq.0) then +! +!........Compute ahat and bhat coefficients assuming perpendicular +! components of gradient are zero. + sigma(1) = dot_product(vn(il01, :), matmul(ck, rmat(:, 1))) + ahat = sigma(1) / dl0(il01) + bhat = 0d0 +! + else +! +!........Transform local connection unit-vectors from model coordinates +! to "(c, d, e)" coordinates associated with the connection +! between cells 0 and 1. + call tranvc(nnbrmx,nnbr,rmat,vc,vccde) +! +!........Get "a" and "b" weights for first perpendicular direction. + call abwts(nnbrmx,nnbr,inbr,il01,2,vccde, & + vcthresh,dl0,dln,acd,add,aed,bd) +! +!........If all neighboring connections are user-designated as +! horizontal, or if none have a non-negligible component in +! the second perpendicular direction, assume zero gradient in +! the second perpendicular direction. Otherwise, get "a" and +! "b" weights for second perpendicular direction based on +! neighboring connections. + if (allhc) then + ace = 0d0 + aee = 1d0 + ade = 0d0 + be = 0d0 + else + iscomp = .false. + do il = 1, nnbr + if ((il == il01) .or. (inbr(il) == 0)) then + cycle + else if (dabs(vccde(il, 3)) > 1d-10) then + iscomp = .true. + exit + end if + end do + if (iscomp) then + call abwts(nnbrmx,nnbr,inbr,il01,3,vccde, & + vcthresh,dl0,dln,ace,aee,ade,be) + else + ace = 0d0 + aee = 1d0 + ade = 0d0 + be = 0d0 + end if + end if +! +!........Compute alpha and beta coefficients. + determ = add * aee - ade * aed + oodet = 1d0 / determ + alphad = (acd * aee - ace * aed) * oodet + alphae = (ace * add - acd * ade) * oodet + betad = 0d0 + betae = 0d0 + do il = 1, nnbr +!...........If this is connection (0,1) or inactive, skip. + if ((il == il01) .or. (inbr(il) == 0)) cycle + betad(il) = (bd(il) * aee - be(il) * aed) * oodet + betae(il) = (be(il) * add - bd(il) * ade) * oodet + end do +! +!........Compute sigma coefficients. + sigma = matmul(vn(il01, :), matmul(ck, rmat)) +! +!........Compute ahat and bhat coefficients. + ahat = (sigma(1) - sigma(2) * alphad - sigma(3) * alphae) / dl0(il01) + bhat = 0d0 + do il = 1, nnbr +!...........If this is connection (0,1) or inactive, skip. + if ((il == il01) .or. (inbr(il) == 0)) cycle + dl0il = dl0(il) + dln(il) + bhat(il) = (sigma(2) * betad(il) + sigma(3) * betae(il)) / dl0il + end do +!........Set the bhat for connection (0,1) to zero here, since we have +! been skipping it in our do loops to avoiding explicitly +! computing it. This will carry through to the corresponding +! chati0 and chat1j value, so that they too are zero. + bhat(il01) = 0d0 +! + end if +! +!.....Multiply by area. + ahat = ahat * ar01 + bhat = bhat * ar01 +! + return + end subroutine abhats + + subroutine getrot(nnbrmx,nnbr,inbr,vc,il01,rmat,iml0) +! ****************************************************************************** +!.....Compute the matrix that rotates the model-coordinate axes to +! the "(c, d, e)-coordinate" axes associated with a connection. +! This is also the matrix that transforms the components of a vector +! from (c, d, e) coordinates to model coordinates. [Its transpose +! transforms from model to (c, d, e) coordinates.] +! +! vcc = unit vector for the primary connection, in model +! coordinates. +! vcd = unit vector for the first perpendicular direction, +! in model coordinates. +! vce = unit vector for the second perpendicular direction, +! in model coordinates. +! vcmax = unit vector for the connection with the maximum +! component perpendicular to the primary connection, +! in model coordinates. +! rmat = rotation matrix from model to (c, d, e) coordinates. +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + integer(I4B) :: nnbrmx + integer(I4B) :: nnbr + integer(I4B), dimension(nnbrmx) :: inbr + real(DP), dimension(nnbrmx, 3) :: vc + integer(I4B) :: il01 + real(DP), dimension(3, 3) :: rmat + integer(I4B) :: iml0 + ! -- local + real(DP), dimension(3) :: vcc + real(DP), dimension(3) :: vcd + real(DP), dimension(3) :: vce + real(DP), dimension(3) :: vcmax + integer(I4B) :: il + real(DP) :: acmpmn + real(DP) :: cmp + real(DP) :: acmp + real(DP) :: cmpmn +! ------------------------------------------------------------------------------ +! +!.....set vcc. + vcc(:) = vc(il01,:) +! +!.....Set vcmax. (If no connection has a perpendicular component +! greater than some tiny threshold, return with iml0=0 and +! the first column of rmat set to vcc -- the other columns +! are not needed.) + acmpmn = 1d0 - 1d-10 + iml0 = 0 + do il = 1, nnbr + if ((il.eq.il01).or.(inbr(il).eq.0)) then + cycle + else + cmp = dot_product(vc(il,:), vcc) + acmp = dabs(cmp) + if (acmp.lt.acmpmn) then + cmpmn = cmp + acmpmn = acmp + iml0 = il + end if + end if + enddo + if (iml0 == 0) then + rmat(:,1) = vcc(:) + goto 999 + else + vcmax(:) = vc(iml0,:) + end if +! +!.....Set the first perpendicular direction as the direction that is +! coplanar with vcc and vcmax and perpendicular to vcc. + vcd = vcmax - cmpmn * vcc + vcd = vcd / dsqrt(1d0 - cmpmn * cmpmn) +! +!.....Set the second perpendicular direction as the cross product of +! the primary and first-perpendicular directions. + vce(1) = vcc(2)*vcd(3) - vcc(3)*vcd(2) + vce(2) = vcc(3)*vcd(1) - vcc(1)*vcd(3) + vce(3) = vcc(1)*vcd(2) - vcc(2)*vcd(1) +! +!.....Set the rotation matrix as the matrix with vcc, vcd, and vce +! as its columns. + rmat(:,1) = vcc(:) + rmat(:,2) = vcd(:) + rmat(:,3) = vce(:) +! +999 return + end subroutine getrot + + subroutine tranvc(nnbrmx,nnbrs,rmat,vc,vccde) +! ****************************************************************************** +!.....Transform local connection unit-vectors from model coordinates +! to "(c, d, e)" coordinates associated with a connection. +! +! nnbrs = number of neighbors (local connections) +! rmat = rotation matrix from (c, d, e) to model coordinates. +! vc = array of connection unit-vectors with respect to model +! coordinates. +! vccde = array of connection unit-vectors with respect to +! (c, d, e) coordinates. +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + integer(I4B) :: nnbrmx + integer(I4B) :: nnbrs + real(DP), dimension(3, 3) :: rmat + real(DP), dimension(nnbrmx, 3) :: vc + real(DP), dimension(nnbrmx, 3) :: vccde + ! -- local + integer(I4B) :: il +! ------------------------------------------------------------------------------ +! +!.....Loop over the local connections, transforming the unit vectors. +! Note that we are multiplying by the transpose of the +! rotation matrix so that the transformation is from model +! to (c, d, e) coordinates. + do il = 1, nnbrs + vccde(il,:) = matmul(transpose(rmat), vc(il,:)) + enddo +! + return + end subroutine tranvc + + subroutine abwts(nnbrmx,nnbr,inbr,il01,nde1,vccde, & + vcthresh,dl0,dln,acd,add,aed,bd) +! ****************************************************************************** +!.....Compute "a" and "b" weights for the local connections with respect +! to the perpendicular direction of primary interest. +! +! nde1 = number that indicates the perpendicular direction of +! primary interest on this call: "d" (2) or "e" (3). +! vccde = array of connection unit-vectors with respect to +! (c, d, e) coordinates. +! bd = array of "b" weights. +! aed = "a" weight that goes on the matrix side of the 2x2 +! problem. +! acd = "a" weight that goes on the right-hand side of the +! 2x2 problem. +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + integer(I4B) :: nnbrmx + integer(I4B) :: nnbr + integer(I4B), dimension(nnbrmx) :: inbr + integer(I4B) :: il01 + integer(I4B) :: nde1 + real(DP), dimension(nnbrmx, 3) :: vccde + real(DP) :: vcthresh + real(DP), dimension(nnbrmx) :: dl0 + real(DP), dimension(nnbrmx) :: dln + real(DP) :: acd + real(DP) :: add + real(DP) :: aed + real(DP), dimension(nnbrmx) :: bd + ! -- local + integer(I4B) :: nde2 + integer(I4B) :: il + real(DP) :: vcmx + real(DP) :: dlm + real(DP) :: cosang + real(DP) :: dl4wt + real(DP) :: fact + real(DP) :: dsum + real(DP) :: oodsum + real(DP) :: fatten + real(DP), dimension(nnbrmx) :: omwt +! ------------------------------------------------------------------------------ +! +!.....Set the perpendicular direction of secondary interest. + nde2 = 5 - nde1 +! +!.....Begin computing "omega" weights. + omwt = 0d0 + dsum = 0d0 + vcmx = 0d0 + do il = 1, nnbr +!........if this is connection (0,1) or inactive, skip. + if ((il.eq.il01).or.(inbr(il).eq.0)) cycle + vcmx = max(dabs(vccde(il,nde1)), vcmx) + dlm = 5d-1*(dl0(il) + dln(il)) +!...........Distance-based weighting. dl4wt is the distance between +! the point supplying the gradient information and the +! point at which the flux is being estimated. Could be +! coded as a special case of resistance-based weighting +! (by setting the conductivity matrix to be the identity +! matrix), but this is more efficient. + cosang = vccde(il,1) + dl4wt = dsqrt(dlm*dlm + dl0(il01)*dl0(il01) & + - 2d0*dlm*dl0(il01)*cosang) + omwt(il) = dabs(vccde(il,nde1))*dl4wt + dsum = dsum + omwt(il) + end do +! +!.....Finish computing non-normalized "omega" weights. [Add a +! tiny bit to dsum so that the normalized omega weight later +! evaluates to (essentially) 1 in the case of a single relevant +! connection, avoiding 0/0.] + dsum = dsum + 1d-10*dsum + do il = 1, nnbr +!........If this is connection (0,1) or inactive, skip. + if ((il.eq.il01).or.(inbr(il).eq.0)) cycle + fact = dsum - omwt(il) + omwt(il) = fact*dabs(vccde(il,nde1)) + end do +! +!.....Compute "b" weights. + bd = 0d0 + dsum = 0d0 + do il = 1, nnbr +!........If this is connection (0,1) or inactive, skip. + if ((il.eq.il01).or.(inbr(il).eq.0)) cycle + bd(il) = omwt(il)*sign(1d0,vccde(il,nde1)) + dsum = dsum + omwt(il)*dabs(vccde(il,nde1)) + end do + oodsum = 1d0/dsum + do il = 1, nnbr +!........If this is connection (0,1) or inactive, skip. + if ((il.eq.il01).or.(inbr(il).eq.0)) cycle + bd(il) = bd(il)*oodsum + end do +! +!.....Compute "a" weights. + add = 1d0 + acd = 0d0 + aed = 0d0 + do il = 1, nnbr +!........If this is connection (0,1) or inactive, skip. + if ((il.eq.il01).or.(inbr(il).eq.0)) cycle + acd = acd + bd(il)*vccde(il,1) + aed = aed + bd(il)*vccde(il,nde2) + end do +! +!.....Apply attenuation function to acd, aed, and bd. + if (vcmx.lt.vcthresh) then + fatten = vcmx/vcthresh + acd = acd*fatten + aed = aed*fatten + bd = bd*fatten + end if +! + end subroutine abwts +! +end module Xt3dAlgorithmModule diff --git a/src/Model/ModelUtilities/Xt3dInterface.f90 b/src/Model/ModelUtilities/Xt3dInterface.f90 index aafdc151289..b9e3916bd78 100644 --- a/src/Model/ModelUtilities/Xt3dInterface.f90 +++ b/src/Model/ModelUtilities/Xt3dInterface.f90 @@ -1,1763 +1,1763 @@ -module Xt3dModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, DHALF, DONE, LENORIGIN - use BaseDisModule, only: DisBaseType - - implicit none - - public Xt3dType - public :: xt3d_cr - - type Xt3dType - integer(I4B), pointer :: inunit => null() - integer(I4B), pointer :: iout => null() - character(len=LENORIGIN), pointer :: origin => null() !origin name of this package (e.g. 'GWF_1 NPF') - integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !pointer to model ibound - integer(I4B),dimension(:), pointer, contiguous :: iax => null() !ia array for extended neighbors used by xt3d - integer(I4B),dimension(:), pointer, contiguous :: jax => null() !ja array for extended neighbors used by xt3d - integer(I4B),dimension(:), pointer, contiguous :: idxglox => null() !mapping array for extended neighbors used by xt3d - integer(I4B), pointer :: numextnbrs => null() !dimension of jax array - integer(I4B), pointer :: ixt3d => null() !xt3d flag (0 is off, 1 is lhs, 2 is rhs) - logical, pointer :: nozee => null() !nozee flag - real(DP), pointer :: vcthresh => null() !attenuation function threshold - real(DP), dimension(:,:), pointer, contiguous :: rmatck => null() !rotation matrix for the conductivity tensor - real(DP), dimension(:,:), pointer, contiguous :: vecc => null() !connection vectors - real(DP), dimension(:,:), pointer, contiguous :: vecn => null() !interface normals - real(DP), dimension(:), pointer, contiguous :: conlen => null() !direct connection lengths - real(DP), dimension(:), pointer, contiguous :: qsat => null() !saturated flow saved for Newton - real(DP), dimension(:), pointer, contiguous :: qrhs => null() !rhs part of flow saved for Newton - integer(I4B), pointer :: nbrmax => null() !maximum number of neighbors for any cell - real(DP), dimension(:), pointer, contiguous :: amatpc => null() !saved contributions to amat from permanently confined connections, direct neighbors - real(DP), dimension(:), pointer, contiguous :: amatpcx => null() !saved contributions to amat from permanently confined connections, extended neighbors - integer(I4B), dimension(:), pointer, contiguous :: iallpc => null() !indicates for each node whether all connections processed by xt3d are permanently confined (0 no, 1 yes) - logical, pointer :: lamatsaved => null() !indicates whether amat has been saved for permanently confined connections - class(DisBaseType), pointer :: dis => null() !discretization object - ! pointers to npf variables - real(DP), dimension(:), pointer, contiguous :: k11 => null() !horizontal hydraulic conductivity - real(DP), dimension(:),pointer, contiguous :: k22 => null() !minor axis of horizontal hydraulic conductivity ellipse - real(DP), dimension(:), pointer, contiguous :: k33 => null() !vertical hydraulic conductivity - integer(I4B), pointer :: ik22 => null() !flag indicates K22 was read - integer(I4B), pointer :: ik33 => null() !flag indicates K33 was read - real(DP), dimension(:), pointer, contiguous :: sat => null() !saturation (0. to 1.) for each cell - integer(I4B), pointer :: inewton => null() !Newton flag - integer(I4B), dimension(:), pointer, contiguous :: icelltype => null() !cell type (confined or unconfined) - integer(I4B), pointer :: iangle1 => null() !flag to indicate angle1 was read - integer(I4B), pointer :: iangle2 => null() !flag to indicate angle2 was read - integer(I4B), pointer :: iangle3 => null() !flag to indicate angle3 was read - real(DP), dimension(:), pointer, contiguous :: angle1 => null() !k ellipse rotation in xy plane around z axis (yaw) - real(DP), dimension(:), pointer, contiguous :: angle2 => null() !k ellipse rotation up from xy plane around y axis (pitch) - real(DP), dimension(:), pointer, contiguous :: angle3 => null() !k tensor rotation around x axis (roll) - logical, pointer :: ldispersion => null() !flag to indicate dispersion - contains - procedure :: xt3d_df - procedure :: xt3d_ac - procedure :: xt3d_mc - procedure :: xt3d_ar - procedure :: xt3d_fc - procedure :: xt3d_fcpc - procedure :: xt3d_fhfb - procedure :: xt3d_flowjahfb - procedure :: xt3d_fn - procedure :: xt3d_flowja - procedure :: xt3d_da - procedure, private :: allocate_scalars - procedure, private :: allocate_arrays - procedure, private :: xt3d_load - procedure, private :: xt3d_load_inbr - procedure, private :: xt3d_indices - procedure, private :: xt3d_areas - procedure, private :: xt3d_amat_nbrs - procedure, private :: xt3d_amatpc_nbrs - procedure, private :: xt3d_amat_nbrnbrs - procedure, private :: xt3d_amatpcx_nbrnbrs - procedure, private :: xt3d_iallpc - procedure, private :: xt3d_get_iinm - procedure, private :: xt3d_get_iinmx - procedure, private :: xt3d_rhs - procedure, private :: xt3d_fillrmatck - procedure, private :: xt3d_qnbrs - end type Xt3dType - - contains - - subroutine xt3d_cr(xt3dobj, name_model, inunit, iout, ldispopt) -! ****************************************************************************** -! xt3d_cr -- Create a new xt3d object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - type(Xt3dType), pointer :: xt3dobj - character(len=*), intent(in) :: name_model - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - logical, optional, intent(in) :: ldispopt -! ------------------------------------------------------------------------------ - ! - ! -- Create the object - allocate(xt3dobj) - ! - ! -- Allocate scalars - call xt3dobj%allocate_scalars(name_model) - ! - ! -- Set variables - xt3dobj%inunit = inunit - xt3dobj%iout = iout - if (present(ldispopt)) xt3dobj%ldispersion = ldispopt - ! - ! -- Return - return - end subroutine xt3d_cr - - subroutine xt3d_df(this, dis) -! ****************************************************************************** -! xt3d_df -- define the xt3d object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(Xt3dType) :: this - class(DisBaseType), pointer, intent(inout) :: dis -! ------------------------------------------------------------------------------ - ! - this%dis => dis - ! - ! -- Return - return - end subroutine xt3d_df - - subroutine xt3d_ac(this, moffset, sparse) -! ****************************************************************************** -! xt3d_ac -- Add connections for extended neighbors to the sparse matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SparseModule, only: sparsematrix - ! -- dummy - class(Xt3dType) :: this - integer(I4B), intent(in) :: moffset - type(sparsematrix), intent(inout) :: sparse - ! -- local - integer(I4B) :: i, j, k, jj, kk, iglo, kglo, iadded -! ------------------------------------------------------------------------------ - ! - ! -- If not rhs, add connections - if (this%ixt3d == 1) then - ! -- loop over nodes - do i = 1, this%dis%nodes - iglo = i + moffset - ! -- loop over neighbors - do jj = this%dis%con%ia(i), this%dis%con%ia(i+1) - 1 - j = this%dis%con%ja(jj) - ! -- loop over neighbors of neighbors - do kk = this%dis%con%ia(j), this%dis%con%ia(j+1) - 1 - k = this%dis%con%ja(kk) - kglo = k + moffset - call sparse%addconnection(iglo, kglo, 1, iadded) - this%numextnbrs = this%numextnbrs + iadded - enddo - enddo - enddo - endif - ! - ! -- Return - return - end subroutine xt3d_ac - - subroutine xt3d_mc(this, moffset, iasln, jasln, inewton) -! ****************************************************************************** -! xt3d_mc -- Map connections and construct iax, jax, and idxglox -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(Xt3dType) :: this - integer(I4B), intent(in) :: moffset - integer(I4B), dimension(:), intent(in) :: iasln - integer(I4B), dimension(:), intent(in) :: jasln - ! -- local - integer(I4B) :: i, j, jj, iglo, jglo, jjg, niax, njax, ipos, inewton - integer(I4B) :: igfirstnod, iglastnod - logical :: isextnbr -! ------------------------------------------------------------------------------ - ! - ! -- If not rhs, map connections for extended neighbors and construct iax, - ! -- jax, and idxglox - if (this%ixt3d == 1) then - ! - ! -- calculate the first node for the model and the last node in global - ! numbers - igfirstnod = moffset + 1 - iglastnod = moffset + this%dis%nodes - ! - ! -- allocate iax, jax, and idxglox - niax = this%dis%nodes + 1 - njax = this%numextnbrs ! + 1 - call mem_allocate(this%iax, niax, 'IAX', trim(this%origin)) - call mem_allocate(this%jax, njax, 'JAX', trim(this%origin)) - call mem_allocate(this%idxglox, njax, 'IDXGLOX', trim(this%origin)) - ! - ! -- load first iax entry - ipos = 1 - this%iax(1) = ipos - ! - ! -- loop over nodes - do i = 1, this%dis%nodes - ! - ! -- calculate global node number - iglo = i + moffset - ! - ! -- loop over neighbors in global matrix - do jjg = iasln(iglo), iasln(iglo + 1) - 1 - ! - ! -- if jglo is in a different model, then it cannot be an extended - ! neighbor, so skip over it - jglo = jasln(jjg) - if (jglo < igfirstnod .or. jglo > iglastnod) then - cycle - endif - ! - ! -- determine whether this neighbor is an extended neighbor - ! by searching the original neighbors - isextnbr = .true. - searchloop: do jj = this%dis%con%ia(i), this%dis%con%ia(i+1) - 1 - j = this%dis%con%ja(jj) - jglo = j + moffset - ! - ! -- if an original neighbor, note that and end the search - if(jglo == jasln(jjg)) then - isextnbr = .false. - exit searchloop - endif - enddo searchloop - ! - ! -- if an extended neighbor, add it to jax and idxglox - if (isextnbr) then - this%jax(ipos) = jasln(jjg) - moffset - this%idxglox(ipos) = jjg - ipos = ipos + 1 - endif - enddo - ! -- load next iax entry - this%iax(i+1) = ipos - enddo - ! - else - ! - call mem_allocate(this%iax, 0, 'IAX', trim(this%origin)) - call mem_allocate(this%jax, 0, 'JAX', trim(this%origin)) - call mem_allocate(this%idxglox, 0, 'IDXGLOX', trim(this%origin)) - ! - endif - ! - ! -- Return - return - end subroutine xt3d_mc - - subroutine xt3d_ar(this, ibound, k11, ik33, k33, sat, ik22, k22, & - inewton, icelltype, iangle1, iangle2, iangle3, angle1, angle2, angle3) -! ****************************************************************************** -! xt3d_ar -- Allocate and Read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: store_error, ustop - ! -- dummy - class(Xt3dType) :: this - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: ibound - real(DP), dimension(:), intent(in), pointer, contiguous :: k11 - integer(I4B), intent(in), pointer :: ik33 - real(DP), dimension(:), intent(in), pointer, contiguous :: k33 - real(DP), dimension(:), intent(in), pointer, contiguous :: sat - integer(I4B), intent(in), pointer :: ik22 - real(DP), dimension(:), intent(in), pointer, contiguous :: k22 - integer(I4B), intent(in), pointer :: inewton - integer(I4B), dimension(:), intent(in), pointer, contiguous :: icelltype - integer(I4B), intent(in), pointer :: iangle1 - integer(I4B), intent(in), pointer :: iangle2 - integer(I4B), intent(in), pointer :: iangle3 - real(DP), dimension(:), intent(in), pointer, contiguous :: angle1 - real(DP), dimension(:), intent(in), pointer, contiguous :: angle2 - real(DP), dimension(:), intent(in), pointer, contiguous :: angle3 - ! -- local - integer(I4B) :: n, nnbrs - ! -- formats - character(len=*), parameter :: fmtheader = & - "(1x, /1x, 'XT3D is active.'//)" - ! -- data -! ------------------------------------------------------------------------------ - ! - ! -- Print a message identifying the xt3d module. - write(this%iout, fmtheader) - ! - ! -- Store pointers to arguments that were passed in - this%ibound => ibound - this%k11 => k11 - this%ik33 => ik33 - this%k33 => k33 - this%sat => sat - this%ik22 => ik22 - this%k22 => k22 - this%inewton => inewton - this%icelltype => icelltype - this%iangle1 => iangle1 - this%iangle2 => iangle2 - this%iangle3 => iangle3 - this%angle1 => angle1 - this%angle2 => angle2 - this%angle3 => angle3 - ! - ! -- If angle1 and angle2 were not specified, then there is no z - ! component in the xt3d formulation for horizontal connections. - if(this%iangle2 == 0) this%nozee = .true. - ! - ! -- Determine the maximum number of neighbors for any cell. - this%nbrmax = 0 - do n = 1, this%dis%nodes - nnbrs = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 - this%nbrmax = max(nnbrs, this%nbrmax) - end do - ! - ! -- Check to make sure dis package can calculate connection direction info - if (this%dis%icondir == 0) then - call store_error('Error. Vertices not specified for discretization ' // & - 'package, but XT3D is active: '// trim(adjustl(this%origin)) // & - '. Vertices must be specified in discretization package in order ' // & - 'to use XT3D.') - call ustop() - endif - ! - ! -- Check to make sure ANGLEDEGX is available for interface normals - if (this%dis%con%ianglex == 0) then - call store_error('Error. ANGLDEGX is not specified in the DIS ' // & - 'package, but XT3D is active: '// trim(adjustl(this%origin)) // & - '. ANGLDEGX must be provided in discretization package in order ' // & - 'to use XT3D.') - call ustop() - endif - ! - ! -- allocate arrays - call this%allocate_arrays() - ! - ! -- If not Newton and not rhs, calculate amatpc and amatpcx for permanently - ! -- confined connections - if(this%lamatsaved) call this%xt3d_fcpc(this%dis%nodes) - ! - ! -- Return - return - end subroutine xt3d_ar - - subroutine xt3d_fc(this, kiter, njasln, amat, idxglo, rhs, hnew) -! ****************************************************************************** -! xt3d_fc -- Formulate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: DONE - use Xt3dAlgorithmModule, only: qconds - ! -- dummy - class(Xt3dType) :: this - integer(I4B) :: kiter - integer(I4B),intent(in) :: njasln - real(DP),dimension(njasln),intent(inout) :: amat - integer(I4B),intent(in),dimension(:) :: idxglo - real(DP),intent(inout),dimension(:) :: rhs - real(DP),intent(inout),dimension(:) :: hnew - ! -- local - integer(I4B) :: nodes, nja - integer(I4B) :: n, m, ipos - ! - logical :: allhc0, allhc1 - integer(I4B) :: nnbr0, nnbr1 - integer(I4B) :: il0, ii01, jjs01, il01, il10, ii00, ii11, ii10 - integer(I4B) :: i - integer(I4B),dimension(this%nbrmax) :: inbr0, inbr1 - real(DP) :: ar01, ar10 - real(DP),dimension(this%nbrmax,3) :: vc0, vn0, vc1, vn1 - real(DP),dimension(this%nbrmax) :: dl0, dl0n, dl1, dl1n - real(DP),dimension(3,3) :: ck0, ck1 - real(DP) :: chat01 - real(DP),dimension(this%nbrmax) :: chati0, chat1j - real(DP) :: qnm, qnbrs -! ------------------------------------------------------------------------------ - ! - ! -- Calculate xt3d conductance-like coefficients and put into amat and rhs - ! -- as appropriate - ! - nodes = this%dis%nodes - nja = this%dis%con%nja - if (this%lamatsaved) then - do i = 1, this%dis%con%nja - amat(idxglo(i)) = amat(idxglo(i)) + this%amatpc(i) - end do - do i = 1, this%numextnbrs - amat(this%idxglox(i)) = amat(this%idxglox(i)) + this%amatpcx(i) - end do - end if - ! - do n = 1, nodes - ! -- Skip if inactive. - if (this%ibound(n).eq.0) cycle - ! -- Skip if all connections are permanently confined - if (this%lamatsaved) then - if (this%iallpc(n) == 1) cycle - end if - nnbr0 = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 - ! -- Load conductivity and connection info for cell 0. - call this%xt3d_load(nodes, n, nnbr0, inbr0, vc0, vn0, dl0, dl0n, & - ck0, allhc0) - ! -- Loop over active neighbors of cell 0 that have a higher - ! -- cell number (taking advantage of reciprocity). - do il0 = 1,nnbr0 - ipos = this%dis%con%ia(n) + il0 - if (this%dis%con%mask(ipos) == 0) cycle - - m = inbr0(il0) - ! -- Skip if neighbor is inactive or has lower cell number. - if ((m.eq.0).or.(m.lt.n)) cycle - nnbr1 = this%dis%con%ia(m+1) - this%dis%con%ia(m) - 1 - ! -- Load conductivity and connection info for cell 1. - call this%xt3d_load(nodes, m, nnbr1, inbr1, vc1, vn1, dl1, dl1n, & - ck1, allhc1) - ! -- Set various indices. - call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & - ii00, ii11, ii10) - ! -- Compute areas. - if (this%inewton /= 0) then - ar01 = DONE - ar10 = DONE - else - call this%xt3d_areas(nodes, n, m, jjs01, .false., ar01, ar10, hnew) - end if - ! -- Compute "conductances" for interface between - ! -- cells 0 and 1. - call qconds(this%nbrmax, nnbr0, inbr0, il01, vc0, vn0, dl0, dl0n, & - ck0, nnbr1, inbr1, il10, vc1, vn1, dl1, dl1n, ck1, ar01, ar10, & - this%vcthresh, allhc0, allhc1, chat01, chati0, chat1j) - ! -- If Newton, compute and save saturated flow, then scale - ! -- conductance-like coefficients by the actual area for - ! -- subsequent amat and rhs assembly. - if (this%inewton /= 0) then - ! -- Contribution to flow from primary connection. - qnm = chat01*(hnew(m) - hnew(n)) - ! -- Contribution from immediate neighbors of node 0. - call this%xt3d_qnbrs(nodes, n, m, nnbr0, inbr0, chati0, hnew, qnbrs) - qnm = qnm + qnbrs - ! -- Contribution from immediate neighbors of node 1. - call this%xt3d_qnbrs(nodes, m, n, nnbr1, inbr1, chat1j, hnew, qnbrs) - qnm = qnm - qnbrs - ! -- Multiply by saturated area and save in qsat. - call this%xt3d_areas(nodes, n, m, jjs01, .true., ar01, ar10, hnew) - this%qsat(ii01) = qnm*ar01 - ! -- Scale coefficients by actual area. If RHS - ! -- formulation, also compute and save qrhs. - call this%xt3d_areas(nodes, n, m, jjs01, .false., ar01, ar10, hnew) - if (this%ixt3d == 2) then - this%qrhs(ii01) = -qnbrs*ar01 - end if - chat01 = chat01*ar01 - chati0 = chati0*ar01 - chat1j = chat1j*ar01 - end if - ! -- Contribute to rows for cells 0 and 1. - amat(idxglo(ii00)) = amat(idxglo(ii00)) - chat01 - amat(idxglo(ii01)) = amat(idxglo(ii01)) + chat01 - amat(idxglo(ii11)) = amat(idxglo(ii11)) - chat01 - amat(idxglo(ii10)) = amat(idxglo(ii10)) + chat01 - if (this%ixt3d == 1) then - call this%xt3d_amat_nbrs(nodes, n, ii00, nnbr0, nja, njasln, & - inbr0, amat, idxglo, chati0) - call this%xt3d_amat_nbrnbrs(nodes, n, m, ii01, nnbr1, nja, njasln, & - inbr1, amat, idxglo, chat1j) - call this%xt3d_amat_nbrs(nodes, m, ii11, nnbr1, nja, njasln, & - inbr1, amat, idxglo, chat1j) - call this%xt3d_amat_nbrnbrs(nodes, m, n, ii10, nnbr0, nja, njasln, & - inbr0, amat, idxglo, chati0) - else - call this%xt3d_rhs(nodes, n, m, nnbr0, inbr0, chati0, hnew, rhs) - call this%xt3d_rhs(nodes, m, n, nnbr1, inbr1, chat1j, hnew, rhs) - endif - ! - enddo - enddo - ! - ! -- Return - return - end subroutine xt3d_fc - - subroutine xt3d_fcpc(this, nodes) -! ****************************************************************************** -! xt3d_fcpc -- Formulate for permanently confined connections and save in -! amatpc and amatpcx -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: DONE - use Xt3dAlgorithmModule, only: qconds - ! -- dummy - class(Xt3dType) :: this - integer(I4B) :: nodes - ! -- local - integer(I4B) :: n, m, ipos - ! - logical :: allhc0, allhc1 - integer(I4B) :: nnbr0, nnbr1 - integer(I4B) :: il0, ii01, jjs01, il01, il10, ii00, ii11, ii10 - integer(I4B),dimension(this%nbrmax) :: inbr0, inbr1 - real(DP) :: ar01, ar10 - real(DP),dimension(this%nbrmax,3) :: vc0, vn0, vc1, vn1 - real(DP),dimension(this%nbrmax) :: dl0, dl0n, dl1, dl1n - real(DP),dimension(3,3) :: ck0, ck1 - real(DP) :: chat01 - real(DP),dimension(this%nbrmax) :: chati0, chat1j -! ------------------------------------------------------------------------------ - ! - ! -- Calculate xt3d conductance-like coefficients for permanently confined - ! -- connections and put into amatpc and amatpcx as appropriate - do n = 1, nodes - ! -- Skip if not iallpc. - if (this%iallpc(n) == 0) cycle - nnbr0 = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 - ! -- Load conductivity and connection info for cell 0. - call this%xt3d_load(nodes, n, nnbr0, inbr0, vc0, vn0, dl0, dl0n, & - ck0, allhc0) - ! -- Loop over active neighbors of cell 0 that have a higher - ! -- cell number (taking advantage of reciprocity). - do il0 = 1,nnbr0 - ipos = this%dis%con%ia(n) + il0 - if (this%dis%con%mask(ipos) == 0) cycle - - m = inbr0(il0) - ! -- Skip if neighbor has lower cell number. - if (m.lt.n) cycle - nnbr1 = this%dis%con%ia(m+1) - this%dis%con%ia(m) - 1 - ! -- Load conductivity and connection info for cell 1. - call this%xt3d_load(nodes, m, nnbr1, inbr1, vc1, vn1, dl1, dl1n, & - ck1, allhc1) - ! -- Set various indices. - call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & - ii00, ii11, ii10) - ! -- Compute confined areas. - call this%xt3d_areas(nodes, n, m, jjs01, .true., ar01, ar10) - ! -- Compute "conductances" for interface between - ! -- cells 0 and 1. - call qconds(this%nbrmax, nnbr0, inbr0, il01, vc0, vn0, dl0, dl0n, & - ck0, nnbr1, inbr1, il10, vc1, vn1, dl1, dl1n, ck1, ar01, ar10, & - this%vcthresh, allhc0, allhc1, chat01, chati0, chat1j) - ! -- Contribute to rows for cells 0 and 1. - this%amatpc(ii00) = this%amatpc(ii00) - chat01 - this%amatpc(ii01) = this%amatpc(ii01) + chat01 - this%amatpc(ii11) = this%amatpc(ii11) - chat01 - this%amatpc(ii10) = this%amatpc(ii10) + chat01 - call this%xt3d_amatpc_nbrs(nodes, n, ii00, nnbr0, inbr0, chati0) - call this%xt3d_amatpcx_nbrnbrs(nodes, n, m, ii01, nnbr1, inbr1, chat1j) - call this%xt3d_amatpc_nbrs(nodes, m, ii11, nnbr1, inbr1, chat1j) - call this%xt3d_amatpcx_nbrnbrs(nodes, m, n, ii10, nnbr0, inbr0, chati0) - enddo - enddo - ! - ! -- Return - return - end subroutine xt3d_fcpc - - subroutine xt3d_fhfb(this, kiter, nodes, nja, njasln, amat, idxglo, rhs, hnew, & - n, m, condhfb) -! ****************************************************************************** -! xt3d_fhfb -- Formulate HFB correction -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: DONE - use Xt3dAlgorithmModule, only: qconds - ! -- dummy - class(Xt3dType) :: this - integer(I4B) :: kiter - integer(I4B),intent(in) :: nodes - integer(I4B),intent(in) :: nja - integer(I4B),intent(in) :: njasln - integer(I4B) :: n, m - real(DP),dimension(njasln),intent(inout) :: amat - integer(I4B),intent(in),dimension(nja) :: idxglo - real(DP),intent(inout),dimension(nodes) :: rhs - real(DP),intent(inout),dimension(nodes) :: hnew - real(DP) :: condhfb - ! -- local - ! - logical :: allhc0, allhc1 - integer(I4B) :: nnbr0, nnbr1 - integer(I4B) :: il0, ii01, jjs01, il01, il10, ii00, ii11, ii10, il - integer(I4B),dimension(this%nbrmax) :: inbr0, inbr1 - real(DP) :: ar01, ar10 - real(DP),dimension(this%nbrmax,3) :: vc0, vn0, vc1, vn1 - real(DP),dimension(this%nbrmax) :: dl0, dl0n, dl1, dl1n - real(DP),dimension(3,3) :: ck0, ck1 - real(DP) :: chat01 - real(DP),dimension(this%nbrmax) :: chati0, chat1j - real(DP) :: qnm, qnbrs - real(DP) :: term -! ------------------------------------------------------------------------------ - ! - ! -- Calculate hfb corrections to xt3d conductance-like coefficients and - ! -- put into amat and rhs as appropriate - ! - nnbr0 = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 - ! -- Load conductivity and connection info for cell 0. - call this%xt3d_load(nodes, n, nnbr0, inbr0, vc0, vn0, dl0, dl0n, & - ck0, allhc0) - ! -- Find local neighbor number of cell 1. - do il = 1,nnbr0 - if (inbr0(il).eq.m) then - il0 = il - exit - end if - end do - nnbr1 = this%dis%con%ia(m+1) - this%dis%con%ia(m) - 1 - ! -- Load conductivity and connection info for cell 1. - call this%xt3d_load(nodes, m, nnbr1, inbr1, vc1, vn1, dl1, dl1n, & - ck1, allhc1) - ! -- Set various indices. - call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & - ii00, ii11, ii10) - ! -- Compute areas. - if (this%inewton /= 0) then - ar01 = DONE - ar10 = DONE - else - call this%xt3d_areas(nodes, n, m, jjs01, .false., ar01, ar10, hnew) - end if - ! -- Compute "conductances" for interface between - ! -- cells 0 and 1. - call qconds(this%nbrmax, nnbr0, inbr0, il01, vc0, vn0, dl0, dl0n, & - ck0, nnbr1, inbr1, il10, vc1, vn1, dl1, dl1n, ck1, ar01, ar10, & - this%vcthresh, allhc0, allhc1, chat01, chati0, chat1j) - ! -- Apply scale factor to compute "conductances" for hfb correction - if(condhfb > DZERO) then - term = chat01/(chat01 + condhfb) - else - term = -condhfb - endif - chat01 = -chat01*term - chati0 = -chati0*term - chat1j = -chat1j*term - ! -- If Newton, compute and save saturated flow, then scale - ! -- conductance-like coefficients by the actual area for - ! -- subsequent amat and rhs assembly. - if (this%inewton /= 0) then - ! -- Contribution to flow from primary connection. - qnm = chat01*(hnew(m) - hnew(n)) - ! -- Contribution from immediate neighbors of node 0. - call this%xt3d_qnbrs(nodes, n, m, nnbr0, inbr0, chati0, hnew, qnbrs) - qnm = qnm + qnbrs - ! -- Contribution from immediate neighbors of node 1. - call this%xt3d_qnbrs(nodes, m, n, nnbr1, inbr1, chat1j, hnew, qnbrs) - qnm = qnm - qnbrs - ! -- Multiply by saturated area and add correction to qsat. - call this%xt3d_areas(nodes, n, m, jjs01, .true., ar01, ar10, hnew) - this%qsat(ii01) = this%qsat(ii01) + qnm*ar01 - ! -- Scale coefficients by actual area. If RHS - ! -- formulation, also compute and add correction to qrhs. - call this%xt3d_areas(nodes, n, m, jjs01, .false., ar01, ar10, hnew) - if (this%ixt3d == 2) then - this%qrhs(ii01) = this%qrhs(ii01) - qnbrs*ar01 - end if - chat01 = chat01*ar01 - chati0 = chati0*ar01 - chat1j = chat1j*ar01 - end if - ! -- Contribute to rows for cells 0 and 1. - amat(idxglo(ii00)) = amat(idxglo(ii00)) - chat01 - amat(idxglo(ii01)) = amat(idxglo(ii01)) + chat01 - amat(idxglo(ii11)) = amat(idxglo(ii11)) - chat01 - amat(idxglo(ii10)) = amat(idxglo(ii10)) + chat01 - if (this%ixt3d == 1) then - call this%xt3d_amat_nbrs(nodes, n, ii00, nnbr0, nja, njasln, & - inbr0, amat, idxglo, chati0) - call this%xt3d_amat_nbrnbrs(nodes, n, m, ii01, nnbr1, nja, njasln, & - inbr1, amat, idxglo, chat1j) - call this%xt3d_amat_nbrs(nodes, m, ii11, nnbr1, nja, njasln, & - inbr1, amat, idxglo, chat1j) - call this%xt3d_amat_nbrnbrs(nodes, m, n, ii10, nnbr0, nja, njasln, & - inbr0, amat, idxglo, chati0) - else - call this%xt3d_rhs(nodes, n, m, nnbr0, inbr0, chati0, hnew, rhs) - call this%xt3d_rhs(nodes, m, n, nnbr1, inbr1, chat1j, hnew, rhs) - endif - ! - ! -- Return - return - end subroutine xt3d_fhfb - - subroutine xt3d_fn(this, kiter, nodes, nja, njasln, amat, idxglo, rhs, hnew) -! ****************************************************************************** -! xt3d_fn -- Fill Newton terms for xt3d -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: DONE - use SmoothingModule, only: sQuadraticSaturationDerivative - ! -- dummy - class(Xt3dType) :: this - integer(I4B) :: kiter - integer(I4B),intent(in) :: nodes - integer(I4B),intent(in) :: nja - integer(I4B),intent(in) :: njasln - real(DP),dimension(njasln),intent(inout) :: amat - integer(I4B),intent(in),dimension(nja) :: idxglo - real(DP),intent(inout),dimension(nodes) :: rhs - real(DP),intent(inout),dimension(nodes) :: hnew - ! -- local - integer(I4B) :: n, m, ipos - ! - integer(I4B) :: nnbr0 - integer(I4B) :: il0, ii01, jjs01, il01, il10, ii00, ii11, ii10 - integer(I4B),dimension(this%nbrmax) :: inbr0 - integer(I4B) :: iups, idn - real(DP) :: topup, botup, derv, term, termrhs -! ------------------------------------------------------------------------------ - ! - ! -- Update amat and rhs with Newton terms - do n = 1, nodes - ! -- Skip if inactive. - if (this%ibound(n).eq.0) cycle - ! -- No Newton correction if amat saved (which implies no rhs option) - ! -- and all connections for the cell are permanently confined. - if (this%lamatsaved) then - if (this%iallpc(n) == 1) cycle - end if - nnbr0 = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 - ! -- Load neighbors of cell. Set cell numbers for inactive - ! -- neighbors to zero. - call this%xt3d_load_inbr(n, nnbr0, inbr0) - ! -- Loop over active neighbors of cell 0 that have a higher - ! -- cell number (taking advantage of reciprocity). - do il0 = 1,nnbr0 - ipos = this%dis%con%ia(n) + il0 - if (this%dis%con%mask(ipos) == 0) cycle - - m = inbr0(il0) - ! -- Skip if neighbor is inactive or has lower cell number. - if ((inbr0(il0).eq.0).or.(m.lt.n)) cycle - ! -- Set various indices. - call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & - ii00, ii11, ii10) - ! determine upstream node - iups = m - if (hnew(m) < hnew(n)) iups = n - idn = n - if (iups == n) idn = m - ! -- no Newton terms if upstream cell is confined - ! -- and no rhs option - if ((this%icelltype(iups) == 0).and.(this%ixt3d.eq.1)) cycle - ! -- Set the upstream top and bot, and then recalculate for a - ! vertically staggered horizontal connection - topup = this%dis%top(iups) - botup = this%dis%bot(iups) - if(this%dis%con%ihc(jjs01) == 2) then - topup = min(this%dis%top(n), this%dis%top(m)) - botup = max(this%dis%bot(n), this%dis%bot(m)) - endif - ! derivative term - derv = sQuadraticSaturationDerivative(topup, botup, hnew(iups)) - term = this%qsat(ii01) * derv - if (this%ixt3d == 1) then - termrhs = term - else - termrhs = term - this%qrhs(ii01) - endif - ! fill Jacobian for n being the upstream node - if (iups == n) then - ! fill in row of n - amat(idxglo(ii00)) = amat(idxglo(ii00)) + term - rhs(n) = rhs(n) + termrhs * hnew(n) - ! fill in row of m - amat(idxglo(ii10)) = amat(idxglo(ii10)) - term - rhs(m) = rhs(m) - termrhs * hnew(n) - ! fill Jacobian for m being the upstream node - else - ! fill in row of n - amat(idxglo(ii01)) = amat(idxglo(ii01)) + term - rhs(n) = rhs(n) + termrhs * hnew(m) - ! fill in row of m - amat(idxglo(ii11)) = amat(idxglo(ii11)) - term - rhs(m) = rhs(m) - termrhs * hnew(m) - end if - enddo - enddo - ! - ! -- Return - return - end subroutine xt3d_fn - - subroutine xt3d_flowja(this, hnew, flowja) -! ****************************************************************************** -! xt3d_flowja -- Budget -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use Xt3dAlgorithmModule, only: qconds - ! -- dummy - class(Xt3dType) :: this - real(DP),intent(inout),dimension(:) :: hnew - real(DP),intent(inout),dimension(:) :: flowja - ! -- local - integer(I4B) :: n, ipos, m, nodes - real(DP) :: qnm, qnbrs - logical :: allhc0, allhc1 - integer(I4B) :: nnbr0, nnbr1 - integer(I4B) :: il0, ii01, jjs01, il01, il10, ii00, ii11, ii10 - integer(I4B),dimension(this%nbrmax) :: inbr0, inbr1 - real(DP) :: ar01, ar10 - real(DP),dimension(this%nbrmax,3) :: vc0, vn0, vc1, vn1 - real(DP),dimension(this%nbrmax) :: dl0, dl0n, dl1, dl1n - real(DP),dimension(3,3) :: ck0, ck1 - real(DP) :: chat01 - real(DP),dimension(this%nbrmax) :: chati0, chat1j -! ------------------------------------------------------------------------------ - ! - ! -- Calculate the flow across each cell face and store in flowja - nodes = this%dis%nodes - do n = 1, nodes - ! -- Skip if inactive. - if (this%ibound(n).eq.0) cycle - nnbr0 = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 - ! -- Load conductivity and connection info for cell 0. - call this%xt3d_load(nodes, n, nnbr0, inbr0, vc0, vn0, dl0, dl0n, & - ck0, allhc0) - ! -- Loop over active neighbors of cell 0 that have a higher - ! -- cell number (taking advantage of reciprocity). - do il0 = 1,nnbr0 - m = inbr0(il0) - ! -- Skip if neighbor is inactive or has lower cell number. - if ((inbr0(il0).eq.0).or.(m.lt.n)) cycle - nnbr1 = this%dis%con%ia(m+1) - this%dis%con%ia(m) - 1 - ! -- Load conductivity and connection info for cell 1. - call this%xt3d_load(nodes, m, nnbr1, inbr1, vc1, vn1, dl1, dl1n, & - ck1, allhc1) - ! -- Set various indices. - call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & - ii00, ii11, ii10) - ! -- Compute areas. - if (this%inewton /= 0) & - call this%xt3d_areas(nodes, n, m, jjs01, .true., ar01, ar10, hnew) - call this%xt3d_areas(nodes, n, m, jjs01, .false., ar01, ar10, hnew) - ! -- Compute "conductances" for interface between - ! -- cells 0 and 1. - call qconds(this%nbrmax, nnbr0, inbr0, il01, vc0, vn0, dl0, dl0n, & - ck0, nnbr1, inbr1, il10, vc1, vn1, dl1, dl1n, ck1, ar01, ar10, & - this%vcthresh, allhc0, allhc1, chat01, chati0, chat1j) - ! -- Contribution to flow from primary connection. - qnm = chat01*(hnew(m) - hnew(n)) - ! -- Contribution from immediate neighbors of node 0. - call this%xt3d_qnbrs(nodes, n, m, nnbr0, inbr0, chati0, hnew, qnbrs) - qnm = qnm + qnbrs - ! -- Contribution from immediate neighbors of node 1. - call this%xt3d_qnbrs(nodes, m, n, nnbr1, inbr1, chat1j, hnew, qnbrs) - qnm = qnm - qnbrs - ipos = ii01 - flowja(ipos) = flowja(ipos) + qnm - flowja(this%dis%con%isym(ipos)) = flowja(this%dis%con%isym(ipos)) - qnm - enddo - enddo - ! - ! -- Return - return - end subroutine xt3d_flowja - - subroutine xt3d_flowjahfb(this, n, m, hnew, flowja, condhfb) -! ****************************************************************************** -! xt3d_flowjahfb -- hfb contribution to flowja when xt3d is used -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: DONE - use Xt3dAlgorithmModule, only: qconds - ! -- dummy - class(Xt3dType) :: this - integer(I4B) :: n, m - real(DP),intent(inout),dimension(:) :: hnew - real(DP),intent(inout),dimension(:) :: flowja - real(DP) :: condhfb - ! -- local - ! - integer(I4B) :: nodes - logical :: allhc0, allhc1 -!!! integer(I4B), parameter :: nbrmax = 10 - integer(I4B) :: nnbr0, nnbr1 - integer(I4B) :: il0, ii01, jjs01, il01, il10, ii00, ii11, ii10, il - integer(I4B),dimension(this%nbrmax) :: inbr0, inbr1 - integer(I4B) :: ipos - real(DP) :: ar01, ar10 - real(DP),dimension(this%nbrmax,3) :: vc0, vn0, vc1, vn1 - real(DP),dimension(this%nbrmax) :: dl0, dl0n, dl1, dl1n - real(DP),dimension(3,3) :: ck0, ck1 - real(DP) :: chat01 - real(DP),dimension(this%nbrmax) :: chati0, chat1j - real(DP) :: qnm, qnbrs - real(DP) :: term -! ------------------------------------------------------------------------------ - ! - ! -- Calculate hfb corrections to xt3d conductance-like coefficients and - ! -- put into amat and rhs as appropriate - ! - nodes = this%dis%nodes - nnbr0 = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 - ! -- Load conductivity and connection info for cell 0. - call this%xt3d_load(nodes, n, nnbr0, inbr0, vc0, vn0, dl0, dl0n, & - ck0, allhc0) - ! -- Find local neighbor number of cell 1. - do il = 1,nnbr0 - if (inbr0(il).eq.m) then - il0 = il - exit - end if - end do - nnbr1 = this%dis%con%ia(m+1) - this%dis%con%ia(m) - 1 - ! -- Load conductivity and connection info for cell 1. - call this%xt3d_load(nodes, m, nnbr1, inbr1, vc1, vn1, dl1, dl1n, & - ck1, allhc1) - ! -- Set various indices. - call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & - ii00, ii11, ii10) - ! -- Compute areas. - if (this%inewton /= 0) then - ar01 = DONE - ar10 = DONE - else - call this%xt3d_areas(nodes, n, m, jjs01, .false., ar01, ar10, hnew) - end if - ! -- Compute "conductances" for interface between - ! -- cells 0 and 1. - call qconds(this%nbrmax, nnbr0, inbr0, il01, vc0, vn0, dl0, dl0n, & - ck0, nnbr1, inbr1, il10, vc1, vn1, dl1, dl1n, ck1, ar01, ar10, & - this%vcthresh, allhc0, allhc1, chat01, chati0, chat1j) - ! -- Apply scale factor to compute "conductances" for hfb correction - if(condhfb > DZERO) then - term = chat01/(chat01 + condhfb) - else - term = -condhfb - endif - chat01 = -chat01*term - chati0 = -chati0*term - chat1j = -chat1j*term - ! -- Contribution to flow from primary connection. - qnm = chat01*(hnew(m) - hnew(n)) - ! -- Contribution from immediate neighbors of node 0. - call this%xt3d_qnbrs(nodes, n, m, nnbr0, inbr0, chati0, hnew, qnbrs) - qnm = qnm + qnbrs - ! -- Contribution from immediate neighbors of node 1. - call this%xt3d_qnbrs(nodes, m, n, nnbr1, inbr1, chat1j, hnew, qnbrs) - qnm = qnm - qnbrs - ! -- If Newton, scale conductance-like coefficients by the - ! -- actual area. - if (this%inewton /= 0) then - call this%xt3d_areas(nodes, n, m, jjs01, .true., ar01, ar10, hnew) - call this%xt3d_areas(nodes, n, m, jjs01, .false., ar01, ar10, hnew) - qnm = qnm*ar01 - end if - ipos = ii01 - flowja(ipos) = flowja(ipos) + qnm - flowja(this%dis%con%isym(ipos)) = flowja(this%dis%con%isym(ipos)) - qnm - ! - ! -- Return - return - end subroutine xt3d_flowjahfb - - subroutine xt3d_da(this) -! ****************************************************************************** -! xt3d_da -- Deallocate variables -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(Xt3dType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Deallocate arrays - if (this%ixt3d /= 0) then - call mem_deallocate(this%iax) - call mem_deallocate(this%jax) - call mem_deallocate(this%idxglox) - call mem_deallocate(this%rmatck) - call mem_deallocate(this%vecc) - call mem_deallocate(this%conlen) - call mem_deallocate(this%vecn) - call mem_deallocate(this%qsat) - call mem_deallocate(this%qrhs) - call mem_deallocate(this%amatpc) - call mem_deallocate(this%amatpcx) - call mem_deallocate(this%iallpc) - endif - ! - ! -- Strings - deallocate(this%origin) - ! - ! -- Scalars - call mem_deallocate(this%ixt3d) - call mem_deallocate(this%inunit) - call mem_deallocate(this%iout) - call mem_deallocate(this%numextnbrs) - call mem_deallocate(this%nozee) - call mem_deallocate(this%vcthresh) - call mem_deallocate(this%lamatsaved) - call mem_deallocate(this%nbrmax) - call mem_deallocate(this%ldispersion) - ! - ! -- Return - return - end subroutine xt3d_da - - subroutine allocate_scalars(this, name_model) -! ****************************************************************************** -! allocate_scalars -- Allocate scalar pointer variables -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(Xt3dType) :: this - character(len=*) :: name_model -! ------------------------------------------------------------------------------ - ! - ! -- Allocate and assign origin - allocate(this%origin) - this%origin = trim(adjustl(name_model)) // ' XT3D' - ! - ! -- Allocate scalars - call mem_allocate(this%ixt3d, 'IXT3D', this%origin) - call mem_allocate(this%nbrmax, 'NBRMAX', this%origin) - call mem_allocate(this%inunit, 'INUNIT', this%origin) - call mem_allocate(this%iout, 'IOUT', this%origin) - call mem_allocate(this%numextnbrs, 'NUMEXTNBRS', this%origin) - call mem_allocate(this%nozee, 'NOZEE', this%origin) - call mem_allocate(this%vcthresh, 'VCTHRESH', this%origin) - call mem_allocate(this%lamatsaved, 'LAMATSAVED', this%origin) - call mem_allocate(this%ldispersion, 'LDISPERSION', this%origin) - ! - ! -- Initialize value - this%ixt3d = 0 - this%nbrmax = 0 - this%inunit = 0 - this%iout = 0 - this%numextnbrs = 0 - this%nozee = .false. - this%vcthresh = 1.d-10 - this%lamatsaved = .false. - this%ldispersion = .false. - ! - ! -- Return - return - end subroutine allocate_scalars - - subroutine allocate_arrays(this) -! ****************************************************************************** -! allocate_arrays -- Allocate xt3d arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(Xt3dType) :: this - ! -- local - integer(I4B) :: njax -! ------------------------------------------------------------------------------ - ! - call mem_allocate(this%rmatck, 3, 3, 'RMATCK', this%origin) - ! - if (this%inewton /= 0) then - call mem_allocate(this%qsat, this%dis%nja, 'QSAT', this%origin) - if (this%ixt3d == 1) then - call mem_allocate(this%qrhs, 0, 'QRHS', this%origin) - else - call mem_allocate(this%qrhs, this%dis%nja, 'QRHS', this%origin) - end if - call mem_allocate(this%amatpc, 0, 'AMATPC', this%origin) - call mem_allocate(this%amatpcx, 0, 'AMATPCX', this%origin) - call mem_allocate(this%iallpc, 0, 'IALLPC', this%origin) - else - call mem_allocate(this%qsat, 0, 'QSAT', this%origin) - call mem_allocate(this%qrhs, 0, 'QRHS', this%origin) - end if - ! - call this%xt3d_iallpc() - ! - if (this%lamatsaved) then - call mem_allocate(this%amatpc, this%dis%nja, 'AMATPC', this%origin) - njax = this%numextnbrs ! + 1 - call mem_allocate(this%amatpcx, njax, 'AMATPCX', this%origin) - else - call mem_allocate(this%amatpc, 0, 'AMATPC', this%origin) - call mem_allocate(this%amatpcx, 0, 'AMATPCX', this%origin) - end if - call mem_allocate(this%vecc, 0, 3, 'VECC', this%origin) - call mem_allocate(this%conlen, 0, 'CONLEN', this%origin) - call mem_allocate(this%vecn, 0, 3, 'VECN', this%origin) - ! - this%rmatck = 0.d0 - if (this%inewton /= 0) then - this%qsat = 0.d0 - if (this%ixt3d == 2) this%qrhs = 0.d0 - else if (this%lamatsaved) then - this%amatpc = 0.d0 - this%amatpcx = 0.d0 - end if - this%vecc = 0.d0 - this%conlen = 0.d0 - this%vecn = 0.d0 - ! - ! -- Return - return - end subroutine allocate_arrays - - subroutine xt3d_iallpc(this) -! ****************************************************************************** -! xt3d_iallpc -- Allocate and populate iallpc array. Set lamatsaved. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate, mem_deallocate - ! -- dummy - class(Xt3dType) :: this - ! -- local - integer(I4B) :: n, m, mm, il0, il1 - integer(I4B) :: nnbr0, nnbr1 - integer(I4B),dimension(this%nbrmax) :: inbr0, inbr1 -! ------------------------------------------------------------------------------ - ! - if(this%ixt3d == 2 .or. this%ldispersion) then - this%lamatsaved = .false. - call mem_allocate(this%iallpc, 0, 'IALLPC', this%origin) - else - call mem_allocate(this%iallpc, this%dis%nodes, 'IALLPC', this%origin) - this%iallpc = 1 - do n = 1, this%dis%nodes - if (this%icelltype(n) /= 0) then - this%iallpc(n) = 0 - cycle - end if - nnbr0 = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 - call this%xt3d_load_inbr(n, nnbr0, inbr0) - do il0 = 1,nnbr0 - m = inbr0(il0) - if (m.lt.n) cycle - if (this%icelltype(m) /= 0) then - this%iallpc(n) = 0 - this%iallpc(m) = 0 - cycle - end if - nnbr1 = this%dis%con%ia(m+1) - this%dis%con%ia(m) - 1 - call this%xt3d_load_inbr(m, nnbr1, inbr1) - do il1 = 1,nnbr1 - mm = inbr1(il1) -!!! if (mm.lt.m) cycle - if (this%icelltype(mm) /= 0) then - this%iallpc(n) = 0 - this%iallpc(m) = 0 - this%iallpc(mm) = 0 - end if - enddo - enddo - enddo - this%lamatsaved = .false. - do n = 1, this%dis%nodes - if (this%iallpc(n) == 1) then - this%lamatsaved = .true. - exit - end if - enddo - end if - ! - if (.not.this%lamatsaved) then - call mem_deallocate(this%iallpc) ! kluge: ok to do this??? - call mem_allocate(this%iallpc, 0, 'IALLPC', this%origin) - end if - ! - ! -- Return - return - end subroutine xt3d_iallpc - - subroutine xt3d_indices(this, n, m, il0, ii01, jjs01, il01, il10, & - ii00, ii11, ii10) -! ****************************************************************************** -! xt3d_indices -- Set various indices for XT3D. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- module - ! -- dummy - class(Xt3dType) :: this - integer(I4B) :: n, m, il0, ii01, jjs01, il01, il10, ii00, ii11, ii10 - ! -- local - integer(I4B) :: iinm -! ------------------------------------------------------------------------------ - ! - ! -- Set local number of node 0-1 connection (local cell number of cell 1 - ! -- in cell 0's neighbor list). - il01 = il0 - ! -- Set local number of node 1-0 connection (local cell number of cell 0 - ! -- in cell 1's neighbor list). - call this%xt3d_get_iinm(m, n, iinm) - il10 = iinm - this%dis%con%ia(m) - ! -- Set index of node 0 diagonal in the ja array. - ii00 = this%dis%con%ia(n) - ! -- Set index of node 0-1 connection in the ja array. - ii01 = ii00 + il01 - ! -- Set symmetric index of node 0-1 connection. - jjs01 = this%dis%con%jas(ii01) - ! -- Set index of node 1 diagonal in the ja array. - ii11 = this%dis%con%ia(m) - ! -- Set index of node 1-0 connection in the ja array. - ii10 = ii11 + il10 - ! - return - end subroutine xt3d_indices - - subroutine xt3d_load(this, nodes, n, nnbr, inbr, vc, vn, dl, dln, ck, allhc) -! ****************************************************************************** -! xt3d_load -- Load conductivity and connection info for a cell into arrays -! used by XT3D. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- module - use ConstantsModule, only: DZERO, DHALF, DONE - ! -- dummy - class(Xt3dType) :: this - logical :: allhc - integer(I4B),intent(in) :: nodes - integer(I4B) :: n, nnbr - integer(I4B),dimension(this%nbrmax) :: inbr - real(DP),dimension(this%nbrmax,3) :: vc, vn - real(DP),dimension(this%nbrmax) :: dl, dln - real(DP),dimension(3,3) :: ck - ! -- local - integer(I4B) :: il, ii, jj, jjs - integer(I4B) :: ihcnjj - real(DP) :: satn, satjj - real(DP) :: cl1njj, cl2njj, dltot, ooclsum -! ------------------------------------------------------------------------------ - ! - ! -- Set conductivity tensor for cell. - ck = DZERO - ck(1,1) = this%k11(n) - if(this%ik22 == 0) then - ck(2,2) = ck(1,1) - else - ck(2,2) = this%k22(n) - end if - if(this%ik33 == 0) then - ck(3,3) = ck(1,1) - else - ck(3,3) = this%k33(n) - endif - call this%xt3d_fillrmatck(n) - ck = matmul(this%rmatck, ck) - ck = matmul(ck, transpose(this%rmatck)) - ! - ! -- Load neighbors of cell. Set cell numbers for inactive - ! -- neighbors to zero so xt3d knows to ignore them. Compute - ! -- direct connection lengths from perpendicular connection - ! -- lengths. Also determine if all active connections are - ! -- horizontal. - allhc = .true. - do il = 1,nnbr - ii = il + this%dis%con%ia(n) - jj = this%dis%con%ja(ii) - jjs = this%dis%con%jas(ii) - if (this%ibound(jj).ne.0) then - inbr(il) = jj - satn = this%sat(n) - satjj = this%sat(jj) - ! -- DISV and DIS - ihcnjj = this%dis%con%ihc(jjs) - call this%dis%connection_normal(n, jj, ihcnjj, & - vn(il, 1), vn(il, 2), vn(il, 3), ii) - call this%dis%connection_vector(n, jj, this%nozee, satn, satjj, & - ihcnjj, vc(il, 1), vc(il, 2), vc(il, 3), dltot) - if(jj > n) then - cl1njj = this%dis%con%cl1(jjs) - cl2njj = this%dis%con%cl2(jjs) - else - cl1njj = this%dis%con%cl2(jjs) - cl2njj = this%dis%con%cl1(jjs) - endif - ooclsum = 1d0/(cl1njj + cl2njj) - dl(il) = dltot*cl1njj*ooclsum - dln(il) = dltot*cl2njj*ooclsum - if (this%dis%con%ihc(jjs).eq.0) allhc = .false. - else - inbr(il) = 0 - end if - end do - ! - return - end subroutine xt3d_load - - subroutine xt3d_load_inbr(this, n, nnbr, inbr) -! ****************************************************************************** -! xt3d_load_inbr -- Load neighbor list for a cell. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- module - ! -- dummy - class(Xt3dType) :: this - integer(I4B) :: n, nnbr - integer(I4B),dimension(this%nbrmax) :: inbr - ! -- local - integer(I4B) :: il, ii, jj -! ------------------------------------------------------------------------------ - ! - ! -- Load neighbors of cell. Set cell numbers for inactive - ! -- neighbors to zero so xt3d knows to ignore them. - do il = 1,nnbr - ii = il + this%dis%con%ia(n) - jj = this%dis%con%ja(ii) - if (this%ibound(jj).ne.0) then - inbr(il) = jj - else - inbr(il) = 0 - end if - end do - ! - return - end subroutine xt3d_load_inbr - - subroutine xt3d_areas(this, nodes, n, m, jjs01, lsat, ar01, ar10, hnew) -! ****************************************************************************** -! xt3d_areas -- Compute interfacial areas. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- module - use ConstantsModule, only: DZERO, DONE - use SmoothingModule, only: sQuadraticSaturation ! kluge debug - ! -- dummy - class(Xt3dType) :: this - logical :: lsat - integer(I4B) :: nodes, n, m, jjs01 - real(DP) :: ar01, ar10 - real(DP),intent(inout),dimension(:), optional :: hnew - ! -- local - real(DP) :: topn, botn, topm, botm, thksatn, thksatm - real(DP) :: sill_top, sill_bot, tpn, tpm - real(DP) :: hn, hm ! kluge debug - real(DP) :: satups -! ------------------------------------------------------------------------------ - ! - ! -- Compute area depending on connection type - if (this%dis%con%ihc(jjs01).eq.0) then - ! -- vertical connection - ar01 = this%dis%con%hwva(jjs01) - ar10 = ar01 - else if (this%inewton /= 0) then - if (lsat) then - topn = this%dis%top(n) - botn = this%dis%bot(n) - topm = this%dis%top(m) - botm = this%dis%bot(m) - thksatn = topn - botn - thksatm = topm - botm - if (this%dis%con%ihc(jjs01).eq.2) then - ! -- vertically staggered - sill_top = min(topn, topm) - sill_bot = max(botn, botm) - tpn = botn + thksatn - tpm = botm + thksatm - thksatn = max(min(tpn, sill_top) - sill_bot, DZERO) - thksatm = max(min(tpm, sill_top) - sill_bot, DZERO) - end if - ar01 = this%dis%con%hwva(jjs01)*DHALF*(thksatn + thksatm) - else - ! -- If Newton and lsat=.false., it is assumed that the fully saturated - ! -- areas have already been calculated and are being passed in through - ! -- ar01 and ar10. The actual areas are obtained simply by scaling by - ! -- the upstream saturation. - if (hnew(m) < hnew(n)) then - if (this%icelltype(n) == 0) then - satups = DONE - else - topn = this%dis%top(n) - botn = this%dis%bot(n) - hn = hnew(n) ! kluge - satups = sQuadraticSaturation(topn, botn, hn) - end if - else - if (this%icelltype(m) == 0) then - satups = DONE - else - topm = this%dis%top(m) - botm = this%dis%bot(m) - hm = hnew(m) ! kluge - satups = sQuadraticSaturation(topm, botm, hm) - end if - end if - ar01 = ar01*satups - end if - ar10 = ar01 - else - topn = this%dis%top(n) - botn = this%dis%bot(n) - topm = this%dis%top(m) - botm = this%dis%bot(m) - if (lsat.or.(this%icelltype(n) == 0)) then - thksatn = topn - botn - else - thksatn = this%sat(n)*(topn - botn) - end if - if (lsat.or.(this%icelltype(m) == 0)) then - thksatm = topm - botm - else - thksatm = this%sat(m)*(topm - botm) - end if - if (this%dis%con%ihc(jjs01).eq.2) then - ! -- vertically staggered - sill_top = min(topn, topm) - sill_bot = max(botn, botm) - tpn = botn + thksatn - tpm = botm + thksatm - thksatn = max(min(tpn, sill_top) - sill_bot, DZERO) - thksatm = max(min(tpm, sill_top) - sill_bot, DZERO) - end if - ar01 = this%dis%con%hwva(jjs01)*thksatn - ar10 = this%dis%con%hwva(jjs01)*thksatm - endif - ! - return - end subroutine xt3d_areas - - subroutine xt3d_amat_nbrs(this, nodes, n, idiag, nnbr, nja, & - njasln, inbr, amat, idxglo, chat) -! ****************************************************************************** -! xt3d_amat_nbrs -- Add contributions from neighbors to amat. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- module - ! -- dummy - class(Xt3dType) :: this - integer(I4B),intent(in) :: nodes - integer(I4B) :: n, idiag, nnbr, nja, njasln - integer(I4B),dimension(this%nbrmax) :: inbr - integer(I4B),intent(in),dimension(nja) :: idxglo - real(DP),dimension(njasln),intent(inout) :: amat - real(DP),dimension(this%nbrmax) :: chat - ! -- local - integer(I4B) :: iil, iii -! ------------------------------------------------------------------------------ - ! - do iil = 1,nnbr - if (inbr(iil).ne.0) then - iii = this%dis%con%ia(n) + iil - amat(idxglo(idiag)) = amat(idxglo(idiag)) - chat(iil) - amat(idxglo(iii)) = amat(idxglo(iii)) + chat(iil) - endif - enddo - ! - return - end subroutine xt3d_amat_nbrs - - subroutine xt3d_amat_nbrnbrs(this, nodes, n, m, ii01, nnbr, nja, & - njasln, inbr, amat, idxglo, chat) -! ****************************************************************************** -! xt3d_amat_nbrnbrs -- Add contributions from neighbors of neighbor to amat. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- module - ! -- dummy - class(Xt3dType) :: this - integer(I4B),intent(in) :: nodes - integer(I4B) :: n, m, ii01, nnbr, nja, njasln - integer(I4B),dimension(this%nbrmax) :: inbr - integer(I4B),intent(in),dimension(nja) :: idxglo - real(DP),dimension(njasln),intent(inout) :: amat - real(DP),dimension(this%nbrmax) :: chat - ! -- local - integer(I4B) :: iil, iii, jjj, iixjjj, iijjj -! ------------------------------------------------------------------------------ - ! - do iil = 1,nnbr - if (inbr(iil).ne.0) then - amat(idxglo(ii01)) = amat(idxglo(ii01)) + chat(iil) - iii = this%dis%con%ia(m) + iil - jjj = this%dis%con%ja(iii) - call this%xt3d_get_iinmx(n, jjj, iixjjj) - if (iixjjj.ne.0) then - amat(this%idxglox(iixjjj)) = amat(this%idxglox(iixjjj)) - chat(iil) - else - call this%xt3d_get_iinm(n, jjj, iijjj) - amat(idxglo(iijjj)) = amat(idxglo(iijjj)) - chat(iil) - endif - endif - enddo - ! - return - end subroutine xt3d_amat_nbrnbrs - - subroutine xt3d_amatpc_nbrs(this, nodes, n, idiag, nnbr, inbr, chat) -! ****************************************************************************** -! xt3d_amatpc_nbrs -- Add contributions from neighbors to amatpc. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- module - ! -- dummy - class(Xt3dType) :: this - integer(I4B),intent(in) :: nodes - integer(I4B) :: n, idiag, nnbr - integer(I4B),dimension(this%nbrmax) :: inbr - real(DP),dimension(this%nbrmax) :: chat - ! -- local - integer(I4B) :: iil, iii -! ------------------------------------------------------------------------------ - ! - do iil = 1,nnbr - iii = this%dis%con%ia(n) + iil - this%amatpc(idiag) = this%amatpc(idiag) - chat(iil) - this%amatpc(iii) = this%amatpc(iii) + chat(iil) - enddo - ! - return - end subroutine xt3d_amatpc_nbrs - - subroutine xt3d_amatpcx_nbrnbrs(this, nodes, n, m, ii01, nnbr, inbr, chat) -! ****************************************************************************** -! xt3d_amatpcx_nbrnbrs -- Add contributions from neighbors of neighbor to -! amatpc and amatpcx. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- module - ! -- dummy - class(Xt3dType) :: this - integer(I4B),intent(in) :: nodes - integer(I4B) :: n, m, ii01, nnbr - integer(I4B),dimension(this%nbrmax) :: inbr - real(DP),dimension(this%nbrmax) :: chat - ! -- local - integer(I4B) :: iil, iii, jjj, iixjjj, iijjj -! ------------------------------------------------------------------------------ - ! - do iil = 1,nnbr - this%amatpc(ii01) = this%amatpc(ii01) + chat(iil) - iii = this%dis%con%ia(m) + iil - jjj = this%dis%con%ja(iii) - call this%xt3d_get_iinmx(n, jjj, iixjjj) - if (iixjjj.ne.0) then - this%amatpcx(iixjjj) = this%amatpcx(iixjjj) - chat(iil) - else - call this%xt3d_get_iinm(n, jjj, iijjj) - this%amatpc(iijjj) = this%amatpc(iijjj) - chat(iil) - endif - enddo - ! - return - end subroutine xt3d_amatpcx_nbrnbrs - - subroutine xt3d_get_iinm(this, n, m, iinm) -! ****************************************************************************** -! xt3d_get_iinm -- Get position of n-m connection in ja array (return 0 if -! not connected). -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- module - ! -- dummy - class(Xt3dType) :: this - integer(I4B) :: n, m, iinm - ! -- local - integer(I4B) :: ii, jj -! ------------------------------------------------------------------------------ - ! - iinm = 0 - do ii = this%dis%con%ia(n), this%dis%con%ia(n+1)-1 - jj = this%dis%con%ja(ii) - if (jj.eq.m) then - iinm = ii - exit - endif - enddo - ! - return - end subroutine xt3d_get_iinm - - subroutine xt3d_get_iinmx(this, n, m, iinmx) -! ****************************************************************************** -! xt3d_get_iinmx -- Get position of n-m "extended connection" in jax array -! (return 0 if not connected). -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- module - ! -- dummy - class(Xt3dType) :: this - integer(I4B) :: n, m, iinmx - ! -- local - integer(I4B) :: iix, jjx -! ------------------------------------------------------------------------------ - ! - iinmx = 0 - do iix = this%iax(n), this%iax(n+1)-1 - jjx = this%jax(iix) - if (jjx.eq.m) then - iinmx = iix - exit - endif - enddo - ! - return - end subroutine xt3d_get_iinmx - - subroutine xt3d_rhs(this, nodes, n, m, nnbr, inbr, chat, hnew, & - rhs) -! ****************************************************************************** -! xt3d_rhs -- Add contributions to rhs. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- module - ! -- dummy - class(Xt3dType) :: this - integer(I4B),intent(in) :: nodes - integer(I4B) :: n, m, nnbr - integer(I4B),dimension(this%nbrmax) :: inbr - real(DP),dimension(this%nbrmax) :: chat - real(DP),intent(inout),dimension(nodes) :: hnew, rhs - ! -- local - integer(I4B) :: iil, iii, jjj - real(DP) :: term -! ------------------------------------------------------------------------------ - ! - do iil = 1,nnbr - if (inbr(iil).ne.0) then - iii = iil + this%dis%con%ia(n) - jjj = this%dis%con%ja(iii) - term = chat(iil)*(hnew(jjj)-hnew(n)) - rhs(n) = rhs(n) - term - rhs(m) = rhs(m) + term - endif - enddo - ! - return - end subroutine xt3d_rhs - - subroutine xt3d_qnbrs(this, nodes, n, m, nnbr, inbr, chat, hnew, & - qnbrs) -! ****************************************************************************** -! xt3d_qnbrs -- Add contributions to flow from neighbors. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- module - ! -- dummy - class(Xt3dType) :: this - integer(I4B),intent(in) :: nodes - integer(I4B) :: n, m, nnbr - integer(I4B),dimension(this%nbrmax) :: inbr - real(DP) :: qnbrs - real(DP),dimension(this%nbrmax) :: chat - real(DP),intent(inout),dimension(nodes) :: hnew - ! -- local - integer(I4B) :: iil, iii, jjj - real(DP) :: term -! ------------------------------------------------------------------------------ - ! - qnbrs = 0d0 - do iil = 1,nnbr - if (inbr(iil).ne.0) then - iii = iil + this%dis%con%ia(n) - jjj = this%dis%con%ja(iii) - term = chat(iil)*(hnew(jjj)-hnew(n)) - qnbrs = qnbrs + term - endif - enddo - ! - return - end subroutine xt3d_qnbrs - - subroutine xt3d_fillrmatck(this, n) -! ****************************************************************************** -! xt3d_fillrmatck -- Fill rmat array for cell n. -! angle1, 2, and 3 must be in radians. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- module - ! -- dummy - class(Xt3dType) :: this - integer(I4B), intent(in) :: n - ! -- local - real(DP) :: ang1, ang2, ang3, ang2d, ang3d - real(DP) :: s1, c1, s2, c2, s3, c3 -! ------------------------------------------------------------------------------ - ! - if (this%nozee) then - ang2d = 0d0 - ang3d = 0d0 - ang1 = this%angle1(n) - ang2 = 0d0 - ang3 = 0d0 - else - ang1 = this%angle1(n) - ang2 = this%angle2(n) - ang3 = this%angle3(n) - endif - s1 = sin(ang1) - c1 = cos(ang1) - s2 = sin(ang2) - c2 = cos(ang2) - s3 = sin(ang3) - c3 = cos(ang3) - this%rmatck(1,1) = c1*c2 - this%rmatck(1,2) = c1*s2*s3 - s1*c3 - this%rmatck(1,3) = -c1*s2*c3 - s1*s3 - this%rmatck(2,1) = s1*c2 - this%rmatck(2,2) = s1*s2*s3 + c1*c3 - this%rmatck(2,3) = -s1*s2*c3 + c1*s3 - this%rmatck(3,1) = s2 - this%rmatck(3,2) = -c2*s3 - this%rmatck(3,3) = c2*c3 - ! - return - end subroutine xt3d_fillrmatck - -end module Xt3dModule +module Xt3dModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, DHALF, DONE, LENORIGIN + use BaseDisModule, only: DisBaseType + + implicit none + + public Xt3dType + public :: xt3d_cr + + type Xt3dType + integer(I4B), pointer :: inunit => null() + integer(I4B), pointer :: iout => null() + character(len=LENORIGIN), pointer :: origin => null() !origin name of this package (e.g. 'GWF_1 NPF') + integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !pointer to model ibound + integer(I4B),dimension(:), pointer, contiguous :: iax => null() !ia array for extended neighbors used by xt3d + integer(I4B),dimension(:), pointer, contiguous :: jax => null() !ja array for extended neighbors used by xt3d + integer(I4B),dimension(:), pointer, contiguous :: idxglox => null() !mapping array for extended neighbors used by xt3d + integer(I4B), pointer :: numextnbrs => null() !dimension of jax array + integer(I4B), pointer :: ixt3d => null() !xt3d flag (0 is off, 1 is lhs, 2 is rhs) + logical, pointer :: nozee => null() !nozee flag + real(DP), pointer :: vcthresh => null() !attenuation function threshold + real(DP), dimension(:,:), pointer, contiguous :: rmatck => null() !rotation matrix for the conductivity tensor + real(DP), dimension(:,:), pointer, contiguous :: vecc => null() !connection vectors + real(DP), dimension(:,:), pointer, contiguous :: vecn => null() !interface normals + real(DP), dimension(:), pointer, contiguous :: conlen => null() !direct connection lengths + real(DP), dimension(:), pointer, contiguous :: qsat => null() !saturated flow saved for Newton + real(DP), dimension(:), pointer, contiguous :: qrhs => null() !rhs part of flow saved for Newton + integer(I4B), pointer :: nbrmax => null() !maximum number of neighbors for any cell + real(DP), dimension(:), pointer, contiguous :: amatpc => null() !saved contributions to amat from permanently confined connections, direct neighbors + real(DP), dimension(:), pointer, contiguous :: amatpcx => null() !saved contributions to amat from permanently confined connections, extended neighbors + integer(I4B), dimension(:), pointer, contiguous :: iallpc => null() !indicates for each node whether all connections processed by xt3d are permanently confined (0 no, 1 yes) + logical, pointer :: lamatsaved => null() !indicates whether amat has been saved for permanently confined connections + class(DisBaseType), pointer :: dis => null() !discretization object + ! pointers to npf variables + real(DP), dimension(:), pointer, contiguous :: k11 => null() !horizontal hydraulic conductivity + real(DP), dimension(:),pointer, contiguous :: k22 => null() !minor axis of horizontal hydraulic conductivity ellipse + real(DP), dimension(:), pointer, contiguous :: k33 => null() !vertical hydraulic conductivity + integer(I4B), pointer :: ik22 => null() !flag indicates K22 was read + integer(I4B), pointer :: ik33 => null() !flag indicates K33 was read + real(DP), dimension(:), pointer, contiguous :: sat => null() !saturation (0. to 1.) for each cell + integer(I4B), pointer :: inewton => null() !Newton flag + integer(I4B), dimension(:), pointer, contiguous :: icelltype => null() !cell type (confined or unconfined) + integer(I4B), pointer :: iangle1 => null() !flag to indicate angle1 was read + integer(I4B), pointer :: iangle2 => null() !flag to indicate angle2 was read + integer(I4B), pointer :: iangle3 => null() !flag to indicate angle3 was read + real(DP), dimension(:), pointer, contiguous :: angle1 => null() !k ellipse rotation in xy plane around z axis (yaw) + real(DP), dimension(:), pointer, contiguous :: angle2 => null() !k ellipse rotation up from xy plane around y axis (pitch) + real(DP), dimension(:), pointer, contiguous :: angle3 => null() !k tensor rotation around x axis (roll) + logical, pointer :: ldispersion => null() !flag to indicate dispersion + contains + procedure :: xt3d_df + procedure :: xt3d_ac + procedure :: xt3d_mc + procedure :: xt3d_ar + procedure :: xt3d_fc + procedure :: xt3d_fcpc + procedure :: xt3d_fhfb + procedure :: xt3d_flowjahfb + procedure :: xt3d_fn + procedure :: xt3d_flowja + procedure :: xt3d_da + procedure, private :: allocate_scalars + procedure, private :: allocate_arrays + procedure, private :: xt3d_load + procedure, private :: xt3d_load_inbr + procedure, private :: xt3d_indices + procedure, private :: xt3d_areas + procedure, private :: xt3d_amat_nbrs + procedure, private :: xt3d_amatpc_nbrs + procedure, private :: xt3d_amat_nbrnbrs + procedure, private :: xt3d_amatpcx_nbrnbrs + procedure, private :: xt3d_iallpc + procedure, private :: xt3d_get_iinm + procedure, private :: xt3d_get_iinmx + procedure, private :: xt3d_rhs + procedure, private :: xt3d_fillrmatck + procedure, private :: xt3d_qnbrs + end type Xt3dType + + contains + + subroutine xt3d_cr(xt3dobj, name_model, inunit, iout, ldispopt) +! ****************************************************************************** +! xt3d_cr -- Create a new xt3d object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + type(Xt3dType), pointer :: xt3dobj + character(len=*), intent(in) :: name_model + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + logical, optional, intent(in) :: ldispopt +! ------------------------------------------------------------------------------ + ! + ! -- Create the object + allocate(xt3dobj) + ! + ! -- Allocate scalars + call xt3dobj%allocate_scalars(name_model) + ! + ! -- Set variables + xt3dobj%inunit = inunit + xt3dobj%iout = iout + if (present(ldispopt)) xt3dobj%ldispersion = ldispopt + ! + ! -- Return + return + end subroutine xt3d_cr + + subroutine xt3d_df(this, dis) +! ****************************************************************************** +! xt3d_df -- define the xt3d object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(Xt3dType) :: this + class(DisBaseType), pointer, intent(inout) :: dis +! ------------------------------------------------------------------------------ + ! + this%dis => dis + ! + ! -- Return + return + end subroutine xt3d_df + + subroutine xt3d_ac(this, moffset, sparse) +! ****************************************************************************** +! xt3d_ac -- Add connections for extended neighbors to the sparse matrix +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SparseModule, only: sparsematrix + ! -- dummy + class(Xt3dType) :: this + integer(I4B), intent(in) :: moffset + type(sparsematrix), intent(inout) :: sparse + ! -- local + integer(I4B) :: i, j, k, jj, kk, iglo, kglo, iadded +! ------------------------------------------------------------------------------ + ! + ! -- If not rhs, add connections + if (this%ixt3d == 1) then + ! -- loop over nodes + do i = 1, this%dis%nodes + iglo = i + moffset + ! -- loop over neighbors + do jj = this%dis%con%ia(i), this%dis%con%ia(i+1) - 1 + j = this%dis%con%ja(jj) + ! -- loop over neighbors of neighbors + do kk = this%dis%con%ia(j), this%dis%con%ia(j+1) - 1 + k = this%dis%con%ja(kk) + kglo = k + moffset + call sparse%addconnection(iglo, kglo, 1, iadded) + this%numextnbrs = this%numextnbrs + iadded + enddo + enddo + enddo + endif + ! + ! -- Return + return + end subroutine xt3d_ac + + subroutine xt3d_mc(this, moffset, iasln, jasln, inewton) +! ****************************************************************************** +! xt3d_mc -- Map connections and construct iax, jax, and idxglox +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(Xt3dType) :: this + integer(I4B), intent(in) :: moffset + integer(I4B), dimension(:), intent(in) :: iasln + integer(I4B), dimension(:), intent(in) :: jasln + ! -- local + integer(I4B) :: i, j, jj, iglo, jglo, jjg, niax, njax, ipos, inewton + integer(I4B) :: igfirstnod, iglastnod + logical :: isextnbr +! ------------------------------------------------------------------------------ + ! + ! -- If not rhs, map connections for extended neighbors and construct iax, + ! -- jax, and idxglox + if (this%ixt3d == 1) then + ! + ! -- calculate the first node for the model and the last node in global + ! numbers + igfirstnod = moffset + 1 + iglastnod = moffset + this%dis%nodes + ! + ! -- allocate iax, jax, and idxglox + niax = this%dis%nodes + 1 + njax = this%numextnbrs ! + 1 + call mem_allocate(this%iax, niax, 'IAX', trim(this%origin)) + call mem_allocate(this%jax, njax, 'JAX', trim(this%origin)) + call mem_allocate(this%idxglox, njax, 'IDXGLOX', trim(this%origin)) + ! + ! -- load first iax entry + ipos = 1 + this%iax(1) = ipos + ! + ! -- loop over nodes + do i = 1, this%dis%nodes + ! + ! -- calculate global node number + iglo = i + moffset + ! + ! -- loop over neighbors in global matrix + do jjg = iasln(iglo), iasln(iglo + 1) - 1 + ! + ! -- if jglo is in a different model, then it cannot be an extended + ! neighbor, so skip over it + jglo = jasln(jjg) + if (jglo < igfirstnod .or. jglo > iglastnod) then + cycle + endif + ! + ! -- determine whether this neighbor is an extended neighbor + ! by searching the original neighbors + isextnbr = .true. + searchloop: do jj = this%dis%con%ia(i), this%dis%con%ia(i+1) - 1 + j = this%dis%con%ja(jj) + jglo = j + moffset + ! + ! -- if an original neighbor, note that and end the search + if(jglo == jasln(jjg)) then + isextnbr = .false. + exit searchloop + endif + enddo searchloop + ! + ! -- if an extended neighbor, add it to jax and idxglox + if (isextnbr) then + this%jax(ipos) = jasln(jjg) - moffset + this%idxglox(ipos) = jjg + ipos = ipos + 1 + endif + enddo + ! -- load next iax entry + this%iax(i+1) = ipos + enddo + ! + else + ! + call mem_allocate(this%iax, 0, 'IAX', trim(this%origin)) + call mem_allocate(this%jax, 0, 'JAX', trim(this%origin)) + call mem_allocate(this%idxglox, 0, 'IDXGLOX', trim(this%origin)) + ! + endif + ! + ! -- Return + return + end subroutine xt3d_mc + + subroutine xt3d_ar(this, ibound, k11, ik33, k33, sat, ik22, k22, & + inewton, icelltype, iangle1, iangle2, iangle3, angle1, angle2, angle3) +! ****************************************************************************** +! xt3d_ar -- Allocate and Read +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: store_error, ustop + ! -- dummy + class(Xt3dType) :: this + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: ibound + real(DP), dimension(:), intent(in), pointer, contiguous :: k11 + integer(I4B), intent(in), pointer :: ik33 + real(DP), dimension(:), intent(in), pointer, contiguous :: k33 + real(DP), dimension(:), intent(in), pointer, contiguous :: sat + integer(I4B), intent(in), pointer :: ik22 + real(DP), dimension(:), intent(in), pointer, contiguous :: k22 + integer(I4B), intent(in), pointer :: inewton + integer(I4B), dimension(:), intent(in), pointer, contiguous :: icelltype + integer(I4B), intent(in), pointer :: iangle1 + integer(I4B), intent(in), pointer :: iangle2 + integer(I4B), intent(in), pointer :: iangle3 + real(DP), dimension(:), intent(in), pointer, contiguous :: angle1 + real(DP), dimension(:), intent(in), pointer, contiguous :: angle2 + real(DP), dimension(:), intent(in), pointer, contiguous :: angle3 + ! -- local + integer(I4B) :: n, nnbrs + ! -- formats + character(len=*), parameter :: fmtheader = & + "(1x, /1x, 'XT3D is active.'//)" + ! -- data +! ------------------------------------------------------------------------------ + ! + ! -- Print a message identifying the xt3d module. + write(this%iout, fmtheader) + ! + ! -- Store pointers to arguments that were passed in + this%ibound => ibound + this%k11 => k11 + this%ik33 => ik33 + this%k33 => k33 + this%sat => sat + this%ik22 => ik22 + this%k22 => k22 + this%inewton => inewton + this%icelltype => icelltype + this%iangle1 => iangle1 + this%iangle2 => iangle2 + this%iangle3 => iangle3 + this%angle1 => angle1 + this%angle2 => angle2 + this%angle3 => angle3 + ! + ! -- If angle1 and angle2 were not specified, then there is no z + ! component in the xt3d formulation for horizontal connections. + if(this%iangle2 == 0) this%nozee = .true. + ! + ! -- Determine the maximum number of neighbors for any cell. + this%nbrmax = 0 + do n = 1, this%dis%nodes + nnbrs = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 + this%nbrmax = max(nnbrs, this%nbrmax) + end do + ! + ! -- Check to make sure dis package can calculate connection direction info + if (this%dis%icondir == 0) then + call store_error('Error. Vertices not specified for discretization ' // & + 'package, but XT3D is active: '// trim(adjustl(this%origin)) // & + '. Vertices must be specified in discretization package in order ' // & + 'to use XT3D.') + call ustop() + endif + ! + ! -- Check to make sure ANGLEDEGX is available for interface normals + if (this%dis%con%ianglex == 0) then + call store_error('Error. ANGLDEGX is not specified in the DIS ' // & + 'package, but XT3D is active: '// trim(adjustl(this%origin)) // & + '. ANGLDEGX must be provided in discretization package in order ' // & + 'to use XT3D.') + call ustop() + endif + ! + ! -- allocate arrays + call this%allocate_arrays() + ! + ! -- If not Newton and not rhs, calculate amatpc and amatpcx for permanently + ! -- confined connections + if(this%lamatsaved) call this%xt3d_fcpc(this%dis%nodes) + ! + ! -- Return + return + end subroutine xt3d_ar + + subroutine xt3d_fc(this, kiter, njasln, amat, idxglo, rhs, hnew) +! ****************************************************************************** +! xt3d_fc -- Formulate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: DONE + use Xt3dAlgorithmModule, only: qconds + ! -- dummy + class(Xt3dType) :: this + integer(I4B) :: kiter + integer(I4B),intent(in) :: njasln + real(DP),dimension(njasln),intent(inout) :: amat + integer(I4B),intent(in),dimension(:) :: idxglo + real(DP),intent(inout),dimension(:) :: rhs + real(DP),intent(inout),dimension(:) :: hnew + ! -- local + integer(I4B) :: nodes, nja + integer(I4B) :: n, m, ipos + ! + logical :: allhc0, allhc1 + integer(I4B) :: nnbr0, nnbr1 + integer(I4B) :: il0, ii01, jjs01, il01, il10, ii00, ii11, ii10 + integer(I4B) :: i + integer(I4B),dimension(this%nbrmax) :: inbr0, inbr1 + real(DP) :: ar01, ar10 + real(DP),dimension(this%nbrmax,3) :: vc0, vn0, vc1, vn1 + real(DP),dimension(this%nbrmax) :: dl0, dl0n, dl1, dl1n + real(DP),dimension(3,3) :: ck0, ck1 + real(DP) :: chat01 + real(DP),dimension(this%nbrmax) :: chati0, chat1j + real(DP) :: qnm, qnbrs +! ------------------------------------------------------------------------------ + ! + ! -- Calculate xt3d conductance-like coefficients and put into amat and rhs + ! -- as appropriate + ! + nodes = this%dis%nodes + nja = this%dis%con%nja + if (this%lamatsaved) then + do i = 1, this%dis%con%nja + amat(idxglo(i)) = amat(idxglo(i)) + this%amatpc(i) + end do + do i = 1, this%numextnbrs + amat(this%idxglox(i)) = amat(this%idxglox(i)) + this%amatpcx(i) + end do + end if + ! + do n = 1, nodes + ! -- Skip if inactive. + if (this%ibound(n).eq.0) cycle + ! -- Skip if all connections are permanently confined + if (this%lamatsaved) then + if (this%iallpc(n) == 1) cycle + end if + nnbr0 = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 + ! -- Load conductivity and connection info for cell 0. + call this%xt3d_load(nodes, n, nnbr0, inbr0, vc0, vn0, dl0, dl0n, & + ck0, allhc0) + ! -- Loop over active neighbors of cell 0 that have a higher + ! -- cell number (taking advantage of reciprocity). + do il0 = 1,nnbr0 + ipos = this%dis%con%ia(n) + il0 + if (this%dis%con%mask(ipos) == 0) cycle + + m = inbr0(il0) + ! -- Skip if neighbor is inactive or has lower cell number. + if ((m.eq.0).or.(m.lt.n)) cycle + nnbr1 = this%dis%con%ia(m+1) - this%dis%con%ia(m) - 1 + ! -- Load conductivity and connection info for cell 1. + call this%xt3d_load(nodes, m, nnbr1, inbr1, vc1, vn1, dl1, dl1n, & + ck1, allhc1) + ! -- Set various indices. + call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & + ii00, ii11, ii10) + ! -- Compute areas. + if (this%inewton /= 0) then + ar01 = DONE + ar10 = DONE + else + call this%xt3d_areas(nodes, n, m, jjs01, .false., ar01, ar10, hnew) + end if + ! -- Compute "conductances" for interface between + ! -- cells 0 and 1. + call qconds(this%nbrmax, nnbr0, inbr0, il01, vc0, vn0, dl0, dl0n, & + ck0, nnbr1, inbr1, il10, vc1, vn1, dl1, dl1n, ck1, ar01, ar10, & + this%vcthresh, allhc0, allhc1, chat01, chati0, chat1j) + ! -- If Newton, compute and save saturated flow, then scale + ! -- conductance-like coefficients by the actual area for + ! -- subsequent amat and rhs assembly. + if (this%inewton /= 0) then + ! -- Contribution to flow from primary connection. + qnm = chat01*(hnew(m) - hnew(n)) + ! -- Contribution from immediate neighbors of node 0. + call this%xt3d_qnbrs(nodes, n, m, nnbr0, inbr0, chati0, hnew, qnbrs) + qnm = qnm + qnbrs + ! -- Contribution from immediate neighbors of node 1. + call this%xt3d_qnbrs(nodes, m, n, nnbr1, inbr1, chat1j, hnew, qnbrs) + qnm = qnm - qnbrs + ! -- Multiply by saturated area and save in qsat. + call this%xt3d_areas(nodes, n, m, jjs01, .true., ar01, ar10, hnew) + this%qsat(ii01) = qnm*ar01 + ! -- Scale coefficients by actual area. If RHS + ! -- formulation, also compute and save qrhs. + call this%xt3d_areas(nodes, n, m, jjs01, .false., ar01, ar10, hnew) + if (this%ixt3d == 2) then + this%qrhs(ii01) = -qnbrs*ar01 + end if + chat01 = chat01*ar01 + chati0 = chati0*ar01 + chat1j = chat1j*ar01 + end if + ! -- Contribute to rows for cells 0 and 1. + amat(idxglo(ii00)) = amat(idxglo(ii00)) - chat01 + amat(idxglo(ii01)) = amat(idxglo(ii01)) + chat01 + amat(idxglo(ii11)) = amat(idxglo(ii11)) - chat01 + amat(idxglo(ii10)) = amat(idxglo(ii10)) + chat01 + if (this%ixt3d == 1) then + call this%xt3d_amat_nbrs(nodes, n, ii00, nnbr0, nja, njasln, & + inbr0, amat, idxglo, chati0) + call this%xt3d_amat_nbrnbrs(nodes, n, m, ii01, nnbr1, nja, njasln, & + inbr1, amat, idxglo, chat1j) + call this%xt3d_amat_nbrs(nodes, m, ii11, nnbr1, nja, njasln, & + inbr1, amat, idxglo, chat1j) + call this%xt3d_amat_nbrnbrs(nodes, m, n, ii10, nnbr0, nja, njasln, & + inbr0, amat, idxglo, chati0) + else + call this%xt3d_rhs(nodes, n, m, nnbr0, inbr0, chati0, hnew, rhs) + call this%xt3d_rhs(nodes, m, n, nnbr1, inbr1, chat1j, hnew, rhs) + endif + ! + enddo + enddo + ! + ! -- Return + return + end subroutine xt3d_fc + + subroutine xt3d_fcpc(this, nodes) +! ****************************************************************************** +! xt3d_fcpc -- Formulate for permanently confined connections and save in +! amatpc and amatpcx +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: DONE + use Xt3dAlgorithmModule, only: qconds + ! -- dummy + class(Xt3dType) :: this + integer(I4B) :: nodes + ! -- local + integer(I4B) :: n, m, ipos + ! + logical :: allhc0, allhc1 + integer(I4B) :: nnbr0, nnbr1 + integer(I4B) :: il0, ii01, jjs01, il01, il10, ii00, ii11, ii10 + integer(I4B),dimension(this%nbrmax) :: inbr0, inbr1 + real(DP) :: ar01, ar10 + real(DP),dimension(this%nbrmax,3) :: vc0, vn0, vc1, vn1 + real(DP),dimension(this%nbrmax) :: dl0, dl0n, dl1, dl1n + real(DP),dimension(3,3) :: ck0, ck1 + real(DP) :: chat01 + real(DP),dimension(this%nbrmax) :: chati0, chat1j +! ------------------------------------------------------------------------------ + ! + ! -- Calculate xt3d conductance-like coefficients for permanently confined + ! -- connections and put into amatpc and amatpcx as appropriate + do n = 1, nodes + ! -- Skip if not iallpc. + if (this%iallpc(n) == 0) cycle + nnbr0 = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 + ! -- Load conductivity and connection info for cell 0. + call this%xt3d_load(nodes, n, nnbr0, inbr0, vc0, vn0, dl0, dl0n, & + ck0, allhc0) + ! -- Loop over active neighbors of cell 0 that have a higher + ! -- cell number (taking advantage of reciprocity). + do il0 = 1,nnbr0 + ipos = this%dis%con%ia(n) + il0 + if (this%dis%con%mask(ipos) == 0) cycle + + m = inbr0(il0) + ! -- Skip if neighbor has lower cell number. + if (m.lt.n) cycle + nnbr1 = this%dis%con%ia(m+1) - this%dis%con%ia(m) - 1 + ! -- Load conductivity and connection info for cell 1. + call this%xt3d_load(nodes, m, nnbr1, inbr1, vc1, vn1, dl1, dl1n, & + ck1, allhc1) + ! -- Set various indices. + call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & + ii00, ii11, ii10) + ! -- Compute confined areas. + call this%xt3d_areas(nodes, n, m, jjs01, .true., ar01, ar10) + ! -- Compute "conductances" for interface between + ! -- cells 0 and 1. + call qconds(this%nbrmax, nnbr0, inbr0, il01, vc0, vn0, dl0, dl0n, & + ck0, nnbr1, inbr1, il10, vc1, vn1, dl1, dl1n, ck1, ar01, ar10, & + this%vcthresh, allhc0, allhc1, chat01, chati0, chat1j) + ! -- Contribute to rows for cells 0 and 1. + this%amatpc(ii00) = this%amatpc(ii00) - chat01 + this%amatpc(ii01) = this%amatpc(ii01) + chat01 + this%amatpc(ii11) = this%amatpc(ii11) - chat01 + this%amatpc(ii10) = this%amatpc(ii10) + chat01 + call this%xt3d_amatpc_nbrs(nodes, n, ii00, nnbr0, inbr0, chati0) + call this%xt3d_amatpcx_nbrnbrs(nodes, n, m, ii01, nnbr1, inbr1, chat1j) + call this%xt3d_amatpc_nbrs(nodes, m, ii11, nnbr1, inbr1, chat1j) + call this%xt3d_amatpcx_nbrnbrs(nodes, m, n, ii10, nnbr0, inbr0, chati0) + enddo + enddo + ! + ! -- Return + return + end subroutine xt3d_fcpc + + subroutine xt3d_fhfb(this, kiter, nodes, nja, njasln, amat, idxglo, rhs, hnew, & + n, m, condhfb) +! ****************************************************************************** +! xt3d_fhfb -- Formulate HFB correction +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: DONE + use Xt3dAlgorithmModule, only: qconds + ! -- dummy + class(Xt3dType) :: this + integer(I4B) :: kiter + integer(I4B),intent(in) :: nodes + integer(I4B),intent(in) :: nja + integer(I4B),intent(in) :: njasln + integer(I4B) :: n, m + real(DP),dimension(njasln),intent(inout) :: amat + integer(I4B),intent(in),dimension(nja) :: idxglo + real(DP),intent(inout),dimension(nodes) :: rhs + real(DP),intent(inout),dimension(nodes) :: hnew + real(DP) :: condhfb + ! -- local + ! + logical :: allhc0, allhc1 + integer(I4B) :: nnbr0, nnbr1 + integer(I4B) :: il0, ii01, jjs01, il01, il10, ii00, ii11, ii10, il + integer(I4B),dimension(this%nbrmax) :: inbr0, inbr1 + real(DP) :: ar01, ar10 + real(DP),dimension(this%nbrmax,3) :: vc0, vn0, vc1, vn1 + real(DP),dimension(this%nbrmax) :: dl0, dl0n, dl1, dl1n + real(DP),dimension(3,3) :: ck0, ck1 + real(DP) :: chat01 + real(DP),dimension(this%nbrmax) :: chati0, chat1j + real(DP) :: qnm, qnbrs + real(DP) :: term +! ------------------------------------------------------------------------------ + ! + ! -- Calculate hfb corrections to xt3d conductance-like coefficients and + ! -- put into amat and rhs as appropriate + ! + nnbr0 = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 + ! -- Load conductivity and connection info for cell 0. + call this%xt3d_load(nodes, n, nnbr0, inbr0, vc0, vn0, dl0, dl0n, & + ck0, allhc0) + ! -- Find local neighbor number of cell 1. + do il = 1,nnbr0 + if (inbr0(il).eq.m) then + il0 = il + exit + end if + end do + nnbr1 = this%dis%con%ia(m+1) - this%dis%con%ia(m) - 1 + ! -- Load conductivity and connection info for cell 1. + call this%xt3d_load(nodes, m, nnbr1, inbr1, vc1, vn1, dl1, dl1n, & + ck1, allhc1) + ! -- Set various indices. + call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & + ii00, ii11, ii10) + ! -- Compute areas. + if (this%inewton /= 0) then + ar01 = DONE + ar10 = DONE + else + call this%xt3d_areas(nodes, n, m, jjs01, .false., ar01, ar10, hnew) + end if + ! -- Compute "conductances" for interface between + ! -- cells 0 and 1. + call qconds(this%nbrmax, nnbr0, inbr0, il01, vc0, vn0, dl0, dl0n, & + ck0, nnbr1, inbr1, il10, vc1, vn1, dl1, dl1n, ck1, ar01, ar10, & + this%vcthresh, allhc0, allhc1, chat01, chati0, chat1j) + ! -- Apply scale factor to compute "conductances" for hfb correction + if(condhfb > DZERO) then + term = chat01/(chat01 + condhfb) + else + term = -condhfb + endif + chat01 = -chat01*term + chati0 = -chati0*term + chat1j = -chat1j*term + ! -- If Newton, compute and save saturated flow, then scale + ! -- conductance-like coefficients by the actual area for + ! -- subsequent amat and rhs assembly. + if (this%inewton /= 0) then + ! -- Contribution to flow from primary connection. + qnm = chat01*(hnew(m) - hnew(n)) + ! -- Contribution from immediate neighbors of node 0. + call this%xt3d_qnbrs(nodes, n, m, nnbr0, inbr0, chati0, hnew, qnbrs) + qnm = qnm + qnbrs + ! -- Contribution from immediate neighbors of node 1. + call this%xt3d_qnbrs(nodes, m, n, nnbr1, inbr1, chat1j, hnew, qnbrs) + qnm = qnm - qnbrs + ! -- Multiply by saturated area and add correction to qsat. + call this%xt3d_areas(nodes, n, m, jjs01, .true., ar01, ar10, hnew) + this%qsat(ii01) = this%qsat(ii01) + qnm*ar01 + ! -- Scale coefficients by actual area. If RHS + ! -- formulation, also compute and add correction to qrhs. + call this%xt3d_areas(nodes, n, m, jjs01, .false., ar01, ar10, hnew) + if (this%ixt3d == 2) then + this%qrhs(ii01) = this%qrhs(ii01) - qnbrs*ar01 + end if + chat01 = chat01*ar01 + chati0 = chati0*ar01 + chat1j = chat1j*ar01 + end if + ! -- Contribute to rows for cells 0 and 1. + amat(idxglo(ii00)) = amat(idxglo(ii00)) - chat01 + amat(idxglo(ii01)) = amat(idxglo(ii01)) + chat01 + amat(idxglo(ii11)) = amat(idxglo(ii11)) - chat01 + amat(idxglo(ii10)) = amat(idxglo(ii10)) + chat01 + if (this%ixt3d == 1) then + call this%xt3d_amat_nbrs(nodes, n, ii00, nnbr0, nja, njasln, & + inbr0, amat, idxglo, chati0) + call this%xt3d_amat_nbrnbrs(nodes, n, m, ii01, nnbr1, nja, njasln, & + inbr1, amat, idxglo, chat1j) + call this%xt3d_amat_nbrs(nodes, m, ii11, nnbr1, nja, njasln, & + inbr1, amat, idxglo, chat1j) + call this%xt3d_amat_nbrnbrs(nodes, m, n, ii10, nnbr0, nja, njasln, & + inbr0, amat, idxglo, chati0) + else + call this%xt3d_rhs(nodes, n, m, nnbr0, inbr0, chati0, hnew, rhs) + call this%xt3d_rhs(nodes, m, n, nnbr1, inbr1, chat1j, hnew, rhs) + endif + ! + ! -- Return + return + end subroutine xt3d_fhfb + + subroutine xt3d_fn(this, kiter, nodes, nja, njasln, amat, idxglo, rhs, hnew) +! ****************************************************************************** +! xt3d_fn -- Fill Newton terms for xt3d +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: DONE + use SmoothingModule, only: sQuadraticSaturationDerivative + ! -- dummy + class(Xt3dType) :: this + integer(I4B) :: kiter + integer(I4B),intent(in) :: nodes + integer(I4B),intent(in) :: nja + integer(I4B),intent(in) :: njasln + real(DP),dimension(njasln),intent(inout) :: amat + integer(I4B),intent(in),dimension(nja) :: idxglo + real(DP),intent(inout),dimension(nodes) :: rhs + real(DP),intent(inout),dimension(nodes) :: hnew + ! -- local + integer(I4B) :: n, m, ipos + ! + integer(I4B) :: nnbr0 + integer(I4B) :: il0, ii01, jjs01, il01, il10, ii00, ii11, ii10 + integer(I4B),dimension(this%nbrmax) :: inbr0 + integer(I4B) :: iups, idn + real(DP) :: topup, botup, derv, term, termrhs +! ------------------------------------------------------------------------------ + ! + ! -- Update amat and rhs with Newton terms + do n = 1, nodes + ! -- Skip if inactive. + if (this%ibound(n).eq.0) cycle + ! -- No Newton correction if amat saved (which implies no rhs option) + ! -- and all connections for the cell are permanently confined. + if (this%lamatsaved) then + if (this%iallpc(n) == 1) cycle + end if + nnbr0 = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 + ! -- Load neighbors of cell. Set cell numbers for inactive + ! -- neighbors to zero. + call this%xt3d_load_inbr(n, nnbr0, inbr0) + ! -- Loop over active neighbors of cell 0 that have a higher + ! -- cell number (taking advantage of reciprocity). + do il0 = 1,nnbr0 + ipos = this%dis%con%ia(n) + il0 + if (this%dis%con%mask(ipos) == 0) cycle + + m = inbr0(il0) + ! -- Skip if neighbor is inactive or has lower cell number. + if ((inbr0(il0).eq.0).or.(m.lt.n)) cycle + ! -- Set various indices. + call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & + ii00, ii11, ii10) + ! determine upstream node + iups = m + if (hnew(m) < hnew(n)) iups = n + idn = n + if (iups == n) idn = m + ! -- no Newton terms if upstream cell is confined + ! -- and no rhs option + if ((this%icelltype(iups) == 0).and.(this%ixt3d.eq.1)) cycle + ! -- Set the upstream top and bot, and then recalculate for a + ! vertically staggered horizontal connection + topup = this%dis%top(iups) + botup = this%dis%bot(iups) + if(this%dis%con%ihc(jjs01) == 2) then + topup = min(this%dis%top(n), this%dis%top(m)) + botup = max(this%dis%bot(n), this%dis%bot(m)) + endif + ! derivative term + derv = sQuadraticSaturationDerivative(topup, botup, hnew(iups)) + term = this%qsat(ii01) * derv + if (this%ixt3d == 1) then + termrhs = term + else + termrhs = term - this%qrhs(ii01) + endif + ! fill Jacobian for n being the upstream node + if (iups == n) then + ! fill in row of n + amat(idxglo(ii00)) = amat(idxglo(ii00)) + term + rhs(n) = rhs(n) + termrhs * hnew(n) + ! fill in row of m + amat(idxglo(ii10)) = amat(idxglo(ii10)) - term + rhs(m) = rhs(m) - termrhs * hnew(n) + ! fill Jacobian for m being the upstream node + else + ! fill in row of n + amat(idxglo(ii01)) = amat(idxglo(ii01)) + term + rhs(n) = rhs(n) + termrhs * hnew(m) + ! fill in row of m + amat(idxglo(ii11)) = amat(idxglo(ii11)) - term + rhs(m) = rhs(m) - termrhs * hnew(m) + end if + enddo + enddo + ! + ! -- Return + return + end subroutine xt3d_fn + + subroutine xt3d_flowja(this, hnew, flowja) +! ****************************************************************************** +! xt3d_flowja -- Budget +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use Xt3dAlgorithmModule, only: qconds + ! -- dummy + class(Xt3dType) :: this + real(DP),intent(inout),dimension(:) :: hnew + real(DP),intent(inout),dimension(:) :: flowja + ! -- local + integer(I4B) :: n, ipos, m, nodes + real(DP) :: qnm, qnbrs + logical :: allhc0, allhc1 + integer(I4B) :: nnbr0, nnbr1 + integer(I4B) :: il0, ii01, jjs01, il01, il10, ii00, ii11, ii10 + integer(I4B),dimension(this%nbrmax) :: inbr0, inbr1 + real(DP) :: ar01, ar10 + real(DP),dimension(this%nbrmax,3) :: vc0, vn0, vc1, vn1 + real(DP),dimension(this%nbrmax) :: dl0, dl0n, dl1, dl1n + real(DP),dimension(3,3) :: ck0, ck1 + real(DP) :: chat01 + real(DP),dimension(this%nbrmax) :: chati0, chat1j +! ------------------------------------------------------------------------------ + ! + ! -- Calculate the flow across each cell face and store in flowja + nodes = this%dis%nodes + do n = 1, nodes + ! -- Skip if inactive. + if (this%ibound(n).eq.0) cycle + nnbr0 = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 + ! -- Load conductivity and connection info for cell 0. + call this%xt3d_load(nodes, n, nnbr0, inbr0, vc0, vn0, dl0, dl0n, & + ck0, allhc0) + ! -- Loop over active neighbors of cell 0 that have a higher + ! -- cell number (taking advantage of reciprocity). + do il0 = 1,nnbr0 + m = inbr0(il0) + ! -- Skip if neighbor is inactive or has lower cell number. + if ((inbr0(il0).eq.0).or.(m.lt.n)) cycle + nnbr1 = this%dis%con%ia(m+1) - this%dis%con%ia(m) - 1 + ! -- Load conductivity and connection info for cell 1. + call this%xt3d_load(nodes, m, nnbr1, inbr1, vc1, vn1, dl1, dl1n, & + ck1, allhc1) + ! -- Set various indices. + call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & + ii00, ii11, ii10) + ! -- Compute areas. + if (this%inewton /= 0) & + call this%xt3d_areas(nodes, n, m, jjs01, .true., ar01, ar10, hnew) + call this%xt3d_areas(nodes, n, m, jjs01, .false., ar01, ar10, hnew) + ! -- Compute "conductances" for interface between + ! -- cells 0 and 1. + call qconds(this%nbrmax, nnbr0, inbr0, il01, vc0, vn0, dl0, dl0n, & + ck0, nnbr1, inbr1, il10, vc1, vn1, dl1, dl1n, ck1, ar01, ar10, & + this%vcthresh, allhc0, allhc1, chat01, chati0, chat1j) + ! -- Contribution to flow from primary connection. + qnm = chat01*(hnew(m) - hnew(n)) + ! -- Contribution from immediate neighbors of node 0. + call this%xt3d_qnbrs(nodes, n, m, nnbr0, inbr0, chati0, hnew, qnbrs) + qnm = qnm + qnbrs + ! -- Contribution from immediate neighbors of node 1. + call this%xt3d_qnbrs(nodes, m, n, nnbr1, inbr1, chat1j, hnew, qnbrs) + qnm = qnm - qnbrs + ipos = ii01 + flowja(ipos) = flowja(ipos) + qnm + flowja(this%dis%con%isym(ipos)) = flowja(this%dis%con%isym(ipos)) - qnm + enddo + enddo + ! + ! -- Return + return + end subroutine xt3d_flowja + + subroutine xt3d_flowjahfb(this, n, m, hnew, flowja, condhfb) +! ****************************************************************************** +! xt3d_flowjahfb -- hfb contribution to flowja when xt3d is used +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: DONE + use Xt3dAlgorithmModule, only: qconds + ! -- dummy + class(Xt3dType) :: this + integer(I4B) :: n, m + real(DP),intent(inout),dimension(:) :: hnew + real(DP),intent(inout),dimension(:) :: flowja + real(DP) :: condhfb + ! -- local + ! + integer(I4B) :: nodes + logical :: allhc0, allhc1 +!!! integer(I4B), parameter :: nbrmax = 10 + integer(I4B) :: nnbr0, nnbr1 + integer(I4B) :: il0, ii01, jjs01, il01, il10, ii00, ii11, ii10, il + integer(I4B),dimension(this%nbrmax) :: inbr0, inbr1 + integer(I4B) :: ipos + real(DP) :: ar01, ar10 + real(DP),dimension(this%nbrmax,3) :: vc0, vn0, vc1, vn1 + real(DP),dimension(this%nbrmax) :: dl0, dl0n, dl1, dl1n + real(DP),dimension(3,3) :: ck0, ck1 + real(DP) :: chat01 + real(DP),dimension(this%nbrmax) :: chati0, chat1j + real(DP) :: qnm, qnbrs + real(DP) :: term +! ------------------------------------------------------------------------------ + ! + ! -- Calculate hfb corrections to xt3d conductance-like coefficients and + ! -- put into amat and rhs as appropriate + ! + nodes = this%dis%nodes + nnbr0 = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 + ! -- Load conductivity and connection info for cell 0. + call this%xt3d_load(nodes, n, nnbr0, inbr0, vc0, vn0, dl0, dl0n, & + ck0, allhc0) + ! -- Find local neighbor number of cell 1. + do il = 1,nnbr0 + if (inbr0(il).eq.m) then + il0 = il + exit + end if + end do + nnbr1 = this%dis%con%ia(m+1) - this%dis%con%ia(m) - 1 + ! -- Load conductivity and connection info for cell 1. + call this%xt3d_load(nodes, m, nnbr1, inbr1, vc1, vn1, dl1, dl1n, & + ck1, allhc1) + ! -- Set various indices. + call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & + ii00, ii11, ii10) + ! -- Compute areas. + if (this%inewton /= 0) then + ar01 = DONE + ar10 = DONE + else + call this%xt3d_areas(nodes, n, m, jjs01, .false., ar01, ar10, hnew) + end if + ! -- Compute "conductances" for interface between + ! -- cells 0 and 1. + call qconds(this%nbrmax, nnbr0, inbr0, il01, vc0, vn0, dl0, dl0n, & + ck0, nnbr1, inbr1, il10, vc1, vn1, dl1, dl1n, ck1, ar01, ar10, & + this%vcthresh, allhc0, allhc1, chat01, chati0, chat1j) + ! -- Apply scale factor to compute "conductances" for hfb correction + if(condhfb > DZERO) then + term = chat01/(chat01 + condhfb) + else + term = -condhfb + endif + chat01 = -chat01*term + chati0 = -chati0*term + chat1j = -chat1j*term + ! -- Contribution to flow from primary connection. + qnm = chat01*(hnew(m) - hnew(n)) + ! -- Contribution from immediate neighbors of node 0. + call this%xt3d_qnbrs(nodes, n, m, nnbr0, inbr0, chati0, hnew, qnbrs) + qnm = qnm + qnbrs + ! -- Contribution from immediate neighbors of node 1. + call this%xt3d_qnbrs(nodes, m, n, nnbr1, inbr1, chat1j, hnew, qnbrs) + qnm = qnm - qnbrs + ! -- If Newton, scale conductance-like coefficients by the + ! -- actual area. + if (this%inewton /= 0) then + call this%xt3d_areas(nodes, n, m, jjs01, .true., ar01, ar10, hnew) + call this%xt3d_areas(nodes, n, m, jjs01, .false., ar01, ar10, hnew) + qnm = qnm*ar01 + end if + ipos = ii01 + flowja(ipos) = flowja(ipos) + qnm + flowja(this%dis%con%isym(ipos)) = flowja(this%dis%con%isym(ipos)) - qnm + ! + ! -- Return + return + end subroutine xt3d_flowjahfb + + subroutine xt3d_da(this) +! ****************************************************************************** +! xt3d_da -- Deallocate variables +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(Xt3dType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Deallocate arrays + if (this%ixt3d /= 0) then + call mem_deallocate(this%iax) + call mem_deallocate(this%jax) + call mem_deallocate(this%idxglox) + call mem_deallocate(this%rmatck) + call mem_deallocate(this%vecc) + call mem_deallocate(this%conlen) + call mem_deallocate(this%vecn) + call mem_deallocate(this%qsat) + call mem_deallocate(this%qrhs) + call mem_deallocate(this%amatpc) + call mem_deallocate(this%amatpcx) + call mem_deallocate(this%iallpc) + endif + ! + ! -- Strings + deallocate(this%origin) + ! + ! -- Scalars + call mem_deallocate(this%ixt3d) + call mem_deallocate(this%inunit) + call mem_deallocate(this%iout) + call mem_deallocate(this%numextnbrs) + call mem_deallocate(this%nozee) + call mem_deallocate(this%vcthresh) + call mem_deallocate(this%lamatsaved) + call mem_deallocate(this%nbrmax) + call mem_deallocate(this%ldispersion) + ! + ! -- Return + return + end subroutine xt3d_da + + subroutine allocate_scalars(this, name_model) +! ****************************************************************************** +! allocate_scalars -- Allocate scalar pointer variables +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(Xt3dType) :: this + character(len=*) :: name_model +! ------------------------------------------------------------------------------ + ! + ! -- Allocate and assign origin + allocate(this%origin) + this%origin = trim(adjustl(name_model)) // ' XT3D' + ! + ! -- Allocate scalars + call mem_allocate(this%ixt3d, 'IXT3D', this%origin) + call mem_allocate(this%nbrmax, 'NBRMAX', this%origin) + call mem_allocate(this%inunit, 'INUNIT', this%origin) + call mem_allocate(this%iout, 'IOUT', this%origin) + call mem_allocate(this%numextnbrs, 'NUMEXTNBRS', this%origin) + call mem_allocate(this%nozee, 'NOZEE', this%origin) + call mem_allocate(this%vcthresh, 'VCTHRESH', this%origin) + call mem_allocate(this%lamatsaved, 'LAMATSAVED', this%origin) + call mem_allocate(this%ldispersion, 'LDISPERSION', this%origin) + ! + ! -- Initialize value + this%ixt3d = 0 + this%nbrmax = 0 + this%inunit = 0 + this%iout = 0 + this%numextnbrs = 0 + this%nozee = .false. + this%vcthresh = 1.d-10 + this%lamatsaved = .false. + this%ldispersion = .false. + ! + ! -- Return + return + end subroutine allocate_scalars + + subroutine allocate_arrays(this) +! ****************************************************************************** +! allocate_arrays -- Allocate xt3d arrays +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(Xt3dType) :: this + ! -- local + integer(I4B) :: njax +! ------------------------------------------------------------------------------ + ! + call mem_allocate(this%rmatck, 3, 3, 'RMATCK', this%origin) + ! + if (this%inewton /= 0) then + call mem_allocate(this%qsat, this%dis%nja, 'QSAT', this%origin) + if (this%ixt3d == 1) then + call mem_allocate(this%qrhs, 0, 'QRHS', this%origin) + else + call mem_allocate(this%qrhs, this%dis%nja, 'QRHS', this%origin) + end if + call mem_allocate(this%amatpc, 0, 'AMATPC', this%origin) + call mem_allocate(this%amatpcx, 0, 'AMATPCX', this%origin) + call mem_allocate(this%iallpc, 0, 'IALLPC', this%origin) + else + call mem_allocate(this%qsat, 0, 'QSAT', this%origin) + call mem_allocate(this%qrhs, 0, 'QRHS', this%origin) + end if + ! + call this%xt3d_iallpc() + ! + if (this%lamatsaved) then + call mem_allocate(this%amatpc, this%dis%nja, 'AMATPC', this%origin) + njax = this%numextnbrs ! + 1 + call mem_allocate(this%amatpcx, njax, 'AMATPCX', this%origin) + else + call mem_allocate(this%amatpc, 0, 'AMATPC', this%origin) + call mem_allocate(this%amatpcx, 0, 'AMATPCX', this%origin) + end if + call mem_allocate(this%vecc, 0, 3, 'VECC', this%origin) + call mem_allocate(this%conlen, 0, 'CONLEN', this%origin) + call mem_allocate(this%vecn, 0, 3, 'VECN', this%origin) + ! + this%rmatck = 0.d0 + if (this%inewton /= 0) then + this%qsat = 0.d0 + if (this%ixt3d == 2) this%qrhs = 0.d0 + else if (this%lamatsaved) then + this%amatpc = 0.d0 + this%amatpcx = 0.d0 + end if + this%vecc = 0.d0 + this%conlen = 0.d0 + this%vecn = 0.d0 + ! + ! -- Return + return + end subroutine allocate_arrays + + subroutine xt3d_iallpc(this) +! ****************************************************************************** +! xt3d_iallpc -- Allocate and populate iallpc array. Set lamatsaved. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate, mem_deallocate + ! -- dummy + class(Xt3dType) :: this + ! -- local + integer(I4B) :: n, m, mm, il0, il1 + integer(I4B) :: nnbr0, nnbr1 + integer(I4B),dimension(this%nbrmax) :: inbr0, inbr1 +! ------------------------------------------------------------------------------ + ! + if(this%ixt3d == 2 .or. this%ldispersion) then + this%lamatsaved = .false. + call mem_allocate(this%iallpc, 0, 'IALLPC', this%origin) + else + call mem_allocate(this%iallpc, this%dis%nodes, 'IALLPC', this%origin) + this%iallpc = 1 + do n = 1, this%dis%nodes + if (this%icelltype(n) /= 0) then + this%iallpc(n) = 0 + cycle + end if + nnbr0 = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 + call this%xt3d_load_inbr(n, nnbr0, inbr0) + do il0 = 1,nnbr0 + m = inbr0(il0) + if (m.lt.n) cycle + if (this%icelltype(m) /= 0) then + this%iallpc(n) = 0 + this%iallpc(m) = 0 + cycle + end if + nnbr1 = this%dis%con%ia(m+1) - this%dis%con%ia(m) - 1 + call this%xt3d_load_inbr(m, nnbr1, inbr1) + do il1 = 1,nnbr1 + mm = inbr1(il1) +!!! if (mm.lt.m) cycle + if (this%icelltype(mm) /= 0) then + this%iallpc(n) = 0 + this%iallpc(m) = 0 + this%iallpc(mm) = 0 + end if + enddo + enddo + enddo + this%lamatsaved = .false. + do n = 1, this%dis%nodes + if (this%iallpc(n) == 1) then + this%lamatsaved = .true. + exit + end if + enddo + end if + ! + if (.not.this%lamatsaved) then + call mem_deallocate(this%iallpc) ! kluge: ok to do this??? + call mem_allocate(this%iallpc, 0, 'IALLPC', this%origin) + end if + ! + ! -- Return + return + end subroutine xt3d_iallpc + + subroutine xt3d_indices(this, n, m, il0, ii01, jjs01, il01, il10, & + ii00, ii11, ii10) +! ****************************************************************************** +! xt3d_indices -- Set various indices for XT3D. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- module + ! -- dummy + class(Xt3dType) :: this + integer(I4B) :: n, m, il0, ii01, jjs01, il01, il10, ii00, ii11, ii10 + ! -- local + integer(I4B) :: iinm +! ------------------------------------------------------------------------------ + ! + ! -- Set local number of node 0-1 connection (local cell number of cell 1 + ! -- in cell 0's neighbor list). + il01 = il0 + ! -- Set local number of node 1-0 connection (local cell number of cell 0 + ! -- in cell 1's neighbor list). + call this%xt3d_get_iinm(m, n, iinm) + il10 = iinm - this%dis%con%ia(m) + ! -- Set index of node 0 diagonal in the ja array. + ii00 = this%dis%con%ia(n) + ! -- Set index of node 0-1 connection in the ja array. + ii01 = ii00 + il01 + ! -- Set symmetric index of node 0-1 connection. + jjs01 = this%dis%con%jas(ii01) + ! -- Set index of node 1 diagonal in the ja array. + ii11 = this%dis%con%ia(m) + ! -- Set index of node 1-0 connection in the ja array. + ii10 = ii11 + il10 + ! + return + end subroutine xt3d_indices + + subroutine xt3d_load(this, nodes, n, nnbr, inbr, vc, vn, dl, dln, ck, allhc) +! ****************************************************************************** +! xt3d_load -- Load conductivity and connection info for a cell into arrays +! used by XT3D. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- module + use ConstantsModule, only: DZERO, DHALF, DONE + ! -- dummy + class(Xt3dType) :: this + logical :: allhc + integer(I4B),intent(in) :: nodes + integer(I4B) :: n, nnbr + integer(I4B),dimension(this%nbrmax) :: inbr + real(DP),dimension(this%nbrmax,3) :: vc, vn + real(DP),dimension(this%nbrmax) :: dl, dln + real(DP),dimension(3,3) :: ck + ! -- local + integer(I4B) :: il, ii, jj, jjs + integer(I4B) :: ihcnjj + real(DP) :: satn, satjj + real(DP) :: cl1njj, cl2njj, dltot, ooclsum +! ------------------------------------------------------------------------------ + ! + ! -- Set conductivity tensor for cell. + ck = DZERO + ck(1,1) = this%k11(n) + if(this%ik22 == 0) then + ck(2,2) = ck(1,1) + else + ck(2,2) = this%k22(n) + end if + if(this%ik33 == 0) then + ck(3,3) = ck(1,1) + else + ck(3,3) = this%k33(n) + endif + call this%xt3d_fillrmatck(n) + ck = matmul(this%rmatck, ck) + ck = matmul(ck, transpose(this%rmatck)) + ! + ! -- Load neighbors of cell. Set cell numbers for inactive + ! -- neighbors to zero so xt3d knows to ignore them. Compute + ! -- direct connection lengths from perpendicular connection + ! -- lengths. Also determine if all active connections are + ! -- horizontal. + allhc = .true. + do il = 1,nnbr + ii = il + this%dis%con%ia(n) + jj = this%dis%con%ja(ii) + jjs = this%dis%con%jas(ii) + if (this%ibound(jj).ne.0) then + inbr(il) = jj + satn = this%sat(n) + satjj = this%sat(jj) + ! -- DISV and DIS + ihcnjj = this%dis%con%ihc(jjs) + call this%dis%connection_normal(n, jj, ihcnjj, & + vn(il, 1), vn(il, 2), vn(il, 3), ii) + call this%dis%connection_vector(n, jj, this%nozee, satn, satjj, & + ihcnjj, vc(il, 1), vc(il, 2), vc(il, 3), dltot) + if(jj > n) then + cl1njj = this%dis%con%cl1(jjs) + cl2njj = this%dis%con%cl2(jjs) + else + cl1njj = this%dis%con%cl2(jjs) + cl2njj = this%dis%con%cl1(jjs) + endif + ooclsum = 1d0/(cl1njj + cl2njj) + dl(il) = dltot*cl1njj*ooclsum + dln(il) = dltot*cl2njj*ooclsum + if (this%dis%con%ihc(jjs).eq.0) allhc = .false. + else + inbr(il) = 0 + end if + end do + ! + return + end subroutine xt3d_load + + subroutine xt3d_load_inbr(this, n, nnbr, inbr) +! ****************************************************************************** +! xt3d_load_inbr -- Load neighbor list for a cell. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- module + ! -- dummy + class(Xt3dType) :: this + integer(I4B) :: n, nnbr + integer(I4B),dimension(this%nbrmax) :: inbr + ! -- local + integer(I4B) :: il, ii, jj +! ------------------------------------------------------------------------------ + ! + ! -- Load neighbors of cell. Set cell numbers for inactive + ! -- neighbors to zero so xt3d knows to ignore them. + do il = 1,nnbr + ii = il + this%dis%con%ia(n) + jj = this%dis%con%ja(ii) + if (this%ibound(jj).ne.0) then + inbr(il) = jj + else + inbr(il) = 0 + end if + end do + ! + return + end subroutine xt3d_load_inbr + + subroutine xt3d_areas(this, nodes, n, m, jjs01, lsat, ar01, ar10, hnew) +! ****************************************************************************** +! xt3d_areas -- Compute interfacial areas. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- module + use ConstantsModule, only: DZERO, DONE + use SmoothingModule, only: sQuadraticSaturation ! kluge debug + ! -- dummy + class(Xt3dType) :: this + logical :: lsat + integer(I4B) :: nodes, n, m, jjs01 + real(DP) :: ar01, ar10 + real(DP),intent(inout),dimension(:), optional :: hnew + ! -- local + real(DP) :: topn, botn, topm, botm, thksatn, thksatm + real(DP) :: sill_top, sill_bot, tpn, tpm + real(DP) :: hn, hm ! kluge debug + real(DP) :: satups +! ------------------------------------------------------------------------------ + ! + ! -- Compute area depending on connection type + if (this%dis%con%ihc(jjs01).eq.0) then + ! -- vertical connection + ar01 = this%dis%con%hwva(jjs01) + ar10 = ar01 + else if (this%inewton /= 0) then + if (lsat) then + topn = this%dis%top(n) + botn = this%dis%bot(n) + topm = this%dis%top(m) + botm = this%dis%bot(m) + thksatn = topn - botn + thksatm = topm - botm + if (this%dis%con%ihc(jjs01).eq.2) then + ! -- vertically staggered + sill_top = min(topn, topm) + sill_bot = max(botn, botm) + tpn = botn + thksatn + tpm = botm + thksatm + thksatn = max(min(tpn, sill_top) - sill_bot, DZERO) + thksatm = max(min(tpm, sill_top) - sill_bot, DZERO) + end if + ar01 = this%dis%con%hwva(jjs01)*DHALF*(thksatn + thksatm) + else + ! -- If Newton and lsat=.false., it is assumed that the fully saturated + ! -- areas have already been calculated and are being passed in through + ! -- ar01 and ar10. The actual areas are obtained simply by scaling by + ! -- the upstream saturation. + if (hnew(m) < hnew(n)) then + if (this%icelltype(n) == 0) then + satups = DONE + else + topn = this%dis%top(n) + botn = this%dis%bot(n) + hn = hnew(n) ! kluge + satups = sQuadraticSaturation(topn, botn, hn) + end if + else + if (this%icelltype(m) == 0) then + satups = DONE + else + topm = this%dis%top(m) + botm = this%dis%bot(m) + hm = hnew(m) ! kluge + satups = sQuadraticSaturation(topm, botm, hm) + end if + end if + ar01 = ar01*satups + end if + ar10 = ar01 + else + topn = this%dis%top(n) + botn = this%dis%bot(n) + topm = this%dis%top(m) + botm = this%dis%bot(m) + if (lsat.or.(this%icelltype(n) == 0)) then + thksatn = topn - botn + else + thksatn = this%sat(n)*(topn - botn) + end if + if (lsat.or.(this%icelltype(m) == 0)) then + thksatm = topm - botm + else + thksatm = this%sat(m)*(topm - botm) + end if + if (this%dis%con%ihc(jjs01).eq.2) then + ! -- vertically staggered + sill_top = min(topn, topm) + sill_bot = max(botn, botm) + tpn = botn + thksatn + tpm = botm + thksatm + thksatn = max(min(tpn, sill_top) - sill_bot, DZERO) + thksatm = max(min(tpm, sill_top) - sill_bot, DZERO) + end if + ar01 = this%dis%con%hwva(jjs01)*thksatn + ar10 = this%dis%con%hwva(jjs01)*thksatm + endif + ! + return + end subroutine xt3d_areas + + subroutine xt3d_amat_nbrs(this, nodes, n, idiag, nnbr, nja, & + njasln, inbr, amat, idxglo, chat) +! ****************************************************************************** +! xt3d_amat_nbrs -- Add contributions from neighbors to amat. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- module + ! -- dummy + class(Xt3dType) :: this + integer(I4B),intent(in) :: nodes + integer(I4B) :: n, idiag, nnbr, nja, njasln + integer(I4B),dimension(this%nbrmax) :: inbr + integer(I4B),intent(in),dimension(nja) :: idxglo + real(DP),dimension(njasln),intent(inout) :: amat + real(DP),dimension(this%nbrmax) :: chat + ! -- local + integer(I4B) :: iil, iii +! ------------------------------------------------------------------------------ + ! + do iil = 1,nnbr + if (inbr(iil).ne.0) then + iii = this%dis%con%ia(n) + iil + amat(idxglo(idiag)) = amat(idxglo(idiag)) - chat(iil) + amat(idxglo(iii)) = amat(idxglo(iii)) + chat(iil) + endif + enddo + ! + return + end subroutine xt3d_amat_nbrs + + subroutine xt3d_amat_nbrnbrs(this, nodes, n, m, ii01, nnbr, nja, & + njasln, inbr, amat, idxglo, chat) +! ****************************************************************************** +! xt3d_amat_nbrnbrs -- Add contributions from neighbors of neighbor to amat. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- module + ! -- dummy + class(Xt3dType) :: this + integer(I4B),intent(in) :: nodes + integer(I4B) :: n, m, ii01, nnbr, nja, njasln + integer(I4B),dimension(this%nbrmax) :: inbr + integer(I4B),intent(in),dimension(nja) :: idxglo + real(DP),dimension(njasln),intent(inout) :: amat + real(DP),dimension(this%nbrmax) :: chat + ! -- local + integer(I4B) :: iil, iii, jjj, iixjjj, iijjj +! ------------------------------------------------------------------------------ + ! + do iil = 1,nnbr + if (inbr(iil).ne.0) then + amat(idxglo(ii01)) = amat(idxglo(ii01)) + chat(iil) + iii = this%dis%con%ia(m) + iil + jjj = this%dis%con%ja(iii) + call this%xt3d_get_iinmx(n, jjj, iixjjj) + if (iixjjj.ne.0) then + amat(this%idxglox(iixjjj)) = amat(this%idxglox(iixjjj)) - chat(iil) + else + call this%xt3d_get_iinm(n, jjj, iijjj) + amat(idxglo(iijjj)) = amat(idxglo(iijjj)) - chat(iil) + endif + endif + enddo + ! + return + end subroutine xt3d_amat_nbrnbrs + + subroutine xt3d_amatpc_nbrs(this, nodes, n, idiag, nnbr, inbr, chat) +! ****************************************************************************** +! xt3d_amatpc_nbrs -- Add contributions from neighbors to amatpc. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- module + ! -- dummy + class(Xt3dType) :: this + integer(I4B),intent(in) :: nodes + integer(I4B) :: n, idiag, nnbr + integer(I4B),dimension(this%nbrmax) :: inbr + real(DP),dimension(this%nbrmax) :: chat + ! -- local + integer(I4B) :: iil, iii +! ------------------------------------------------------------------------------ + ! + do iil = 1,nnbr + iii = this%dis%con%ia(n) + iil + this%amatpc(idiag) = this%amatpc(idiag) - chat(iil) + this%amatpc(iii) = this%amatpc(iii) + chat(iil) + enddo + ! + return + end subroutine xt3d_amatpc_nbrs + + subroutine xt3d_amatpcx_nbrnbrs(this, nodes, n, m, ii01, nnbr, inbr, chat) +! ****************************************************************************** +! xt3d_amatpcx_nbrnbrs -- Add contributions from neighbors of neighbor to +! amatpc and amatpcx. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- module + ! -- dummy + class(Xt3dType) :: this + integer(I4B),intent(in) :: nodes + integer(I4B) :: n, m, ii01, nnbr + integer(I4B),dimension(this%nbrmax) :: inbr + real(DP),dimension(this%nbrmax) :: chat + ! -- local + integer(I4B) :: iil, iii, jjj, iixjjj, iijjj +! ------------------------------------------------------------------------------ + ! + do iil = 1,nnbr + this%amatpc(ii01) = this%amatpc(ii01) + chat(iil) + iii = this%dis%con%ia(m) + iil + jjj = this%dis%con%ja(iii) + call this%xt3d_get_iinmx(n, jjj, iixjjj) + if (iixjjj.ne.0) then + this%amatpcx(iixjjj) = this%amatpcx(iixjjj) - chat(iil) + else + call this%xt3d_get_iinm(n, jjj, iijjj) + this%amatpc(iijjj) = this%amatpc(iijjj) - chat(iil) + endif + enddo + ! + return + end subroutine xt3d_amatpcx_nbrnbrs + + subroutine xt3d_get_iinm(this, n, m, iinm) +! ****************************************************************************** +! xt3d_get_iinm -- Get position of n-m connection in ja array (return 0 if +! not connected). +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- module + ! -- dummy + class(Xt3dType) :: this + integer(I4B) :: n, m, iinm + ! -- local + integer(I4B) :: ii, jj +! ------------------------------------------------------------------------------ + ! + iinm = 0 + do ii = this%dis%con%ia(n), this%dis%con%ia(n+1)-1 + jj = this%dis%con%ja(ii) + if (jj.eq.m) then + iinm = ii + exit + endif + enddo + ! + return + end subroutine xt3d_get_iinm + + subroutine xt3d_get_iinmx(this, n, m, iinmx) +! ****************************************************************************** +! xt3d_get_iinmx -- Get position of n-m "extended connection" in jax array +! (return 0 if not connected). +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- module + ! -- dummy + class(Xt3dType) :: this + integer(I4B) :: n, m, iinmx + ! -- local + integer(I4B) :: iix, jjx +! ------------------------------------------------------------------------------ + ! + iinmx = 0 + do iix = this%iax(n), this%iax(n+1)-1 + jjx = this%jax(iix) + if (jjx.eq.m) then + iinmx = iix + exit + endif + enddo + ! + return + end subroutine xt3d_get_iinmx + + subroutine xt3d_rhs(this, nodes, n, m, nnbr, inbr, chat, hnew, & + rhs) +! ****************************************************************************** +! xt3d_rhs -- Add contributions to rhs. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- module + ! -- dummy + class(Xt3dType) :: this + integer(I4B),intent(in) :: nodes + integer(I4B) :: n, m, nnbr + integer(I4B),dimension(this%nbrmax) :: inbr + real(DP),dimension(this%nbrmax) :: chat + real(DP),intent(inout),dimension(nodes) :: hnew, rhs + ! -- local + integer(I4B) :: iil, iii, jjj + real(DP) :: term +! ------------------------------------------------------------------------------ + ! + do iil = 1,nnbr + if (inbr(iil).ne.0) then + iii = iil + this%dis%con%ia(n) + jjj = this%dis%con%ja(iii) + term = chat(iil)*(hnew(jjj)-hnew(n)) + rhs(n) = rhs(n) - term + rhs(m) = rhs(m) + term + endif + enddo + ! + return + end subroutine xt3d_rhs + + subroutine xt3d_qnbrs(this, nodes, n, m, nnbr, inbr, chat, hnew, & + qnbrs) +! ****************************************************************************** +! xt3d_qnbrs -- Add contributions to flow from neighbors. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- module + ! -- dummy + class(Xt3dType) :: this + integer(I4B),intent(in) :: nodes + integer(I4B) :: n, m, nnbr + integer(I4B),dimension(this%nbrmax) :: inbr + real(DP) :: qnbrs + real(DP),dimension(this%nbrmax) :: chat + real(DP),intent(inout),dimension(nodes) :: hnew + ! -- local + integer(I4B) :: iil, iii, jjj + real(DP) :: term +! ------------------------------------------------------------------------------ + ! + qnbrs = 0d0 + do iil = 1,nnbr + if (inbr(iil).ne.0) then + iii = iil + this%dis%con%ia(n) + jjj = this%dis%con%ja(iii) + term = chat(iil)*(hnew(jjj)-hnew(n)) + qnbrs = qnbrs + term + endif + enddo + ! + return + end subroutine xt3d_qnbrs + + subroutine xt3d_fillrmatck(this, n) +! ****************************************************************************** +! xt3d_fillrmatck -- Fill rmat array for cell n. +! angle1, 2, and 3 must be in radians. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- module + ! -- dummy + class(Xt3dType) :: this + integer(I4B), intent(in) :: n + ! -- local + real(DP) :: ang1, ang2, ang3, ang2d, ang3d + real(DP) :: s1, c1, s2, c2, s3, c3 +! ------------------------------------------------------------------------------ + ! + if (this%nozee) then + ang2d = 0d0 + ang3d = 0d0 + ang1 = this%angle1(n) + ang2 = 0d0 + ang3 = 0d0 + else + ang1 = this%angle1(n) + ang2 = this%angle2(n) + ang3 = this%angle3(n) + endif + s1 = sin(ang1) + c1 = cos(ang1) + s2 = sin(ang2) + c2 = cos(ang2) + s3 = sin(ang3) + c3 = cos(ang3) + this%rmatck(1,1) = c1*c2 + this%rmatck(1,2) = c1*s2*s3 - s1*c3 + this%rmatck(1,3) = -c1*s2*c3 - s1*s3 + this%rmatck(2,1) = s1*c2 + this%rmatck(2,2) = s1*s2*s3 + c1*c3 + this%rmatck(2,3) = -s1*s2*c3 + c1*s3 + this%rmatck(3,1) = s2 + this%rmatck(3,2) = -c2*s3 + this%rmatck(3,3) = c2*c3 + ! + return + end subroutine xt3d_fillrmatck + +end module Xt3dModule diff --git a/src/Model/NumericalModel.f90 b/src/Model/NumericalModel.f90 index 16741a68ef0..da7f0a6bb7b 100644 --- a/src/Model/NumericalModel.f90 +++ b/src/Model/NumericalModel.f90 @@ -1,426 +1,426 @@ -module NumericalModelModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH, LENBUDTXT, LENPACKAGENAME, LENPAKLOC - use BaseModelModule, only: BaseModelType - use BaseDisModule, only: DisBaseType - use SparseModule, only: sparsematrix - use TimeArraySeriesManagerModule, only: TimeArraySeriesManagerType - use ListModule, only: ListType - - implicit none - private - public :: NumericalModelType, AddNumericalModelToList, & - GetNumericalModelFromList - - type, extends(BaseModelType) :: NumericalModelType - character(len=LINELENGTH), pointer :: filename => null() !input file name - integer(I4B), pointer :: neq => null() !number of equations - integer(I4B), pointer :: nja => null() !number of connections - integer(I4B), pointer :: moffset => null() !offset of this model in the solution - integer(I4B), pointer :: icnvg => null() !convergence flag - integer(I4B), dimension(:), pointer, contiguous :: ia => null() !csr row pointer - integer(I4B), dimension(:), pointer, contiguous :: ja => null() !csr columns - real(DP), dimension(:), pointer, contiguous :: x => null() !dependent variable (head, conc, etc) - real(DP), dimension(:), pointer, contiguous :: rhs => null() !right-hand side vector - real(DP), dimension(:), pointer, contiguous :: cond => null() !conductance matrix - integer(I4B), dimension(:), pointer, contiguous :: idxglo => null() !pointer to position in solution matrix - real(DP), dimension(:), pointer, contiguous :: xold => null() !dependent variable for previous timestep - real(DP), dimension(:), pointer, contiguous :: flowja => null() !intercell flows - integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !ibound array - ! - ! -- Derived types - type(ListType), pointer :: bndlist => null() !array of boundary packages for this model - class(DisBaseType), pointer :: dis => null() !discretization object - - contains - ! - ! -- Required for all models (override procedures defined in BaseModelType) - procedure :: model_df - procedure :: model_ar - procedure :: model_fp - procedure :: model_da - ! - ! -- Methods specific to a numerical model - procedure :: model_ac - procedure :: model_mc - procedure :: model_rp - procedure :: model_ad - procedure :: model_cf - procedure :: model_fc - procedure :: model_ptcchk - procedure :: model_ptc - procedure :: model_nr - procedure :: model_cc - procedure :: model_nur - procedure :: model_cq - procedure :: model_bd - procedure :: model_bdcalc - procedure :: model_bdsave - procedure :: model_ot - procedure :: model_bdentry - ! - ! -- Utility methods - procedure :: allocate_scalars - procedure :: allocate_arrays - procedure :: set_moffset - procedure :: set_idsoln - procedure :: set_xptr - procedure :: set_rhsptr - procedure :: set_iboundptr - procedure :: get_nsubtimes - procedure :: get_mrange - procedure :: get_mcellid - procedure :: get_mnodeu - procedure :: get_iasym - end type NumericalModelType - - contains - ! - ! -- Type-bound procedures for a numerical model - ! - subroutine model_df(this) - class(NumericalModelType) :: this - end subroutine model_df - - subroutine model_ac(this, sparse) - class(NumericalModelType) :: this - type(sparsematrix), intent(inout) :: sparse - end subroutine model_ac - - subroutine model_mc(this, iasln, jasln) - class(NumericalModelType) :: this - integer(I4B), dimension(:), intent(in) :: iasln - integer(I4B), dimension(:), intent(in) :: jasln - end subroutine model_mc - - subroutine model_ar(this) - class(NumericalModelType) :: this - end subroutine model_ar - - subroutine model_rp(this) - class(NumericalModelType) :: this - end subroutine model_rp - - subroutine model_ad(this, ipicard, isubtime) - class(NumericalModelType) :: this - integer(I4B), intent(in) :: ipicard - integer(I4B), intent(in) :: isubtime - end subroutine model_ad - - subroutine model_cf(this,kiter) - class(NumericalModelType) :: this - integer(I4B),intent(in) :: kiter - end subroutine model_cf - - subroutine model_fc(this, kiter, amatsln, njasln, inwtflag) - class(NumericalModelType) :: this - integer(I4B),intent(in) :: kiter - integer(I4B),intent(in) :: njasln - real(DP),dimension(njasln),intent(inout) :: amatsln - integer(I4B), intent(in) :: inwtflag - end subroutine model_fc - - subroutine model_ptcchk(this, iptc) - class(NumericalModelType) :: this - integer(I4B), intent(inout) :: iptc - iptc = 0 - end subroutine model_ptcchk - - subroutine model_ptc(this, kiter, neqsln, njasln, & - ia, ja, x, rhs, amatsln, iptc, ptcf) - class(NumericalModelType) :: this - integer(I4B),intent(in) :: kiter - integer(I4B), intent(in) :: neqsln - integer(I4B),intent(in) :: njasln - integer(I4B), dimension(neqsln+1), intent(in) :: ia - integer(I4B),dimension(njasln),intent(in) :: ja - real(DP), dimension(neqsln), intent(in) :: x - real(DP), dimension(neqsln), intent(in) :: rhs - real(DP),dimension(njasln),intent(in) :: amatsln - integer(I4B), intent(inout) :: iptc - real(DP),intent(inout) :: ptcf - end subroutine model_ptc - - subroutine model_nr(this, kiter, amatsln, njasln, inwtflag) - class(NumericalModelType) :: this - integer(I4B),intent(in) :: kiter - integer(I4B),intent(in) :: njasln - real(DP),dimension(njasln),intent(inout) :: amatsln - integer(I4B), intent(in) :: inwtflag - end subroutine model_nr - - subroutine model_cc(this, kiter, iend, icnvgmod, cpak, dpak) - class(NumericalModelType) :: this - integer(I4B),intent(in) :: kiter - integer(I4B),intent(in) :: iend - integer(I4B),intent(in) :: icnvgmod - character(len=LENPAKLOC), intent(inout) :: cpak - real(DP), intent(inout) :: dpak - end subroutine model_cc - - subroutine model_nur(this, neqmod, x, xtemp, dx, inewtonur, dxmax, locmax) - class(NumericalModelType) :: this - integer(I4B), intent(in) :: neqmod - real(DP), dimension(neqmod), intent(inout) :: x - real(DP), dimension(neqmod), intent(in) :: xtemp - real(DP), dimension(neqmod), intent(inout) :: dx - integer(I4B), intent(inout) :: inewtonur - real(DP), intent(inout) :: dxmax - integer(I4B), intent(inout) :: locmax - end subroutine model_nur - - subroutine model_cq(this, icnvg, isuppress_output) - class(NumericalModelType) :: this - integer(I4B),intent(in) :: icnvg - integer(I4B), intent(in) :: isuppress_output - end subroutine model_cq - - subroutine model_bd(this, icnvg, isuppress_output) - class(NumericalModelType) :: this - integer(I4B),intent(in) :: icnvg - integer(I4B), intent(in) :: isuppress_output - end subroutine model_bd - - subroutine model_bdcalc(this, icnvg) - class(NumericalModelType) :: this - integer(I4B),intent(in) :: icnvg - end subroutine model_bdcalc - - subroutine model_bdsave(this, icnvg) - class(NumericalModelType) :: this - integer(I4B),intent(in) :: icnvg - end subroutine model_bdsave - - subroutine model_ot(this) - class(NumericalModelType) :: this - end subroutine model_ot - - subroutine model_bdentry(this, budterm, budtxt, rowlabel) - class(NumericalModelType) :: this - real(DP), dimension(:, :), intent(in) :: budterm - character(len=LENBUDTXT), dimension(:), intent(in) :: budtxt - character(len=LENPACKAGENAME), intent(in) :: rowlabel - end subroutine model_bdentry - - subroutine model_fp(this) - class(NumericalModelType) :: this - end subroutine model_fp - - subroutine model_da(this) - ! -- modules - use MemoryManagerModule, only: mem_deallocate - class(NumericalModelType) :: this - ! - ! -- BaseModelType - call this%BaseModelType%model_da() - ! - ! -- Scalars - call mem_deallocate(this%neq) - call mem_deallocate(this%nja) - call mem_deallocate(this%icnvg) - call mem_deallocate(this%moffset) - deallocate(this%filename) - ! - ! -- Arrays - call mem_deallocate(this%xold) - call mem_deallocate(this%flowja) - call mem_deallocate(this%idxglo) - ! - ! -- derived types - call this%bndlist%Clear() - deallocate(this%bndlist) - ! - ! -- nullify pointers - nullify(this%x) - nullify(this%rhs) - nullify(this%ibound) - ! - ! -- Return - return - end subroutine model_da - - subroutine set_moffset(this, moffset) - class(NumericalModelType) :: this - integer(I4B), intent(in) :: moffset - this%moffset = moffset - end subroutine set_moffset - - subroutine get_mrange(this, mstart, mend) - class(NumericalModelType) :: this - integer(I4B), intent(inout) :: mstart - integer(I4B), intent(inout) :: mend - mstart = this%moffset + 1 - mend = mstart + this%neq - 1 - end subroutine get_mrange - - subroutine set_idsoln(this, id) - class(NumericalModelType) :: this - integer(I4B), intent(in) :: id - this%idsoln = id - end subroutine set_idsoln - - subroutine allocate_scalars(this, modelname) - use MemoryManagerModule, only: mem_allocate - class(NumericalModelType) :: this - character(len=*), intent(in) :: modelname - ! - ! -- allocate basetype members - call this%BaseModelType%allocate_scalars(modelname) - ! - ! -- allocate members from this type - call mem_allocate(this%neq, 'NEQ', modelname) - call mem_allocate(this%nja, 'NJA', modelname) - call mem_allocate(this%icnvg, 'ICNVG', modelname) - call mem_allocate(this%moffset, 'MOFFSET', modelname) - allocate(this%filename) - allocate(this%bndlist) - ! - this%filename = '' - this%neq = 0 - this%nja = 0 - this%icnvg = 0 - this%moffset = 0 - ! - ! -- return - return - end subroutine allocate_scalars - - subroutine allocate_arrays(this) - use MemoryManagerModule, only: mem_allocate - class(NumericalModelType) :: this - ! - call mem_allocate(this%xold, this%neq, 'XOLD', trim(this%name)) - call mem_allocate(this%flowja, this%nja, 'FLOWJA', trim(this%name)) - call mem_allocate(this%idxglo, this%nja, 'IDXGLO', trim(this%name)) - ! - ! -- return - return - end subroutine allocate_arrays - - subroutine set_xptr(this, xsln) - class(NumericalModelType) :: this - real(DP), dimension(:), pointer, contiguous, intent(in) :: xsln - this%x => xsln(this%moffset + 1:this%moffset + this%neq) - end subroutine set_xptr - - subroutine set_rhsptr(this, rhssln) - class(NumericalModelType) :: this - real(DP), dimension(:), pointer, contiguous, intent(in) :: rhssln - this%rhs => rhssln(this%moffset + 1:this%moffset + this%neq) - end subroutine set_rhsptr - - subroutine set_iboundptr(this, iboundsln) - class(NumericalModelType) :: this - integer(I4B), dimension(:), pointer, contiguous, intent(in) :: iboundsln - this%ibound => iboundsln(this%moffset + 1:this%moffset + this%neq) - end subroutine set_iboundptr - - function get_nsubtimes(this) result(nsubtimes) - integer(I4B) :: nsubtimes - class(NumericalModelType) :: this - nsubtimes = 1 - return - end function get_nsubtimes - - subroutine get_mcellid(this, node, mcellid) - use BndModule, only: BndType, GetBndFromList - class(NumericalModelType) :: this - integer(I4B), intent(in) :: node - character(len=*), intent(inout) :: mcellid - ! -- local - character(len=20) :: cellid - integer(I4B) :: ip, ipaknode, istart, istop - class(BndType), pointer :: packobj - - if (node < 1) then - cellid = '' - else if(node <= this%dis%nodes) then - call this%dis%noder_to_string(node, cellid) - else - cellid = '***ERROR***' - ipaknode = node - this%dis%nodes - istart = 1 - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - if(packobj%npakeq == 0) cycle - istop = istart + packobj%npakeq - 1 - if(istart <= ipaknode .and. ipaknode <= istop) then - write(cellid, '(a, a, a, i0, a, i0, a)') '(', & - trim(packobj%filtyp), '_', & - packobj%ibcnum, '-', ipaknode - packobj%ioffset, ')' - exit - endif - istart = istop + 1 - enddo - endif - write(mcellid, '(i0, a, a, a, a)') this%id, '_', this%macronym, '-', & - trim(adjustl(cellid)) - return - end subroutine get_mcellid - - subroutine get_mnodeu(this, node, nodeu) - use BndModule, only: BndType, GetBndFromList - class(NumericalModelType) :: this - integer(I4B), intent(in) :: node - integer(I4B), intent(inout) :: nodeu - ! -- local - if(node <= this%dis%nodes) then - nodeu = this%dis%get_nodeuser(node) - else - nodeu = -(node - this%dis%nodes) - endif - return - end subroutine get_mnodeu - - function get_iasym(this) result (iasym) - class(NumericalModelType) :: this - integer(I4B) :: iasym - iasym = 0 - end function get_iasym - - function CastAsNumericalModelClass(obj) result (res) - implicit none - class(*), pointer, intent(inout) :: obj - class(NumericalModelType), pointer :: res - ! - res => null() - if (.not. associated(obj)) return - ! - select type (obj) - class is (NumericalModelType) - res => obj - end select - return - end function CastAsNumericalModelClass - - subroutine AddNumericalModelToList(list, model) - implicit none - ! -- dummy - type(ListType), intent(inout) :: list - class(NumericalModelType), pointer, intent(inout) :: model - ! -- local - class(*), pointer :: obj - ! - obj => model - call list%Add(obj) - ! - return - end subroutine AddNumericalModelToList - - function GetNumericalModelFromList(list, idx) result (res) - implicit none - ! -- dummy - type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx - class(NumericalModelType), pointer :: res - ! -- local - class(*), pointer :: obj - ! - obj => list%GetItem(idx) - res => CastAsNumericalModelClass(obj) - ! - return - end function GetNumericalModelFromList - -end module NumericalModelModule +module NumericalModelModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: LINELENGTH, LENBUDTXT, LENPACKAGENAME, LENPAKLOC + use BaseModelModule, only: BaseModelType + use BaseDisModule, only: DisBaseType + use SparseModule, only: sparsematrix + use TimeArraySeriesManagerModule, only: TimeArraySeriesManagerType + use ListModule, only: ListType + + implicit none + private + public :: NumericalModelType, AddNumericalModelToList, & + GetNumericalModelFromList + + type, extends(BaseModelType) :: NumericalModelType + character(len=LINELENGTH), pointer :: filename => null() !input file name + integer(I4B), pointer :: neq => null() !number of equations + integer(I4B), pointer :: nja => null() !number of connections + integer(I4B), pointer :: moffset => null() !offset of this model in the solution + integer(I4B), pointer :: icnvg => null() !convergence flag + integer(I4B), dimension(:), pointer, contiguous :: ia => null() !csr row pointer + integer(I4B), dimension(:), pointer, contiguous :: ja => null() !csr columns + real(DP), dimension(:), pointer, contiguous :: x => null() !dependent variable (head, conc, etc) + real(DP), dimension(:), pointer, contiguous :: rhs => null() !right-hand side vector + real(DP), dimension(:), pointer, contiguous :: cond => null() !conductance matrix + integer(I4B), dimension(:), pointer, contiguous :: idxglo => null() !pointer to position in solution matrix + real(DP), dimension(:), pointer, contiguous :: xold => null() !dependent variable for previous timestep + real(DP), dimension(:), pointer, contiguous :: flowja => null() !intercell flows + integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !ibound array + ! + ! -- Derived types + type(ListType), pointer :: bndlist => null() !array of boundary packages for this model + class(DisBaseType), pointer :: dis => null() !discretization object + + contains + ! + ! -- Required for all models (override procedures defined in BaseModelType) + procedure :: model_df + procedure :: model_ar + procedure :: model_fp + procedure :: model_da + ! + ! -- Methods specific to a numerical model + procedure :: model_ac + procedure :: model_mc + procedure :: model_rp + procedure :: model_ad + procedure :: model_cf + procedure :: model_fc + procedure :: model_ptcchk + procedure :: model_ptc + procedure :: model_nr + procedure :: model_cc + procedure :: model_nur + procedure :: model_cq + procedure :: model_bd + procedure :: model_bdcalc + procedure :: model_bdsave + procedure :: model_ot + procedure :: model_bdentry + ! + ! -- Utility methods + procedure :: allocate_scalars + procedure :: allocate_arrays + procedure :: set_moffset + procedure :: set_idsoln + procedure :: set_xptr + procedure :: set_rhsptr + procedure :: set_iboundptr + procedure :: get_nsubtimes + procedure :: get_mrange + procedure :: get_mcellid + procedure :: get_mnodeu + procedure :: get_iasym + end type NumericalModelType + + contains + ! + ! -- Type-bound procedures for a numerical model + ! + subroutine model_df(this) + class(NumericalModelType) :: this + end subroutine model_df + + subroutine model_ac(this, sparse) + class(NumericalModelType) :: this + type(sparsematrix), intent(inout) :: sparse + end subroutine model_ac + + subroutine model_mc(this, iasln, jasln) + class(NumericalModelType) :: this + integer(I4B), dimension(:), intent(in) :: iasln + integer(I4B), dimension(:), intent(in) :: jasln + end subroutine model_mc + + subroutine model_ar(this) + class(NumericalModelType) :: this + end subroutine model_ar + + subroutine model_rp(this) + class(NumericalModelType) :: this + end subroutine model_rp + + subroutine model_ad(this, ipicard, isubtime) + class(NumericalModelType) :: this + integer(I4B), intent(in) :: ipicard + integer(I4B), intent(in) :: isubtime + end subroutine model_ad + + subroutine model_cf(this,kiter) + class(NumericalModelType) :: this + integer(I4B),intent(in) :: kiter + end subroutine model_cf + + subroutine model_fc(this, kiter, amatsln, njasln, inwtflag) + class(NumericalModelType) :: this + integer(I4B),intent(in) :: kiter + integer(I4B),intent(in) :: njasln + real(DP),dimension(njasln),intent(inout) :: amatsln + integer(I4B), intent(in) :: inwtflag + end subroutine model_fc + + subroutine model_ptcchk(this, iptc) + class(NumericalModelType) :: this + integer(I4B), intent(inout) :: iptc + iptc = 0 + end subroutine model_ptcchk + + subroutine model_ptc(this, kiter, neqsln, njasln, & + ia, ja, x, rhs, amatsln, iptc, ptcf) + class(NumericalModelType) :: this + integer(I4B),intent(in) :: kiter + integer(I4B), intent(in) :: neqsln + integer(I4B),intent(in) :: njasln + integer(I4B), dimension(neqsln+1), intent(in) :: ia + integer(I4B),dimension(njasln),intent(in) :: ja + real(DP), dimension(neqsln), intent(in) :: x + real(DP), dimension(neqsln), intent(in) :: rhs + real(DP),dimension(njasln),intent(in) :: amatsln + integer(I4B), intent(inout) :: iptc + real(DP),intent(inout) :: ptcf + end subroutine model_ptc + + subroutine model_nr(this, kiter, amatsln, njasln, inwtflag) + class(NumericalModelType) :: this + integer(I4B),intent(in) :: kiter + integer(I4B),intent(in) :: njasln + real(DP),dimension(njasln),intent(inout) :: amatsln + integer(I4B), intent(in) :: inwtflag + end subroutine model_nr + + subroutine model_cc(this, kiter, iend, icnvgmod, cpak, dpak) + class(NumericalModelType) :: this + integer(I4B),intent(in) :: kiter + integer(I4B),intent(in) :: iend + integer(I4B),intent(in) :: icnvgmod + character(len=LENPAKLOC), intent(inout) :: cpak + real(DP), intent(inout) :: dpak + end subroutine model_cc + + subroutine model_nur(this, neqmod, x, xtemp, dx, inewtonur, dxmax, locmax) + class(NumericalModelType) :: this + integer(I4B), intent(in) :: neqmod + real(DP), dimension(neqmod), intent(inout) :: x + real(DP), dimension(neqmod), intent(in) :: xtemp + real(DP), dimension(neqmod), intent(inout) :: dx + integer(I4B), intent(inout) :: inewtonur + real(DP), intent(inout) :: dxmax + integer(I4B), intent(inout) :: locmax + end subroutine model_nur + + subroutine model_cq(this, icnvg, isuppress_output) + class(NumericalModelType) :: this + integer(I4B),intent(in) :: icnvg + integer(I4B), intent(in) :: isuppress_output + end subroutine model_cq + + subroutine model_bd(this, icnvg, isuppress_output) + class(NumericalModelType) :: this + integer(I4B),intent(in) :: icnvg + integer(I4B), intent(in) :: isuppress_output + end subroutine model_bd + + subroutine model_bdcalc(this, icnvg) + class(NumericalModelType) :: this + integer(I4B),intent(in) :: icnvg + end subroutine model_bdcalc + + subroutine model_bdsave(this, icnvg) + class(NumericalModelType) :: this + integer(I4B),intent(in) :: icnvg + end subroutine model_bdsave + + subroutine model_ot(this) + class(NumericalModelType) :: this + end subroutine model_ot + + subroutine model_bdentry(this, budterm, budtxt, rowlabel) + class(NumericalModelType) :: this + real(DP), dimension(:, :), intent(in) :: budterm + character(len=LENBUDTXT), dimension(:), intent(in) :: budtxt + character(len=LENPACKAGENAME), intent(in) :: rowlabel + end subroutine model_bdentry + + subroutine model_fp(this) + class(NumericalModelType) :: this + end subroutine model_fp + + subroutine model_da(this) + ! -- modules + use MemoryManagerModule, only: mem_deallocate + class(NumericalModelType) :: this + ! + ! -- BaseModelType + call this%BaseModelType%model_da() + ! + ! -- Scalars + call mem_deallocate(this%neq) + call mem_deallocate(this%nja) + call mem_deallocate(this%icnvg) + call mem_deallocate(this%moffset) + deallocate(this%filename) + ! + ! -- Arrays + call mem_deallocate(this%xold) + call mem_deallocate(this%flowja) + call mem_deallocate(this%idxglo) + ! + ! -- derived types + call this%bndlist%Clear() + deallocate(this%bndlist) + ! + ! -- nullify pointers + nullify(this%x) + nullify(this%rhs) + nullify(this%ibound) + ! + ! -- Return + return + end subroutine model_da + + subroutine set_moffset(this, moffset) + class(NumericalModelType) :: this + integer(I4B), intent(in) :: moffset + this%moffset = moffset + end subroutine set_moffset + + subroutine get_mrange(this, mstart, mend) + class(NumericalModelType) :: this + integer(I4B), intent(inout) :: mstart + integer(I4B), intent(inout) :: mend + mstart = this%moffset + 1 + mend = mstart + this%neq - 1 + end subroutine get_mrange + + subroutine set_idsoln(this, id) + class(NumericalModelType) :: this + integer(I4B), intent(in) :: id + this%idsoln = id + end subroutine set_idsoln + + subroutine allocate_scalars(this, modelname) + use MemoryManagerModule, only: mem_allocate + class(NumericalModelType) :: this + character(len=*), intent(in) :: modelname + ! + ! -- allocate basetype members + call this%BaseModelType%allocate_scalars(modelname) + ! + ! -- allocate members from this type + call mem_allocate(this%neq, 'NEQ', modelname) + call mem_allocate(this%nja, 'NJA', modelname) + call mem_allocate(this%icnvg, 'ICNVG', modelname) + call mem_allocate(this%moffset, 'MOFFSET', modelname) + allocate(this%filename) + allocate(this%bndlist) + ! + this%filename = '' + this%neq = 0 + this%nja = 0 + this%icnvg = 0 + this%moffset = 0 + ! + ! -- return + return + end subroutine allocate_scalars + + subroutine allocate_arrays(this) + use MemoryManagerModule, only: mem_allocate + class(NumericalModelType) :: this + ! + call mem_allocate(this%xold, this%neq, 'XOLD', trim(this%name)) + call mem_allocate(this%flowja, this%nja, 'FLOWJA', trim(this%name)) + call mem_allocate(this%idxglo, this%nja, 'IDXGLO', trim(this%name)) + ! + ! -- return + return + end subroutine allocate_arrays + + subroutine set_xptr(this, xsln) + class(NumericalModelType) :: this + real(DP), dimension(:), pointer, contiguous, intent(in) :: xsln + this%x => xsln(this%moffset + 1:this%moffset + this%neq) + end subroutine set_xptr + + subroutine set_rhsptr(this, rhssln) + class(NumericalModelType) :: this + real(DP), dimension(:), pointer, contiguous, intent(in) :: rhssln + this%rhs => rhssln(this%moffset + 1:this%moffset + this%neq) + end subroutine set_rhsptr + + subroutine set_iboundptr(this, iboundsln) + class(NumericalModelType) :: this + integer(I4B), dimension(:), pointer, contiguous, intent(in) :: iboundsln + this%ibound => iboundsln(this%moffset + 1:this%moffset + this%neq) + end subroutine set_iboundptr + + function get_nsubtimes(this) result(nsubtimes) + integer(I4B) :: nsubtimes + class(NumericalModelType) :: this + nsubtimes = 1 + return + end function get_nsubtimes + + subroutine get_mcellid(this, node, mcellid) + use BndModule, only: BndType, GetBndFromList + class(NumericalModelType) :: this + integer(I4B), intent(in) :: node + character(len=*), intent(inout) :: mcellid + ! -- local + character(len=20) :: cellid + integer(I4B) :: ip, ipaknode, istart, istop + class(BndType), pointer :: packobj + + if (node < 1) then + cellid = '' + else if(node <= this%dis%nodes) then + call this%dis%noder_to_string(node, cellid) + else + cellid = '***ERROR***' + ipaknode = node - this%dis%nodes + istart = 1 + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + if(packobj%npakeq == 0) cycle + istop = istart + packobj%npakeq - 1 + if(istart <= ipaknode .and. ipaknode <= istop) then + write(cellid, '(a, a, a, i0, a, i0, a)') '(', & + trim(packobj%filtyp), '_', & + packobj%ibcnum, '-', ipaknode - packobj%ioffset, ')' + exit + endif + istart = istop + 1 + enddo + endif + write(mcellid, '(i0, a, a, a, a)') this%id, '_', this%macronym, '-', & + trim(adjustl(cellid)) + return + end subroutine get_mcellid + + subroutine get_mnodeu(this, node, nodeu) + use BndModule, only: BndType, GetBndFromList + class(NumericalModelType) :: this + integer(I4B), intent(in) :: node + integer(I4B), intent(inout) :: nodeu + ! -- local + if(node <= this%dis%nodes) then + nodeu = this%dis%get_nodeuser(node) + else + nodeu = -(node - this%dis%nodes) + endif + return + end subroutine get_mnodeu + + function get_iasym(this) result (iasym) + class(NumericalModelType) :: this + integer(I4B) :: iasym + iasym = 0 + end function get_iasym + + function CastAsNumericalModelClass(obj) result (res) + implicit none + class(*), pointer, intent(inout) :: obj + class(NumericalModelType), pointer :: res + ! + res => null() + if (.not. associated(obj)) return + ! + select type (obj) + class is (NumericalModelType) + res => obj + end select + return + end function CastAsNumericalModelClass + + subroutine AddNumericalModelToList(list, model) + implicit none + ! -- dummy + type(ListType), intent(inout) :: list + class(NumericalModelType), pointer, intent(inout) :: model + ! -- local + class(*), pointer :: obj + ! + obj => model + call list%Add(obj) + ! + return + end subroutine AddNumericalModelToList + + function GetNumericalModelFromList(list, idx) result (res) + implicit none + ! -- dummy + type(ListType), intent(inout) :: list + integer(I4B), intent(in) :: idx + class(NumericalModelType), pointer :: res + ! -- local + class(*), pointer :: obj + ! + obj => list%GetItem(idx) + res => CastAsNumericalModelClass(obj) + ! + return + end function GetNumericalModelFromList + +end module NumericalModelModule diff --git a/src/Model/NumericalPackage.f90 b/src/Model/NumericalPackage.f90 index b90c1556662..b05d89d3c2e 100644 --- a/src/Model/NumericalPackage.f90 +++ b/src/Model/NumericalPackage.f90 @@ -1,284 +1,284 @@ -module NumericalPackageModule - ! -- modules - use KindModule, only: DP, I4B - use ConstantsModule, only: LENPACKAGENAME, LENMODELNAME, & - LENORIGIN, LENFTYPE, LINELENGTH - use SimModule, only: store_error, ustop - use BlockParserModule, only: BlockParserType - use BaseDisModule, only: DisBaseType - - implicit none - private - public NumericalPackageType - - type :: NumericalPackageType - - ! -- strings - character(len=LENPACKAGENAME) :: name = '' !name of the package - character(len=LENMODELNAME) :: name_model = '' !name of model to which package belongs - character(len=LENORIGIN) :: origin = '' !name of model // name of package - character(len=LENFTYPE) :: filtyp = '' !file type (CHD, DRN, RIV, etc.) - ! - ! -- integers - integer(I4B), pointer :: id => null() !consecutive package number in model - integer(I4B), pointer :: inunit => null() !unit number for input file - integer(I4B), pointer :: iout => null() !unit number for writing package output - integer(I4B), pointer :: inewton => null() !newton flag - integer(I4B), pointer :: iasym => null() !package causes matrix asymmetry +module NumericalPackageModule + ! -- modules + use KindModule, only: DP, I4B + use ConstantsModule, only: LENPACKAGENAME, LENMODELNAME, & + LENORIGIN, LENFTYPE, LINELENGTH + use SimModule, only: store_error, ustop + use BlockParserModule, only: BlockParserType + use BaseDisModule, only: DisBaseType + + implicit none + private + public NumericalPackageType + + type :: NumericalPackageType + + ! -- strings + character(len=LENPACKAGENAME) :: name = '' !name of the package + character(len=LENMODELNAME) :: name_model = '' !name of model to which package belongs + character(len=LENORIGIN) :: origin = '' !name of model // name of package + character(len=LENFTYPE) :: filtyp = '' !file type (CHD, DRN, RIV, etc.) + ! + ! -- integers + integer(I4B), pointer :: id => null() !consecutive package number in model + integer(I4B), pointer :: inunit => null() !unit number for input file + integer(I4B), pointer :: iout => null() !unit number for writing package output + integer(I4B), pointer :: inewton => null() !newton flag + integer(I4B), pointer :: iasym => null() !package causes matrix asymmetry integer(I4B), pointer :: iprpak => null() !integer flag to echo input integer(I4B), pointer :: iprflow => null() !flag to print simulated flows - integer(I4B), pointer :: ipakcb => null() !output flows (-1, 0, 1) - save_flows - integer(I4B), pointer :: ionper => null() !stress period for next data - integer(I4B), pointer :: lastonper => null() !last value of ionper (for checking) - ! - ! -- derived types - type(BlockParserType) :: parser !parser object for reading blocks of information - class(DisBaseType), pointer :: dis => null() - - contains - procedure :: set_names - procedure :: allocate_scalars - procedure :: da - procedure :: read_check_ionper - procedure :: get_block_data - end type NumericalPackageType - ! - contains - ! - subroutine set_names(this, ibcnum, name_model, pakname, ftype) -! ****************************************************************************** -! set_names -- Assign strings to some character attributes -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(NumericalPackageType),intent(inout) :: this - integer(I4B), intent(in) :: ibcnum - character(len=*), intent(in) :: name_model - character(len=*), intent(in) :: pakname - character(len=*), intent(in) :: ftype - ! -- locals - character(len=LINELENGTH) :: errmsg -! ------------------------------------------------------------------------------ - this%name_model = name_model - this%filtyp = ftype - if(pakname == '') then - write(this%name,'(a, i0)') trim(ftype) // '-', ibcnum - else - ! - ! -- Ensure pakname has no spaces - if(index(trim(pakname), ' ') > 0) then - errmsg = 'Package name contains spaces: ' // trim(pakname) - call store_error(errmsg) - errmsg = 'Remove spaces from name.' - call store_error(errmsg) - call ustop() - endif - ! - this%name = pakname - endif - this%origin = trim(this%name_model) // ' ' // trim(this%name) - ! - ! -- Return - return - end subroutine set_names - - subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -- allocate the scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate, mem_setptr - ! -- dummy - class(NumericalPackageType) :: this - ! -- local - integer(I4B), pointer :: imodelnewton => NULL() - integer(I4B), pointer :: imodelprpak => NULL() - integer(I4B), pointer :: imodelprflow => NULL() - integer(I4B), pointer :: imodelpakcb => NULL() -! ------------------------------------------------------------------------------ - ! - ! -- allocate - call mem_allocate(this%id, 'ID', this%origin) - call mem_allocate(this%inunit, 'INUNIT', this%origin) - call mem_allocate(this%iout, 'IOUT', this%origin) - call mem_allocate(this%inewton, 'INEWTON', this%origin) - call mem_allocate(this%iasym, 'IASYM', this%origin) - call mem_allocate(this%iprpak, 'IPRPAK', this%origin) - call mem_allocate(this%iprflow, 'IPRFLOW', this%origin) - call mem_allocate(this%ipakcb, 'IPAKCB', this%origin) - ! - ! -- set pointer to model inewton variable - call mem_setptr(imodelnewton, 'INEWTON', trim(this%name_model)) + integer(I4B), pointer :: ipakcb => null() !output flows (-1, 0, 1) - save_flows + integer(I4B), pointer :: ionper => null() !stress period for next data + integer(I4B), pointer :: lastonper => null() !last value of ionper (for checking) + ! + ! -- derived types + type(BlockParserType) :: parser !parser object for reading blocks of information + class(DisBaseType), pointer :: dis => null() + + contains + procedure :: set_names + procedure :: allocate_scalars + procedure :: da + procedure :: read_check_ionper + procedure :: get_block_data + end type NumericalPackageType + ! + contains + ! + subroutine set_names(this, ibcnum, name_model, pakname, ftype) +! ****************************************************************************** +! set_names -- Assign strings to some character attributes +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(NumericalPackageType),intent(inout) :: this + integer(I4B), intent(in) :: ibcnum + character(len=*), intent(in) :: name_model + character(len=*), intent(in) :: pakname + character(len=*), intent(in) :: ftype + ! -- locals + character(len=LINELENGTH) :: errmsg +! ------------------------------------------------------------------------------ + this%name_model = name_model + this%filtyp = ftype + if(pakname == '') then + write(this%name,'(a, i0)') trim(ftype) // '-', ibcnum + else + ! + ! -- Ensure pakname has no spaces + if(index(trim(pakname), ' ') > 0) then + errmsg = 'Package name contains spaces: ' // trim(pakname) + call store_error(errmsg) + errmsg = 'Remove spaces from name.' + call store_error(errmsg) + call ustop() + endif + ! + this%name = pakname + endif + this%origin = trim(this%name_model) // ' ' // trim(this%name) + ! + ! -- Return + return + end subroutine set_names + + subroutine allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars -- allocate the scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate, mem_setptr + ! -- dummy + class(NumericalPackageType) :: this + ! -- local + integer(I4B), pointer :: imodelnewton => NULL() + integer(I4B), pointer :: imodelprpak => NULL() + integer(I4B), pointer :: imodelprflow => NULL() + integer(I4B), pointer :: imodelpakcb => NULL() +! ------------------------------------------------------------------------------ + ! + ! -- allocate + call mem_allocate(this%id, 'ID', this%origin) + call mem_allocate(this%inunit, 'INUNIT', this%origin) + call mem_allocate(this%iout, 'IOUT', this%origin) + call mem_allocate(this%inewton, 'INEWTON', this%origin) + call mem_allocate(this%iasym, 'IASYM', this%origin) + call mem_allocate(this%iprpak, 'IPRPAK', this%origin) + call mem_allocate(this%iprflow, 'IPRFLOW', this%origin) + call mem_allocate(this%ipakcb, 'IPAKCB', this%origin) + ! + ! -- set pointer to model inewton variable + call mem_setptr(imodelnewton, 'INEWTON', trim(this%name_model)) ! ! -- Set pointer to model iprpak, iprflow, and ipakcb variables call mem_setptr(imodelprpak, 'IPRPAK', trim(this%name_model)) call mem_setptr(imodelprflow, 'IPRFLOW', trim(this%name_model)) call mem_setptr(imodelpakcb, 'IPAKCB', trim(this%name_model)) - call mem_allocate(this%ionper, 'IONPER', this%origin) - call mem_allocate(this%lastonper, 'LASTONPER', this%origin) - ! - ! -- initialize - this%id = 0 - this%inunit = 0 - this%iout = 0 - this%inewton = imodelnewton - this%iasym = 0 - this%iprpak = imodelprpak - this%iprflow = imodelprflow - this%ipakcb = imodelpakcb - this%ionper = 0 - this%lastonper = 0 - ! - ! -- nullify unneeded pointers - imodelnewton => NULL() - imodelprpak => NULL() - imodelprflow => NULL() - imodelpakcb => NULL() - ! - ! -- Return - return - end subroutine allocate_scalars - - subroutine da(this) -! ****************************************************************************** -! deallocate -- deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(NumericalPackageType) :: this - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- allocate - call mem_deallocate(this%id) - call mem_deallocate(this%inunit) - call mem_deallocate(this%iout) - call mem_deallocate(this%inewton) - call mem_deallocate(this%iasym) - call mem_deallocate(this%iprpak) - call mem_deallocate(this%iprflow) - call mem_deallocate(this%ipakcb) - call mem_deallocate(this%ionper) - call mem_deallocate(this%lastonper) - ! - ! -- Return - return - end subroutine da - ! - subroutine read_check_ionper(this) -! ****************************************************************************** -! read_check_ionper -- Read ionper and check to make sure periods are increasing -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: kper - ! -- dummy - class(NumericalPackageType),intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: errmsg -! ------------------------------------------------------------------------------ - ! - ! -- save last value and read period number - this%lastonper = this%ionper - this%ionper = this%parser%GetInteger() - ! - ! -- make check - if (this%ionper <= this%lastonper) then - write(errmsg, '(a, i0)') & - 'ERROR IN STRESS PERIOD ', kper - call store_error(errmsg) - write(errmsg, '(a, i0)') & - 'PERIOD NUMBERS NOT INCREASING. FOUND ', this%ionper - call store_error(errmsg) - write(errmsg, '(a, i0)') & - 'BUT LAST PERIOD BLOCK WAS ASSIGNED ', this%lastonper - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- return - return - end subroutine read_check_ionper - - subroutine get_block_data(this, tags, lfound, varinames) -! ****************************************************************************** -! get_block_data -- Read griddata block for a package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_setptr - ! -- dummy - class(NumericalPackageType) :: this - character(len=24), dimension(:), intent(in) :: tags - logical, dimension(:), intent(inout) :: lfound - character(len=24), dimension(:), intent(in), optional :: varinames - ! -- local - logical :: lkeyword - logical :: endOfBlock - integer(I4B) :: nsize - integer(I4B) :: j - character(len=LENORIGIN) :: name - character(len=LINELENGTH) :: line, errmsg, keyword - integer(I4B) :: istart, istop, lloc + call mem_allocate(this%ionper, 'IONPER', this%origin) + call mem_allocate(this%lastonper, 'LASTONPER', this%origin) + ! + ! -- initialize + this%id = 0 + this%inunit = 0 + this%iout = 0 + this%inewton = imodelnewton + this%iasym = 0 + this%iprpak = imodelprpak + this%iprflow = imodelprflow + this%ipakcb = imodelpakcb + this%ionper = 0 + this%lastonper = 0 + ! + ! -- nullify unneeded pointers + imodelnewton => NULL() + imodelprpak => NULL() + imodelprflow => NULL() + imodelpakcb => NULL() + ! + ! -- Return + return + end subroutine allocate_scalars + + subroutine da(this) +! ****************************************************************************** +! deallocate -- deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(NumericalPackageType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- allocate + call mem_deallocate(this%id) + call mem_deallocate(this%inunit) + call mem_deallocate(this%iout) + call mem_deallocate(this%inewton) + call mem_deallocate(this%iasym) + call mem_deallocate(this%iprpak) + call mem_deallocate(this%iprflow) + call mem_deallocate(this%ipakcb) + call mem_deallocate(this%ionper) + call mem_deallocate(this%lastonper) + ! + ! -- Return + return + end subroutine da + ! + subroutine read_check_ionper(this) +! ****************************************************************************** +! read_check_ionper -- Read ionper and check to make sure periods are increasing +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: kper + ! -- dummy + class(NumericalPackageType),intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: errmsg +! ------------------------------------------------------------------------------ + ! + ! -- save last value and read period number + this%lastonper = this%ionper + this%ionper = this%parser%GetInteger() + ! + ! -- make check + if (this%ionper <= this%lastonper) then + write(errmsg, '(a, i0)') & + 'ERROR IN STRESS PERIOD ', kper + call store_error(errmsg) + write(errmsg, '(a, i0)') & + 'PERIOD NUMBERS NOT INCREASING. FOUND ', this%ionper + call store_error(errmsg) + write(errmsg, '(a, i0)') & + 'BUT LAST PERIOD BLOCK WAS ASSIGNED ', this%lastonper + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- return + return + end subroutine read_check_ionper + + subroutine get_block_data(this, tags, lfound, varinames) +! ****************************************************************************** +! get_block_data -- Read griddata block for a package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_setptr + ! -- dummy + class(NumericalPackageType) :: this + character(len=24), dimension(:), intent(in) :: tags + logical, dimension(:), intent(inout) :: lfound + character(len=24), dimension(:), intent(in), optional :: varinames + ! -- local + logical :: lkeyword + logical :: endOfBlock + integer(I4B) :: nsize + integer(I4B) :: j + character(len=LENORIGIN) :: name + character(len=LINELENGTH) :: line, errmsg, keyword + integer(I4B) :: istart, istop, lloc integer(I4B), dimension(:), pointer, contiguous :: aint real(DP), dimension(:), pointer, contiguous :: adbl -! ------------------------------------------------------------------------------ - ! -- initialize nsize - nsize = size(tags) - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - call this%parser%GetRemainingLine(line) - lkeyword = .false. - lloc = 1 - tag_iter: do j = 1, nsize - if (trim(adjustl(keyword)) == trim(adjustl(tags(j)))) then - lkeyword = .true. - lfound(j) = .true. - if (present(varinames)) then - name = adjustl(varinames(j)) - else - name = adjustl(tags(j)) - end if - if (keyword(1:1) == 'I') then - call mem_setptr(aint, trim(name), trim(this%origin)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, aint, tags(j)) - else - call mem_setptr(adbl, trim(name), trim(this%origin)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, adbl, tags(j)) - end if - exit tag_iter - end if - end do tag_iter - if (.not.lkeyword) then - write(errmsg,'(4x,a,a)')'ERROR. UNKNOWN GRIDDATA TAG: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - end do - ! - ! -- return - return - end subroutine get_block_data - -end module NumericalPackageModule - +! ------------------------------------------------------------------------------ + ! -- initialize nsize + nsize = size(tags) + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + call this%parser%GetRemainingLine(line) + lkeyword = .false. + lloc = 1 + tag_iter: do j = 1, nsize + if (trim(adjustl(keyword)) == trim(adjustl(tags(j)))) then + lkeyword = .true. + lfound(j) = .true. + if (present(varinames)) then + name = adjustl(varinames(j)) + else + name = adjustl(tags(j)) + end if + if (keyword(1:1) == 'I') then + call mem_setptr(aint, trim(name), trim(this%origin)) + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, aint, tags(j)) + else + call mem_setptr(adbl, trim(name), trim(this%origin)) + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, adbl, tags(j)) + end if + exit tag_iter + end if + end do tag_iter + if (.not.lkeyword) then + write(errmsg,'(4x,a,a)')'ERROR. UNKNOWN GRIDDATA TAG: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end if + end do + ! + ! -- return + return + end subroutine get_block_data + +end module NumericalPackageModule + diff --git a/src/SimulationCreate.f90 b/src/SimulationCreate.f90 index 4e9939b89a0..aa25514ab14 100644 --- a/src/SimulationCreate.f90 +++ b/src/SimulationCreate.f90 @@ -1,684 +1,684 @@ -module SimulationCreateModule - - use KindModule, only: DP, I4B, write_kindinfo - use ConstantsModule, only: LINELENGTH, LENMODELNAME, LENBIGLINE, DZERO - use SimVariablesModule, only: simfile, simlstfile, iout - use GenericUtilitiesModule, only: sim_message, write_centered - use SimModule, only: ustop, store_error, count_errors, & - store_error_unit, maxerrors - use InputOutputModule, only: getunit, urword, openfile - use ArrayHandlersModule, only: expandarray, ifind - use BaseModelModule, only: BaseModelType - use BaseSolutionModule, only: BaseSolutionType, AddBaseSolutionToList, & - GetBaseSolutionFromList - use SolutionGroupModule, only: SolutionGroupType, AddSolutionGroupToList - use BaseExchangeModule, only: BaseExchangeType - use ListsModule, only: basesolutionlist, basemodellist, & - solutiongrouplist - use BaseModelModule, only: GetBaseModelFromList - use BlockParserModule, only: BlockParserType - - implicit none - private - public :: simulation_cr - public :: simulation_da - - integer(I4B) :: inunit = 0 - character(len=LENMODELNAME), allocatable, dimension(:) :: modelname - type(BlockParserType) :: parser - - contains - - subroutine simulation_cr() -! ****************************************************************************** -! Read the simulation name file and initialize the models, exchanges -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- local - character(len=LINELENGTH) :: line -! ------------------------------------------------------------------------------ - ! - ! -- initialize iout - iout = 0 - ! - ! -- Open simulation list file - iout = getunit() - call openfile(iout, 0, simlstfile, 'LIST', filstat_opt='REPLACE') - ! - ! -- write simlstfile to stdout - write(line,'(2(1x,A))') 'Writing simulation list file:', & - trim(adjustl(simlstfile)) - call sim_message(line) - call write_simulation_header() - ! - ! -- Read the simulation name file and create objects - call read_simulation_namefile(trim(adjustl(simfile))) - ! - ! -- Return - return - end subroutine simulation_cr - - subroutine simulation_da() -! ****************************************************************************** -! Deallocate simulation variables -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- variables - deallocate(modelname) - ! - ! -- Return - return - end subroutine simulation_da - - subroutine write_simulation_header() -! ****************************************************************************** -! Write header information for the simulation -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LENBIGLINE - use VersionModule, only: VERSION, MFVNAM, MFTITLE, FMTDISCLAIMER, & - IDEVELOPMODE - use CompilerVersion - use GenericUtilitiesModule, only: write_centered - ! -- dummy - ! -- local - character(len=LENBIGLINE) :: syscmd - character(len=80) :: compiler -! ------------------------------------------------------------------------------ - ! - ! -- Write header lines to simulation list file. - call write_centered('MODFLOW'//MFVNAM, 80, iunit=iout) - call write_centered(MFTITLE, 80, iunit=iout) - call write_centered('VERSION '//VERSION, 80, iunit=iout) - ! - ! -- Write if develop mode - if (IDEVELOPMODE == 1) then - call write_centered('***DEVELOP MODE***', 80, iunit=iout) - end if - ! - ! -- Write compiler version - call get_compiler(compiler) - call write_centered(' ', 80, iunit=iout) - call write_centered(trim(adjustl(compiler)), 80, iunit=iout) - ! - ! -- Write disclaimer - write(iout, FMTDISCLAIMER) - ! - ! -- Write the system command used to initiate simulation - call GET_COMMAND(syscmd) - write(iout, '(/,a,/,a)') 'System command used to initiate simulation:', & - trim(syscmd) - ! - ! -- Write precision of real variables - write(iout, '(/,a)') 'MODFLOW was compiled using uniform precision.' - call write_kindinfo(iout) - write(iout, *) - ! - ! -- Return - return - end subroutine write_simulation_header - - subroutine read_simulation_namefile(simfile) -! ****************************************************************************** -! Read the simulation name file and initialize the models, exchanges, -! solutions, solutions groups. Then add the exchanges to the appropriate -! solutions. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - character(len=*),intent(in) :: simfile - ! -- local - character(len=LINELENGTH) :: line - character(len=LINELENGTH) :: errmsg - class(BaseSolutionType), pointer :: sp - class(BaseModelType), pointer :: mp - integer(I4B) :: is, im -! ------------------------------------------------------------------------------ - ! - ! -- Open simulation name file - inunit = getunit() - call openfile(inunit, iout, simfile, 'NAM') - ! - ! -- write simfile name to stdout - write(line,'(2(1x,a))') 'Using Simulation name file:', simfile - call sim_message(line, skipafter=1) - ! - ! -- Initialize block parser - call parser%Initialize(inunit, iout) - ! - ! -- Process OPTIONS block in simfile - call options_create() - ! - ! -- Process TIMING block in simfile - call timing_create() - ! - ! -- Process MODELS block in simfile - call models_create() - ! - ! -- Process EXCHANGES block in simfile - call exchanges_create() - ! - ! -- Process SOLUTION_GROUPS blocks in simfile - call solution_groups_create() - ! - ! -- Go through each model and make sure that it has been assigned to - ! a solution. - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - if (mp%idsoln == 0) then - write(errmsg, '(a,a)') & - '****ERROR. Model was not assigned to a solution: ', mp%name - call store_error(errmsg) - endif - enddo - if (count_errors() > 0) then - call store_error_unit(inunit) - call ustop() - endif - ! - ! -- Close the input file - close(inunit) - ! - ! -- Go through each solution and assign exchanges accordingly - do is = 1, basesolutionlist%Count() - sp => GetBaseSolutionFromList(basesolutionlist, is) - call sp%slnassignexchanges() - enddo - ! - ! -- Return - return - end subroutine read_simulation_namefile - - subroutine options_create() -! ****************************************************************************** -! Set the simulation options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_set_print_option - use SimVariablesModule, only: isimcontinue, isimcheck - ! -- local - integer(I4B) :: ierr - logical :: isfound, endOfBlock - character(len=LINELENGTH) :: errmsg - character(len=LINELENGTH) :: keyword -! ------------------------------------------------------------------------------ - ! - ! -- Process OPTIONS block - call parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) - if (isfound) then - write(iout,'(/1x,a)')'READING SIMULATION OPTIONS' - do - call parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call parser%GetStringCaps(keyword) - select case (keyword) - case ('CONTINUE') - isimcontinue = 1 - write(iout, '(4x, a)') & - 'SIMULATION WILL CONTINUE EVEN IF THERE IS NONCONVERGENCE.' - case ('NOCHECK') - isimcheck = 0 - write(iout, '(4x, a)') & - 'MODEL DATA WILL NOT BE CHECKED FOR ERRORS.' - case ('MEMORY_PRINT_OPTION') - errmsg = '' - call parser%GetStringCaps(keyword) - call mem_set_print_option(iout, keyword, errmsg) - if (errmsg /= ' ') then - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - endif - case ('MAXERRORS') - maxerrors = parser%GetInteger() - write(iout, '(4x, a, i0)') & - 'MAXIMUM NUMBER OF ERRORS THAT WILL BE STORED IS ', maxerrors - case default - write(errmsg, '(4x,a,a)') & - '****ERROR. UNKNOWN SIMULATION OPTION: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - end select - end do - write(iout,'(1x,a)')'END OF SIMULATION OPTIONS' - end if - ! - ! -- return - return - end subroutine options_create - - subroutine timing_create() -! ****************************************************************************** -! Set the timing module to be used for the simulation -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use TdisModule, only: tdis_cr - ! -- dummy - ! -- local - integer(I4B) :: ierr - logical :: isfound, endOfBlock - character(len=LINELENGTH) :: errmsg - character(len=LINELENGTH) :: line, keyword - logical :: found_tdis -! ------------------------------------------------------------------------------ - ! - ! -- Initialize - found_tdis = .false. - ! - ! -- Process TIMING block - call parser%GetBlock('TIMING', isfound, ierr, & - supportOpenClose=.true.) - if (isfound) then - write(iout,'(/1x,a)')'READING SIMULATION TIMING' - do - call parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call parser%GetStringCaps(keyword) - select case (keyword) - case ('TDIS6') - found_tdis = .true. - call parser%GetString(line) - call tdis_cr(line) - case default - write(errmsg, '(4x,a,a)') & - '****ERROR. UNKNOWN SIMULATION TIMING: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - end select - end do - write(iout,'(1x,a)')'END OF SIMULATION TIMING' - else - call store_error('****ERROR. Did not find TIMING block in simulation'// & - ' control file.') - call parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- Ensure that TDIS was found - if(.not. found_tdis) then - call store_error('****ERROR. TDIS not found in TIMING block.') - call parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- return - return - end subroutine timing_create - - subroutine models_create() -! ****************************************************************************** -! Set the models to be used for the simulation -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use GwfModule, only: gwf_cr - use ConstantsModule, only: LENMODELNAME - ! -- dummy - ! -- local - integer(I4B) :: ierr - logical :: isfound, endOfBlock - integer(I4B) :: im - character(len=LINELENGTH) :: errmsg - character(len=LINELENGTH) :: keyword - character(len=LINELENGTH) :: fname, mname -! ------------------------------------------------------------------------------ - ! - ! -- Process MODELS block - call parser%GetBlock('MODELS', isfound, ierr, & - supportOpenClose=.true.) - if (isfound) then - write(iout,'(/1x,a)')'READING SIMULATION MODELS' - im = 0 - do - call parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call parser%GetStringCaps(keyword) - select case (keyword) - case ('GWF6') - call parser%GetString(fname) - call add_model(im, 'GWF6', mname) - call gwf_cr(fname, im, modelname(im)) - case default - write(errmsg, '(4x,a,a)') & - '****ERROR. UNKNOWN SIMULATION MODEL: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - end select - end do - write(iout,'(1x,a)')'END OF SIMULATION MODELS' - else - call store_error('****ERROR. Did not find MODELS block in simulation'// & - ' control file.') - call parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- return - return - end subroutine models_create - - subroutine exchanges_create() -! ****************************************************************************** -! Set the exchanges to be used for the simulation -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use GwfGwfExchangeModule, only: gwfexchange_create - ! -- dummy - ! -- local - integer(I4B) :: ierr - logical :: isfound, endOfBlock - integer(I4B) :: id - integer(I4B) :: m1 - integer(I4B) :: m2 - character(len=LINELENGTH) :: errmsg - character(len=LINELENGTH) :: keyword - character(len=LINELENGTH) :: fname, name1, name2 - ! -- formats - character(len=*), parameter :: fmtmerr = "('Error in simulation control ', & - &'file. Could not find model: ', a)" -! ------------------------------------------------------------------------------ - call parser%GetBlock('EXCHANGES', isfound, ierr, & - supportOpenClose=.true.) - if (isfound) then - write(iout,'(/1x,a)')'READING SIMULATION EXCHANGES' - id = 0 - do - call parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call parser%GetStringCaps(keyword) - select case (keyword) - case ('GWF6-GWF6') - id = id + 1 - ! - ! -- get filename - call parser%GetString(fname) - ! - ! -- get first modelname and then model id - call parser%GetStringCaps(name1) - m1 = ifind(modelname, name1) - if(m1 < 0) then - write(errmsg, fmtmerr) trim(name1) - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- get second modelname and then model id - call parser%GetStringCaps(name2) - m2 = ifind(modelname, name2) - if(m2 < 0) then - write(errmsg, fmtmerr) trim(name2) - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Create the exchange object. - write(iout, '(4x,a,i0,a,i0,a,i0)') 'GWF6-GWF6 exchange ', id, & - ' will be created to connect model ', m1, ' with model ', m2 - call gwfexchange_create(fname, id, m1, m2) - case default - write(errmsg, '(4x,a,a)') & - '****ERROR. UNKNOWN SIMULATION EXCHANGES: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - end select - end do - write(iout,'(1x,a)')'END OF SIMULATION EXCHANGES' - else - call store_error('****ERROR. Did not find EXCHANGES block in '// & - 'simulation control file.') - call parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- return - return - end subroutine exchanges_create - - subroutine solution_groups_create() -! ****************************************************************************** -! Set the solution_groups to be used for the simulation -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use SolutionGroupModule, only: SolutionGroupType, & - solutiongroup_create - use BaseSolutionModule, only: BaseSolutionType - use BaseModelModule, only: BaseModelType - use BaseExchangeModule, only: BaseExchangeType - use NumericalSolutionModule, only: solution_create - ! -- dummy - ! -- local - type(SolutionGroupType), pointer :: sgp - class(BaseSolutionType), pointer :: sp - class(BaseModelType), pointer :: mp - integer(I4B) :: ierr - logical :: isfound, endOfBlock - integer(I4B) :: isoln - integer(I4B) :: isgp - integer(I4B) :: isgpsoln - integer(I4B) :: sgid - integer(I4B) :: mid - character(len=LINELENGTH) :: errmsg - character(len=LENBIGLINE) :: keyword - character(len=LINELENGTH) :: fname, mname - ! -- formats - character(len=*), parameter :: fmterrmxiter = & - "('ERROR. MXITER IS SET TO ', i0, ' BUT THERE IS ONLY ONE SOLUTION', & - &' IN SOLUTION GROUP ', i0, '. SET MXITER TO 1 IN SIMULATION CONTROL', & - &' FILE.')" -! ------------------------------------------------------------------------------ - ! - ! -- isoln is the cumulative solution number, isgp is the cumulative - ! solution group number. - isoln = 0 - isgp = 0 - ! - !Read through the simulation name file and process each SOLUTION_GROUP - sgploop: do - ! - call parser%GetBlock('SOLUTIONGROUP', isfound, ierr, & - supportOpenClose=.true.) - if(ierr /= 0) exit sgploop - if (.not. isfound) exit sgploop - isgp = isgp + 1 - ! - ! -- Get the solutiongroup id and check that it is listed consecutively. - sgid = parser%GetInteger() - if(isgp /= sgid) then - write(errmsg, '(a)') 'Solution groups are not listed consecutively.' - call store_error(errmsg) - write(errmsg, '(a,i0,a,i0)' ) 'Found ', sgid, ' when looking for ',isgp - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- Create the solutiongroup and add it to the solutiongrouplist - call solutiongroup_create(sgp, sgid) - call AddSolutionGroupToList(solutiongrouplist, sgp) - ! - ! -- Begin processing the solution group - write(iout,'(/1x,a)')'READING SOLUTIONGROUP' - ! - ! -- Initialize isgpsoln to 0. isgpsoln is the solution counter for this - ! particular solution group. It goes from 1 to the number of solutions - ! in this group. - isgpsoln = 0 - do - call parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call parser%GetStringCaps(keyword) - select case (keyword) - ! - case ('MXITER') - sgp%mxiter = parser%GetInteger() - ! - case ('IMS6') - ! - ! -- Initialize and increment counters - isoln = isoln + 1 - isgpsoln = isgpsoln + 1 - ! - ! -- Create the solution, retrieve from the list, and add to sgp - call parser%GetString(fname) - call solution_create(fname, isoln) - sp => GetBaseSolutionFromList(basesolutionlist, isoln) - call sgp%add_solution(isoln, sp) - ! - ! -- Add all of the models that are listed on this line to - ! the current solution (sp) - do - ! - ! -- Set istart and istop to encompass model name. Exit this - ! loop if there are no more models. - call parser%GetStringCaps(mname) - if (mname == '') exit - ! - ! -- Find the model id, and then get model - mid = ifind(modelname, mname) - if(mid <= 0) then - write(errmsg, '(a,a)') 'Error. Invalid modelname: ', & - trim(mname) - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - endif - mp => GetBaseModelFromList(basemodellist, mid) - ! - ! -- Add the model to the solution - call sp%addmodel(mp) - mp%idsoln = isoln - ! - enddo - ! - case default - write(errmsg, '(4x,a,a)') & - '****ERROR. UNKNOWN SOLUTIONGROUP ENTRY: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - end select - end do - ! - ! -- Make sure there is a solution in this solution group - if(isgpsoln == 0) then - write(errmsg, '(4x,a,i0)') & - 'ERROR. THERE ARE NO SOLUTIONS FOR SOLUTION GROUP ', isgp - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- If there is only one solution then mxiter should be 1. - if(isgpsoln == 1 .and. sgp%mxiter > 1) then - write(errmsg, fmterrmxiter) sgp%mxiter, isgpsoln - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- todo: more error checking? - ! - write(iout,'(1x,a)')'END OF SIMULATION SOLUTIONGROUP' - ! - enddo sgploop - ! - ! -- Check and make sure at least one solution group was found - if(solutiongrouplist%Count() == 0) then - call store_error('ERROR. THERE ARE NO SOLUTION GROUPS.') - call parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- return - return - end subroutine solution_groups_create - - subroutine add_model(im, mtype, mname) -! ****************************************************************************** -! Add the model to the list of modelnames, check that the model name is valid. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - integer, intent(inout) :: im - character(len=*), intent(in) :: mtype - character(len=*), intent(inout) :: mname - ! -- local - integer :: ilen - integer :: i - character(len=LINELENGTH) :: errmsg -! ------------------------------------------------------------------------------ - im = im + 1 - call expandarray(modelname) - call parser%GetStringCaps(mname) - ilen = len_trim(mname) - if (ilen > LENMODELNAME) then - write(errmsg, '(4x,a,a)') & - 'ERROR. INVALID MODEL NAME: ', trim(mname) - call store_error(errmsg) - write(errmsg, '(4x,a,i0,a,i0)') & - 'NAME LENGTH OF ', ilen, ' EXCEEDS MAXIMUM LENGTH OF ', & - LENMODELNAME - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - endif - do i = 1, ilen - if (mname(i:i) == ' ') then - write(errmsg, '(4x,a,a)') & - 'ERROR. INVALID MODEL NAME: ', trim(mname) - call store_error(errmsg) - write(errmsg, '(4x,a)') & - 'MODEL NAME CANNOT HAVE SPACES WITHIN IT.' - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - endif - enddo - modelname(im) = mname - write(iout, '(4x,a,i0)') mtype // ' model ' // trim(mname) // & - ' will be created as model ', im - ! - ! -- return - return - end subroutine add_model - -end module SimulationCreateModule +module SimulationCreateModule + + use KindModule, only: DP, I4B, write_kindinfo + use ConstantsModule, only: LINELENGTH, LENMODELNAME, LENBIGLINE, DZERO + use SimVariablesModule, only: simfile, simlstfile, iout + use GenericUtilitiesModule, only: sim_message, write_centered + use SimModule, only: ustop, store_error, count_errors, & + store_error_unit, maxerrors + use InputOutputModule, only: getunit, urword, openfile + use ArrayHandlersModule, only: expandarray, ifind + use BaseModelModule, only: BaseModelType + use BaseSolutionModule, only: BaseSolutionType, AddBaseSolutionToList, & + GetBaseSolutionFromList + use SolutionGroupModule, only: SolutionGroupType, AddSolutionGroupToList + use BaseExchangeModule, only: BaseExchangeType + use ListsModule, only: basesolutionlist, basemodellist, & + solutiongrouplist + use BaseModelModule, only: GetBaseModelFromList + use BlockParserModule, only: BlockParserType + + implicit none + private + public :: simulation_cr + public :: simulation_da + + integer(I4B) :: inunit = 0 + character(len=LENMODELNAME), allocatable, dimension(:) :: modelname + type(BlockParserType) :: parser + + contains + + subroutine simulation_cr() +! ****************************************************************************** +! Read the simulation name file and initialize the models, exchanges +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- local + character(len=LINELENGTH) :: line +! ------------------------------------------------------------------------------ + ! + ! -- initialize iout + iout = 0 + ! + ! -- Open simulation list file + iout = getunit() + call openfile(iout, 0, simlstfile, 'LIST', filstat_opt='REPLACE') + ! + ! -- write simlstfile to stdout + write(line,'(2(1x,A))') 'Writing simulation list file:', & + trim(adjustl(simlstfile)) + call sim_message(line) + call write_simulation_header() + ! + ! -- Read the simulation name file and create objects + call read_simulation_namefile(trim(adjustl(simfile))) + ! + ! -- Return + return + end subroutine simulation_cr + + subroutine simulation_da() +! ****************************************************************************** +! Deallocate simulation variables +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- variables + deallocate(modelname) + ! + ! -- Return + return + end subroutine simulation_da + + subroutine write_simulation_header() +! ****************************************************************************** +! Write header information for the simulation +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LENBIGLINE + use VersionModule, only: VERSION, MFVNAM, MFTITLE, FMTDISCLAIMER, & + IDEVELOPMODE + use CompilerVersion + use GenericUtilitiesModule, only: write_centered + ! -- dummy + ! -- local + character(len=LENBIGLINE) :: syscmd + character(len=80) :: compiler +! ------------------------------------------------------------------------------ + ! + ! -- Write header lines to simulation list file. + call write_centered('MODFLOW'//MFVNAM, 80, iunit=iout) + call write_centered(MFTITLE, 80, iunit=iout) + call write_centered('VERSION '//VERSION, 80, iunit=iout) + ! + ! -- Write if develop mode + if (IDEVELOPMODE == 1) then + call write_centered('***DEVELOP MODE***', 80, iunit=iout) + end if + ! + ! -- Write compiler version + call get_compiler(compiler) + call write_centered(' ', 80, iunit=iout) + call write_centered(trim(adjustl(compiler)), 80, iunit=iout) + ! + ! -- Write disclaimer + write(iout, FMTDISCLAIMER) + ! + ! -- Write the system command used to initiate simulation + call GET_COMMAND(syscmd) + write(iout, '(/,a,/,a)') 'System command used to initiate simulation:', & + trim(syscmd) + ! + ! -- Write precision of real variables + write(iout, '(/,a)') 'MODFLOW was compiled using uniform precision.' + call write_kindinfo(iout) + write(iout, *) + ! + ! -- Return + return + end subroutine write_simulation_header + + subroutine read_simulation_namefile(simfile) +! ****************************************************************************** +! Read the simulation name file and initialize the models, exchanges, +! solutions, solutions groups. Then add the exchanges to the appropriate +! solutions. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + character(len=*),intent(in) :: simfile + ! -- local + character(len=LINELENGTH) :: line + character(len=LINELENGTH) :: errmsg + class(BaseSolutionType), pointer :: sp + class(BaseModelType), pointer :: mp + integer(I4B) :: is, im +! ------------------------------------------------------------------------------ + ! + ! -- Open simulation name file + inunit = getunit() + call openfile(inunit, iout, simfile, 'NAM') + ! + ! -- write simfile name to stdout + write(line,'(2(1x,a))') 'Using Simulation name file:', simfile + call sim_message(line, skipafter=1) + ! + ! -- Initialize block parser + call parser%Initialize(inunit, iout) + ! + ! -- Process OPTIONS block in simfile + call options_create() + ! + ! -- Process TIMING block in simfile + call timing_create() + ! + ! -- Process MODELS block in simfile + call models_create() + ! + ! -- Process EXCHANGES block in simfile + call exchanges_create() + ! + ! -- Process SOLUTION_GROUPS blocks in simfile + call solution_groups_create() + ! + ! -- Go through each model and make sure that it has been assigned to + ! a solution. + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + if (mp%idsoln == 0) then + write(errmsg, '(a,a)') & + '****ERROR. Model was not assigned to a solution: ', mp%name + call store_error(errmsg) + endif + enddo + if (count_errors() > 0) then + call store_error_unit(inunit) + call ustop() + endif + ! + ! -- Close the input file + close(inunit) + ! + ! -- Go through each solution and assign exchanges accordingly + do is = 1, basesolutionlist%Count() + sp => GetBaseSolutionFromList(basesolutionlist, is) + call sp%slnassignexchanges() + enddo + ! + ! -- Return + return + end subroutine read_simulation_namefile + + subroutine options_create() +! ****************************************************************************** +! Set the simulation options +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_set_print_option + use SimVariablesModule, only: isimcontinue, isimcheck + ! -- local + integer(I4B) :: ierr + logical :: isfound, endOfBlock + character(len=LINELENGTH) :: errmsg + character(len=LINELENGTH) :: keyword +! ------------------------------------------------------------------------------ + ! + ! -- Process OPTIONS block + call parser%GetBlock('OPTIONS', isfound, ierr, & + supportOpenClose=.true., blockRequired=.false.) + if (isfound) then + write(iout,'(/1x,a)')'READING SIMULATION OPTIONS' + do + call parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call parser%GetStringCaps(keyword) + select case (keyword) + case ('CONTINUE') + isimcontinue = 1 + write(iout, '(4x, a)') & + 'SIMULATION WILL CONTINUE EVEN IF THERE IS NONCONVERGENCE.' + case ('NOCHECK') + isimcheck = 0 + write(iout, '(4x, a)') & + 'MODEL DATA WILL NOT BE CHECKED FOR ERRORS.' + case ('MEMORY_PRINT_OPTION') + errmsg = '' + call parser%GetStringCaps(keyword) + call mem_set_print_option(iout, keyword, errmsg) + if (errmsg /= ' ') then + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + endif + case ('MAXERRORS') + maxerrors = parser%GetInteger() + write(iout, '(4x, a, i0)') & + 'MAXIMUM NUMBER OF ERRORS THAT WILL BE STORED IS ', maxerrors + case default + write(errmsg, '(4x,a,a)') & + '****ERROR. UNKNOWN SIMULATION OPTION: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + end select + end do + write(iout,'(1x,a)')'END OF SIMULATION OPTIONS' + end if + ! + ! -- return + return + end subroutine options_create + + subroutine timing_create() +! ****************************************************************************** +! Set the timing module to be used for the simulation +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use TdisModule, only: tdis_cr + ! -- dummy + ! -- local + integer(I4B) :: ierr + logical :: isfound, endOfBlock + character(len=LINELENGTH) :: errmsg + character(len=LINELENGTH) :: line, keyword + logical :: found_tdis +! ------------------------------------------------------------------------------ + ! + ! -- Initialize + found_tdis = .false. + ! + ! -- Process TIMING block + call parser%GetBlock('TIMING', isfound, ierr, & + supportOpenClose=.true.) + if (isfound) then + write(iout,'(/1x,a)')'READING SIMULATION TIMING' + do + call parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call parser%GetStringCaps(keyword) + select case (keyword) + case ('TDIS6') + found_tdis = .true. + call parser%GetString(line) + call tdis_cr(line) + case default + write(errmsg, '(4x,a,a)') & + '****ERROR. UNKNOWN SIMULATION TIMING: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + end select + end do + write(iout,'(1x,a)')'END OF SIMULATION TIMING' + else + call store_error('****ERROR. Did not find TIMING block in simulation'// & + ' control file.') + call parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- Ensure that TDIS was found + if(.not. found_tdis) then + call store_error('****ERROR. TDIS not found in TIMING block.') + call parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- return + return + end subroutine timing_create + + subroutine models_create() +! ****************************************************************************** +! Set the models to be used for the simulation +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use GwfModule, only: gwf_cr + use ConstantsModule, only: LENMODELNAME + ! -- dummy + ! -- local + integer(I4B) :: ierr + logical :: isfound, endOfBlock + integer(I4B) :: im + character(len=LINELENGTH) :: errmsg + character(len=LINELENGTH) :: keyword + character(len=LINELENGTH) :: fname, mname +! ------------------------------------------------------------------------------ + ! + ! -- Process MODELS block + call parser%GetBlock('MODELS', isfound, ierr, & + supportOpenClose=.true.) + if (isfound) then + write(iout,'(/1x,a)')'READING SIMULATION MODELS' + im = 0 + do + call parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call parser%GetStringCaps(keyword) + select case (keyword) + case ('GWF6') + call parser%GetString(fname) + call add_model(im, 'GWF6', mname) + call gwf_cr(fname, im, modelname(im)) + case default + write(errmsg, '(4x,a,a)') & + '****ERROR. UNKNOWN SIMULATION MODEL: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + end select + end do + write(iout,'(1x,a)')'END OF SIMULATION MODELS' + else + call store_error('****ERROR. Did not find MODELS block in simulation'// & + ' control file.') + call parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- return + return + end subroutine models_create + + subroutine exchanges_create() +! ****************************************************************************** +! Set the exchanges to be used for the simulation +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use GwfGwfExchangeModule, only: gwfexchange_create + ! -- dummy + ! -- local + integer(I4B) :: ierr + logical :: isfound, endOfBlock + integer(I4B) :: id + integer(I4B) :: m1 + integer(I4B) :: m2 + character(len=LINELENGTH) :: errmsg + character(len=LINELENGTH) :: keyword + character(len=LINELENGTH) :: fname, name1, name2 + ! -- formats + character(len=*), parameter :: fmtmerr = "('Error in simulation control ', & + &'file. Could not find model: ', a)" +! ------------------------------------------------------------------------------ + call parser%GetBlock('EXCHANGES', isfound, ierr, & + supportOpenClose=.true.) + if (isfound) then + write(iout,'(/1x,a)')'READING SIMULATION EXCHANGES' + id = 0 + do + call parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call parser%GetStringCaps(keyword) + select case (keyword) + case ('GWF6-GWF6') + id = id + 1 + ! + ! -- get filename + call parser%GetString(fname) + ! + ! -- get first modelname and then model id + call parser%GetStringCaps(name1) + m1 = ifind(modelname, name1) + if(m1 < 0) then + write(errmsg, fmtmerr) trim(name1) + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- get second modelname and then model id + call parser%GetStringCaps(name2) + m2 = ifind(modelname, name2) + if(m2 < 0) then + write(errmsg, fmtmerr) trim(name2) + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Create the exchange object. + write(iout, '(4x,a,i0,a,i0,a,i0)') 'GWF6-GWF6 exchange ', id, & + ' will be created to connect model ', m1, ' with model ', m2 + call gwfexchange_create(fname, id, m1, m2) + case default + write(errmsg, '(4x,a,a)') & + '****ERROR. UNKNOWN SIMULATION EXCHANGES: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + end select + end do + write(iout,'(1x,a)')'END OF SIMULATION EXCHANGES' + else + call store_error('****ERROR. Did not find EXCHANGES block in '// & + 'simulation control file.') + call parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- return + return + end subroutine exchanges_create + + subroutine solution_groups_create() +! ****************************************************************************** +! Set the solution_groups to be used for the simulation +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use SolutionGroupModule, only: SolutionGroupType, & + solutiongroup_create + use BaseSolutionModule, only: BaseSolutionType + use BaseModelModule, only: BaseModelType + use BaseExchangeModule, only: BaseExchangeType + use NumericalSolutionModule, only: solution_create + ! -- dummy + ! -- local + type(SolutionGroupType), pointer :: sgp + class(BaseSolutionType), pointer :: sp + class(BaseModelType), pointer :: mp + integer(I4B) :: ierr + logical :: isfound, endOfBlock + integer(I4B) :: isoln + integer(I4B) :: isgp + integer(I4B) :: isgpsoln + integer(I4B) :: sgid + integer(I4B) :: mid + character(len=LINELENGTH) :: errmsg + character(len=LENBIGLINE) :: keyword + character(len=LINELENGTH) :: fname, mname + ! -- formats + character(len=*), parameter :: fmterrmxiter = & + "('ERROR. MXITER IS SET TO ', i0, ' BUT THERE IS ONLY ONE SOLUTION', & + &' IN SOLUTION GROUP ', i0, '. SET MXITER TO 1 IN SIMULATION CONTROL', & + &' FILE.')" +! ------------------------------------------------------------------------------ + ! + ! -- isoln is the cumulative solution number, isgp is the cumulative + ! solution group number. + isoln = 0 + isgp = 0 + ! + !Read through the simulation name file and process each SOLUTION_GROUP + sgploop: do + ! + call parser%GetBlock('SOLUTIONGROUP', isfound, ierr, & + supportOpenClose=.true.) + if(ierr /= 0) exit sgploop + if (.not. isfound) exit sgploop + isgp = isgp + 1 + ! + ! -- Get the solutiongroup id and check that it is listed consecutively. + sgid = parser%GetInteger() + if(isgp /= sgid) then + write(errmsg, '(a)') 'Solution groups are not listed consecutively.' + call store_error(errmsg) + write(errmsg, '(a,i0,a,i0)' ) 'Found ', sgid, ' when looking for ',isgp + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- Create the solutiongroup and add it to the solutiongrouplist + call solutiongroup_create(sgp, sgid) + call AddSolutionGroupToList(solutiongrouplist, sgp) + ! + ! -- Begin processing the solution group + write(iout,'(/1x,a)')'READING SOLUTIONGROUP' + ! + ! -- Initialize isgpsoln to 0. isgpsoln is the solution counter for this + ! particular solution group. It goes from 1 to the number of solutions + ! in this group. + isgpsoln = 0 + do + call parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call parser%GetStringCaps(keyword) + select case (keyword) + ! + case ('MXITER') + sgp%mxiter = parser%GetInteger() + ! + case ('IMS6') + ! + ! -- Initialize and increment counters + isoln = isoln + 1 + isgpsoln = isgpsoln + 1 + ! + ! -- Create the solution, retrieve from the list, and add to sgp + call parser%GetString(fname) + call solution_create(fname, isoln) + sp => GetBaseSolutionFromList(basesolutionlist, isoln) + call sgp%add_solution(isoln, sp) + ! + ! -- Add all of the models that are listed on this line to + ! the current solution (sp) + do + ! + ! -- Set istart and istop to encompass model name. Exit this + ! loop if there are no more models. + call parser%GetStringCaps(mname) + if (mname == '') exit + ! + ! -- Find the model id, and then get model + mid = ifind(modelname, mname) + if(mid <= 0) then + write(errmsg, '(a,a)') 'Error. Invalid modelname: ', & + trim(mname) + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + endif + mp => GetBaseModelFromList(basemodellist, mid) + ! + ! -- Add the model to the solution + call sp%addmodel(mp) + mp%idsoln = isoln + ! + enddo + ! + case default + write(errmsg, '(4x,a,a)') & + '****ERROR. UNKNOWN SOLUTIONGROUP ENTRY: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + end select + end do + ! + ! -- Make sure there is a solution in this solution group + if(isgpsoln == 0) then + write(errmsg, '(4x,a,i0)') & + 'ERROR. THERE ARE NO SOLUTIONS FOR SOLUTION GROUP ', isgp + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- If there is only one solution then mxiter should be 1. + if(isgpsoln == 1 .and. sgp%mxiter > 1) then + write(errmsg, fmterrmxiter) sgp%mxiter, isgpsoln + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- todo: more error checking? + ! + write(iout,'(1x,a)')'END OF SIMULATION SOLUTIONGROUP' + ! + enddo sgploop + ! + ! -- Check and make sure at least one solution group was found + if(solutiongrouplist%Count() == 0) then + call store_error('ERROR. THERE ARE NO SOLUTION GROUPS.') + call parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- return + return + end subroutine solution_groups_create + + subroutine add_model(im, mtype, mname) +! ****************************************************************************** +! Add the model to the list of modelnames, check that the model name is valid. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + integer, intent(inout) :: im + character(len=*), intent(in) :: mtype + character(len=*), intent(inout) :: mname + ! -- local + integer :: ilen + integer :: i + character(len=LINELENGTH) :: errmsg +! ------------------------------------------------------------------------------ + im = im + 1 + call expandarray(modelname) + call parser%GetStringCaps(mname) + ilen = len_trim(mname) + if (ilen > LENMODELNAME) then + write(errmsg, '(4x,a,a)') & + 'ERROR. INVALID MODEL NAME: ', trim(mname) + call store_error(errmsg) + write(errmsg, '(4x,a,i0,a,i0)') & + 'NAME LENGTH OF ', ilen, ' EXCEEDS MAXIMUM LENGTH OF ', & + LENMODELNAME + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + endif + do i = 1, ilen + if (mname(i:i) == ' ') then + write(errmsg, '(4x,a,a)') & + 'ERROR. INVALID MODEL NAME: ', trim(mname) + call store_error(errmsg) + write(errmsg, '(4x,a)') & + 'MODEL NAME CANNOT HAVE SPACES WITHIN IT.' + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + endif + enddo + modelname(im) = mname + write(iout, '(4x,a,i0)') mtype // ' model ' // trim(mname) // & + ' will be created as model ', im + ! + ! -- return + return + end subroutine add_model + +end module SimulationCreateModule diff --git a/src/Solution/NumericalSolution.f90 b/src/Solution/NumericalSolution.f90 index d0d6f0a0ddc..de6d8d35b5d 100644 --- a/src/Solution/NumericalSolution.f90 +++ b/src/Solution/NumericalSolution.f90 @@ -1,2953 +1,2953 @@ -! This is the numerical solution module. - -module NumericalSolutionModule - use KindModule, only: DP, I4B - use TimerModule, only: code_timer - use ConstantsModule, only: LINELENGTH, LENSOLUTIONNAME, LENPAKLOC, & - DPREC, DZERO, DEM20, DEM15, DEM6, & - DEM4, DEM3, DEM2, DEM1, DHALF, & - DONE, DTHREE, DEP6, DEP20, DNODATA, & - TABLEFT, TABRIGHT - use TableModule, only: TableType, table_cr - use GenericUtilitiesModule, only: IS_SAME, sim_message, stop_with_error - use VersionModule, only: IDEVELOPMODE - use BaseModelModule, only: BaseModelType - use BaseSolutionModule, only: BaseSolutionType, AddBaseSolutionToList - use ListModule, only: ListType - use ListsModule, only: basesolutionlist - use NumericalModelModule, only: NumericalModelType, & - AddNumericalModelToList, & - GetNumericalModelFromList - use NumericalExchangeModule, only: NumericalExchangeType, & - AddNumericalExchangeToList, & - GetNumericalExchangeFromList - use SparseModule, only: sparsematrix - use SimVariablesModule, only: iout - use BlockParserModule, only: BlockParserType - use IMSLinearModule - - implicit none - private - - public :: solution_create - - ! expose for use in the bmi++ - public :: NumericalSolutionType - public :: GetNumericalSolutionFromList - public :: prepareIteration, doIteration, finalizeIteration - - type, extends(BaseSolutionType) :: NumericalSolutionType - character(len=LINELENGTH) :: fname - type(ListType) :: modellist - type(ListType) :: exchangelist - integer(I4B), pointer :: id - integer(I4B), pointer :: iu - real(DP), pointer :: ttform - real(DP), pointer :: ttsoln - integer(I4B), pointer :: neq => NULL() - integer(I4B), pointer :: nja => NULL() - integer(I4B), dimension(:), pointer, contiguous :: ia => NULL() - integer(I4B), dimension(:), pointer, contiguous :: ja => NULL() - real(DP), dimension(:), pointer, contiguous :: amat => NULL() - real(DP), dimension(:), pointer, contiguous :: rhs => NULL() - real(DP), dimension(:), pointer, contiguous :: x => NULL() - integer(I4B), dimension(:), pointer, contiguous :: active => NULL() - real(DP), dimension(:), pointer, contiguous :: xtemp => NULL() - type(BlockParserType) :: parser - ! - ! -- sparse matrix data - real(DP), pointer :: theta => NULL() - real(DP), pointer :: akappa => NULL() - real(DP), pointer :: gamma => NULL() - real(DP), pointer :: amomentum => NULL() - real(DP), pointer :: breduc => NULL() - real(DP), pointer :: btol => NULL() - real(DP), pointer :: res_lim => NULL() - real(DP), pointer :: hclose => NULL() - real(DP), pointer :: hiclose => NULL() - real(DP), pointer :: bigchold => NULL() - real(DP), pointer :: bigch => NULL() - real(DP), pointer :: relaxold => NULL() - real(DP), pointer :: res_prev => NULL() - real(DP), pointer :: res_new => NULL() - real(DP), pointer :: res_in => NULL() - integer(I4B), pointer :: ibcount => NULL() - integer(I4B), pointer :: icnvg => NULL() - integer(I4B), pointer :: itertot => NULL() ! total nr. of linear solves per call to sln_ca - integer(I4B), pointer :: mxiter => NULL() - integer(I4B), pointer :: linmeth => NULL() - integer(I4B), pointer :: nonmeth => NULL() - integer(I4B), pointer :: numtrack => NULL() - integer(I4B), pointer :: iprims => NULL() - integer(I4B), pointer :: ibflag => NULL() - integer(I4B), dimension(:,:), pointer, contiguous :: lrch => NULL() - real(DP), dimension(:), pointer, contiguous :: hncg => NULL() - real(DP), dimension(:), pointer, contiguous :: dxold => NULL() - real(DP), dimension(:), pointer, contiguous :: deold => NULL() - real(DP), dimension(:), pointer, contiguous :: wsave => NULL() - real(DP), dimension(:), pointer, contiguous :: hchold => NULL() - ! - ! -- convergence summary information - character(len=31), dimension(:), pointer, contiguous :: caccel => NULL() - integer(I4B), pointer :: icsvout => NULL() - integer(I4B), pointer :: nitermax => NULL() - integer(I4B), pointer :: nitercnt => NULL() - integer(I4B), pointer :: convnmod => NULL() - integer(I4B), dimension(:), pointer, contiguous :: convmodstart => NULL() - integer(I4B), dimension(:), pointer, contiguous :: locdv => NULL() - integer(I4B), dimension(:), pointer, contiguous :: locdr => NULL() - integer(I4B), dimension(:), pointer, contiguous :: itinner => NULL() - integer(I4B), pointer, dimension(:,:), contiguous :: convlocdv => NULL() - integer(I4B), pointer, dimension(:,:), contiguous :: convlocdr => NULL() - real(DP), dimension(:), pointer, contiguous :: dvmax => NULL() - real(DP), dimension(:), pointer, contiguous :: drmax => NULL() - real(DP), pointer, dimension(:,:), contiguous :: convdvmax => NULL() - real(DP), pointer, dimension(:,:), contiguous :: convdrmax => NULL() - ! - ! -- pseudo-transient continuation - integer(I4B), pointer :: iallowptc => NULL() - integer(I4B), pointer :: iptcopt => NULL() - integer(I4B), pointer :: iptcout => NULL() - real(DP), pointer :: l2norm0 => NULL() - real(DP), pointer :: ptcfact => NULL() - real(DP), pointer :: ptcdel => NULL() - real(DP), pointer :: ptcdel0 => NULL() - real(DP), pointer :: ptcexp => NULL() - real(DP), pointer :: ptcthresh => NULL() - real(DP), pointer :: ptcrat => NULL() - ! - ! -- linear accelerator storage - type(IMSLINEAR_DATA), POINTER :: imslinear => NULL() - ! - ! -- sparse object - type(sparsematrix) :: sparse - ! - ! -- table objects - type(TableType), pointer :: innertab => null() - type(TableType), pointer :: outertab => null() - - contains - procedure :: sln_df - procedure :: sln_ar - procedure :: sln_rp - procedure :: sln_ot - procedure :: sln_ca - procedure :: sln_fp - procedure :: sln_da - procedure :: addmodel - procedure :: addexchange - procedure :: slnassignexchanges - procedure :: save - - procedure, private :: sln_connect - procedure, private :: sln_reset - procedure, private :: sln_ls - procedure, private :: sln_setouter - procedure, private :: sln_backtracking - procedure, private :: sln_backtracking_xupdate - procedure, private :: sln_l2norm - procedure, private :: sln_maxval - procedure, private :: sln_calcdx - procedure, private :: sln_underrelax - procedure, private :: sln_outer_check - procedure, private :: sln_get_loc - procedure, private :: sln_get_nodeu - procedure, private :: allocate_scalars - procedure, private :: allocate_arrays - procedure, private :: convergence_summary - procedure, private :: csv_convergence_summary - - ! for BMI refactoring: - procedure, public :: prepareIteration - procedure, public :: doIteration - procedure, public :: finalizeIteration - procedure, private :: writeCSVHeader - procedure, private :: writePTCInfoToFile - procedure, private :: advanceSolution - - end type NumericalSolutionType - -contains - - subroutine solution_create(filename, id) -! ****************************************************************************** -! solution_create -- Create a New Solution -! Using the data in filename, assign this new solution an id number and store -! the solution in the basesolutionlist. -! Subroutine: (1) allocate solution and assign id and name -! (2) open the filename for later reading -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimVariablesModule, only: iout - use InputOutputModule, only: getunit, openfile - ! -- dummy - character(len=*),intent(in) :: filename - integer(I4B),intent(in) :: id - ! -- local - integer(I4B) :: inunit - type(NumericalSolutionType), pointer :: solution => null() - class(BaseSolutionType), pointer :: solbase => null() - character(len=LENSOLUTIONNAME) :: solutionname -! ------------------------------------------------------------------------------ - ! - ! -- Create a new solution and add it to the basesolutionlist container - allocate(solution) - solbase => solution - write(solutionname,'(a, i0)') 'SLN_', id - call solution%allocate_scalars(solutionname) - call AddBaseSolutionToList(basesolutionlist, solbase) - ! - solution%id = id - ! - ! -- Open solution input file for reading later after problem size is known - ! Check to see if the file is already opened, which can happen when - ! running in single model mode - inquire(file=filename, number=inunit) - - if(inunit < 0) inunit = getunit() - solution%iu = inunit - write(iout,'(/a,a)') ' Creating solution: ', solution%name - call openfile(solution%iu, iout, filename, 'IMS') - ! - ! -- Initialize block parser - call solution%parser%Initialize(solution%iu, iout) - ! - ! -- return - return - end subroutine solution_create - - subroutine allocate_scalars(this, solutionname) -! ****************************************************************************** -! allocate_scalars -- Allocate scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(NumericalSolutionType) :: this - character(len=*), intent(in) :: solutionname - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- set value for solution name, which is a member of the base solution - this%name = solutionname - ! - ! -- allocate scalars - call mem_allocate(this%id, 'ID', solutionname) - call mem_allocate(this%iu, 'IU', solutionname) - call mem_allocate(this%ttform, 'TTFORM', solutionname) - call mem_allocate(this%ttsoln, 'TTSOLN', solutionname) - call mem_allocate(this%neq, 'NEQ', solutionname) - call mem_allocate(this%nja, 'NJA', solutionname) - call mem_allocate(this%hclose, 'HCLOSE', solutionname) - call mem_allocate(this%hiclose, 'HICLOSE', solutionname) - call mem_allocate(this%bigchold, 'BIGCHOLD', solutionname) - call mem_allocate(this%bigch, 'BIGCH', solutionname) - call mem_allocate(this%relaxold, 'RELAXOLD', solutionname) - call mem_allocate(this%res_prev, 'RES_PREV', solutionname) - call mem_allocate(this%res_new, 'RES_NEW', solutionname) - call mem_allocate(this%res_in, 'RES_IN', solutionname) - call mem_allocate(this%ibcount, 'IBCOUNT', solutionname) - call mem_allocate(this%icnvg, 'ICNVG', solutionname) - call mem_allocate(this%itertot, 'ITERTOT', solutionname) - call mem_allocate(this%mxiter, 'MXITER', solutionname) - call mem_allocate(this%linmeth, 'LINMETH', solutionname) - call mem_allocate(this%nonmeth, 'NONMETH', solutionname) - call mem_allocate(this%iprims, 'IPRIMS', solutionname) - call mem_allocate(this%theta, 'THETA', solutionname) - call mem_allocate(this%akappa, 'AKAPPA', solutionname) - call mem_allocate(this%gamma, 'GAMMA', solutionname) - call mem_allocate(this%amomentum, 'AMOMENTUM', solutionname) - call mem_allocate(this%breduc, 'BREDUC', solutionname) - call mem_allocate(this%btol, 'BTOL', solutionname) - call mem_allocate(this%res_lim, 'RES_LIM', solutionname) - call mem_allocate(this%numtrack, 'NUMTRACK', solutionname) - call mem_allocate(this%ibflag, 'IBFLAG', solutionname) - call mem_allocate(this%icsvout, 'ICSVOUT', solutionname) - call mem_allocate(this%nitermax, 'NITERMAX', solutionname) - call mem_allocate(this%nitercnt, 'NITERCNT', solutionname) - call mem_allocate(this%convnmod, 'CONVNMOD', solutionname) - call mem_allocate(this%iallowptc, 'IALLOWPTC', solutionname) - call mem_allocate(this%iptcopt, 'IPTCOPT', solutionname) - call mem_allocate(this%iptcout, 'IPTCOUT', solutionname) - call mem_allocate(this%l2norm0, 'L2NORM0', solutionname) - call mem_allocate(this%ptcfact, 'PTCFACT', solutionname) - call mem_allocate(this%ptcdel, 'PTCDEL', solutionname) - call mem_allocate(this%ptcdel0, 'PTCDEL0', solutionname) - call mem_allocate(this%ptcexp, 'PTCEXP', solutionname) - call mem_allocate(this%ptcthresh, 'PTCTHRESH', solutionname) - call mem_allocate(this%ptcrat, 'PTCRAT', solutionname) - ! - ! -- initialize - this%id = 0 - this%iu = 0 - this%ttform = DZERO - this%ttsoln = DZERO - this%neq = 0 - this%nja = 0 - this%hclose = DZERO - this%hiclose = DZERO - this%bigchold = DZERO - this%bigch = DZERO - this%relaxold = DZERO - this%res_prev = DZERO - this%res_in = DZERO - this%ibcount = 0 - this%icnvg = 0 - this%itertot = 0 - this%mxiter = 0 - this%linmeth = 1 - this%nonmeth = 0 - this%iprims = 0 - this%theta = DZERO - this%akappa = DZERO - this%gamma = DZERO - this%amomentum = DZERO - this%breduc = DZERO - this%btol = 0 - this%res_lim = DZERO - this%numtrack = 0 - this%ibflag = 0 - this%icsvout = 0 - this%nitermax = 0 - this%nitercnt = 0 - this%convnmod = 0 - this%iallowptc = 1 - this%iptcopt = 0 - this%iptcout = 0 - this%l2norm0 = DZERO - this%ptcfact = dem1 - this%ptcdel = DZERO - this%ptcdel0 = DZERO - this%ptcexp = done - this%ptcthresh = DEM3 - this%ptcrat = DZERO - ! - ! -- return - return - end subroutine allocate_scalars - - subroutine allocate_arrays(this) -! ****************************************************************************** -! allocate_arrays -- Allocate arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(NumericalSolutionType) :: this - ! -- local - class(NumericalModelType), pointer :: mp - integer(I4B) :: i - integer(I4B) :: ieq -! ------------------------------------------------------------------------------ - ! - ! -- initialize the number of models in the solution - this%convnmod = this%modellist%Count() - ! - ! -- allocate arrays - call mem_allocate(this%ia, this%neq + 1, 'IA', this%name) - call mem_allocate(this%x, this%neq, 'X', this%name) - call mem_allocate(this%rhs, this%neq, 'RHS', this%name) - call mem_allocate(this%active, this%neq, 'IACTIVE', this%name) - call mem_allocate(this%xtemp, this%neq, 'XTEMP', this%name) - call mem_allocate(this%dxold, this%neq, 'DXOLD', this%name) - call mem_allocate(this%hncg, 0, 'HNCG', this%name) - call mem_allocate(this%lrch, 3, 0, 'LRCH', this%name) - call mem_allocate(this%wsave, 0, 'WSAVE', this%name) - call mem_allocate(this%hchold, 0, 'HCHOLD', this%name) - call mem_allocate(this%deold, 0, 'DEOLD', this%name) - call mem_allocate(this%convmodstart, this%convnmod+1, 'CONVMODSTART', this%name) - call mem_allocate(this%locdv, this%convnmod, 'LOCDV', this%name) - call mem_allocate(this%locdr, this%convnmod, 'LOCDR', this%name) - call mem_allocate(this%itinner, 0, 'ITINNER', this%name) - call mem_allocate(this%convlocdv, this%convnmod, 0, 'CONVLOCDV', this%name) - call mem_allocate(this%convlocdr, this%convnmod, 0, 'CONVLOCDR', this%name) - call mem_allocate(this%dvmax, this%convnmod, 'DVMAX', this%name) - call mem_allocate(this%drmax, this%convnmod, 'DRMAX', this%name) - call mem_allocate(this%convdvmax, this%convnmod, 0, 'CONVDVMAX', this%name) - call mem_allocate(this%convdrmax, this%convnmod, 0, 'CONVDRMAX', this%name) - ! - ! -- initialize allocated arrays - do i = 1, this%neq - this%x(i) = DZERO - this%xtemp(i) = DZERO - this%dxold(i) = DZERO - this%active(i) = 1 !default is active - enddo - ! - ! -- initialize convmodstart - ieq = 1 - this%convmodstart(1) = ieq - do i = 1, this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, i) - ieq = ieq + mp%neq - this%convmodstart(i+1) = ieq - end do - ! - ! -- return - return - end subroutine allocate_arrays - - subroutine sln_df(this) -! ****************************************************************************** -! sln_df -- Define the solution -! Must be called after the models and exchanges have been added to solution. -! Subroutine: (1) Allocate neq and nja -! (2) Assign model offsets and solution ids -! (3) Allocate and initialize the solution arrays -! (4) Point each model's x and rhs arrays -! (5) Initialize the sparsematrix instance -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(NumericalSolutionType) :: this - ! -- local - class(NumericalModelType), pointer :: mp - integer(I4B) :: i - integer(I4B), allocatable, dimension(:) :: rowmaxnnz -! ------------------------------------------------------------------------------ - ! - ! -- calculate and set offsets - do i = 1, this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, i) - call mp%set_idsoln(this%id) - call mp%set_moffset(this%neq) - this%neq = this%neq + mp%neq - enddo - ! - ! -- Allocate and initialize solution arrays - call this%allocate_arrays() - ! - ! -- Go through each model and point x, ibound, and rhs to solution - do i = 1, this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, i) - call mp%set_xptr(this%x) - call mp%set_rhsptr(this%rhs) - call mp%set_iboundptr(this%active) - enddo - ! - ! -- Create the sparsematrix instance - allocate(rowmaxnnz(this%neq)) - do i=1,this%neq - rowmaxnnz(i)=4 - enddo - call this%sparse%init(this%neq, this%neq, rowmaxnnz) - deallocate(rowmaxnnz) - ! - ! -- Assign connections, fill ia/ja, map connections - call this%sln_connect() - ! - ! -- return - return - end subroutine sln_df - - subroutine sln_ar(this) -! ****************************************************************************** -! sln_ar -- Allocate and Read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_reallocate - use SimVariablesModule, only: iout - use SimModule, only: ustop, store_error, count_errors - use InputOutputModule, only: getunit, openfile - ! -- dummy - class(NumericalSolutionType) :: this - ! -- local - class(NumericalModelType), pointer :: mp - class(NumericalExchangeType), pointer :: cp - integer(I4B) :: i - integer(I4B) :: im - integer(I4B) :: ifdparam, mxvl, npp - integer(I4B) :: imslinear - character(len=linelength) :: errmsg, keyword, fname - character(len=linelength) :: msg - integer(I4B) :: isymflg=1 - integer(I4B) :: ierr - logical :: isfound, endOfBlock - integer(I4B) :: ival - real(DP) :: rval - character(len=*),parameter :: fmtcsvout = & - "(4x, 'CSV OUTPUT WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" - character(len=*),parameter :: fmtptcout = & - "(4x, 'PTC OUTPUT WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" - character(len=*), parameter :: fmterrasym = & - "(a,' **',a,'** PRODUCES AN ASYMMETRIC COEFFICIENT MATRIX, BUT THE & - &CONJUGATE GRADIENT METHOD WAS SELECTED. USE BICGSTAB INSTEAD. ')" -! ------------------------------------------------------------------------------ - ! - ! identify package and initialize. - WRITE(IOUT,1) this%iu -00001 FORMAT(1X,/1X,'IMS -- ITERATIVE MODEL SOLUTION PACKAGE, VERSION 6', & - & ', 4/28/2017',/,9X,'INPUT READ FROM UNIT',I5) - ! - ! -- initialize - i = 1 - ifdparam = 1 - npp = 0 - mxvl = 0 - ! - ! -- get options block - call this%parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) - ! - ! -- parse options block if detected - if (isfound) then - write(iout,'(/1x,a)')'PROCESSING IMS OPTIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('PRINT_OPTION') - call this%parser%GetStringCaps(keyword) - if (keyword.eq.'NONE') then - this%iprims = 0 - else if (keyword.eq.'SUMMARY') then - this%iprims = 1 - else if (keyword.eq.'ALL') then - this%iprims = 2 - else - write(errmsg,'(4x,a,a)') 'IMS sln_ar: UNKNOWN IMS PRINT OPTION: ', & - trim(keyword) - call store_error(errmsg) - end if - case ('COMPLEXITY') - call this%parser%GetStringCaps(keyword) - if (keyword.eq.'SIMPLE') then - ifdparam = 1 - WRITE(IOUT,21) - else if (keyword.eq.'MODERATE') then - ifdparam = 2 - WRITE(IOUT,23) - else if (keyword.eq.'COMPLEX') then - ifdparam = 3 - WRITE(IOUT,25) - else - write(errmsg,'(4x,a,a)') & - 'IMS sln_ar: UNKNOWN IMS COMPLEXITY OPTION: ', & - trim(keyword) - call store_error(errmsg) - end if - case ('CSV_OUTPUT') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%icsvout = getunit() - call openfile(this%icsvout, iout, fname, 'CSV_OUTPUT', & - filstat_opt='REPLACE') - write(iout,fmtcsvout) trim(fname), this%icsvout - else - write(errmsg,'(4x,a)') 'IMS sln_ar: OPTIONAL CSV_OUTPUT ' // & - 'KEYWORD MUST BE FOLLOWED BY FILEOUT' - call store_error(errmsg) - end if - case ('NO_PTC') - call this%parser%GetStringCaps(keyword) - select case(keyword) - case ('ALL') - ival = 0 - msg = 'ALL' - case ('FIRST') - ival = -1 - msg = 'THE FIRST' - case default - ival = 0 - msg = 'ALL' - end select - this%iallowptc = ival - write(IOUT,'(1x,A)') 'PSEUDO-TRANSIENT CONTINUATION DISABLED FOR' // & - ' ' // trim(adjustl(msg)) // ' STRESS-PERIOD(S)' - ! - ! -- right now these 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_PTC') - call this%parser%DevOpt() - this%iallowptc = 1 - write(IOUT,'(1x,A)') 'PSEUDO-TRANSIENT CONTINUATION ENABLED' - case('DEV_PTC_OUTPUT') - call this%parser%DevOpt() - this%iallowptc = 1 - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%iptcout = getunit() - call openfile(this%iptcout, iout, fname, 'PTC-OUT', & - filstat_opt='REPLACE') - write(iout,fmtptcout) trim(fname), this%iptcout - else - write(errmsg,'(4x,a)') 'IMS sln_ar: OPTIONAL PTC_OUTPUT ' // & - 'KEYWORD MUST BE FOLLOWED BY FILEOUT' - call store_error(errmsg) - end if - case ('DEV_PTC_OPTION') - call this%parser%DevOpt() - this%iallowptc = 1 - this%iptcopt = 1 - write(IOUT,'(1x,A)') & - 'PSEUDO-TRANSIENT CONTINUATION USES BNORM AND L2NORM TO ' // & - 'SET INITIAL VALUE' - case ('DEV_PTC_EXPONENT') - call this%parser%DevOpt() - rval = this%parser%GetDouble() - if (rval < DZERO) then - write(errmsg,'(4x,a)') 'IMS sln_ar: PTC_EXPONENT MUST BE > 0.' - call store_error(errmsg) - else - this%iallowptc = 1 - this%ptcexp = rval - write(IOUT,'(1x,A,1x,g15.7)') & - 'PSEUDO-TRANSIENT CONTINUATION EXPONENT', this%ptcexp - end if - case ('DEV_PTC_THRESHOLD') - call this%parser%DevOpt() - rval = this%parser%GetDouble() - if (rval < DZERO) then - write(errmsg,'(4x,a)')'IMS sln_ar: PTC_THRESHOLD MUST BE > 0.' - call store_error(errmsg) - else - this%iallowptc = 1 - this%ptcthresh = rval - write(IOUT,'(1x,A,1x,g15.7)') & - 'PSEUDO-TRANSIENT CONTINUATION THRESHOLD', this%ptcthresh - end if - case ('DEV_PTC_DEL0') - call this%parser%DevOpt() - rval = this%parser%GetDouble() - if (rval < DZERO) then - write(errmsg,'(4x,a)')'IMS sln_ar: PTC_DEL0 MUST BE > 0.' - call store_error(errmsg) - else - this%iallowptc = 1 - this%ptcdel0 = rval - write(IOUT,'(1x,A,1x,g15.7)') & - 'PSEUDO-TRANSIENT CONTINUATION INITIAL TIMESTEP', this%ptcdel0 - end if - case default - write(errmsg,'(4x,a,a)') 'IMS sln_ar: UNKNOWN IMS OPTION: ', & - trim(keyword) - call store_error(errmsg) - end select - end do - write(iout,'(1x,a)')'END OF IMS OPTIONS' - else - write(iout,'(1x,a)')'NO IMS OPTION BLOCK DETECTED.' - end if - -00021 FORMAT(1X,'SIMPLE OPTION:',/, & - & 1X,'DEFAULT SOLVER INPUT VALUES FOR FAST SOLUTIONS') -00023 FORMAT(1X,'MODERATE OPTION:',/,1X,'DEFAULT SOLVER', & - & ' INPUT VALUES REFLECT MODERETELY NONLINEAR MODEL') -00025 FORMAT(1X,'COMPLEX OPTION:',/,1X,'DEFAULT SOLVER', & - & ' INPUT VALUES REFLECT STRONGLY NONLINEAR MODEL') - - !-------READ NONLINEAR ITERATION PARAMETERS AND LINEAR SOLVER SELECTION INDEX - ! -- set default nonlinear parameters - call this%sln_setouter(ifdparam) - ! - ! -- get NONLINEAR block - call this%parser%GetBlock('NONLINEAR', isfound, ierr, & - supportOpenClose=.true., blockRequired=.FALSE.) - ! - ! -- parse NONLINEAR block if detected - if (isfound) then - write(iout,'(/1x,a)')'PROCESSING IMS NONLINEAR' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - ! -- parse keyword - select case (keyword) - case ('OUTER_HCLOSE') - this%hclose = this%parser%GetDouble() - case ('OUTER_MAXIMUM') - this%mxiter = this%parser%GetInteger() - case ('UNDER_RELAXATION') - call this%parser%GetStringCaps(keyword) - ival = 0 - if (keyword == 'NONE') then - ival = 0 - else if (keyword == 'SIMPLE') then - ival = 1 - else if (keyword == 'COOLEY') then - ival = 2 - else if (keyword == 'DBD') then - ival = 3 - else - write(errmsg,'(1x,a)') 'IMS sln_ar: UNKNOWN UNDER_RELAXATION SPECIFIED.' - call store_error(errmsg) - end if - this%nonmeth = ival - case ('LINEAR_SOLVER') - call this%parser%GetStringCaps(keyword) - ival = 1 - if (keyword.eq.'DEFAULT' .or. & - keyword.eq.'LINEAR') then - ival = 1 - else - write(errmsg,'(1x,a)') 'IMS sln_ar: UNKNOWN LINEAR_SOLVER SPECIFIED.' - call store_error(errmsg) - end if - this%linmeth = ival - case ('UNDER_RELAXATION_THETA') - this%theta = this%parser%GetDouble() - case ('UNDER_RELAXATION_KAPPA') - this%akappa = this%parser%GetDouble() - case ('UNDER_RELAXATION_GAMMA') - this%gamma = this%parser%GetDouble() - case ('UNDER_RELAXATION_MOMENTUM') - this%amomentum = this%parser%GetDouble() - case ('BACKTRACKING_NUMBER') - this%numtrack = this%parser%GetInteger() - IF (this%numtrack > 0) this%ibflag = 1 - case ('BACKTRACKING_TOLERANCE') - this%btol = this%parser%GetDouble() - case ('BACKTRACKING_REDUCTION_FACTOR') - this%breduc = this%parser%GetDouble() - case ('BACKTRACKING_RESIDUAL_LIMIT') - this%res_lim = this%parser%GetDouble() - case default - write(errmsg,'(4x,a,a)')'IMS sln_ar: UNKNOWN IMS NONLINEAR KEYWORD: ', & - trim(keyword) - call store_error(errmsg) - end select - end do - write(iout,'(1x,a)') 'END OF IMS NONLINEAR DATA' - else - if (IFDPARAM.EQ.0) then - write(errmsg,'(1x,a)') 'NO IMS NONLINEAR BLOCK DETECTED.' - call store_error(errmsg) - end if - end if - ! - IF ( THIS%THETA < DEM3 ) this%theta = DEM3 - ! - ! -- backtracking should only be used if this%nonmeth > 0 - if (this%nonmeth < 1) then - this%ibflag = 0 - end if - ! - ! -- check that MXITER is greater than zero - if (this%mxiter <= 0) then - write(errmsg,'(a)') 'IMS sln_ar: OUTER ITERATION NUMBER MUST BE > 0.' - call store_error(errmsg) - END IF - ! - ! - isymflg = 1 - if ( this%nonmeth > 0 )then - WRITE(IOUT,*) '**UNDER-RELAXATION WILL BE USED***' - WRITE(IOUT,*) - isymflg = 0 - elseif ( this%nonmeth == 0 )then - WRITE(IOUT,*) '***UNDER-RELAXATION WILL NOT BE USED***' - WRITE(IOUT,*) - ELSE - WRITE(errmsg,'(a)') '***INCORRECT VALUE FOR VARIABLE NONMETH ', & - & 'WAS SPECIFIED. CHECK INPUT.***' - call store_error(errmsg) - END IF - ! call secondary subroutine to initialize and read linear solver parameters - ! IMSLINEAR solver - if ( this%linmeth == 1 )then - allocate(this%imslinear) - WRITE(IOUT,*) '***IMS LINEAR SOLVER WILL BE USED***' - call this%imslinear%imslinear_allocate(this%name, this%iu, IOUT, & - this%iprims, this%mxiter, & - ifdparam, imslinear, & - this%neq, this%nja, this%ia, & - this%ja, this%amat, this%rhs, & - this%x, this%nitermax) - WRITE(IOUT,*) - isymflg = 0 - if ( imslinear.eq.1 ) isymflg = 1 - ! incorrect linear solver flag - ELSE - WRITE(errmsg, *) '***INCORRECT VALUE FOR LINEAR SOLUTION ', & - & 'METHOD SPECIFIED. CHECK INPUT.***' - call store_error(errmsg) - END IF - ! - ! -- If CG, then go through each model and each exchange and check - ! for asymmetry - if (isymflg == 1) then - ! - ! -- Models - do i = 1, this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, i) - if (mp%get_iasym() /= 0) then - write(errmsg, fmterrasym) 'MODEL', trim(adjustl(mp%name)) - call store_error(errmsg) - endif - enddo - ! - ! -- Exchanges - do i = 1, this%exchangelist%Count() - cp => GetNumericalExchangeFromList(this%exchangelist, i) - if (cp%get_iasym() /= 0) then - write(errmsg, fmterrasym) 'EXCHANGE', trim(adjustl(cp%name)) - call store_error(errmsg) - endif - enddo - ! - endif - ! - ! -- write solver data to output file - ! - ! -- non-linear solver data - WRITE(IOUT,9002) this%hclose, this%mxiter, & - this%iprims, this%nonmeth, this%linmeth - ! - ! -- standard outer iteration formats -9002 FORMAT(1X,'OUTER ITERATION CONVERGENCE CRITERION (HCLOSE) = ', E15.6, & - & /1X,'MAXIMUM NUMBER OF OUTER ITERATIONS (MXITER) = ', I9, & - & /1X,'SOLVER PRINTOUT INDEX (IPRIMS) = ', I9, & - & /1X,'NONLINEAR ITERATION METHOD (NONLINMETH) = ', I9, & - & /1X,'LINEAR SOLUTION METHOD (LINMETH) = ', I9) - ! - IF(this%nonmeth /= 0)THEN - WRITE(IOUT,9003) this%theta, this%akappa, this%gamma, this%amomentum, & - this%numtrack - IF(this%numtrack /= 0) WRITE(IOUT,9004) this%btol,this%breduc,this%res_lim - END IF - ! - ! -- under-relaxation formats -9003 FORMAT(1X,'UNDER-RELAXATION WEIGHT REDUCTION FACTOR (THETA) = ', E15.6, & - & /1X,'UNDER-RELAXATION WEIGHT INCREASE INCREMENT (KAPPA) = ', E15.6, & - & /1X,'UNDER-RELAXATION PREVIOUS HISTORY FACTOR (GAMMA) = ', E15.6, & - & /1X,'UNDER-RELAXATIONMOMENTUM TERM (AMOMENTUM) = ', E15.6, & - & /1X,' MAXIMUM NUMBER OF BACKTRACKS (NUMTRACK) = ',I9) - ! - ! -- backtracking formats -9004 FORMAT(1X,'BACKTRACKING TOLERANCE FACTOR (BTOL) = ', E15.6, & - & /1X,'BACKTRACKING REDUCTION FACTOR (BREDUC) = ', E15.6, & - & /1X,'BACKTRACKING RESIDUAL LIMIT (RES_LIM) = ', E15.6) - ! - ! -- linear solver data - call this%imslinear%imslinear_summary(this%mxiter) - - ! -- write summary of solver error messages - ierr = count_errors() - if (ierr>0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! reallocate space for nonlinear arrays and initialize - call mem_reallocate(this%hncg, this%mxiter, 'HNCG', this%name) - call mem_reallocate(this%lrch, 3, this%mxiter, 'LRCH', this%name) - - ! delta-bar-delta under-relaxation - if(this%nonmeth.eq.3)then - call mem_reallocate(this%wsave, this%neq, 'WSAVE', this%name) - call mem_reallocate(this%hchold, this%neq, 'HCHOLD', this%name) - call mem_reallocate(this%deold, this%neq, 'DEOLD', this%name) - do i = 1, this%neq - this%wsave(i) = DZERO - this%hchold(i) = DZERO - this%deold(i) = DZERO - end do - endif - this%hncg = DZERO - this%lrch = 0 - - ! allocate space for saving solver convergence history - if (this%iprims == 2) then - this%nitermax = this%nitermax * this%mxiter - else - this%nitermax = 1 - end if - - allocate(this%caccel(this%nitermax)) - - im = this%convnmod - call mem_reallocate(this%itinner, this%nitermax, 'ITINNER', & - trim(this%name)) - call mem_reallocate(this%convlocdv, im, this%nitermax, 'CONVLOCDV', & - trim(this%name)) - call mem_reallocate(this%convlocdr, im, this%nitermax, 'CONVLOCDR', & - trim(this%name)) - call mem_reallocate(this%convdvmax, im, this%nitermax, 'CONVDVMAX', & - trim(this%name)) - call mem_reallocate(this%convdrmax, im, this%nitermax, 'CONVDRMAX', & - trim(this%name)) - do i = 1, this%nitermax - this%itinner(i) = 0 - do im = 1, this%convnmod - this%convlocdv(im, i) = 0 - this%convlocdr(im, i) = 0 - this%convdvmax(im, i) = DZERO - this%convdrmax(im, i) = DZERO - end do - end do - ! - ! close ims input file - call this%parser%Clear() - ! - ! -- return - return - end subroutine sln_ar - - subroutine sln_rp(this) -! ****************************************************************************** -! sln_rp -- Read and Prepare -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: readnewdata - ! -- dummy - class(NumericalSolutionType) :: this - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- Check with TDIS on whether or not it is time to RP - if (.not. readnewdata) return - ! - ! -- return - return - end subroutine sln_rp - - subroutine sln_ot(this) -! ****************************************************************************** -! sln_ot -- Output -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(NumericalSolutionType) :: this - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- Nothing to do here - ! - ! -- return - return - end subroutine sln_ot - - subroutine sln_fp(this) -! ****************************************************************************** -! sln_fp -- Final processing -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(NumericalSolutionType) :: this - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- Nothing to do here - if (IDEVELOPMODE == 1) then - write(this%imslinear%iout, '(//1x,a,1x,a,1x,a)') & - 'Solution', trim(adjustl(this%name)), 'summary' - write(this%imslinear%iout, "(1x,70('-'))") - write(this%imslinear%iout, '(1x,a,1x,g0,1x,a)') & - 'Total formulate time: ', this%ttform, 'seconds' - write(this%imslinear%iout, '(1x,a,1x,g0,1x,a,/)') & - 'Total solution time: ', this%ttsoln, 'seconds' - end if - ! - ! -- return - return - end subroutine sln_fp - - subroutine sln_da(this) -! ****************************************************************************** -! sln_da -- Deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(NumericalSolutionType) :: this - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- IMSLinearModule - call this%imslinear%imslinear_da() - deallocate(this%imslinear) - ! - ! -- lists - call this%modellist%Clear() - call this%exchangelist%Clear() - ! - ! -- character arrays - deallocate(this%caccel) - ! - ! -- inner iteration table object - if (associated(this%innertab)) then - call this%innertab%table_da() - deallocate(this%innertab) - nullify(this%innertab) - end if - ! - ! -- outer iteration table object - if (associated(this%outertab)) then - call this%outertab%table_da() - deallocate(this%outertab) - nullify(this%outertab) - end if - ! - ! -- arrays - call mem_deallocate(this%ja) - call mem_deallocate(this%amat) - call mem_deallocate(this%ia) - call mem_deallocate(this%x) - call mem_deallocate(this%rhs) - call mem_deallocate(this%active) - call mem_deallocate(this%xtemp) - call mem_deallocate(this%dxold) - call mem_deallocate(this%hncg) - call mem_deallocate(this%lrch) - call mem_deallocate(this%wsave) - call mem_deallocate(this%hchold) - call mem_deallocate(this%deold) - call mem_deallocate(this%convmodstart) - call mem_deallocate(this%locdv) - call mem_deallocate(this%locdr) - call mem_deallocate(this%itinner) - call mem_deallocate(this%convlocdv) - call mem_deallocate(this%convlocdr) - call mem_deallocate(this%dvmax) - call mem_deallocate(this%drmax) - call mem_deallocate(this%convdvmax) - call mem_deallocate(this%convdrmax) - ! - ! -- Scalars - call mem_deallocate(this%id) - call mem_deallocate(this%iu) - call mem_deallocate(this%ttform) - call mem_deallocate(this%ttsoln) - call mem_deallocate(this%neq) - call mem_deallocate(this%nja) - call mem_deallocate(this%hclose) - call mem_deallocate(this%hiclose) - call mem_deallocate(this%bigchold) - call mem_deallocate(this%bigch) - call mem_deallocate(this%relaxold) - call mem_deallocate(this%res_prev) - call mem_deallocate(this%res_new) - call mem_deallocate(this%res_in) - call mem_deallocate(this%ibcount) - call mem_deallocate(this%icnvg) - call mem_deallocate(this%itertot) - call mem_deallocate(this%mxiter) - call mem_deallocate(this%linmeth) - call mem_deallocate(this%nonmeth) - call mem_deallocate(this%iprims) - call mem_deallocate(this%theta) - call mem_deallocate(this%akappa) - call mem_deallocate(this%gamma) - call mem_deallocate(this%amomentum) - call mem_deallocate(this%breduc) - call mem_deallocate(this%btol) - call mem_deallocate(this%res_lim) - call mem_deallocate(this%numtrack) - call mem_deallocate(this%ibflag) - call mem_deallocate(this%icsvout) - call mem_deallocate(this%nitermax) - call mem_deallocate(this%nitercnt) - call mem_deallocate(this%convnmod) - call mem_deallocate(this%iallowptc) - call mem_deallocate(this%iptcopt) - call mem_deallocate(this%iptcout) - call mem_deallocate(this%l2norm0) - call mem_deallocate(this%ptcfact) - call mem_deallocate(this%ptcdel) - call mem_deallocate(this%ptcdel0) - call mem_deallocate(this%ptcexp) - call mem_deallocate(this%ptcthresh) - call mem_deallocate(this%ptcrat) - ! - ! -- return - return - end subroutine sln_da - - subroutine sln_ca(this, kpicard, isgcnvg, isuppress_output) -! ****************************************************************************** -! sln_ca -- Solve the models in this solution for kper and kstp. If necessary -! use subtiming to get to the end of the time step -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: kper, subtiming_begin, subtiming_end, perlen, totimsav - ! -- dummy - class(NumericalSolutionType) :: this - integer(I4B), intent(in) :: kpicard - integer(I4B), intent(inout) :: isgcnvg - integer(I4B), intent(in) :: isuppress_output - ! -- local - class(NumericalModelType), pointer :: mp - class(NumericalExchangeType), pointer :: cp - integer(I4B) :: kiter ! non-linear iteration counter - integer(I4B) :: im, ic - integer(I4B) :: nsubtimes, nstm, isubtime - real(DP) :: dt - real(DP) :: totim - -! ------------------------------------------------------------------------------ - - ! TODO_MJR: the subtime loop is now around the sln_ca body, easy to discard, do we still want this? - - ! -- Find the number of sub-timesteps for each model and then use - ! the largest one. - nsubtimes = 1 - do im=1,this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, im) - nstm = mp%get_nsubtimes() - if(nstm > nsubtimes) nsubtimes = nstm - enddo - - dt = perlen(kper) / REAL(nsubtimes, DP) - totim = totimsav - ! - do isubtime = 1, nsubtimes - ! - ! -- update totim - totim = totim + dt - ! - ! -- Start subtiming - call subtiming_begin(isubtime, nsubtimes, this%id) - - ! prepare for the nonlinear iteration loop - call this%prepareIteration(kpicard, isubtime) - - ! nonlinear iteration loop for this solution - outerloop: do kiter = 1, this%mxiter - - ! perform a single iteration - call this%doIteration(kiter) - - ! exit if converged - if (this%icnvg == 1) then - exit outerloop - end if - - end do outerloop - - ! finish up, write convergence info, CSV file, budgets and flows, ... - call this%finalizeIteration(kiter, isgcnvg, isubtime, isuppress_output) - - ! -- End of the sub-timestep loop - end do - - ! -- end the subtiming - call subtiming_end() - ! - ! - ! -- Check if convergence for the exchange packages - ! TODO_MJR: shouldn't this be in the subtiming loop? - do ic = 1, this%exchangelist%Count() - cp => GetNumericalExchangeFromList(this%exchangelist, ic) - call cp%exg_cnvg(this%id, isgcnvg) - enddo - ! - ! -- return - return - end subroutine sln_ca - - ! prepare for iteration loop, use isubtime == 1 when there is no subtiming - ! and the default kpicard == 1 when no picard loop (c.f. sgp_ca()) - subroutine prepareIteration(this, kpicard, isubtime) - use TdisModule, only: kper, kstp - class(NumericalSolutionType) :: this - integer(I4B), intent(in) :: kpicard - integer(I4B), intent(in) :: isubtime - - ! write headers to CSV file - if (kper == 1 .and. kstp == 1 .and. isubtime == 1) then - call this%writeCSVHeader() - end if - - ! advance models and exchanges - call this%advanceSolution(kpicard, isubtime) - - ! write PTC info on models to iout - call this%writePTCInfoToFile(kper) - - ! reset convergence flag and inner solve counter - this%icnvg = 0 - if (isubtime == 1) then - this%itertot = 0 - end if - - end subroutine - - ! write the header for the solver output to the CSV file - subroutine writeCSVHeader(this) - class(NumericalSolutionType) :: this - ! local - integer(I4B) :: im - class(NumericalModelType), pointer :: mp - - if (this%icsvout > 0) then - write(this%icsvout, '(*(G0,:,","))', advance='NO') & - 'total_iterations', 'totim', 'kper', 'kstp', 'ksub', 'nouter', & - 'ninner', 'solution_dvmax', 'solution_dvmax_model', & - 'solution_dvmax_node' - if (this%iprims == 2) then - write(this%icsvout, '(*(G0,:,","))', advance='NO') & - '', 'solution_drmax', 'solution_drmax_model', & - 'solution_drmax_node', 'solution_alpha' - if (this%imslinear%ilinmeth == 2) then - write(this%icsvout, '(*(G0,:,","))', advance='NO') & - '', 'solution_omega' - end if - ! -- check for more than one model - if (this%convnmod > 1) then - do im=1,this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, im) - write(this%icsvout, '(*(G0,:,","))', advance='NO') & - '', trim(adjustl(mp%name)) // '_dvmax', & - trim(adjustl(mp%name)) // '_dvmax_node', & - trim(adjustl(mp%name)) // '_drmax', & - trim(adjustl(mp%name)) // '_drmax_node' - end do - end if - end if - write(this%icsvout,'(a)') '' - end if - - end subroutine writeCSVHeader - - ! advances the exchanges and models in this solution by 1 (sub)timestep - ! kpicard will change if we are running the outer picard loop, - ! if not (the current use cases) then we use kpicard == 1 - subroutine advanceSolution(this, isubtime, kpicard) - class(NumericalSolutionType) :: this - integer(I4B), intent(in) :: isubtime, kpicard - ! local - integer(I4B) :: ic, im - class(NumericalExchangeType), pointer :: cp - class(NumericalModelType), pointer :: mp - - ! -- Exchange advance - do ic=1,this%exchangelist%Count() - cp => GetNumericalExchangeFromList(this%exchangelist, ic) - call cp%exg_ad(this%id, kpicard, isubtime) - enddo - - ! -- Model advance - do im = 1, this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, im) - call mp%model_ad(kpicard, isubtime) - enddo - - end subroutine advanceSolution - - ! write the PTC header information to file - subroutine writePTCInfoToFile(this, kper) - class(NumericalSolutionType) :: this - integer(I4B), intent(in) :: kper - ! local - integer(I4B) :: n, im, iallowptc, iptc - class(NumericalModelType), pointer :: mp - - ! -- determine if PTC will be used in any model - n = 1 - do im = 1, this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, im) - call mp%model_ptcchk(iptc) - ! - ! -- set iallowptc - ! -- no_ptc_option is FIRST - if (this%iallowptc < 0) then - if (kper > 1) then - iallowptc = 1 - else - iallowptc = 0 - end if - ! -- no_ptc_option is ALL (0) or using PTC (1) - else - iallowptc = this%iallowptc - end if - iptc = iptc * iallowptc - if (iptc /= 0) then - if (n == 1) then - write(iout, '(//)') - n = 0 - end if - write(iout, '(1x,a,1x,i0,1x,3a)') & - 'PSEUDO-TRANSIENT CONTINUATION WILL BE APPLIED TO MODEL', im, '("', & - trim(adjustl(mp%name)), '") DURING THIS TIME STEP' - end if - enddo - - end subroutine writePTCInfoToFile - - ! this routine performs a single iteration, with the following steps: - ! (TODO_MJR: refactor this routine, it is long) - ! - ! - backtracking - ! - reset amat and rhs - ! - calculate matrix terms (*_cf) - ! - add coefficients to matrix (*_fc) - ! - newton-raphson - ! - PTC - ! - linear solve - ! - convergence checks - ! - write output - ! - underrelaxation - ! - ! it updates the convergence flag "this%icnvg" accordingly - subroutine doIteration(this, kiter) - use TdisModule, only: kstp, kper - class(NumericalSolutionType) :: this - integer(I4B), intent(in) :: kiter - ! local - integer(I4B) :: ic, im - class(NumericalModelType), pointer :: mp - class(NumericalExchangeType), pointer :: cp - character(len=LINELENGTH) :: title - character(len=LINELENGTH) :: tag - character(len=LINELENGTH) :: line - character(len=LENPAKLOC) :: cmod - character(len=LENPAKLOC) :: cpak - character(len=34) :: strh - character(len=25) :: cval - character(len=7) :: cmsg - integer(I4B) :: ntabrows - integer(I4B) :: ntabcols - integer(I4B) :: i0, i1 - integer(I4B) :: itestmat, n - integer(I4B) :: iter - integer(I4B) :: inewtonur - integer(I4B) :: locmax_nur - integer(I4B) :: iend - integer(I4B) :: icnvgmod - integer(I4B) :: iptc - real(DP) :: dxmax_nur - real(DP) :: dxmax - real(DP) :: ptcf - real(DP) :: ttform - real(DP) :: ttsoln - real(DP) :: dpak - ! formats -! ----------------------------------------------------------------------------- - ! - ! -- code - ! - ! -- create header for outer iteration table - if (this%iprims > 0) then - if (.not. associated(this%outertab)) then - ! - ! -- create outer iteration table - ! -- table dimensions - ntabrows = 1 - ntabcols = 6 - if (this%numtrack > 0) then - ntabcols = ntabcols + 4 - end if - ! - ! -- initialize table and define columns - title = 'OUTER ITERATION SUMMARY' - call table_cr(this%outertab, this%name, title) - call this%outertab%table_df(ntabrows, ntabcols, iout, & - finalize=.FALSE.) - tag = 'OUTER ITERATION STEP' - call this%outertab%initialize_column(tag, 15, alignment=TABLEFT) - tag = 'OUTER ITERATION' - call this%outertab%initialize_column(tag, 10, alignment=TABRIGHT) - tag = 'INNER ITERATION' - call this%outertab%initialize_column(tag, 10, alignment=TABRIGHT) - if (this%numtrack > 0) then - tag = 'BACKTRACK FLAG' - call this%outertab%initialize_column(tag, 10, alignment=TABRIGHT) - tag = 'BACKTRACK ITERATIONS' - call this%outertab%initialize_column(tag, 10, alignment=TABRIGHT) - tag = 'INCOMING RESIDUAL' - call this%outertab%initialize_column(tag, 15, alignment=TABRIGHT) - tag = 'OUTGOING RESIDUAL' - call this%outertab%initialize_column(tag, 15, alignment=TABRIGHT) - end if - tag = 'MAXIMUM CHANGE' - call this%outertab%initialize_column(tag, 15, alignment=TABRIGHT) - tag = 'STEP SUCCESS' - call this%outertab%initialize_column(tag, 7, alignment=TABRIGHT) - tag = 'MAXIMUM CHANGE MODEL-(CELLID) OR MODEL-PACKAGE-(NUMBER)' - call this%outertab%initialize_column(tag, 34, alignment=TABRIGHT) - end if - end if - ! - ! -- backtracking - if (this%numtrack > 0) then - call this%sln_backtracking(mp, cp, kiter) - end if - ! - ! -- Set amat and rhs to zero - call this%sln_reset() - call code_timer(0, ttform, this%ttform) - ! - ! -- Calculate the matrix terms for each exchange - do ic=1,this%exchangelist%Count() - cp => GetNumericalExchangeFromList(this%exchangelist, ic) - call cp%exg_cf(kiter) - enddo - ! - ! -- Calculate the matrix terms for each model - do im=1,this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, im) - call mp%model_cf(kiter) - enddo - ! - ! -- Add exchange coefficients to the solution - do ic=1,this%exchangelist%Count() - cp => GetNumericalExchangeFromList(this%exchangelist, ic) - call cp%exg_fc(kiter, this%ia, this%amat, 1) - enddo - ! - ! -- Add model coefficients to the solution - do im=1,this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, im) - call mp%model_fc(kiter, this%amat, this%nja, 1) - enddo - ! - ! -- Add exchange Newton-Raphson terms to solution - do ic=1,this%exchangelist%Count() - cp => GetNumericalExchangeFromList(this%exchangelist, ic) - call cp%exg_nr(kiter, this%ia, this%amat) - enddo - ! - ! -- Calculate pseudo-transient continuation factor for each model - iptc = 0 - ptcf = DZERO - do im=1,this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, im) - call mp%model_ptc(kiter, this%neq, this%nja, & - this%ia, this%ja, this%x, & - this%rhs, this%amat, & - iptc, ptcf) - end do - ! - ! -- Add model Newton-Raphson terms to solution - do im=1,this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, im) - call mp%model_nr(kiter, this%amat, this%nja, 1) - enddo - call code_timer(1, ttform, this%ttform) - ! - ! -- linear solve - call code_timer(0, ttsoln, this%ttsoln) - CALL this%sln_ls(kiter, kstp, kper, iter, iptc, ptcf) - call code_timer(1, ttsoln, this%ttsoln) - ! - ! -- save matrix to a file - ! to enable set itestmat to 1 and recompile - !------------------------------------------------------- - itestmat = 0 - if (itestmat /= 0) then - open(99,file='sol_MF6.TXT') - WRITE(99,*) 'MATRIX SOLUTION FOLLOWS' - WRITE(99,'(10(I8,G15.4))') (n, this%x(N), N = 1, this%NEQ) - close(99) - call stop_with_error() - end if - !------------------------------------------------------- - ! - ! -- check convergence of solution - call this%sln_outer_check(this%hncg(kiter), this%lrch(1,kiter)) - if (this%icnvg /= 0) then - this%icnvg = 0 - if (abs(this%hncg(kiter)) <= this%hclose) then - this%icnvg = 1 - end if - end if - ! - ! -- set failure flag - if (this%icnvg == 0) then - cmsg = ' ' - else - cmsg = '*' - end if - ! - ! -- set flag if this is the last outer iteration - iend = 0 - if (kiter == this%mxiter) then - iend = 1 - end if - ! - ! -- Additional convergence check for pseudo-transient continuation - ! term. Evaluate if the ptc value added to the diagonal has - ! decayed sufficiently. - if (iptc > 0) then - if (this%icnvg /= 0) then - if (this%ptcrat > this%ptcthresh) then - this%icnvg = 0 - cmsg = trim(cmsg) // 'PTC' - if (iend /= 0) then - write(line, '(a)') & - 'PSEUDO-TRANSIENT CONTINUATION CAUSED CONVERGENCE FAILURE' - call sim_message(line) - end if - end if - end if - end if - ! - ! -- write maximum head change from linear solver to list file - if (this%iprims > 0) then - cval = 'Model' - call this%sln_get_loc(this%lrch(1,kiter), strh) - ! - ! -- add data to outertab - call this%outertab%add_term(cval) - call this%outertab%add_term(kiter) - call this%outertab%add_term(iter) - if (this%numtrack > 0) then - call this%outertab%add_term(' ') - call this%outertab%add_term(' ') - call this%outertab%add_term(' ') - call this%outertab%add_term(' ') - end if - call this%outertab%add_term(this%hncg(kiter)) - call this%outertab%add_term(cmsg) - call this%outertab%add_term(trim(strh)) - end if - ! - ! -- Additional convergence check for exchanges - do ic=1,this%exchangelist%Count() - cp => GetNumericalExchangeFromList(this%exchangelist, ic) - call cp%exg_cc(this%icnvg) - end do - ! - ! -- additional convergence check for model packages - icnvgmod = this%icnvg - dpak = DZERO - cpak = ' ' - do im=1,this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, im) - call mp%get_mcellid(0, cmod) - call mp%model_cc(kiter, iend, icnvgmod, cpak, dpak) - if (abs(dpak) > DZERO) then - write(cpak, '(a,a)') trim(cmod) // trim(cpak) - else - cpak = ' ' - end if - end do - ! - ! -- evaluate package convergence - if (abs(dpak) > this%hclose) then - this%icnvg = 0 - ! -- write message to stdout - if (iend /= 0) then - write(line, '(3a)') & - 'PACKAGE (', trim(cpak), ') CAUSED CONVERGENCE FAILURE' - call sim_message(line) - end if - end if - ! - ! -- write maximum change in package convergence check - if (this%iprims > 0) then - cval = 'Package' - if (this%icnvg /= 1) then - cmsg = ' ' - else - cmsg = '*' - end if - !if (len_trim(this%cpak) > 0) then - if (len_trim(cpak) > 0) then - ! - ! -- add data to outertab - call this%outertab%add_term(cval) - call this%outertab%add_term(kiter) - call this%outertab%add_term(' ') - if (this%numtrack > 0) then - call this%outertab%add_term(' ') - call this%outertab%add_term(' ') - call this%outertab%add_term(' ') - call this%outertab%add_term(' ') - end if - call this%outertab%add_term(dpak) - call this%outertab%add_term(cmsg) - call this%outertab%add_term(cpak) - end if - end if - ! - ! -- increment the counter storing the total number of linear iterations - this%itertot = this%itertot + iter - ! - ! -- under-relaxation - only done if convergence not achieved - if (this%icnvg /= 1) then - if (this%nonmeth > 0) then - call this%sln_underrelax(kiter, this%hncg(kiter), this%neq, & - this%active, this%x, this%xtemp) - else - call this%sln_calcdx(this%neq, this%active, & - this%x, this%xtemp, this%dxold) - endif - ! - ! -- adjust heads by newton under-relaxation, if necessary - inewtonur = 0 - dxmax_nur = DZERO - locmax_nur = 0 - do im=1,this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, im) - i0 = mp%moffset + 1 - i1 = i0 + mp%neq - 1 - call mp%model_nur(mp%neq, this%x(i0:i1), this%xtemp(i0:i1), & - this%dxold(i0:i1), inewtonur, dxmax_nur, locmax_nur) - end do - ! - ! -- check for convergence if newton under-relaxation applied - if (inewtonur /= 0) then - call this%sln_maxval(this%neq, this%dxold, dxmax) - ! - ! -- evaluate convergence - if (abs(dxmax) <= this%hclose .and. & - abs(this%hncg(kiter)) <= this%hclose) then - this%icnvg = 1 - end if - end if - end if - - end subroutine doIteration - - ! finalize the solution calculate, called after the non-linear iteration loop - ! when used without subtiming, do isubtime == 1 - subroutine finalizeIteration(this, kiter, isgcnvg, isubtime, isuppress_output) - use TdisModule, only: totim, kper, kstp - class(NumericalSolutionType) :: this - integer(I4B), intent(in) :: kiter ! the number at which the iteration loop was exited - integer(I4B), intent(inout) :: isgcnvg - integer(I4B), intent(in) :: isubtime - integer(I4B), intent(in) :: isuppress_output - ! local - integer(I4B) :: ic, im - class(NumericalModelType), pointer :: mp - class(NumericalExchangeType), pointer :: cp - integer(I4B) :: nodeu - - ! -- formats for convergence info - character(len=*), parameter :: fmtnocnvg = & - &"(1X,'Solution ', i0, ' did not converge for stress period ', i0, & - &' and time step ', i0)" - character(len=*), parameter :: fmtcnvg = & - &"(1X, I0, ' CALLS TO NUMERICAL SOLUTION ', 'IN TIME STEP ', I0, & - &' STRESS PERIOD ',I0,/1X,I0,' TOTAL ITERATIONS')" - - ! - ! -- finalize the outer iteration table - if (this%iprims > 0) then - call this%outertab%finalize_table() - end if - ! -- write convergence info - if (this%icnvg == 1) then - if (this%iprims > 0) then - write(iout, fmtcnvg) kiter, kstp, kper, this%itertot - end if - end if - - ! -- Write a message if convergence was not achieved - if (this%icnvg == 0) then - write(iout, fmtnocnvg) this%id, kper, kstp - end if - - ! - ! -- write inner iteration convergence summary - if (this%iprims == 2) then - ! - ! -- write summary for each model - do im=1,this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, im) - call this%convergence_summary(mp%iout, im, this%itertot) - end do - ! - ! -- write summary for entire solution - call this%convergence_summary(iout, this%convnmod+1, this%itertot) - end if - ! - ! -- write to csv file - if (this%icsvout > 0) then - if (this%iprims < 2) then - ! - ! -- determine the total number of iterations at the end of this outer - this%nitercnt = this%nitercnt + this%itertot - ! - ! -- get model number and user node number - call this%sln_get_nodeu(this%lrch(1,kiter), im, nodeu) - ! - ! -- write line - write(this%icsvout, '(*(G0,:,","))') & - this%nitercnt, totim, kper, kstp, isubtime, kiter, this%itertot, & - this%hncg(kiter), im, nodeu - else - call this%csv_convergence_summary(this%icsvout, totim, kper, kstp, & - isubtime, this%itertot) - end if - end if - ! - ! - if (this%icnvg == 0) isgcnvg = 0 - ! - ! -- Calculate flow for each model - do im=1,this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, im) - call mp%model_cq(this%icnvg, isuppress_output) - enddo - ! - ! -- Calculate flow for each exchange - do ic = 1, this%exchangelist%Count() - cp => GetNumericalExchangeFromList(this%exchangelist, ic) - call cp%exg_cq(isgcnvg, isuppress_output, this%id) - enddo - ! - ! -- Budget terms for each model - do im=1,this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, im) - call mp%model_bd(this%icnvg, isuppress_output) - enddo - ! - ! -- Budget terms for each exchange - do ic = 1, this%exchangelist%Count() - cp => GetNumericalExchangeFromList(this%exchangelist, ic) - call cp%exg_bd(isgcnvg, isuppress_output, this%id) - enddo - - end subroutine finalizeIteration - - subroutine convergence_summary(this, iu, im, itertot) -! ****************************************************************************** -! convergence_summary -- Save convergence summary to a File -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only:getunit - ! -- dummy - class(NumericalSolutionType) :: this - integer(I4B), intent(in) :: iu - integer(I4B), intent(in) :: im - integer(I4B), intent(in) :: itertot - ! -- local - character(len=34) :: strh, strr - integer(I4B) :: i - integer(I4B) :: i0 - integer(I4B) :: iouter - integer(I4B) :: j - integer(I4B) :: k - integer(I4B) :: locdv - integer(I4B) :: locdr - real(DP) :: dv - real(DP) :: dr -! ------------------------------------------------------------------------------ - iouter = 1 - write(iu,"(/,1x,A)") 'INNER ITERATION SUMMARY' - write(iu,"(1x,128('-'))") - write(iu,'(1x,3a)') ' TOTAL OUTER INNER', & - ' MAXIMUM CHANGE MAXIMUM', & - ' MAXIMUM RESIDUAL MAXIMUM' - write(iu,'(1x,3a)') 'ITERATION ITERATION ITERATION', & - ' MODEL-(CELLID) CHANGE', & - ' MODEL-(CELLID) RESIDUAL' - write(iu,"(1x,128('-'))") - i0 = 0 - do k = 1, itertot - i = this%itinner(k) - if (i <= i0) then - iouter = iouter + 1 - end if - if (im > this%convnmod) then - dv = DZERO - dr = DZERO - do j = 1, this%convnmod - if (ABS(this%convdvmax(j, k)) > ABS(dv)) then - locdv = this%convlocdv(j, k) - dv = this%convdvmax(j, k) - end if - if (ABS(this%convdrmax(j, k)) > ABS(dr)) then - locdr = this%convlocdr(j, k) - dr = this%convdrmax(j, k) - end if - end do - else - locdv = this%convlocdv(im, k) - locdr = this%convlocdr(im, k) - dv = this%convdvmax(im, k) - dr = this%convdrmax(im, k) - end if - call this%sln_get_loc(locdv, strh) - call this%sln_get_loc(locdr, strr) - write(iu, '(1x,3i10,a34,g15.7,a34,g15.7)') k, iouter, i, & - adjustr(trim(strh)), dv, & - adjustr(trim(strr)), dr - i0 = i - end do - ! - ! -- write blank line - if (im <= this%convnmod) then - write(iu, '(a)') '' - end if - ! - ! -- return - return - end subroutine convergence_summary - - - subroutine csv_convergence_summary(this, iu, totim, kper, kstp, isubtime, & - itertot) -! ****************************************************************************** -! csv_convergence_summary -- Save convergence summary to a csv file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only:getunit - ! -- dummy - class(NumericalSolutionType) :: this - integer(I4B), intent(in) :: iu - real(DP), intent(in) :: totim - integer(I4B), intent(in) :: kper - integer(I4B), intent(in) :: kstp - integer(I4B), intent(in) :: isubtime - integer(I4B), intent(in) :: itertot - ! -- local - integer(I4B) :: i - integer(I4B) :: i0 - integer(I4B) :: iouter - integer(I4B) :: im - integer(I4B) :: j - integer(I4B) :: k - integer(I4B) :: locdv - integer(I4B) :: locdr - integer(I4B) :: nodeu - real(DP) :: dv - real(DP) :: dr -! ------------------------------------------------------------------------------ - iouter = 1 - i0 = 0 - do k = 1, itertot - this%nitercnt = this%nitercnt + 1 - i = this%itinner(k) - if (i <= i0) then - iouter = iouter + 1 - end if - write(iu, '(*(G0,:,","))', advance='NO') & - this%nitercnt, totim, kper, kstp, isubtime, iouter, i - ! - ! -- solution summary - dv = DZERO - dr = DZERO - do j = 1, this%convnmod - if (ABS(this%convdvmax(j, k)) > ABS(dv)) then - locdv = this%convlocdv(j, k) - dv = this%convdvmax(j, k) - end if - if (ABS(this%convdrmax(j, k)) > ABS(dr)) then - locdr = this%convlocdr(j, k) - dr = this%convdrmax(j, k) - end if - end do - ! - ! -- get model number and user node number for dv - call this%sln_get_nodeu(locdv, im, nodeu) - write(iu, '(*(G0,:,","))', advance='NO') '', dv, im, nodeu - ! - ! -- get model number and user node number for dr - call this%sln_get_nodeu(locdr, im, nodeu) - write(iu, '(*(G0,:,","))', advance='NO') '', dr, im, nodeu - ! - ! -- write acceleration parameters - write(iu, '(*(G0,:,","))', advance='NO') '', trim(adjustl(this%caccel(k))) - ! - ! -- write information for each model - if (this%convnmod > 1) then - do j = 1, this%convnmod - locdv = this%convlocdv(j, k) - dv = this%convdvmax(j, k) - locdr = this%convlocdr(j, k) - dr = this%convdrmax(j, k) - ! - ! -- get model number and user node number for dv - call this%sln_get_nodeu(locdv, im, nodeu) - write(iu, '(*(G0,:,","))', advance='NO') '', dv, nodeu - ! - ! -- get model number and user node number for dr - call this%sln_get_nodeu(locdr, im, nodeu) - write(iu, '(*(G0,:,","))', advance='NO') '', dr, nodeu - end do - end if - ! - ! -- write line - write(iu,'(a)') '' - ! - ! -- update i0 - i0 = i - end do - ! - ! -- return - return - end subroutine csv_convergence_summary - - subroutine save(this, filename) -! ****************************************************************************** -! save -- Save Solution Matrices to a File -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only:getunit - ! -- dummy - class(NumericalSolutionType) :: this - character(len=*), intent(in) :: filename - ! -- local - integer(I4B) :: inunit -! ------------------------------------------------------------------------------ - ! - inunit = getunit() - open(unit=inunit,file=filename,status='unknown') - write(inunit,*) 'ia' - write(inunit,*) this%ia - write(inunit,*) 'ja' - write(inunit,*) this%ja - write(inunit,*) 'amat' - write(inunit,*) this%amat - write(inunit,*) 'rhs' - write(inunit,*) this%rhs - write(inunit,*) 'x' - write(inunit,*) this%x - close(inunit) - ! - ! -- return - return - end subroutine save - - subroutine addmodel(this, mp) -! ****************************************************************************** -! addmodel -- Add Model -! Subroutine: (1) add a model to this%modellist -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(NumericalSolutionType) :: this - class(BaseModelType), pointer, intent(in) :: mp - ! -- local - class(NumericalModelType), pointer :: m -! ------------------------------------------------------------------------------ - ! - select type(mp) - class is (NumericalModelType) - m => mp - call AddNumericalModelToList(this%modellist, m) - end select - ! - ! -- return - return - end subroutine addmodel - - subroutine addexchange(this, exchange) -! ****************************************************************************** -! addexchange -- Add exchange -! Subroutine: (1) add an exchange to this%exchangelist -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(NumericalSolutionType) :: this - class(NumericalExchangeType), pointer, intent(in) :: exchange -! ------------------------------------------------------------------------------ - ! - call AddNumericalExchangeToList(this%exchangelist, exchange) - ! - ! -- return - return - end subroutine addexchange - - subroutine slnassignexchanges(this) -! ****************************************************************************** -! slnassignexchanges -- Assign exchanges to this solution -! Subroutine: (1) assign the appropriate exchanges to this%exchangelist -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList - use ListsModule, only: baseexchangelist - ! -- dummy - class(NumericalSolutionType) :: this - ! -- local - class(BaseExchangeType), pointer :: cb - class(NumericalExchangeType), pointer :: c - integer(I4B) :: ic -! ------------------------------------------------------------------------------ - ! - ! -- Go through the list of exchange objects and if either model1 or model2 - ! are part of this solution, then include the exchange object as part of - ! this solution. - c => null() - do ic=1,baseexchangelist%Count() - cb => GetBaseExchangeFromList(baseexchangelist, ic) - select type (cb) - class is (NumericalExchangeType) - c=>cb - end select - if(associated(c)) then - if(c%m1%idsoln==this%id) then - call this%addexchange(c) - cycle - elseif(c%m2%idsoln==this%id) then - call this%addexchange(c) - cycle - endif - endif - enddo - ! - ! -- return - return - end subroutine slnassignexchanges - - subroutine sln_connect(this) -! ****************************************************************************** -! sln_connect -- Assign Connections -! Main workhorse method for solution. This goes through all the models and all -! the connections and builds up the sparse matrix. -! Subroutine: (1) Add internal model connections, -! (2) Add cross terms, -! (3) Allocate solution arrays -! (4) Create mapping arrays -! (5) Fill cross term values if necessary -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(NumericalSolutionType) :: this - ! -- local - class(NumericalModelType), pointer :: mp - class(NumericalExchangeType), pointer :: cp - integer(I4B) :: im, ic, ierror -! ------------------------------------------------------------------------------ - ! - ! -- Add internal model connections to sparse - do im=1,this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, im) - call mp%model_ac(this%sparse) - enddo - ! - ! -- Add the cross terms to sparse - do ic=1,this%exchangelist%Count() - cp => GetNumericalExchangeFromList(this%exchangelist, ic) - call cp%exg_ac(this%sparse) - enddo - ! - ! -- The number of non-zero array values are now known so - ! -- ia and ja can be created from sparse. then destroy sparse - this%nja=this%sparse%nnz - call mem_allocate(this%ja, this%nja, 'JA', this%name) - call mem_allocate(this%amat, this%nja, 'AMAT', this%name) - call this%sparse%sort() - call this%sparse%filliaja(this%ia,this%ja,ierror) - call this%sparse%destroy() - ! - ! -- Create mapping arrays for each model. Mapping assumes - ! -- that each row has the diagonal in the first position, - ! -- however, rows do not need to be sorted. - do im=1,this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, im) - call mp%model_mc(this%ia, this%ja) - enddo - ! - ! -- Create arrays for mapping exchange connections to global solution - do ic=1,this%exchangelist%Count() - cp => GetNumericalExchangeFromList(this%exchangelist, ic) - call cp%exg_mc(this%ia, this%ja) - enddo - ! - ! -- return - return - end subroutine sln_connect - - subroutine sln_reset(this) -! ****************************************************************************** -! sln_reset -- Reset This Solution -! Reset this solution by setting amat and rhs to zero -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(NumericalSolutionType) :: this - ! -- local - integer(I4B) :: i - real(DP) :: zero = 0.d0 -! ------------------------------------------------------------------------------ - ! - do i=1,this%nja - this%amat(i) = zero - enddo - do i=1,this%neq - this%rhs(i) = zero - enddo - ! - ! -- return - return - end subroutine sln_reset -! - subroutine sln_ls(this, kiter, kstp, kper, in_iter, iptc, ptcf) -! ****************************************************************************** -! perform residual reduction and newton linearization and -! prepare for sparse solver, and check convergence of nonlinearities -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - class(NumericalSolutionType), intent(inout) :: this - integer(I4B), intent(in) :: kiter - integer(I4B), intent(in) :: kstp - integer(I4B), intent(in) :: kper - integer(I4B), intent(inout) :: in_iter - integer(I4B), intent(inout) :: iptc - real(DP), intent(in) :: ptcf - ! -- local - logical :: lsame - integer(I4B) :: n - integer(I4B) :: itestmat, i, i1, i2 - integer(I4B) :: iptct - integer(I4B) :: iallowptc - real(DP) :: adiag, diagval - real(DP) :: l2norm - real(DP) :: ptcval - real(DP) :: diagmin - real(DP) :: bnorm - character(len=50) :: fname - character(len=*), parameter :: fmtfname = "('mf6mat_', i0, '_', i0, & - &'_', i0, '_', i0, '.txt')" -! ------------------------------------------------------------------------------ - ! - ! -- take care of loose ends for all nodes before call to solver - do n = 1, this%neq - ! -- store x in temporary location - this%xtemp(n) = this%x(n) - ! -- set dirichlet boundary and no-flow condition - if (this%active(n) <= 0) then - this%amat(this%ia(n)) = DONE - this%rhs(n) = this%x(n) - i1 = this%ia(n) + 1 - i2 = this%ia(n + 1) - 1 - do i = i1, i2 - this%amat(i) = DZERO - enddo - else - ! -- take care of zero row diagonal - diagval = DONE - adiag = abs(this%amat(this%ia(n))) - if(adiag.lt.DEM15)then - this%amat(this%ia(n)) = diagval - this%rhs(n) = this%rhs(n) + this%x(n) * diagval - endif - endif - end do - ! -- pseudo transient continuation - ! - ! -- set iallowptc - ! -- no_ptc_option is FIRST - if (this%iallowptc < 0) then - if (kper > 1) then - iallowptc = 1 - else - iallowptc = 0 - end if - ! -- no_ptc_option is ALL (0) or using PTC (1) - else - iallowptc = this%iallowptc - end if - iptct = iptc * iallowptc - if (iptct /= 0) then - call this%sln_l2norm(this%neq, this%nja, & - this%ia, this%ja, this%active, & - this%amat, this%rhs, this%x, l2norm) - ! -- confirm that the l2norm exceeds previous l2norm - ! if not, there is no need to add ptc terms - if (kiter == 1) then - if (kper > 1 .or. kstp > 1) then - if (l2norm <= this%l2norm0) then - iptc = 0 - end if - end if - else - lsame = IS_SAME(l2norm, this%l2norm0) - if (lsame) then - iptc = 0 - end if - end if - end if - iptct = iptc * iallowptc - if (iptct /= 0) then - if (kiter == 1) then - if (this%iptcout > 0) then - write(this%iptcout, '(A10,6(1x,A15),2(1x,A15))') 'OUTER ITER', & - ' PTCDEL', ' L2NORM0', ' L2NORM', & - ' RHSNORM', ' 1/PTCDEL', ' DIAGONAL MIN.', & - ' RHSNORM/L2NORM', ' STOPPING CRIT.' - end if - if (this%ptcdel0 > DZERO) then - this%ptcdel = this%ptcdel0 - else - if (this%iptcopt == 0) then - ! - ! -- ptcf is the reciprocal of the pseudo-time step - this%ptcdel = DONE / ptcf - else - bnorm = DZERO - do n = 1, this%neq - if (this%active(n).gt.0) then - bnorm = bnorm + this%rhs(n) * this%rhs(n) - end if - end do - bnorm = sqrt(bnorm) - this%ptcdel = bnorm / l2norm - end if - end if - else - if (l2norm > DZERO) then - this%ptcdel = this%ptcdel * (this%l2norm0 / l2norm)**this%ptcexp - else - this%ptcdel = DZERO - end if - end if - if (this%ptcdel > DZERO) then - ptcval = DONE / this%ptcdel - else - ptcval = DONE - end if - diagmin = DEP20 - bnorm = DZERO - do n = 1, this%neq - if (this%active(n).gt.0) then - diagval = abs(this%amat(this%ia(n))) - bnorm = bnorm + this%rhs(n) * this%rhs(n) - if (diagval < diagmin) diagmin = diagval - this%amat(this%ia(n)) = this%amat(this%ia(n)) - ptcval - this%rhs(n) = this%rhs(n) - ptcval * this%x(n) - end if - end do - bnorm = sqrt(bnorm) - if (this%iptcout > 0) then - write(this%iptcout, '(i10,6(1x,e15.7),2(1x,f15.6))') & - kiter, this%ptcdel, this%l2norm0, l2norm, bnorm, & - ptcval, diagmin, bnorm/l2norm, ptcval / diagmin - end if - this%l2norm0 = l2norm - end if - ! - ! -- save rhs, amat to a file - ! to enable set itestmat to 1 and recompile - !------------------------------------------------------- - itestmat = 0 - if (itestmat == 1) then - write(fname, fmtfname) this%id, kper, kstp, kiter - print *, 'Saving amat to: ', trim(adjustl(fname)) - open(99,file=trim(adjustl(fname))) - WRITE(99,*)'NODE, RHS, AMAT FOLLOW' - DO N = 1, this%NEQ - I1 = this%IA(N) - I2 = this%IA(N+1)-1 - WRITE(99,'(*(G0,:,","))') N, this%RHS(N), (this%ja(i),i=i1,i2), & - (this%AMAT(I),I=I1,I2) - END DO - close(99) - !stop - end if - !------------------------------------------------------- - ! - ! call appropriate linear solver - ! call ims linear solver - if (this%linmeth == 1) then - call this%imslinear%imslinear_apply(this%icnvg, kstp, kiter, in_iter, & - this%nitermax, & - this%convnmod, this%convmodstart, & - this%locdv, this%locdr, & - this%caccel, this%itinner, & - this%convlocdv, this%convlocdr, & - this%dvmax, this%drmax, & - this%convdvmax, this%convdrmax) - end if - ! - ! ptc finalize - set ratio of ptc value added to the diagonal and the - ! minimum value on the diagonal. This value will be used - ! to determine if the make sure the ptc value has decayed - ! sufficiently - if (iptct /= 0) then - this%ptcrat = ptcval / diagmin - end if - ! - ! -- return - return - end subroutine sln_ls - - ! - subroutine sln_setouter(this, ifdparam) -! ****************************************************************************** -! sln_setouter -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(NumericalSolutionType), intent(inout) :: this - integer(I4B), intent(in) :: ifdparam -! ------------------------------------------------------------------------------ - ! - ! -- simple option - select case ( ifdparam ) - case ( 1 ) - this%hclose = dem3 - this%mxiter = 25 - this%nonmeth = 0 - this%theta = 1.0 - this%akappa = DZERO - this%gamma = DZERO - this%amomentum = DZERO - this%numtrack = 0 - this%btol = DZERO - this%breduc = DZERO - this%res_lim = DZERO - ! - ! -- moderate - case ( 2 ) - this%hclose = dem2 - this%mxiter = 50 - this%nonmeth = 3 - this%theta = 0.9d0 - this%akappa = 0.0001d0 - this%gamma = DZERO - this%amomentum = DZERO - this%numtrack = 0 - this%btol = DZERO - this%breduc = DZERO - this%res_lim = DZERO - ! - ! -- complex - case ( 3 ) - this%hclose = dem1 - this%mxiter = 100 - this%nonmeth = 3 - this%theta = 0.8d0 - this%akappa = 0.0001d0 - this%gamma = DZERO - this%amomentum = DZERO - this%numtrack = 20 - this%btol = 1.05d0 - this%breduc = 0.1d0 - this%res_lim = 0.002d0 - end select - ! - ! -- return - return - end subroutine sln_setouter - - subroutine sln_backtracking(this, mp, cp, kiter) -! ****************************************************************************** -! sln_backtracking -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(NumericalSolutionType), intent(inout) :: this - class(NumericalModelType), pointer :: mp - class(NumericalExchangeType), pointer :: cp - integer(I4B), intent(in) :: kiter - ! -- local - character(len=7) :: cmsg - integer(I4B) :: ic - integer(I4B) :: im - integer(I4B) :: nb - integer(I4B) :: btflag - integer(I4B) :: ibflag - integer(I4B) :: ibtcnt - real(DP) :: resin -! ------------------------------------------------------------------------------ - ! - ! -- initialize local variables - ibflag = 0 - ! - ! -- refill amat and rhs with standard conductance - ! -- Set amat and rhs to zero - call this%sln_reset() - ! - ! -- Calculate matrix coefficients (CF) for each exchange - do ic=1,this%exchangelist%Count() - cp => GetNumericalExchangeFromList(this%exchangelist, ic) - call cp%exg_cf(kiter) - end do - ! - ! -- Calculate matrix coefficients (CF) for each model - do im=1,this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, im) - call mp%model_cf(kiter) - end do - ! - ! -- Fill coefficients (FC) for each exchange - do ic=1,this%exchangelist%Count() - cp => GetNumericalExchangeFromList(this%exchangelist, ic) - call cp%exg_fc(kiter, this%ia, this%amat, 0) - end do - ! - ! -- Fill coefficients (FC) for each model - do im=1,this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, im) - call mp%model_fc(kiter, this%amat, this%nja, 0) - end do - ! - ! -- calculate initial l2 norm - if (kiter == 1) then - call this%sln_l2norm(this%neq, this%nja, & - this%ia, this%ja, this%active, & - this%amat, this%rhs, this%x, this%res_prev) - resin = this%res_prev - ibflag = 0 - else - call this%sln_l2norm(this%neq, this%nja, & - this%ia, this%ja, this%active, & - this%amat, this%rhs, this%x, this%res_new) - resin = this%res_new - end if - ibtcnt = 0 - if (kiter > 1) then - if (this%res_new > this%res_prev * this%btol) then - ! - ! -- iterate until backtracking complete - btloop: do nb = 1, this%numtrack - ! - ! -- backtrack heads - call this%sln_backtracking_xupdate(btflag) - ! - ! -- head change less than hclose - if (btflag == 0) then - ibflag = 4 - exit btloop - end if - ! - ibtcnt = nb - ! - ! -- Set amat and rhs to zero - call this%sln_reset() - ! - ! -- Calculate matrix coefficients (CF) for each exchange - do ic=1,this%exchangelist%Count() - cp => GetNumericalExchangeFromList(this%exchangelist, ic) - call cp%exg_cf(kiter) - end do - ! - ! -- Calculate matrix coefficients (CF) for each model - do im=1,this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, im) - call mp%model_cf(kiter) - end do - ! - ! -- Fill coefficients (FC) for each exchange - do ic=1,this%exchangelist%Count() - cp => GetNumericalExchangeFromList(this%exchangelist, ic) - call cp%exg_fc(kiter, this%ia, this%amat, 0) - end do - ! - ! -- Fill coefficients (FC) for each model - do im=1,this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, im) - call mp%model_fc(kiter, this%amat, this%nja, 0) - end do - ! - ! -- calculate updated l2norm - call this%sln_l2norm(this%neq, this%nja, & - this%ia, this%ja, this%active, & - this%amat, this%rhs, this%x, this%res_new) - ! - ! -- evaluate if back tracking can be terminated - if (nb == this%numtrack) then - ibflag = 2 - exit btloop - end if - if (this%res_new < this%res_prev * this%btol) then - ibflag = 1 - exit btloop - end if - if (this%res_new < this%res_lim) then - exit btloop - end if - end do btloop - end if - ! -- save new residual - this%res_prev = this%res_new - end if - ! - ! -- write back backtracking results - if (this%iprims > 0) then - if (ibtcnt > 0) then - cmsg = ' ' - else - cmsg = '*' - end if - ! - ! -- add data to outertab - call this%outertab%add_term( 'Backtracking') - call this%outertab%add_term(kiter) - call this%outertab%add_term(' ') - if (this%numtrack > 0) then - call this%outertab%add_term(ibflag) - call this%outertab%add_term(ibtcnt) - call this%outertab%add_term(resin) - call this%outertab%add_term(this%res_prev) - end if - call this%outertab%add_term(' ') - call this%outertab%add_term(cmsg) - call this%outertab%add_term(' ') - end if - ! - ! -- return - return - end subroutine sln_backtracking - - subroutine sln_backtracking_xupdate(this, btflag) -! ****************************************************************************** -! sln_backtracking_xupdate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(NumericalSolutionType), intent(inout) :: this - integer(I4B), intent(inout) :: btflag - ! -- local - integer(I4B) :: n - real(DP) :: delx - real(DP) :: absdelx - real(DP) :: chmax -! ------------------------------------------------------------------------------ - ! - btflag = 0 - ! no backtracking if maximum change is less than closure so return - chmax = 0.0 - do n=1, this%neq - if (this%active(n) < 1) cycle - delx = this%breduc*(this%x(n) - this%xtemp(n)) - absdelx = abs(delx) - if(absdelx > chmax) chmax = absdelx - end do - ! perform backtracking if free of constraints and set counter and flag - if (chmax >= this%hclose) then - btflag = 1 - do n = 1, this%neq - if (this%active(n) < 1) cycle - delx = this%breduc*(this%x(n) - this%xtemp(n)) - this%x(n) = this%xtemp(n) + delx - end do - end if - ! - ! -- return - return - end subroutine sln_backtracking_xupdate - - subroutine sln_l2norm(this, neq, nja, ia, ja, active, amat, rhs, x, resid) -! ****************************************************************************** -! sln_l2norm -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(NumericalSolutionType), intent(inout) :: this - integer(I4B), intent(in) :: neq - integer(I4B), intent(in) :: nja - integer(I4B), dimension(neq+1), intent(in) :: ia - integer(I4B), dimension(nja), intent(in) :: ja - integer(I4B), dimension(neq), intent(in) :: active - real(DP), dimension(nja), intent(in) :: amat - real(DP), dimension(neq), intent(in) :: rhs - real(DP), dimension(neq), intent(in) :: x - real(DP), intent(inout) :: resid - ! -- local - integer(I4B) :: n - integer(I4B) :: j, jcol - real(DP) :: rowsum -! ------------------------------------------------------------------------------ - ! - resid = DZERO - do n = 1, neq - if (active(n) > 0) then - rowsum = DZERO - do j = ia(n), ia(n+1)-1 - jcol = ja(j) - rowsum = rowsum + amat(j) * x(jcol) - end do - ! compute mean square residual from q of each node - resid = resid + (rowsum - rhs(n))**2 - end if - end do - ! -- l2norm is the square root of the sum of the square of the residuals - resid = sqrt(resid) - ! - ! -- return - return - end subroutine sln_l2norm - - subroutine sln_maxval(this, neq, v, vnorm) -! ****************************************************************************** -! sln_maxval -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(NumericalSolutionType), intent(inout) :: this - integer(I4B), intent(in) :: neq - real(DP), dimension(neq), intent(in) :: v - real(DP), intent(inout) :: vnorm - ! -- local - integer(I4B) :: n - real(DP) :: d - real(DP) :: denom - real(DP) :: dnorm -! ------------------------------------------------------------------------------ - vnorm = v(1) - do n = 2, neq - d = v(n) - denom = abs(vnorm) - if (denom == DZERO) then - denom = DPREC - end if - ! - ! -- calculate normalized value - dnorm = abs(d) / denom - if (dnorm > DONE) then - vnorm = d - end if - end do - ! - ! -- return - return - end subroutine sln_maxval - - subroutine sln_calcdx(this, neq, active, x, xtemp, dx) -! ****************************************************************************** -! sln_calcdx -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(NumericalSolutionType), intent(inout) :: this - integer(I4B), intent(in) :: neq - integer(I4B), dimension(neq), intent(in) :: active - real(DP), dimension(neq), intent(in) :: x - real(DP), dimension(neq), intent(in) :: xtemp - real(DP), dimension(neq), intent(inout) :: dx - ! -- local - integer(I4B) :: n -! ------------------------------------------------------------------------------ - do n = 1, neq - ! -- skip inactive nodes - if (active(n) < 1) then - dx(n) = DZERO - else - dx(n) = x(n) - xtemp(n) - end if - end do - ! - ! -- return - return - end subroutine sln_calcdx - - - subroutine sln_underrelax(this, kiter, bigch, neq, active, x, xtemp) -! ****************************************************************************** -! under relax using delta-bar-delta or cooley formula -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(NumericalSolutionType), intent(inout) :: this - integer(I4B), intent(in) :: kiter - real(DP), intent(in) :: bigch - integer(I4B), intent(in) :: neq - integer(I4B), dimension(neq), intent(in) :: active - real(DP), dimension(neq), intent(inout) :: x - real(DP), dimension(neq), intent(in) :: xtemp - ! -- local - real(DP) :: ww, delx, relax, es, aes, amom - integer(I4B) :: n -! ------------------------------------------------------------------------------ - ! - ! -- option for using simple dampening (as done by MODFLOW-2005 PCG) - if (this%nonmeth == 1) then - do n = 1, neq - ! -- skip inactive nodes - if (active(n) < 1) cycle - ! - ! -- compute step-size (delta x) - delx = x(n) - xtemp(n) - this%dxold(n) = delx - - ! -- dampen head solution - x(n) = xtemp(n) + this%gamma * delx - end do - ! - ! -- option for using cooley underrelaxation - else if (this%nonmeth == 2) then - if (kiter == 1) then - relax = done - this%relaxold = DONE - this%bigch = bigch - this%bigchold = bigch - else - ! -- compute relaxation factor - es = this%bigch / (this%bigchold * this%relaxold) - aes = abs(es) - if (es < -DONE) then - relax = dhalf / aes - else - relax = (DTHREE + es) / (DTHREE + aes) - end if - end if - this%relaxold = relax - ! - ! -- modify cooley to use exponential average of past changes - this%bigchold = (DONE - this%gamma) * this%bigch + this%gamma * & - this%bigchold - ! -- this method does it right after newton - need to do it after - ! underrelaxation and backtracking. - ! - ! -- compute new head after under-relaxation - if (relax < DONE) then - do n = 1, neq - if (active(n) < 1) cycle - delx = x(n) - xtemp(n) - this%dxold(n) = delx - x(n) = xtemp(n) + relax * delx - end do - end if - ! - ! -- option for using delta-bar-delta scheme to under-relax for all equations - else if (this%nonmeth == 3) then - do n = 1, neq - ! -- skip inactive nodes - if (active(n) < 1) cycle - ! - ! -- compute step-size (delta x) and initialize d-b-d parameters - delx = x(n) - xtemp(n) - - if ( kiter == 1 ) then - this%wsave(n) = DONE - this%hchold(n) = DEM20 - this%deold(n) = DZERO - end if - ! - ! -- compute new relaxation term as per delta-bar-delta - ww = this%wsave(n) - - ! for flip-flop condition, decrease factor - if ( this%deold(n)*delx < DZERO ) then - ww = this%theta * this%wsave(n) - ! -- when change is of same sign, increase factor - else - ww = this%wsave(n) + this%akappa - end if - if ( ww > DONE ) ww = DONE - this%wsave(n) = ww - - ! -- compute exponential average of past changes in hchold - if (kiter == 1) then - ! -- this method does it right after newton - ! -- need to do it after underrelaxation and backtracking. - this%hchold(n) = delx - else - this%hchold(n) = (DONE - this%gamma) * delx + & - this%gamma * this%hchold(n) - end if - ! - ! -- store slope (change) term for next iteration - this%deold(n) = delx - this%dxold(n) = delx - ! - ! -- compute accepted step-size and new head - amom = DZERO - if (kiter > 4) amom = this%amomentum - delx = delx * ww + amom * this%hchold(n) - x(n) = xtemp(n) + delx - end do - ! - end if - ! - ! -- return - return - end subroutine sln_underrelax - - subroutine sln_outer_check(this, hncg, lrch) -! ****************************************************************************** -! sln_outer_check -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(NumericalSolutionType), intent(inout) :: this - real(DP), intent(inout) :: hncg - integer(I4B), intent(inout) :: lrch - ! -- local - integer(I4B) :: nb - real(DP) :: bigch - real(DP) :: abigch - integer(I4B) :: n - real(DP) :: hdif - real(DP) :: ahdif -! ------------------------------------------------------------------------------ - ! - nb = 1 - bigch = DZERO - abigch = DZERO - do n = 1, this%neq - if(this%active(n) < 1) cycle - hdif = this%x(n) - this%xtemp(n) - ahdif = abs(hdif) - if (ahdif >= abigch) then - bigch = hdif - abigch = ahdif - nb = n - end if - end do - ! - !-----store maximum change value and location - hncg = bigch - lrch = nb - ! - ! -- return - return - end subroutine sln_outer_check - - subroutine sln_get_loc(this, nodesln, str) -! ****************************************************************************** -! sln_get_loc -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(NumericalSolutionType), intent(inout) :: this - integer(I4B), intent(in) :: nodesln - character(len=*), intent(inout) :: str - ! -- local - class(NumericalModelType),pointer :: mp - integer(I4B) :: i - integer(I4B) :: istart - integer(I4B) :: iend - integer(I4B) :: noder -! ------------------------------------------------------------------------------ - ! - ! -- calculate and set offsets - noder = 0 - str = '' - do i = 1, this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, i) - call mp%get_mrange(istart, iend) - if (nodesln >= istart .and. nodesln <= iend) then - noder = nodesln - istart + 1 - call mp%get_mcellid(noder, str) - exit - end if - end do - ! - ! -- return - return - end subroutine sln_get_loc - - subroutine sln_get_nodeu(this, nodesln, im, nodeu) -! ****************************************************************************** -! sln_get_nodeu -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(NumericalSolutionType), intent(inout) :: this - integer(I4B), intent(in) :: nodesln - integer(I4B), intent(inout) :: im - integer(I4B), intent(inout) :: nodeu - ! -- local - class(NumericalModelType),pointer :: mp - integer(I4B) :: i - integer(I4B) :: istart - integer(I4B) :: iend - integer(I4B) :: noder -! ------------------------------------------------------------------------------ - ! - ! -- calculate and set offsets - noder = 0 - do i = 1, this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, i) - call mp%get_mrange(istart, iend) - if (nodesln >= istart .and. nodesln <= iend) then - noder = nodesln - istart + 1 - call mp%get_mnodeu(noder, nodeu) - im = i - exit - end if - end do - ! - ! -- return - return - end subroutine sln_get_nodeu - - function CastAsNumericalSolutionClass(obj) result (res) - implicit none - class(*), pointer, intent(inout) :: obj - class(NumericalSolutionType), pointer :: res - ! - res => null() - if (.not. associated(obj)) return - ! - select type (obj) - class is (NumericalSolutionType) - res => obj - end select - return - end function CastAsNumericalSolutionClass - - function GetNumericalSolutionFromList(list, idx) result (res) - implicit none - ! -- dummy - type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx - class(NumericalSolutionType), pointer :: res - ! -- local - class(*), pointer :: obj - ! - obj => list%GetItem(idx) - res => CastAsNumericalSolutionClass(obj) - ! - return - end function GetNumericalSolutionFromList - - - -end module NumericalSolutionModule +! This is the numerical solution module. + +module NumericalSolutionModule + use KindModule, only: DP, I4B + use TimerModule, only: code_timer + use ConstantsModule, only: LINELENGTH, LENSOLUTIONNAME, LENPAKLOC, & + DPREC, DZERO, DEM20, DEM15, DEM6, & + DEM4, DEM3, DEM2, DEM1, DHALF, & + DONE, DTHREE, DEP6, DEP20, DNODATA, & + TABLEFT, TABRIGHT + use TableModule, only: TableType, table_cr + use GenericUtilitiesModule, only: IS_SAME, sim_message, stop_with_error + use VersionModule, only: IDEVELOPMODE + use BaseModelModule, only: BaseModelType + use BaseSolutionModule, only: BaseSolutionType, AddBaseSolutionToList + use ListModule, only: ListType + use ListsModule, only: basesolutionlist + use NumericalModelModule, only: NumericalModelType, & + AddNumericalModelToList, & + GetNumericalModelFromList + use NumericalExchangeModule, only: NumericalExchangeType, & + AddNumericalExchangeToList, & + GetNumericalExchangeFromList + use SparseModule, only: sparsematrix + use SimVariablesModule, only: iout + use BlockParserModule, only: BlockParserType + use IMSLinearModule + + implicit none + private + + public :: solution_create + + ! expose for use in the bmi++ + public :: NumericalSolutionType + public :: GetNumericalSolutionFromList + public :: prepareIteration, doIteration, finalizeIteration + + type, extends(BaseSolutionType) :: NumericalSolutionType + character(len=LINELENGTH) :: fname + type(ListType) :: modellist + type(ListType) :: exchangelist + integer(I4B), pointer :: id + integer(I4B), pointer :: iu + real(DP), pointer :: ttform + real(DP), pointer :: ttsoln + integer(I4B), pointer :: neq => NULL() + integer(I4B), pointer :: nja => NULL() + integer(I4B), dimension(:), pointer, contiguous :: ia => NULL() + integer(I4B), dimension(:), pointer, contiguous :: ja => NULL() + real(DP), dimension(:), pointer, contiguous :: amat => NULL() + real(DP), dimension(:), pointer, contiguous :: rhs => NULL() + real(DP), dimension(:), pointer, contiguous :: x => NULL() + integer(I4B), dimension(:), pointer, contiguous :: active => NULL() + real(DP), dimension(:), pointer, contiguous :: xtemp => NULL() + type(BlockParserType) :: parser + ! + ! -- sparse matrix data + real(DP), pointer :: theta => NULL() + real(DP), pointer :: akappa => NULL() + real(DP), pointer :: gamma => NULL() + real(DP), pointer :: amomentum => NULL() + real(DP), pointer :: breduc => NULL() + real(DP), pointer :: btol => NULL() + real(DP), pointer :: res_lim => NULL() + real(DP), pointer :: hclose => NULL() + real(DP), pointer :: hiclose => NULL() + real(DP), pointer :: bigchold => NULL() + real(DP), pointer :: bigch => NULL() + real(DP), pointer :: relaxold => NULL() + real(DP), pointer :: res_prev => NULL() + real(DP), pointer :: res_new => NULL() + real(DP), pointer :: res_in => NULL() + integer(I4B), pointer :: ibcount => NULL() + integer(I4B), pointer :: icnvg => NULL() + integer(I4B), pointer :: itertot => NULL() ! total nr. of linear solves per call to sln_ca + integer(I4B), pointer :: mxiter => NULL() + integer(I4B), pointer :: linmeth => NULL() + integer(I4B), pointer :: nonmeth => NULL() + integer(I4B), pointer :: numtrack => NULL() + integer(I4B), pointer :: iprims => NULL() + integer(I4B), pointer :: ibflag => NULL() + integer(I4B), dimension(:,:), pointer, contiguous :: lrch => NULL() + real(DP), dimension(:), pointer, contiguous :: hncg => NULL() + real(DP), dimension(:), pointer, contiguous :: dxold => NULL() + real(DP), dimension(:), pointer, contiguous :: deold => NULL() + real(DP), dimension(:), pointer, contiguous :: wsave => NULL() + real(DP), dimension(:), pointer, contiguous :: hchold => NULL() + ! + ! -- convergence summary information + character(len=31), dimension(:), pointer, contiguous :: caccel => NULL() + integer(I4B), pointer :: icsvout => NULL() + integer(I4B), pointer :: nitermax => NULL() + integer(I4B), pointer :: nitercnt => NULL() + integer(I4B), pointer :: convnmod => NULL() + integer(I4B), dimension(:), pointer, contiguous :: convmodstart => NULL() + integer(I4B), dimension(:), pointer, contiguous :: locdv => NULL() + integer(I4B), dimension(:), pointer, contiguous :: locdr => NULL() + integer(I4B), dimension(:), pointer, contiguous :: itinner => NULL() + integer(I4B), pointer, dimension(:,:), contiguous :: convlocdv => NULL() + integer(I4B), pointer, dimension(:,:), contiguous :: convlocdr => NULL() + real(DP), dimension(:), pointer, contiguous :: dvmax => NULL() + real(DP), dimension(:), pointer, contiguous :: drmax => NULL() + real(DP), pointer, dimension(:,:), contiguous :: convdvmax => NULL() + real(DP), pointer, dimension(:,:), contiguous :: convdrmax => NULL() + ! + ! -- pseudo-transient continuation + integer(I4B), pointer :: iallowptc => NULL() + integer(I4B), pointer :: iptcopt => NULL() + integer(I4B), pointer :: iptcout => NULL() + real(DP), pointer :: l2norm0 => NULL() + real(DP), pointer :: ptcfact => NULL() + real(DP), pointer :: ptcdel => NULL() + real(DP), pointer :: ptcdel0 => NULL() + real(DP), pointer :: ptcexp => NULL() + real(DP), pointer :: ptcthresh => NULL() + real(DP), pointer :: ptcrat => NULL() + ! + ! -- linear accelerator storage + type(IMSLINEAR_DATA), POINTER :: imslinear => NULL() + ! + ! -- sparse object + type(sparsematrix) :: sparse + ! + ! -- table objects + type(TableType), pointer :: innertab => null() + type(TableType), pointer :: outertab => null() + + contains + procedure :: sln_df + procedure :: sln_ar + procedure :: sln_rp + procedure :: sln_ot + procedure :: sln_ca + procedure :: sln_fp + procedure :: sln_da + procedure :: addmodel + procedure :: addexchange + procedure :: slnassignexchanges + procedure :: save + + procedure, private :: sln_connect + procedure, private :: sln_reset + procedure, private :: sln_ls + procedure, private :: sln_setouter + procedure, private :: sln_backtracking + procedure, private :: sln_backtracking_xupdate + procedure, private :: sln_l2norm + procedure, private :: sln_maxval + procedure, private :: sln_calcdx + procedure, private :: sln_underrelax + procedure, private :: sln_outer_check + procedure, private :: sln_get_loc + procedure, private :: sln_get_nodeu + procedure, private :: allocate_scalars + procedure, private :: allocate_arrays + procedure, private :: convergence_summary + procedure, private :: csv_convergence_summary + + ! for BMI refactoring: + procedure, public :: prepareIteration + procedure, public :: doIteration + procedure, public :: finalizeIteration + procedure, private :: writeCSVHeader + procedure, private :: writePTCInfoToFile + procedure, private :: advanceSolution + + end type NumericalSolutionType + +contains + + subroutine solution_create(filename, id) +! ****************************************************************************** +! solution_create -- Create a New Solution +! Using the data in filename, assign this new solution an id number and store +! the solution in the basesolutionlist. +! Subroutine: (1) allocate solution and assign id and name +! (2) open the filename for later reading +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimVariablesModule, only: iout + use InputOutputModule, only: getunit, openfile + ! -- dummy + character(len=*),intent(in) :: filename + integer(I4B),intent(in) :: id + ! -- local + integer(I4B) :: inunit + type(NumericalSolutionType), pointer :: solution => null() + class(BaseSolutionType), pointer :: solbase => null() + character(len=LENSOLUTIONNAME) :: solutionname +! ------------------------------------------------------------------------------ + ! + ! -- Create a new solution and add it to the basesolutionlist container + allocate(solution) + solbase => solution + write(solutionname,'(a, i0)') 'SLN_', id + call solution%allocate_scalars(solutionname) + call AddBaseSolutionToList(basesolutionlist, solbase) + ! + solution%id = id + ! + ! -- Open solution input file for reading later after problem size is known + ! Check to see if the file is already opened, which can happen when + ! running in single model mode + inquire(file=filename, number=inunit) + + if(inunit < 0) inunit = getunit() + solution%iu = inunit + write(iout,'(/a,a)') ' Creating solution: ', solution%name + call openfile(solution%iu, iout, filename, 'IMS') + ! + ! -- Initialize block parser + call solution%parser%Initialize(solution%iu, iout) + ! + ! -- return + return + end subroutine solution_create + + subroutine allocate_scalars(this, solutionname) +! ****************************************************************************** +! allocate_scalars -- Allocate scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(NumericalSolutionType) :: this + character(len=*), intent(in) :: solutionname + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- set value for solution name, which is a member of the base solution + this%name = solutionname + ! + ! -- allocate scalars + call mem_allocate(this%id, 'ID', solutionname) + call mem_allocate(this%iu, 'IU', solutionname) + call mem_allocate(this%ttform, 'TTFORM', solutionname) + call mem_allocate(this%ttsoln, 'TTSOLN', solutionname) + call mem_allocate(this%neq, 'NEQ', solutionname) + call mem_allocate(this%nja, 'NJA', solutionname) + call mem_allocate(this%hclose, 'HCLOSE', solutionname) + call mem_allocate(this%hiclose, 'HICLOSE', solutionname) + call mem_allocate(this%bigchold, 'BIGCHOLD', solutionname) + call mem_allocate(this%bigch, 'BIGCH', solutionname) + call mem_allocate(this%relaxold, 'RELAXOLD', solutionname) + call mem_allocate(this%res_prev, 'RES_PREV', solutionname) + call mem_allocate(this%res_new, 'RES_NEW', solutionname) + call mem_allocate(this%res_in, 'RES_IN', solutionname) + call mem_allocate(this%ibcount, 'IBCOUNT', solutionname) + call mem_allocate(this%icnvg, 'ICNVG', solutionname) + call mem_allocate(this%itertot, 'ITERTOT', solutionname) + call mem_allocate(this%mxiter, 'MXITER', solutionname) + call mem_allocate(this%linmeth, 'LINMETH', solutionname) + call mem_allocate(this%nonmeth, 'NONMETH', solutionname) + call mem_allocate(this%iprims, 'IPRIMS', solutionname) + call mem_allocate(this%theta, 'THETA', solutionname) + call mem_allocate(this%akappa, 'AKAPPA', solutionname) + call mem_allocate(this%gamma, 'GAMMA', solutionname) + call mem_allocate(this%amomentum, 'AMOMENTUM', solutionname) + call mem_allocate(this%breduc, 'BREDUC', solutionname) + call mem_allocate(this%btol, 'BTOL', solutionname) + call mem_allocate(this%res_lim, 'RES_LIM', solutionname) + call mem_allocate(this%numtrack, 'NUMTRACK', solutionname) + call mem_allocate(this%ibflag, 'IBFLAG', solutionname) + call mem_allocate(this%icsvout, 'ICSVOUT', solutionname) + call mem_allocate(this%nitermax, 'NITERMAX', solutionname) + call mem_allocate(this%nitercnt, 'NITERCNT', solutionname) + call mem_allocate(this%convnmod, 'CONVNMOD', solutionname) + call mem_allocate(this%iallowptc, 'IALLOWPTC', solutionname) + call mem_allocate(this%iptcopt, 'IPTCOPT', solutionname) + call mem_allocate(this%iptcout, 'IPTCOUT', solutionname) + call mem_allocate(this%l2norm0, 'L2NORM0', solutionname) + call mem_allocate(this%ptcfact, 'PTCFACT', solutionname) + call mem_allocate(this%ptcdel, 'PTCDEL', solutionname) + call mem_allocate(this%ptcdel0, 'PTCDEL0', solutionname) + call mem_allocate(this%ptcexp, 'PTCEXP', solutionname) + call mem_allocate(this%ptcthresh, 'PTCTHRESH', solutionname) + call mem_allocate(this%ptcrat, 'PTCRAT', solutionname) + ! + ! -- initialize + this%id = 0 + this%iu = 0 + this%ttform = DZERO + this%ttsoln = DZERO + this%neq = 0 + this%nja = 0 + this%hclose = DZERO + this%hiclose = DZERO + this%bigchold = DZERO + this%bigch = DZERO + this%relaxold = DZERO + this%res_prev = DZERO + this%res_in = DZERO + this%ibcount = 0 + this%icnvg = 0 + this%itertot = 0 + this%mxiter = 0 + this%linmeth = 1 + this%nonmeth = 0 + this%iprims = 0 + this%theta = DZERO + this%akappa = DZERO + this%gamma = DZERO + this%amomentum = DZERO + this%breduc = DZERO + this%btol = 0 + this%res_lim = DZERO + this%numtrack = 0 + this%ibflag = 0 + this%icsvout = 0 + this%nitermax = 0 + this%nitercnt = 0 + this%convnmod = 0 + this%iallowptc = 1 + this%iptcopt = 0 + this%iptcout = 0 + this%l2norm0 = DZERO + this%ptcfact = dem1 + this%ptcdel = DZERO + this%ptcdel0 = DZERO + this%ptcexp = done + this%ptcthresh = DEM3 + this%ptcrat = DZERO + ! + ! -- return + return + end subroutine allocate_scalars + + subroutine allocate_arrays(this) +! ****************************************************************************** +! allocate_arrays -- Allocate arrays +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(NumericalSolutionType) :: this + ! -- local + class(NumericalModelType), pointer :: mp + integer(I4B) :: i + integer(I4B) :: ieq +! ------------------------------------------------------------------------------ + ! + ! -- initialize the number of models in the solution + this%convnmod = this%modellist%Count() + ! + ! -- allocate arrays + call mem_allocate(this%ia, this%neq + 1, 'IA', this%name) + call mem_allocate(this%x, this%neq, 'X', this%name) + call mem_allocate(this%rhs, this%neq, 'RHS', this%name) + call mem_allocate(this%active, this%neq, 'IACTIVE', this%name) + call mem_allocate(this%xtemp, this%neq, 'XTEMP', this%name) + call mem_allocate(this%dxold, this%neq, 'DXOLD', this%name) + call mem_allocate(this%hncg, 0, 'HNCG', this%name) + call mem_allocate(this%lrch, 3, 0, 'LRCH', this%name) + call mem_allocate(this%wsave, 0, 'WSAVE', this%name) + call mem_allocate(this%hchold, 0, 'HCHOLD', this%name) + call mem_allocate(this%deold, 0, 'DEOLD', this%name) + call mem_allocate(this%convmodstart, this%convnmod+1, 'CONVMODSTART', this%name) + call mem_allocate(this%locdv, this%convnmod, 'LOCDV', this%name) + call mem_allocate(this%locdr, this%convnmod, 'LOCDR', this%name) + call mem_allocate(this%itinner, 0, 'ITINNER', this%name) + call mem_allocate(this%convlocdv, this%convnmod, 0, 'CONVLOCDV', this%name) + call mem_allocate(this%convlocdr, this%convnmod, 0, 'CONVLOCDR', this%name) + call mem_allocate(this%dvmax, this%convnmod, 'DVMAX', this%name) + call mem_allocate(this%drmax, this%convnmod, 'DRMAX', this%name) + call mem_allocate(this%convdvmax, this%convnmod, 0, 'CONVDVMAX', this%name) + call mem_allocate(this%convdrmax, this%convnmod, 0, 'CONVDRMAX', this%name) + ! + ! -- initialize allocated arrays + do i = 1, this%neq + this%x(i) = DZERO + this%xtemp(i) = DZERO + this%dxold(i) = DZERO + this%active(i) = 1 !default is active + enddo + ! + ! -- initialize convmodstart + ieq = 1 + this%convmodstart(1) = ieq + do i = 1, this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, i) + ieq = ieq + mp%neq + this%convmodstart(i+1) = ieq + end do + ! + ! -- return + return + end subroutine allocate_arrays + + subroutine sln_df(this) +! ****************************************************************************** +! sln_df -- Define the solution +! Must be called after the models and exchanges have been added to solution. +! Subroutine: (1) Allocate neq and nja +! (2) Assign model offsets and solution ids +! (3) Allocate and initialize the solution arrays +! (4) Point each model's x and rhs arrays +! (5) Initialize the sparsematrix instance +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(NumericalSolutionType) :: this + ! -- local + class(NumericalModelType), pointer :: mp + integer(I4B) :: i + integer(I4B), allocatable, dimension(:) :: rowmaxnnz +! ------------------------------------------------------------------------------ + ! + ! -- calculate and set offsets + do i = 1, this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, i) + call mp%set_idsoln(this%id) + call mp%set_moffset(this%neq) + this%neq = this%neq + mp%neq + enddo + ! + ! -- Allocate and initialize solution arrays + call this%allocate_arrays() + ! + ! -- Go through each model and point x, ibound, and rhs to solution + do i = 1, this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, i) + call mp%set_xptr(this%x) + call mp%set_rhsptr(this%rhs) + call mp%set_iboundptr(this%active) + enddo + ! + ! -- Create the sparsematrix instance + allocate(rowmaxnnz(this%neq)) + do i=1,this%neq + rowmaxnnz(i)=4 + enddo + call this%sparse%init(this%neq, this%neq, rowmaxnnz) + deallocate(rowmaxnnz) + ! + ! -- Assign connections, fill ia/ja, map connections + call this%sln_connect() + ! + ! -- return + return + end subroutine sln_df + + subroutine sln_ar(this) +! ****************************************************************************** +! sln_ar -- Allocate and Read +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_reallocate + use SimVariablesModule, only: iout + use SimModule, only: ustop, store_error, count_errors + use InputOutputModule, only: getunit, openfile + ! -- dummy + class(NumericalSolutionType) :: this + ! -- local + class(NumericalModelType), pointer :: mp + class(NumericalExchangeType), pointer :: cp + integer(I4B) :: i + integer(I4B) :: im + integer(I4B) :: ifdparam, mxvl, npp + integer(I4B) :: imslinear + character(len=linelength) :: errmsg, keyword, fname + character(len=linelength) :: msg + integer(I4B) :: isymflg=1 + integer(I4B) :: ierr + logical :: isfound, endOfBlock + integer(I4B) :: ival + real(DP) :: rval + character(len=*),parameter :: fmtcsvout = & + "(4x, 'CSV OUTPUT WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" + character(len=*),parameter :: fmtptcout = & + "(4x, 'PTC OUTPUT WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" + character(len=*), parameter :: fmterrasym = & + "(a,' **',a,'** PRODUCES AN ASYMMETRIC COEFFICIENT MATRIX, BUT THE & + &CONJUGATE GRADIENT METHOD WAS SELECTED. USE BICGSTAB INSTEAD. ')" +! ------------------------------------------------------------------------------ + ! + ! identify package and initialize. + WRITE(IOUT,1) this%iu +00001 FORMAT(1X,/1X,'IMS -- ITERATIVE MODEL SOLUTION PACKAGE, VERSION 6', & + & ', 4/28/2017',/,9X,'INPUT READ FROM UNIT',I5) + ! + ! -- initialize + i = 1 + ifdparam = 1 + npp = 0 + mxvl = 0 + ! + ! -- get options block + call this%parser%GetBlock('OPTIONS', isfound, ierr, & + supportOpenClose=.true., blockRequired=.false.) + ! + ! -- parse options block if detected + if (isfound) then + write(iout,'(/1x,a)')'PROCESSING IMS OPTIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('PRINT_OPTION') + call this%parser%GetStringCaps(keyword) + if (keyword.eq.'NONE') then + this%iprims = 0 + else if (keyword.eq.'SUMMARY') then + this%iprims = 1 + else if (keyword.eq.'ALL') then + this%iprims = 2 + else + write(errmsg,'(4x,a,a)') 'IMS sln_ar: UNKNOWN IMS PRINT OPTION: ', & + trim(keyword) + call store_error(errmsg) + end if + case ('COMPLEXITY') + call this%parser%GetStringCaps(keyword) + if (keyword.eq.'SIMPLE') then + ifdparam = 1 + WRITE(IOUT,21) + else if (keyword.eq.'MODERATE') then + ifdparam = 2 + WRITE(IOUT,23) + else if (keyword.eq.'COMPLEX') then + ifdparam = 3 + WRITE(IOUT,25) + else + write(errmsg,'(4x,a,a)') & + 'IMS sln_ar: UNKNOWN IMS COMPLEXITY OPTION: ', & + trim(keyword) + call store_error(errmsg) + end if + case ('CSV_OUTPUT') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%icsvout = getunit() + call openfile(this%icsvout, iout, fname, 'CSV_OUTPUT', & + filstat_opt='REPLACE') + write(iout,fmtcsvout) trim(fname), this%icsvout + else + write(errmsg,'(4x,a)') 'IMS sln_ar: OPTIONAL CSV_OUTPUT ' // & + 'KEYWORD MUST BE FOLLOWED BY FILEOUT' + call store_error(errmsg) + end if + case ('NO_PTC') + call this%parser%GetStringCaps(keyword) + select case(keyword) + case ('ALL') + ival = 0 + msg = 'ALL' + case ('FIRST') + ival = -1 + msg = 'THE FIRST' + case default + ival = 0 + msg = 'ALL' + end select + this%iallowptc = ival + write(IOUT,'(1x,A)') 'PSEUDO-TRANSIENT CONTINUATION DISABLED FOR' // & + ' ' // trim(adjustl(msg)) // ' STRESS-PERIOD(S)' + ! + ! -- right now these 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_PTC') + call this%parser%DevOpt() + this%iallowptc = 1 + write(IOUT,'(1x,A)') 'PSEUDO-TRANSIENT CONTINUATION ENABLED' + case('DEV_PTC_OUTPUT') + call this%parser%DevOpt() + this%iallowptc = 1 + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%iptcout = getunit() + call openfile(this%iptcout, iout, fname, 'PTC-OUT', & + filstat_opt='REPLACE') + write(iout,fmtptcout) trim(fname), this%iptcout + else + write(errmsg,'(4x,a)') 'IMS sln_ar: OPTIONAL PTC_OUTPUT ' // & + 'KEYWORD MUST BE FOLLOWED BY FILEOUT' + call store_error(errmsg) + end if + case ('DEV_PTC_OPTION') + call this%parser%DevOpt() + this%iallowptc = 1 + this%iptcopt = 1 + write(IOUT,'(1x,A)') & + 'PSEUDO-TRANSIENT CONTINUATION USES BNORM AND L2NORM TO ' // & + 'SET INITIAL VALUE' + case ('DEV_PTC_EXPONENT') + call this%parser%DevOpt() + rval = this%parser%GetDouble() + if (rval < DZERO) then + write(errmsg,'(4x,a)') 'IMS sln_ar: PTC_EXPONENT MUST BE > 0.' + call store_error(errmsg) + else + this%iallowptc = 1 + this%ptcexp = rval + write(IOUT,'(1x,A,1x,g15.7)') & + 'PSEUDO-TRANSIENT CONTINUATION EXPONENT', this%ptcexp + end if + case ('DEV_PTC_THRESHOLD') + call this%parser%DevOpt() + rval = this%parser%GetDouble() + if (rval < DZERO) then + write(errmsg,'(4x,a)')'IMS sln_ar: PTC_THRESHOLD MUST BE > 0.' + call store_error(errmsg) + else + this%iallowptc = 1 + this%ptcthresh = rval + write(IOUT,'(1x,A,1x,g15.7)') & + 'PSEUDO-TRANSIENT CONTINUATION THRESHOLD', this%ptcthresh + end if + case ('DEV_PTC_DEL0') + call this%parser%DevOpt() + rval = this%parser%GetDouble() + if (rval < DZERO) then + write(errmsg,'(4x,a)')'IMS sln_ar: PTC_DEL0 MUST BE > 0.' + call store_error(errmsg) + else + this%iallowptc = 1 + this%ptcdel0 = rval + write(IOUT,'(1x,A,1x,g15.7)') & + 'PSEUDO-TRANSIENT CONTINUATION INITIAL TIMESTEP', this%ptcdel0 + end if + case default + write(errmsg,'(4x,a,a)') 'IMS sln_ar: UNKNOWN IMS OPTION: ', & + trim(keyword) + call store_error(errmsg) + end select + end do + write(iout,'(1x,a)')'END OF IMS OPTIONS' + else + write(iout,'(1x,a)')'NO IMS OPTION BLOCK DETECTED.' + end if + +00021 FORMAT(1X,'SIMPLE OPTION:',/, & + & 1X,'DEFAULT SOLVER INPUT VALUES FOR FAST SOLUTIONS') +00023 FORMAT(1X,'MODERATE OPTION:',/,1X,'DEFAULT SOLVER', & + & ' INPUT VALUES REFLECT MODERETELY NONLINEAR MODEL') +00025 FORMAT(1X,'COMPLEX OPTION:',/,1X,'DEFAULT SOLVER', & + & ' INPUT VALUES REFLECT STRONGLY NONLINEAR MODEL') + + !-------READ NONLINEAR ITERATION PARAMETERS AND LINEAR SOLVER SELECTION INDEX + ! -- set default nonlinear parameters + call this%sln_setouter(ifdparam) + ! + ! -- get NONLINEAR block + call this%parser%GetBlock('NONLINEAR', isfound, ierr, & + supportOpenClose=.true., blockRequired=.FALSE.) + ! + ! -- parse NONLINEAR block if detected + if (isfound) then + write(iout,'(/1x,a)')'PROCESSING IMS NONLINEAR' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + ! -- parse keyword + select case (keyword) + case ('OUTER_HCLOSE') + this%hclose = this%parser%GetDouble() + case ('OUTER_MAXIMUM') + this%mxiter = this%parser%GetInteger() + case ('UNDER_RELAXATION') + call this%parser%GetStringCaps(keyword) + ival = 0 + if (keyword == 'NONE') then + ival = 0 + else if (keyword == 'SIMPLE') then + ival = 1 + else if (keyword == 'COOLEY') then + ival = 2 + else if (keyword == 'DBD') then + ival = 3 + else + write(errmsg,'(1x,a)') 'IMS sln_ar: UNKNOWN UNDER_RELAXATION SPECIFIED.' + call store_error(errmsg) + end if + this%nonmeth = ival + case ('LINEAR_SOLVER') + call this%parser%GetStringCaps(keyword) + ival = 1 + if (keyword.eq.'DEFAULT' .or. & + keyword.eq.'LINEAR') then + ival = 1 + else + write(errmsg,'(1x,a)') 'IMS sln_ar: UNKNOWN LINEAR_SOLVER SPECIFIED.' + call store_error(errmsg) + end if + this%linmeth = ival + case ('UNDER_RELAXATION_THETA') + this%theta = this%parser%GetDouble() + case ('UNDER_RELAXATION_KAPPA') + this%akappa = this%parser%GetDouble() + case ('UNDER_RELAXATION_GAMMA') + this%gamma = this%parser%GetDouble() + case ('UNDER_RELAXATION_MOMENTUM') + this%amomentum = this%parser%GetDouble() + case ('BACKTRACKING_NUMBER') + this%numtrack = this%parser%GetInteger() + IF (this%numtrack > 0) this%ibflag = 1 + case ('BACKTRACKING_TOLERANCE') + this%btol = this%parser%GetDouble() + case ('BACKTRACKING_REDUCTION_FACTOR') + this%breduc = this%parser%GetDouble() + case ('BACKTRACKING_RESIDUAL_LIMIT') + this%res_lim = this%parser%GetDouble() + case default + write(errmsg,'(4x,a,a)')'IMS sln_ar: UNKNOWN IMS NONLINEAR KEYWORD: ', & + trim(keyword) + call store_error(errmsg) + end select + end do + write(iout,'(1x,a)') 'END OF IMS NONLINEAR DATA' + else + if (IFDPARAM.EQ.0) then + write(errmsg,'(1x,a)') 'NO IMS NONLINEAR BLOCK DETECTED.' + call store_error(errmsg) + end if + end if + ! + IF ( THIS%THETA < DEM3 ) this%theta = DEM3 + ! + ! -- backtracking should only be used if this%nonmeth > 0 + if (this%nonmeth < 1) then + this%ibflag = 0 + end if + ! + ! -- check that MXITER is greater than zero + if (this%mxiter <= 0) then + write(errmsg,'(a)') 'IMS sln_ar: OUTER ITERATION NUMBER MUST BE > 0.' + call store_error(errmsg) + END IF + ! + ! + isymflg = 1 + if ( this%nonmeth > 0 )then + WRITE(IOUT,*) '**UNDER-RELAXATION WILL BE USED***' + WRITE(IOUT,*) + isymflg = 0 + elseif ( this%nonmeth == 0 )then + WRITE(IOUT,*) '***UNDER-RELAXATION WILL NOT BE USED***' + WRITE(IOUT,*) + ELSE + WRITE(errmsg,'(a)') '***INCORRECT VALUE FOR VARIABLE NONMETH ', & + & 'WAS SPECIFIED. CHECK INPUT.***' + call store_error(errmsg) + END IF + ! call secondary subroutine to initialize and read linear solver parameters + ! IMSLINEAR solver + if ( this%linmeth == 1 )then + allocate(this%imslinear) + WRITE(IOUT,*) '***IMS LINEAR SOLVER WILL BE USED***' + call this%imslinear%imslinear_allocate(this%name, this%iu, IOUT, & + this%iprims, this%mxiter, & + ifdparam, imslinear, & + this%neq, this%nja, this%ia, & + this%ja, this%amat, this%rhs, & + this%x, this%nitermax) + WRITE(IOUT,*) + isymflg = 0 + if ( imslinear.eq.1 ) isymflg = 1 + ! incorrect linear solver flag + ELSE + WRITE(errmsg, *) '***INCORRECT VALUE FOR LINEAR SOLUTION ', & + & 'METHOD SPECIFIED. CHECK INPUT.***' + call store_error(errmsg) + END IF + ! + ! -- If CG, then go through each model and each exchange and check + ! for asymmetry + if (isymflg == 1) then + ! + ! -- Models + do i = 1, this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, i) + if (mp%get_iasym() /= 0) then + write(errmsg, fmterrasym) 'MODEL', trim(adjustl(mp%name)) + call store_error(errmsg) + endif + enddo + ! + ! -- Exchanges + do i = 1, this%exchangelist%Count() + cp => GetNumericalExchangeFromList(this%exchangelist, i) + if (cp%get_iasym() /= 0) then + write(errmsg, fmterrasym) 'EXCHANGE', trim(adjustl(cp%name)) + call store_error(errmsg) + endif + enddo + ! + endif + ! + ! -- write solver data to output file + ! + ! -- non-linear solver data + WRITE(IOUT,9002) this%hclose, this%mxiter, & + this%iprims, this%nonmeth, this%linmeth + ! + ! -- standard outer iteration formats +9002 FORMAT(1X,'OUTER ITERATION CONVERGENCE CRITERION (HCLOSE) = ', E15.6, & + & /1X,'MAXIMUM NUMBER OF OUTER ITERATIONS (MXITER) = ', I9, & + & /1X,'SOLVER PRINTOUT INDEX (IPRIMS) = ', I9, & + & /1X,'NONLINEAR ITERATION METHOD (NONLINMETH) = ', I9, & + & /1X,'LINEAR SOLUTION METHOD (LINMETH) = ', I9) + ! + IF(this%nonmeth /= 0)THEN + WRITE(IOUT,9003) this%theta, this%akappa, this%gamma, this%amomentum, & + this%numtrack + IF(this%numtrack /= 0) WRITE(IOUT,9004) this%btol,this%breduc,this%res_lim + END IF + ! + ! -- under-relaxation formats +9003 FORMAT(1X,'UNDER-RELAXATION WEIGHT REDUCTION FACTOR (THETA) = ', E15.6, & + & /1X,'UNDER-RELAXATION WEIGHT INCREASE INCREMENT (KAPPA) = ', E15.6, & + & /1X,'UNDER-RELAXATION PREVIOUS HISTORY FACTOR (GAMMA) = ', E15.6, & + & /1X,'UNDER-RELAXATIONMOMENTUM TERM (AMOMENTUM) = ', E15.6, & + & /1X,' MAXIMUM NUMBER OF BACKTRACKS (NUMTRACK) = ',I9) + ! + ! -- backtracking formats +9004 FORMAT(1X,'BACKTRACKING TOLERANCE FACTOR (BTOL) = ', E15.6, & + & /1X,'BACKTRACKING REDUCTION FACTOR (BREDUC) = ', E15.6, & + & /1X,'BACKTRACKING RESIDUAL LIMIT (RES_LIM) = ', E15.6) + ! + ! -- linear solver data + call this%imslinear%imslinear_summary(this%mxiter) + + ! -- write summary of solver error messages + ierr = count_errors() + if (ierr>0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! reallocate space for nonlinear arrays and initialize + call mem_reallocate(this%hncg, this%mxiter, 'HNCG', this%name) + call mem_reallocate(this%lrch, 3, this%mxiter, 'LRCH', this%name) + + ! delta-bar-delta under-relaxation + if(this%nonmeth.eq.3)then + call mem_reallocate(this%wsave, this%neq, 'WSAVE', this%name) + call mem_reallocate(this%hchold, this%neq, 'HCHOLD', this%name) + call mem_reallocate(this%deold, this%neq, 'DEOLD', this%name) + do i = 1, this%neq + this%wsave(i) = DZERO + this%hchold(i) = DZERO + this%deold(i) = DZERO + end do + endif + this%hncg = DZERO + this%lrch = 0 + + ! allocate space for saving solver convergence history + if (this%iprims == 2) then + this%nitermax = this%nitermax * this%mxiter + else + this%nitermax = 1 + end if + + allocate(this%caccel(this%nitermax)) + + im = this%convnmod + call mem_reallocate(this%itinner, this%nitermax, 'ITINNER', & + trim(this%name)) + call mem_reallocate(this%convlocdv, im, this%nitermax, 'CONVLOCDV', & + trim(this%name)) + call mem_reallocate(this%convlocdr, im, this%nitermax, 'CONVLOCDR', & + trim(this%name)) + call mem_reallocate(this%convdvmax, im, this%nitermax, 'CONVDVMAX', & + trim(this%name)) + call mem_reallocate(this%convdrmax, im, this%nitermax, 'CONVDRMAX', & + trim(this%name)) + do i = 1, this%nitermax + this%itinner(i) = 0 + do im = 1, this%convnmod + this%convlocdv(im, i) = 0 + this%convlocdr(im, i) = 0 + this%convdvmax(im, i) = DZERO + this%convdrmax(im, i) = DZERO + end do + end do + ! + ! close ims input file + call this%parser%Clear() + ! + ! -- return + return + end subroutine sln_ar + + subroutine sln_rp(this) +! ****************************************************************************** +! sln_rp -- Read and Prepare +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: readnewdata + ! -- dummy + class(NumericalSolutionType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Check with TDIS on whether or not it is time to RP + if (.not. readnewdata) return + ! + ! -- return + return + end subroutine sln_rp + + subroutine sln_ot(this) +! ****************************************************************************** +! sln_ot -- Output +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(NumericalSolutionType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Nothing to do here + ! + ! -- return + return + end subroutine sln_ot + + subroutine sln_fp(this) +! ****************************************************************************** +! sln_fp -- Final processing +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(NumericalSolutionType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Nothing to do here + if (IDEVELOPMODE == 1) then + write(this%imslinear%iout, '(//1x,a,1x,a,1x,a)') & + 'Solution', trim(adjustl(this%name)), 'summary' + write(this%imslinear%iout, "(1x,70('-'))") + write(this%imslinear%iout, '(1x,a,1x,g0,1x,a)') & + 'Total formulate time: ', this%ttform, 'seconds' + write(this%imslinear%iout, '(1x,a,1x,g0,1x,a,/)') & + 'Total solution time: ', this%ttsoln, 'seconds' + end if + ! + ! -- return + return + end subroutine sln_fp + + subroutine sln_da(this) +! ****************************************************************************** +! sln_da -- Deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(NumericalSolutionType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- IMSLinearModule + call this%imslinear%imslinear_da() + deallocate(this%imslinear) + ! + ! -- lists + call this%modellist%Clear() + call this%exchangelist%Clear() + ! + ! -- character arrays + deallocate(this%caccel) + ! + ! -- inner iteration table object + if (associated(this%innertab)) then + call this%innertab%table_da() + deallocate(this%innertab) + nullify(this%innertab) + end if + ! + ! -- outer iteration table object + if (associated(this%outertab)) then + call this%outertab%table_da() + deallocate(this%outertab) + nullify(this%outertab) + end if + ! + ! -- arrays + call mem_deallocate(this%ja) + call mem_deallocate(this%amat) + call mem_deallocate(this%ia) + call mem_deallocate(this%x) + call mem_deallocate(this%rhs) + call mem_deallocate(this%active) + call mem_deallocate(this%xtemp) + call mem_deallocate(this%dxold) + call mem_deallocate(this%hncg) + call mem_deallocate(this%lrch) + call mem_deallocate(this%wsave) + call mem_deallocate(this%hchold) + call mem_deallocate(this%deold) + call mem_deallocate(this%convmodstart) + call mem_deallocate(this%locdv) + call mem_deallocate(this%locdr) + call mem_deallocate(this%itinner) + call mem_deallocate(this%convlocdv) + call mem_deallocate(this%convlocdr) + call mem_deallocate(this%dvmax) + call mem_deallocate(this%drmax) + call mem_deallocate(this%convdvmax) + call mem_deallocate(this%convdrmax) + ! + ! -- Scalars + call mem_deallocate(this%id) + call mem_deallocate(this%iu) + call mem_deallocate(this%ttform) + call mem_deallocate(this%ttsoln) + call mem_deallocate(this%neq) + call mem_deallocate(this%nja) + call mem_deallocate(this%hclose) + call mem_deallocate(this%hiclose) + call mem_deallocate(this%bigchold) + call mem_deallocate(this%bigch) + call mem_deallocate(this%relaxold) + call mem_deallocate(this%res_prev) + call mem_deallocate(this%res_new) + call mem_deallocate(this%res_in) + call mem_deallocate(this%ibcount) + call mem_deallocate(this%icnvg) + call mem_deallocate(this%itertot) + call mem_deallocate(this%mxiter) + call mem_deallocate(this%linmeth) + call mem_deallocate(this%nonmeth) + call mem_deallocate(this%iprims) + call mem_deallocate(this%theta) + call mem_deallocate(this%akappa) + call mem_deallocate(this%gamma) + call mem_deallocate(this%amomentum) + call mem_deallocate(this%breduc) + call mem_deallocate(this%btol) + call mem_deallocate(this%res_lim) + call mem_deallocate(this%numtrack) + call mem_deallocate(this%ibflag) + call mem_deallocate(this%icsvout) + call mem_deallocate(this%nitermax) + call mem_deallocate(this%nitercnt) + call mem_deallocate(this%convnmod) + call mem_deallocate(this%iallowptc) + call mem_deallocate(this%iptcopt) + call mem_deallocate(this%iptcout) + call mem_deallocate(this%l2norm0) + call mem_deallocate(this%ptcfact) + call mem_deallocate(this%ptcdel) + call mem_deallocate(this%ptcdel0) + call mem_deallocate(this%ptcexp) + call mem_deallocate(this%ptcthresh) + call mem_deallocate(this%ptcrat) + ! + ! -- return + return + end subroutine sln_da + + subroutine sln_ca(this, kpicard, isgcnvg, isuppress_output) +! ****************************************************************************** +! sln_ca -- Solve the models in this solution for kper and kstp. If necessary +! use subtiming to get to the end of the time step +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: kper, subtiming_begin, subtiming_end, perlen, totimsav + ! -- dummy + class(NumericalSolutionType) :: this + integer(I4B), intent(in) :: kpicard + integer(I4B), intent(inout) :: isgcnvg + integer(I4B), intent(in) :: isuppress_output + ! -- local + class(NumericalModelType), pointer :: mp + class(NumericalExchangeType), pointer :: cp + integer(I4B) :: kiter ! non-linear iteration counter + integer(I4B) :: im, ic + integer(I4B) :: nsubtimes, nstm, isubtime + real(DP) :: dt + real(DP) :: totim + +! ------------------------------------------------------------------------------ + + ! TODO_MJR: the subtime loop is now around the sln_ca body, easy to discard, do we still want this? + + ! -- Find the number of sub-timesteps for each model and then use + ! the largest one. + nsubtimes = 1 + do im=1,this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, im) + nstm = mp%get_nsubtimes() + if(nstm > nsubtimes) nsubtimes = nstm + enddo + + dt = perlen(kper) / REAL(nsubtimes, DP) + totim = totimsav + ! + do isubtime = 1, nsubtimes + ! + ! -- update totim + totim = totim + dt + ! + ! -- Start subtiming + call subtiming_begin(isubtime, nsubtimes, this%id) + + ! prepare for the nonlinear iteration loop + call this%prepareIteration(kpicard, isubtime) + + ! nonlinear iteration loop for this solution + outerloop: do kiter = 1, this%mxiter + + ! perform a single iteration + call this%doIteration(kiter) + + ! exit if converged + if (this%icnvg == 1) then + exit outerloop + end if + + end do outerloop + + ! finish up, write convergence info, CSV file, budgets and flows, ... + call this%finalizeIteration(kiter, isgcnvg, isubtime, isuppress_output) + + ! -- End of the sub-timestep loop + end do + + ! -- end the subtiming + call subtiming_end() + ! + ! + ! -- Check if convergence for the exchange packages + ! TODO_MJR: shouldn't this be in the subtiming loop? + do ic = 1, this%exchangelist%Count() + cp => GetNumericalExchangeFromList(this%exchangelist, ic) + call cp%exg_cnvg(this%id, isgcnvg) + enddo + ! + ! -- return + return + end subroutine sln_ca + + ! prepare for iteration loop, use isubtime == 1 when there is no subtiming + ! and the default kpicard == 1 when no picard loop (c.f. sgp_ca()) + subroutine prepareIteration(this, kpicard, isubtime) + use TdisModule, only: kper, kstp + class(NumericalSolutionType) :: this + integer(I4B), intent(in) :: kpicard + integer(I4B), intent(in) :: isubtime + + ! write headers to CSV file + if (kper == 1 .and. kstp == 1 .and. isubtime == 1) then + call this%writeCSVHeader() + end if + + ! advance models and exchanges + call this%advanceSolution(kpicard, isubtime) + + ! write PTC info on models to iout + call this%writePTCInfoToFile(kper) + + ! reset convergence flag and inner solve counter + this%icnvg = 0 + if (isubtime == 1) then + this%itertot = 0 + end if + + end subroutine + + ! write the header for the solver output to the CSV file + subroutine writeCSVHeader(this) + class(NumericalSolutionType) :: this + ! local + integer(I4B) :: im + class(NumericalModelType), pointer :: mp + + if (this%icsvout > 0) then + write(this%icsvout, '(*(G0,:,","))', advance='NO') & + 'total_iterations', 'totim', 'kper', 'kstp', 'ksub', 'nouter', & + 'ninner', 'solution_dvmax', 'solution_dvmax_model', & + 'solution_dvmax_node' + if (this%iprims == 2) then + write(this%icsvout, '(*(G0,:,","))', advance='NO') & + '', 'solution_drmax', 'solution_drmax_model', & + 'solution_drmax_node', 'solution_alpha' + if (this%imslinear%ilinmeth == 2) then + write(this%icsvout, '(*(G0,:,","))', advance='NO') & + '', 'solution_omega' + end if + ! -- check for more than one model + if (this%convnmod > 1) then + do im=1,this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, im) + write(this%icsvout, '(*(G0,:,","))', advance='NO') & + '', trim(adjustl(mp%name)) // '_dvmax', & + trim(adjustl(mp%name)) // '_dvmax_node', & + trim(adjustl(mp%name)) // '_drmax', & + trim(adjustl(mp%name)) // '_drmax_node' + end do + end if + end if + write(this%icsvout,'(a)') '' + end if + + end subroutine writeCSVHeader + + ! advances the exchanges and models in this solution by 1 (sub)timestep + ! kpicard will change if we are running the outer picard loop, + ! if not (the current use cases) then we use kpicard == 1 + subroutine advanceSolution(this, isubtime, kpicard) + class(NumericalSolutionType) :: this + integer(I4B), intent(in) :: isubtime, kpicard + ! local + integer(I4B) :: ic, im + class(NumericalExchangeType), pointer :: cp + class(NumericalModelType), pointer :: mp + + ! -- Exchange advance + do ic=1,this%exchangelist%Count() + cp => GetNumericalExchangeFromList(this%exchangelist, ic) + call cp%exg_ad(this%id, kpicard, isubtime) + enddo + + ! -- Model advance + do im = 1, this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, im) + call mp%model_ad(kpicard, isubtime) + enddo + + end subroutine advanceSolution + + ! write the PTC header information to file + subroutine writePTCInfoToFile(this, kper) + class(NumericalSolutionType) :: this + integer(I4B), intent(in) :: kper + ! local + integer(I4B) :: n, im, iallowptc, iptc + class(NumericalModelType), pointer :: mp + + ! -- determine if PTC will be used in any model + n = 1 + do im = 1, this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, im) + call mp%model_ptcchk(iptc) + ! + ! -- set iallowptc + ! -- no_ptc_option is FIRST + if (this%iallowptc < 0) then + if (kper > 1) then + iallowptc = 1 + else + iallowptc = 0 + end if + ! -- no_ptc_option is ALL (0) or using PTC (1) + else + iallowptc = this%iallowptc + end if + iptc = iptc * iallowptc + if (iptc /= 0) then + if (n == 1) then + write(iout, '(//)') + n = 0 + end if + write(iout, '(1x,a,1x,i0,1x,3a)') & + 'PSEUDO-TRANSIENT CONTINUATION WILL BE APPLIED TO MODEL', im, '("', & + trim(adjustl(mp%name)), '") DURING THIS TIME STEP' + end if + enddo + + end subroutine writePTCInfoToFile + + ! this routine performs a single iteration, with the following steps: + ! (TODO_MJR: refactor this routine, it is long) + ! + ! - backtracking + ! - reset amat and rhs + ! - calculate matrix terms (*_cf) + ! - add coefficients to matrix (*_fc) + ! - newton-raphson + ! - PTC + ! - linear solve + ! - convergence checks + ! - write output + ! - underrelaxation + ! + ! it updates the convergence flag "this%icnvg" accordingly + subroutine doIteration(this, kiter) + use TdisModule, only: kstp, kper + class(NumericalSolutionType) :: this + integer(I4B), intent(in) :: kiter + ! local + integer(I4B) :: ic, im + class(NumericalModelType), pointer :: mp + class(NumericalExchangeType), pointer :: cp + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: tag + character(len=LINELENGTH) :: line + character(len=LENPAKLOC) :: cmod + character(len=LENPAKLOC) :: cpak + character(len=34) :: strh + character(len=25) :: cval + character(len=7) :: cmsg + integer(I4B) :: ntabrows + integer(I4B) :: ntabcols + integer(I4B) :: i0, i1 + integer(I4B) :: itestmat, n + integer(I4B) :: iter + integer(I4B) :: inewtonur + integer(I4B) :: locmax_nur + integer(I4B) :: iend + integer(I4B) :: icnvgmod + integer(I4B) :: iptc + real(DP) :: dxmax_nur + real(DP) :: dxmax + real(DP) :: ptcf + real(DP) :: ttform + real(DP) :: ttsoln + real(DP) :: dpak + ! formats +! ----------------------------------------------------------------------------- + ! + ! -- code + ! + ! -- create header for outer iteration table + if (this%iprims > 0) then + if (.not. associated(this%outertab)) then + ! + ! -- create outer iteration table + ! -- table dimensions + ntabrows = 1 + ntabcols = 6 + if (this%numtrack > 0) then + ntabcols = ntabcols + 4 + end if + ! + ! -- initialize table and define columns + title = 'OUTER ITERATION SUMMARY' + call table_cr(this%outertab, this%name, title) + call this%outertab%table_df(ntabrows, ntabcols, iout, & + finalize=.FALSE.) + tag = 'OUTER ITERATION STEP' + call this%outertab%initialize_column(tag, 15, alignment=TABLEFT) + tag = 'OUTER ITERATION' + call this%outertab%initialize_column(tag, 10, alignment=TABRIGHT) + tag = 'INNER ITERATION' + call this%outertab%initialize_column(tag, 10, alignment=TABRIGHT) + if (this%numtrack > 0) then + tag = 'BACKTRACK FLAG' + call this%outertab%initialize_column(tag, 10, alignment=TABRIGHT) + tag = 'BACKTRACK ITERATIONS' + call this%outertab%initialize_column(tag, 10, alignment=TABRIGHT) + tag = 'INCOMING RESIDUAL' + call this%outertab%initialize_column(tag, 15, alignment=TABRIGHT) + tag = 'OUTGOING RESIDUAL' + call this%outertab%initialize_column(tag, 15, alignment=TABRIGHT) + end if + tag = 'MAXIMUM CHANGE' + call this%outertab%initialize_column(tag, 15, alignment=TABRIGHT) + tag = 'STEP SUCCESS' + call this%outertab%initialize_column(tag, 7, alignment=TABRIGHT) + tag = 'MAXIMUM CHANGE MODEL-(CELLID) OR MODEL-PACKAGE-(NUMBER)' + call this%outertab%initialize_column(tag, 34, alignment=TABRIGHT) + end if + end if + ! + ! -- backtracking + if (this%numtrack > 0) then + call this%sln_backtracking(mp, cp, kiter) + end if + ! + ! -- Set amat and rhs to zero + call this%sln_reset() + call code_timer(0, ttform, this%ttform) + ! + ! -- Calculate the matrix terms for each exchange + do ic=1,this%exchangelist%Count() + cp => GetNumericalExchangeFromList(this%exchangelist, ic) + call cp%exg_cf(kiter) + enddo + ! + ! -- Calculate the matrix terms for each model + do im=1,this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, im) + call mp%model_cf(kiter) + enddo + ! + ! -- Add exchange coefficients to the solution + do ic=1,this%exchangelist%Count() + cp => GetNumericalExchangeFromList(this%exchangelist, ic) + call cp%exg_fc(kiter, this%ia, this%amat, 1) + enddo + ! + ! -- Add model coefficients to the solution + do im=1,this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, im) + call mp%model_fc(kiter, this%amat, this%nja, 1) + enddo + ! + ! -- Add exchange Newton-Raphson terms to solution + do ic=1,this%exchangelist%Count() + cp => GetNumericalExchangeFromList(this%exchangelist, ic) + call cp%exg_nr(kiter, this%ia, this%amat) + enddo + ! + ! -- Calculate pseudo-transient continuation factor for each model + iptc = 0 + ptcf = DZERO + do im=1,this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, im) + call mp%model_ptc(kiter, this%neq, this%nja, & + this%ia, this%ja, this%x, & + this%rhs, this%amat, & + iptc, ptcf) + end do + ! + ! -- Add model Newton-Raphson terms to solution + do im=1,this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, im) + call mp%model_nr(kiter, this%amat, this%nja, 1) + enddo + call code_timer(1, ttform, this%ttform) + ! + ! -- linear solve + call code_timer(0, ttsoln, this%ttsoln) + CALL this%sln_ls(kiter, kstp, kper, iter, iptc, ptcf) + call code_timer(1, ttsoln, this%ttsoln) + ! + ! -- save matrix to a file + ! to enable set itestmat to 1 and recompile + !------------------------------------------------------- + itestmat = 0 + if (itestmat /= 0) then + open(99,file='sol_MF6.TXT') + WRITE(99,*) 'MATRIX SOLUTION FOLLOWS' + WRITE(99,'(10(I8,G15.4))') (n, this%x(N), N = 1, this%NEQ) + close(99) + call stop_with_error() + end if + !------------------------------------------------------- + ! + ! -- check convergence of solution + call this%sln_outer_check(this%hncg(kiter), this%lrch(1,kiter)) + if (this%icnvg /= 0) then + this%icnvg = 0 + if (abs(this%hncg(kiter)) <= this%hclose) then + this%icnvg = 1 + end if + end if + ! + ! -- set failure flag + if (this%icnvg == 0) then + cmsg = ' ' + else + cmsg = '*' + end if + ! + ! -- set flag if this is the last outer iteration + iend = 0 + if (kiter == this%mxiter) then + iend = 1 + end if + ! + ! -- Additional convergence check for pseudo-transient continuation + ! term. Evaluate if the ptc value added to the diagonal has + ! decayed sufficiently. + if (iptc > 0) then + if (this%icnvg /= 0) then + if (this%ptcrat > this%ptcthresh) then + this%icnvg = 0 + cmsg = trim(cmsg) // 'PTC' + if (iend /= 0) then + write(line, '(a)') & + 'PSEUDO-TRANSIENT CONTINUATION CAUSED CONVERGENCE FAILURE' + call sim_message(line) + end if + end if + end if + end if + ! + ! -- write maximum head change from linear solver to list file + if (this%iprims > 0) then + cval = 'Model' + call this%sln_get_loc(this%lrch(1,kiter), strh) + ! + ! -- add data to outertab + call this%outertab%add_term(cval) + call this%outertab%add_term(kiter) + call this%outertab%add_term(iter) + if (this%numtrack > 0) then + call this%outertab%add_term(' ') + call this%outertab%add_term(' ') + call this%outertab%add_term(' ') + call this%outertab%add_term(' ') + end if + call this%outertab%add_term(this%hncg(kiter)) + call this%outertab%add_term(cmsg) + call this%outertab%add_term(trim(strh)) + end if + ! + ! -- Additional convergence check for exchanges + do ic=1,this%exchangelist%Count() + cp => GetNumericalExchangeFromList(this%exchangelist, ic) + call cp%exg_cc(this%icnvg) + end do + ! + ! -- additional convergence check for model packages + icnvgmod = this%icnvg + dpak = DZERO + cpak = ' ' + do im=1,this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, im) + call mp%get_mcellid(0, cmod) + call mp%model_cc(kiter, iend, icnvgmod, cpak, dpak) + if (abs(dpak) > DZERO) then + write(cpak, '(a,a)') trim(cmod) // trim(cpak) + else + cpak = ' ' + end if + end do + ! + ! -- evaluate package convergence + if (abs(dpak) > this%hclose) then + this%icnvg = 0 + ! -- write message to stdout + if (iend /= 0) then + write(line, '(3a)') & + 'PACKAGE (', trim(cpak), ') CAUSED CONVERGENCE FAILURE' + call sim_message(line) + end if + end if + ! + ! -- write maximum change in package convergence check + if (this%iprims > 0) then + cval = 'Package' + if (this%icnvg /= 1) then + cmsg = ' ' + else + cmsg = '*' + end if + !if (len_trim(this%cpak) > 0) then + if (len_trim(cpak) > 0) then + ! + ! -- add data to outertab + call this%outertab%add_term(cval) + call this%outertab%add_term(kiter) + call this%outertab%add_term(' ') + if (this%numtrack > 0) then + call this%outertab%add_term(' ') + call this%outertab%add_term(' ') + call this%outertab%add_term(' ') + call this%outertab%add_term(' ') + end if + call this%outertab%add_term(dpak) + call this%outertab%add_term(cmsg) + call this%outertab%add_term(cpak) + end if + end if + ! + ! -- increment the counter storing the total number of linear iterations + this%itertot = this%itertot + iter + ! + ! -- under-relaxation - only done if convergence not achieved + if (this%icnvg /= 1) then + if (this%nonmeth > 0) then + call this%sln_underrelax(kiter, this%hncg(kiter), this%neq, & + this%active, this%x, this%xtemp) + else + call this%sln_calcdx(this%neq, this%active, & + this%x, this%xtemp, this%dxold) + endif + ! + ! -- adjust heads by newton under-relaxation, if necessary + inewtonur = 0 + dxmax_nur = DZERO + locmax_nur = 0 + do im=1,this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, im) + i0 = mp%moffset + 1 + i1 = i0 + mp%neq - 1 + call mp%model_nur(mp%neq, this%x(i0:i1), this%xtemp(i0:i1), & + this%dxold(i0:i1), inewtonur, dxmax_nur, locmax_nur) + end do + ! + ! -- check for convergence if newton under-relaxation applied + if (inewtonur /= 0) then + call this%sln_maxval(this%neq, this%dxold, dxmax) + ! + ! -- evaluate convergence + if (abs(dxmax) <= this%hclose .and. & + abs(this%hncg(kiter)) <= this%hclose) then + this%icnvg = 1 + end if + end if + end if + + end subroutine doIteration + + ! finalize the solution calculate, called after the non-linear iteration loop + ! when used without subtiming, do isubtime == 1 + subroutine finalizeIteration(this, kiter, isgcnvg, isubtime, isuppress_output) + use TdisModule, only: totim, kper, kstp + class(NumericalSolutionType) :: this + integer(I4B), intent(in) :: kiter ! the number at which the iteration loop was exited + integer(I4B), intent(inout) :: isgcnvg + integer(I4B), intent(in) :: isubtime + integer(I4B), intent(in) :: isuppress_output + ! local + integer(I4B) :: ic, im + class(NumericalModelType), pointer :: mp + class(NumericalExchangeType), pointer :: cp + integer(I4B) :: nodeu + + ! -- formats for convergence info + character(len=*), parameter :: fmtnocnvg = & + &"(1X,'Solution ', i0, ' did not converge for stress period ', i0, & + &' and time step ', i0)" + character(len=*), parameter :: fmtcnvg = & + &"(1X, I0, ' CALLS TO NUMERICAL SOLUTION ', 'IN TIME STEP ', I0, & + &' STRESS PERIOD ',I0,/1X,I0,' TOTAL ITERATIONS')" + + ! + ! -- finalize the outer iteration table + if (this%iprims > 0) then + call this%outertab%finalize_table() + end if + ! -- write convergence info + if (this%icnvg == 1) then + if (this%iprims > 0) then + write(iout, fmtcnvg) kiter, kstp, kper, this%itertot + end if + end if + + ! -- Write a message if convergence was not achieved + if (this%icnvg == 0) then + write(iout, fmtnocnvg) this%id, kper, kstp + end if + + ! + ! -- write inner iteration convergence summary + if (this%iprims == 2) then + ! + ! -- write summary for each model + do im=1,this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, im) + call this%convergence_summary(mp%iout, im, this%itertot) + end do + ! + ! -- write summary for entire solution + call this%convergence_summary(iout, this%convnmod+1, this%itertot) + end if + ! + ! -- write to csv file + if (this%icsvout > 0) then + if (this%iprims < 2) then + ! + ! -- determine the total number of iterations at the end of this outer + this%nitercnt = this%nitercnt + this%itertot + ! + ! -- get model number and user node number + call this%sln_get_nodeu(this%lrch(1,kiter), im, nodeu) + ! + ! -- write line + write(this%icsvout, '(*(G0,:,","))') & + this%nitercnt, totim, kper, kstp, isubtime, kiter, this%itertot, & + this%hncg(kiter), im, nodeu + else + call this%csv_convergence_summary(this%icsvout, totim, kper, kstp, & + isubtime, this%itertot) + end if + end if + ! + ! + if (this%icnvg == 0) isgcnvg = 0 + ! + ! -- Calculate flow for each model + do im=1,this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, im) + call mp%model_cq(this%icnvg, isuppress_output) + enddo + ! + ! -- Calculate flow for each exchange + do ic = 1, this%exchangelist%Count() + cp => GetNumericalExchangeFromList(this%exchangelist, ic) + call cp%exg_cq(isgcnvg, isuppress_output, this%id) + enddo + ! + ! -- Budget terms for each model + do im=1,this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, im) + call mp%model_bd(this%icnvg, isuppress_output) + enddo + ! + ! -- Budget terms for each exchange + do ic = 1, this%exchangelist%Count() + cp => GetNumericalExchangeFromList(this%exchangelist, ic) + call cp%exg_bd(isgcnvg, isuppress_output, this%id) + enddo + + end subroutine finalizeIteration + + subroutine convergence_summary(this, iu, im, itertot) +! ****************************************************************************** +! convergence_summary -- Save convergence summary to a File +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only:getunit + ! -- dummy + class(NumericalSolutionType) :: this + integer(I4B), intent(in) :: iu + integer(I4B), intent(in) :: im + integer(I4B), intent(in) :: itertot + ! -- local + character(len=34) :: strh, strr + integer(I4B) :: i + integer(I4B) :: i0 + integer(I4B) :: iouter + integer(I4B) :: j + integer(I4B) :: k + integer(I4B) :: locdv + integer(I4B) :: locdr + real(DP) :: dv + real(DP) :: dr +! ------------------------------------------------------------------------------ + iouter = 1 + write(iu,"(/,1x,A)") 'INNER ITERATION SUMMARY' + write(iu,"(1x,128('-'))") + write(iu,'(1x,3a)') ' TOTAL OUTER INNER', & + ' MAXIMUM CHANGE MAXIMUM', & + ' MAXIMUM RESIDUAL MAXIMUM' + write(iu,'(1x,3a)') 'ITERATION ITERATION ITERATION', & + ' MODEL-(CELLID) CHANGE', & + ' MODEL-(CELLID) RESIDUAL' + write(iu,"(1x,128('-'))") + i0 = 0 + do k = 1, itertot + i = this%itinner(k) + if (i <= i0) then + iouter = iouter + 1 + end if + if (im > this%convnmod) then + dv = DZERO + dr = DZERO + do j = 1, this%convnmod + if (ABS(this%convdvmax(j, k)) > ABS(dv)) then + locdv = this%convlocdv(j, k) + dv = this%convdvmax(j, k) + end if + if (ABS(this%convdrmax(j, k)) > ABS(dr)) then + locdr = this%convlocdr(j, k) + dr = this%convdrmax(j, k) + end if + end do + else + locdv = this%convlocdv(im, k) + locdr = this%convlocdr(im, k) + dv = this%convdvmax(im, k) + dr = this%convdrmax(im, k) + end if + call this%sln_get_loc(locdv, strh) + call this%sln_get_loc(locdr, strr) + write(iu, '(1x,3i10,a34,g15.7,a34,g15.7)') k, iouter, i, & + adjustr(trim(strh)), dv, & + adjustr(trim(strr)), dr + i0 = i + end do + ! + ! -- write blank line + if (im <= this%convnmod) then + write(iu, '(a)') '' + end if + ! + ! -- return + return + end subroutine convergence_summary + + + subroutine csv_convergence_summary(this, iu, totim, kper, kstp, isubtime, & + itertot) +! ****************************************************************************** +! csv_convergence_summary -- Save convergence summary to a csv file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only:getunit + ! -- dummy + class(NumericalSolutionType) :: this + integer(I4B), intent(in) :: iu + real(DP), intent(in) :: totim + integer(I4B), intent(in) :: kper + integer(I4B), intent(in) :: kstp + integer(I4B), intent(in) :: isubtime + integer(I4B), intent(in) :: itertot + ! -- local + integer(I4B) :: i + integer(I4B) :: i0 + integer(I4B) :: iouter + integer(I4B) :: im + integer(I4B) :: j + integer(I4B) :: k + integer(I4B) :: locdv + integer(I4B) :: locdr + integer(I4B) :: nodeu + real(DP) :: dv + real(DP) :: dr +! ------------------------------------------------------------------------------ + iouter = 1 + i0 = 0 + do k = 1, itertot + this%nitercnt = this%nitercnt + 1 + i = this%itinner(k) + if (i <= i0) then + iouter = iouter + 1 + end if + write(iu, '(*(G0,:,","))', advance='NO') & + this%nitercnt, totim, kper, kstp, isubtime, iouter, i + ! + ! -- solution summary + dv = DZERO + dr = DZERO + do j = 1, this%convnmod + if (ABS(this%convdvmax(j, k)) > ABS(dv)) then + locdv = this%convlocdv(j, k) + dv = this%convdvmax(j, k) + end if + if (ABS(this%convdrmax(j, k)) > ABS(dr)) then + locdr = this%convlocdr(j, k) + dr = this%convdrmax(j, k) + end if + end do + ! + ! -- get model number and user node number for dv + call this%sln_get_nodeu(locdv, im, nodeu) + write(iu, '(*(G0,:,","))', advance='NO') '', dv, im, nodeu + ! + ! -- get model number and user node number for dr + call this%sln_get_nodeu(locdr, im, nodeu) + write(iu, '(*(G0,:,","))', advance='NO') '', dr, im, nodeu + ! + ! -- write acceleration parameters + write(iu, '(*(G0,:,","))', advance='NO') '', trim(adjustl(this%caccel(k))) + ! + ! -- write information for each model + if (this%convnmod > 1) then + do j = 1, this%convnmod + locdv = this%convlocdv(j, k) + dv = this%convdvmax(j, k) + locdr = this%convlocdr(j, k) + dr = this%convdrmax(j, k) + ! + ! -- get model number and user node number for dv + call this%sln_get_nodeu(locdv, im, nodeu) + write(iu, '(*(G0,:,","))', advance='NO') '', dv, nodeu + ! + ! -- get model number and user node number for dr + call this%sln_get_nodeu(locdr, im, nodeu) + write(iu, '(*(G0,:,","))', advance='NO') '', dr, nodeu + end do + end if + ! + ! -- write line + write(iu,'(a)') '' + ! + ! -- update i0 + i0 = i + end do + ! + ! -- return + return + end subroutine csv_convergence_summary + + subroutine save(this, filename) +! ****************************************************************************** +! save -- Save Solution Matrices to a File +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only:getunit + ! -- dummy + class(NumericalSolutionType) :: this + character(len=*), intent(in) :: filename + ! -- local + integer(I4B) :: inunit +! ------------------------------------------------------------------------------ + ! + inunit = getunit() + open(unit=inunit,file=filename,status='unknown') + write(inunit,*) 'ia' + write(inunit,*) this%ia + write(inunit,*) 'ja' + write(inunit,*) this%ja + write(inunit,*) 'amat' + write(inunit,*) this%amat + write(inunit,*) 'rhs' + write(inunit,*) this%rhs + write(inunit,*) 'x' + write(inunit,*) this%x + close(inunit) + ! + ! -- return + return + end subroutine save + + subroutine addmodel(this, mp) +! ****************************************************************************** +! addmodel -- Add Model +! Subroutine: (1) add a model to this%modellist +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(NumericalSolutionType) :: this + class(BaseModelType), pointer, intent(in) :: mp + ! -- local + class(NumericalModelType), pointer :: m +! ------------------------------------------------------------------------------ + ! + select type(mp) + class is (NumericalModelType) + m => mp + call AddNumericalModelToList(this%modellist, m) + end select + ! + ! -- return + return + end subroutine addmodel + + subroutine addexchange(this, exchange) +! ****************************************************************************** +! addexchange -- Add exchange +! Subroutine: (1) add an exchange to this%exchangelist +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(NumericalSolutionType) :: this + class(NumericalExchangeType), pointer, intent(in) :: exchange +! ------------------------------------------------------------------------------ + ! + call AddNumericalExchangeToList(this%exchangelist, exchange) + ! + ! -- return + return + end subroutine addexchange + + subroutine slnassignexchanges(this) +! ****************************************************************************** +! slnassignexchanges -- Assign exchanges to this solution +! Subroutine: (1) assign the appropriate exchanges to this%exchangelist +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList + use ListsModule, only: baseexchangelist + ! -- dummy + class(NumericalSolutionType) :: this + ! -- local + class(BaseExchangeType), pointer :: cb + class(NumericalExchangeType), pointer :: c + integer(I4B) :: ic +! ------------------------------------------------------------------------------ + ! + ! -- Go through the list of exchange objects and if either model1 or model2 + ! are part of this solution, then include the exchange object as part of + ! this solution. + c => null() + do ic=1,baseexchangelist%Count() + cb => GetBaseExchangeFromList(baseexchangelist, ic) + select type (cb) + class is (NumericalExchangeType) + c=>cb + end select + if(associated(c)) then + if(c%m1%idsoln==this%id) then + call this%addexchange(c) + cycle + elseif(c%m2%idsoln==this%id) then + call this%addexchange(c) + cycle + endif + endif + enddo + ! + ! -- return + return + end subroutine slnassignexchanges + + subroutine sln_connect(this) +! ****************************************************************************** +! sln_connect -- Assign Connections +! Main workhorse method for solution. This goes through all the models and all +! the connections and builds up the sparse matrix. +! Subroutine: (1) Add internal model connections, +! (2) Add cross terms, +! (3) Allocate solution arrays +! (4) Create mapping arrays +! (5) Fill cross term values if necessary +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(NumericalSolutionType) :: this + ! -- local + class(NumericalModelType), pointer :: mp + class(NumericalExchangeType), pointer :: cp + integer(I4B) :: im, ic, ierror +! ------------------------------------------------------------------------------ + ! + ! -- Add internal model connections to sparse + do im=1,this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, im) + call mp%model_ac(this%sparse) + enddo + ! + ! -- Add the cross terms to sparse + do ic=1,this%exchangelist%Count() + cp => GetNumericalExchangeFromList(this%exchangelist, ic) + call cp%exg_ac(this%sparse) + enddo + ! + ! -- The number of non-zero array values are now known so + ! -- ia and ja can be created from sparse. then destroy sparse + this%nja=this%sparse%nnz + call mem_allocate(this%ja, this%nja, 'JA', this%name) + call mem_allocate(this%amat, this%nja, 'AMAT', this%name) + call this%sparse%sort() + call this%sparse%filliaja(this%ia,this%ja,ierror) + call this%sparse%destroy() + ! + ! -- Create mapping arrays for each model. Mapping assumes + ! -- that each row has the diagonal in the first position, + ! -- however, rows do not need to be sorted. + do im=1,this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, im) + call mp%model_mc(this%ia, this%ja) + enddo + ! + ! -- Create arrays for mapping exchange connections to global solution + do ic=1,this%exchangelist%Count() + cp => GetNumericalExchangeFromList(this%exchangelist, ic) + call cp%exg_mc(this%ia, this%ja) + enddo + ! + ! -- return + return + end subroutine sln_connect + + subroutine sln_reset(this) +! ****************************************************************************** +! sln_reset -- Reset This Solution +! Reset this solution by setting amat and rhs to zero +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(NumericalSolutionType) :: this + ! -- local + integer(I4B) :: i + real(DP) :: zero = 0.d0 +! ------------------------------------------------------------------------------ + ! + do i=1,this%nja + this%amat(i) = zero + enddo + do i=1,this%neq + this%rhs(i) = zero + enddo + ! + ! -- return + return + end subroutine sln_reset +! + subroutine sln_ls(this, kiter, kstp, kper, in_iter, iptc, ptcf) +! ****************************************************************************** +! perform residual reduction and newton linearization and +! prepare for sparse solver, and check convergence of nonlinearities +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + class(NumericalSolutionType), intent(inout) :: this + integer(I4B), intent(in) :: kiter + integer(I4B), intent(in) :: kstp + integer(I4B), intent(in) :: kper + integer(I4B), intent(inout) :: in_iter + integer(I4B), intent(inout) :: iptc + real(DP), intent(in) :: ptcf + ! -- local + logical :: lsame + integer(I4B) :: n + integer(I4B) :: itestmat, i, i1, i2 + integer(I4B) :: iptct + integer(I4B) :: iallowptc + real(DP) :: adiag, diagval + real(DP) :: l2norm + real(DP) :: ptcval + real(DP) :: diagmin + real(DP) :: bnorm + character(len=50) :: fname + character(len=*), parameter :: fmtfname = "('mf6mat_', i0, '_', i0, & + &'_', i0, '_', i0, '.txt')" +! ------------------------------------------------------------------------------ + ! + ! -- take care of loose ends for all nodes before call to solver + do n = 1, this%neq + ! -- store x in temporary location + this%xtemp(n) = this%x(n) + ! -- set dirichlet boundary and no-flow condition + if (this%active(n) <= 0) then + this%amat(this%ia(n)) = DONE + this%rhs(n) = this%x(n) + i1 = this%ia(n) + 1 + i2 = this%ia(n + 1) - 1 + do i = i1, i2 + this%amat(i) = DZERO + enddo + else + ! -- take care of zero row diagonal + diagval = DONE + adiag = abs(this%amat(this%ia(n))) + if(adiag.lt.DEM15)then + this%amat(this%ia(n)) = diagval + this%rhs(n) = this%rhs(n) + this%x(n) * diagval + endif + endif + end do + ! -- pseudo transient continuation + ! + ! -- set iallowptc + ! -- no_ptc_option is FIRST + if (this%iallowptc < 0) then + if (kper > 1) then + iallowptc = 1 + else + iallowptc = 0 + end if + ! -- no_ptc_option is ALL (0) or using PTC (1) + else + iallowptc = this%iallowptc + end if + iptct = iptc * iallowptc + if (iptct /= 0) then + call this%sln_l2norm(this%neq, this%nja, & + this%ia, this%ja, this%active, & + this%amat, this%rhs, this%x, l2norm) + ! -- confirm that the l2norm exceeds previous l2norm + ! if not, there is no need to add ptc terms + if (kiter == 1) then + if (kper > 1 .or. kstp > 1) then + if (l2norm <= this%l2norm0) then + iptc = 0 + end if + end if + else + lsame = IS_SAME(l2norm, this%l2norm0) + if (lsame) then + iptc = 0 + end if + end if + end if + iptct = iptc * iallowptc + if (iptct /= 0) then + if (kiter == 1) then + if (this%iptcout > 0) then + write(this%iptcout, '(A10,6(1x,A15),2(1x,A15))') 'OUTER ITER', & + ' PTCDEL', ' L2NORM0', ' L2NORM', & + ' RHSNORM', ' 1/PTCDEL', ' DIAGONAL MIN.', & + ' RHSNORM/L2NORM', ' STOPPING CRIT.' + end if + if (this%ptcdel0 > DZERO) then + this%ptcdel = this%ptcdel0 + else + if (this%iptcopt == 0) then + ! + ! -- ptcf is the reciprocal of the pseudo-time step + this%ptcdel = DONE / ptcf + else + bnorm = DZERO + do n = 1, this%neq + if (this%active(n).gt.0) then + bnorm = bnorm + this%rhs(n) * this%rhs(n) + end if + end do + bnorm = sqrt(bnorm) + this%ptcdel = bnorm / l2norm + end if + end if + else + if (l2norm > DZERO) then + this%ptcdel = this%ptcdel * (this%l2norm0 / l2norm)**this%ptcexp + else + this%ptcdel = DZERO + end if + end if + if (this%ptcdel > DZERO) then + ptcval = DONE / this%ptcdel + else + ptcval = DONE + end if + diagmin = DEP20 + bnorm = DZERO + do n = 1, this%neq + if (this%active(n).gt.0) then + diagval = abs(this%amat(this%ia(n))) + bnorm = bnorm + this%rhs(n) * this%rhs(n) + if (diagval < diagmin) diagmin = diagval + this%amat(this%ia(n)) = this%amat(this%ia(n)) - ptcval + this%rhs(n) = this%rhs(n) - ptcval * this%x(n) + end if + end do + bnorm = sqrt(bnorm) + if (this%iptcout > 0) then + write(this%iptcout, '(i10,6(1x,e15.7),2(1x,f15.6))') & + kiter, this%ptcdel, this%l2norm0, l2norm, bnorm, & + ptcval, diagmin, bnorm/l2norm, ptcval / diagmin + end if + this%l2norm0 = l2norm + end if + ! + ! -- save rhs, amat to a file + ! to enable set itestmat to 1 and recompile + !------------------------------------------------------- + itestmat = 0 + if (itestmat == 1) then + write(fname, fmtfname) this%id, kper, kstp, kiter + print *, 'Saving amat to: ', trim(adjustl(fname)) + open(99,file=trim(adjustl(fname))) + WRITE(99,*)'NODE, RHS, AMAT FOLLOW' + DO N = 1, this%NEQ + I1 = this%IA(N) + I2 = this%IA(N+1)-1 + WRITE(99,'(*(G0,:,","))') N, this%RHS(N), (this%ja(i),i=i1,i2), & + (this%AMAT(I),I=I1,I2) + END DO + close(99) + !stop + end if + !------------------------------------------------------- + ! + ! call appropriate linear solver + ! call ims linear solver + if (this%linmeth == 1) then + call this%imslinear%imslinear_apply(this%icnvg, kstp, kiter, in_iter, & + this%nitermax, & + this%convnmod, this%convmodstart, & + this%locdv, this%locdr, & + this%caccel, this%itinner, & + this%convlocdv, this%convlocdr, & + this%dvmax, this%drmax, & + this%convdvmax, this%convdrmax) + end if + ! + ! ptc finalize - set ratio of ptc value added to the diagonal and the + ! minimum value on the diagonal. This value will be used + ! to determine if the make sure the ptc value has decayed + ! sufficiently + if (iptct /= 0) then + this%ptcrat = ptcval / diagmin + end if + ! + ! -- return + return + end subroutine sln_ls + + ! + subroutine sln_setouter(this, ifdparam) +! ****************************************************************************** +! sln_setouter +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(NumericalSolutionType), intent(inout) :: this + integer(I4B), intent(in) :: ifdparam +! ------------------------------------------------------------------------------ + ! + ! -- simple option + select case ( ifdparam ) + case ( 1 ) + this%hclose = dem3 + this%mxiter = 25 + this%nonmeth = 0 + this%theta = 1.0 + this%akappa = DZERO + this%gamma = DZERO + this%amomentum = DZERO + this%numtrack = 0 + this%btol = DZERO + this%breduc = DZERO + this%res_lim = DZERO + ! + ! -- moderate + case ( 2 ) + this%hclose = dem2 + this%mxiter = 50 + this%nonmeth = 3 + this%theta = 0.9d0 + this%akappa = 0.0001d0 + this%gamma = DZERO + this%amomentum = DZERO + this%numtrack = 0 + this%btol = DZERO + this%breduc = DZERO + this%res_lim = DZERO + ! + ! -- complex + case ( 3 ) + this%hclose = dem1 + this%mxiter = 100 + this%nonmeth = 3 + this%theta = 0.8d0 + this%akappa = 0.0001d0 + this%gamma = DZERO + this%amomentum = DZERO + this%numtrack = 20 + this%btol = 1.05d0 + this%breduc = 0.1d0 + this%res_lim = 0.002d0 + end select + ! + ! -- return + return + end subroutine sln_setouter + + subroutine sln_backtracking(this, mp, cp, kiter) +! ****************************************************************************** +! sln_backtracking +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(NumericalSolutionType), intent(inout) :: this + class(NumericalModelType), pointer :: mp + class(NumericalExchangeType), pointer :: cp + integer(I4B), intent(in) :: kiter + ! -- local + character(len=7) :: cmsg + integer(I4B) :: ic + integer(I4B) :: im + integer(I4B) :: nb + integer(I4B) :: btflag + integer(I4B) :: ibflag + integer(I4B) :: ibtcnt + real(DP) :: resin +! ------------------------------------------------------------------------------ + ! + ! -- initialize local variables + ibflag = 0 + ! + ! -- refill amat and rhs with standard conductance + ! -- Set amat and rhs to zero + call this%sln_reset() + ! + ! -- Calculate matrix coefficients (CF) for each exchange + do ic=1,this%exchangelist%Count() + cp => GetNumericalExchangeFromList(this%exchangelist, ic) + call cp%exg_cf(kiter) + end do + ! + ! -- Calculate matrix coefficients (CF) for each model + do im=1,this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, im) + call mp%model_cf(kiter) + end do + ! + ! -- Fill coefficients (FC) for each exchange + do ic=1,this%exchangelist%Count() + cp => GetNumericalExchangeFromList(this%exchangelist, ic) + call cp%exg_fc(kiter, this%ia, this%amat, 0) + end do + ! + ! -- Fill coefficients (FC) for each model + do im=1,this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, im) + call mp%model_fc(kiter, this%amat, this%nja, 0) + end do + ! + ! -- calculate initial l2 norm + if (kiter == 1) then + call this%sln_l2norm(this%neq, this%nja, & + this%ia, this%ja, this%active, & + this%amat, this%rhs, this%x, this%res_prev) + resin = this%res_prev + ibflag = 0 + else + call this%sln_l2norm(this%neq, this%nja, & + this%ia, this%ja, this%active, & + this%amat, this%rhs, this%x, this%res_new) + resin = this%res_new + end if + ibtcnt = 0 + if (kiter > 1) then + if (this%res_new > this%res_prev * this%btol) then + ! + ! -- iterate until backtracking complete + btloop: do nb = 1, this%numtrack + ! + ! -- backtrack heads + call this%sln_backtracking_xupdate(btflag) + ! + ! -- head change less than hclose + if (btflag == 0) then + ibflag = 4 + exit btloop + end if + ! + ibtcnt = nb + ! + ! -- Set amat and rhs to zero + call this%sln_reset() + ! + ! -- Calculate matrix coefficients (CF) for each exchange + do ic=1,this%exchangelist%Count() + cp => GetNumericalExchangeFromList(this%exchangelist, ic) + call cp%exg_cf(kiter) + end do + ! + ! -- Calculate matrix coefficients (CF) for each model + do im=1,this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, im) + call mp%model_cf(kiter) + end do + ! + ! -- Fill coefficients (FC) for each exchange + do ic=1,this%exchangelist%Count() + cp => GetNumericalExchangeFromList(this%exchangelist, ic) + call cp%exg_fc(kiter, this%ia, this%amat, 0) + end do + ! + ! -- Fill coefficients (FC) for each model + do im=1,this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, im) + call mp%model_fc(kiter, this%amat, this%nja, 0) + end do + ! + ! -- calculate updated l2norm + call this%sln_l2norm(this%neq, this%nja, & + this%ia, this%ja, this%active, & + this%amat, this%rhs, this%x, this%res_new) + ! + ! -- evaluate if back tracking can be terminated + if (nb == this%numtrack) then + ibflag = 2 + exit btloop + end if + if (this%res_new < this%res_prev * this%btol) then + ibflag = 1 + exit btloop + end if + if (this%res_new < this%res_lim) then + exit btloop + end if + end do btloop + end if + ! -- save new residual + this%res_prev = this%res_new + end if + ! + ! -- write back backtracking results + if (this%iprims > 0) then + if (ibtcnt > 0) then + cmsg = ' ' + else + cmsg = '*' + end if + ! + ! -- add data to outertab + call this%outertab%add_term( 'Backtracking') + call this%outertab%add_term(kiter) + call this%outertab%add_term(' ') + if (this%numtrack > 0) then + call this%outertab%add_term(ibflag) + call this%outertab%add_term(ibtcnt) + call this%outertab%add_term(resin) + call this%outertab%add_term(this%res_prev) + end if + call this%outertab%add_term(' ') + call this%outertab%add_term(cmsg) + call this%outertab%add_term(' ') + end if + ! + ! -- return + return + end subroutine sln_backtracking + + subroutine sln_backtracking_xupdate(this, btflag) +! ****************************************************************************** +! sln_backtracking_xupdate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(NumericalSolutionType), intent(inout) :: this + integer(I4B), intent(inout) :: btflag + ! -- local + integer(I4B) :: n + real(DP) :: delx + real(DP) :: absdelx + real(DP) :: chmax +! ------------------------------------------------------------------------------ + ! + btflag = 0 + ! no backtracking if maximum change is less than closure so return + chmax = 0.0 + do n=1, this%neq + if (this%active(n) < 1) cycle + delx = this%breduc*(this%x(n) - this%xtemp(n)) + absdelx = abs(delx) + if(absdelx > chmax) chmax = absdelx + end do + ! perform backtracking if free of constraints and set counter and flag + if (chmax >= this%hclose) then + btflag = 1 + do n = 1, this%neq + if (this%active(n) < 1) cycle + delx = this%breduc*(this%x(n) - this%xtemp(n)) + this%x(n) = this%xtemp(n) + delx + end do + end if + ! + ! -- return + return + end subroutine sln_backtracking_xupdate + + subroutine sln_l2norm(this, neq, nja, ia, ja, active, amat, rhs, x, resid) +! ****************************************************************************** +! sln_l2norm +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(NumericalSolutionType), intent(inout) :: this + integer(I4B), intent(in) :: neq + integer(I4B), intent(in) :: nja + integer(I4B), dimension(neq+1), intent(in) :: ia + integer(I4B), dimension(nja), intent(in) :: ja + integer(I4B), dimension(neq), intent(in) :: active + real(DP), dimension(nja), intent(in) :: amat + real(DP), dimension(neq), intent(in) :: rhs + real(DP), dimension(neq), intent(in) :: x + real(DP), intent(inout) :: resid + ! -- local + integer(I4B) :: n + integer(I4B) :: j, jcol + real(DP) :: rowsum +! ------------------------------------------------------------------------------ + ! + resid = DZERO + do n = 1, neq + if (active(n) > 0) then + rowsum = DZERO + do j = ia(n), ia(n+1)-1 + jcol = ja(j) + rowsum = rowsum + amat(j) * x(jcol) + end do + ! compute mean square residual from q of each node + resid = resid + (rowsum - rhs(n))**2 + end if + end do + ! -- l2norm is the square root of the sum of the square of the residuals + resid = sqrt(resid) + ! + ! -- return + return + end subroutine sln_l2norm + + subroutine sln_maxval(this, neq, v, vnorm) +! ****************************************************************************** +! sln_maxval +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(NumericalSolutionType), intent(inout) :: this + integer(I4B), intent(in) :: neq + real(DP), dimension(neq), intent(in) :: v + real(DP), intent(inout) :: vnorm + ! -- local + integer(I4B) :: n + real(DP) :: d + real(DP) :: denom + real(DP) :: dnorm +! ------------------------------------------------------------------------------ + vnorm = v(1) + do n = 2, neq + d = v(n) + denom = abs(vnorm) + if (denom == DZERO) then + denom = DPREC + end if + ! + ! -- calculate normalized value + dnorm = abs(d) / denom + if (dnorm > DONE) then + vnorm = d + end if + end do + ! + ! -- return + return + end subroutine sln_maxval + + subroutine sln_calcdx(this, neq, active, x, xtemp, dx) +! ****************************************************************************** +! sln_calcdx +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(NumericalSolutionType), intent(inout) :: this + integer(I4B), intent(in) :: neq + integer(I4B), dimension(neq), intent(in) :: active + real(DP), dimension(neq), intent(in) :: x + real(DP), dimension(neq), intent(in) :: xtemp + real(DP), dimension(neq), intent(inout) :: dx + ! -- local + integer(I4B) :: n +! ------------------------------------------------------------------------------ + do n = 1, neq + ! -- skip inactive nodes + if (active(n) < 1) then + dx(n) = DZERO + else + dx(n) = x(n) - xtemp(n) + end if + end do + ! + ! -- return + return + end subroutine sln_calcdx + + + subroutine sln_underrelax(this, kiter, bigch, neq, active, x, xtemp) +! ****************************************************************************** +! under relax using delta-bar-delta or cooley formula +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(NumericalSolutionType), intent(inout) :: this + integer(I4B), intent(in) :: kiter + real(DP), intent(in) :: bigch + integer(I4B), intent(in) :: neq + integer(I4B), dimension(neq), intent(in) :: active + real(DP), dimension(neq), intent(inout) :: x + real(DP), dimension(neq), intent(in) :: xtemp + ! -- local + real(DP) :: ww, delx, relax, es, aes, amom + integer(I4B) :: n +! ------------------------------------------------------------------------------ + ! + ! -- option for using simple dampening (as done by MODFLOW-2005 PCG) + if (this%nonmeth == 1) then + do n = 1, neq + ! -- skip inactive nodes + if (active(n) < 1) cycle + ! + ! -- compute step-size (delta x) + delx = x(n) - xtemp(n) + this%dxold(n) = delx + + ! -- dampen head solution + x(n) = xtemp(n) + this%gamma * delx + end do + ! + ! -- option for using cooley underrelaxation + else if (this%nonmeth == 2) then + if (kiter == 1) then + relax = done + this%relaxold = DONE + this%bigch = bigch + this%bigchold = bigch + else + ! -- compute relaxation factor + es = this%bigch / (this%bigchold * this%relaxold) + aes = abs(es) + if (es < -DONE) then + relax = dhalf / aes + else + relax = (DTHREE + es) / (DTHREE + aes) + end if + end if + this%relaxold = relax + ! + ! -- modify cooley to use exponential average of past changes + this%bigchold = (DONE - this%gamma) * this%bigch + this%gamma * & + this%bigchold + ! -- this method does it right after newton - need to do it after + ! underrelaxation and backtracking. + ! + ! -- compute new head after under-relaxation + if (relax < DONE) then + do n = 1, neq + if (active(n) < 1) cycle + delx = x(n) - xtemp(n) + this%dxold(n) = delx + x(n) = xtemp(n) + relax * delx + end do + end if + ! + ! -- option for using delta-bar-delta scheme to under-relax for all equations + else if (this%nonmeth == 3) then + do n = 1, neq + ! -- skip inactive nodes + if (active(n) < 1) cycle + ! + ! -- compute step-size (delta x) and initialize d-b-d parameters + delx = x(n) - xtemp(n) + + if ( kiter == 1 ) then + this%wsave(n) = DONE + this%hchold(n) = DEM20 + this%deold(n) = DZERO + end if + ! + ! -- compute new relaxation term as per delta-bar-delta + ww = this%wsave(n) + + ! for flip-flop condition, decrease factor + if ( this%deold(n)*delx < DZERO ) then + ww = this%theta * this%wsave(n) + ! -- when change is of same sign, increase factor + else + ww = this%wsave(n) + this%akappa + end if + if ( ww > DONE ) ww = DONE + this%wsave(n) = ww + + ! -- compute exponential average of past changes in hchold + if (kiter == 1) then + ! -- this method does it right after newton + ! -- need to do it after underrelaxation and backtracking. + this%hchold(n) = delx + else + this%hchold(n) = (DONE - this%gamma) * delx + & + this%gamma * this%hchold(n) + end if + ! + ! -- store slope (change) term for next iteration + this%deold(n) = delx + this%dxold(n) = delx + ! + ! -- compute accepted step-size and new head + amom = DZERO + if (kiter > 4) amom = this%amomentum + delx = delx * ww + amom * this%hchold(n) + x(n) = xtemp(n) + delx + end do + ! + end if + ! + ! -- return + return + end subroutine sln_underrelax + + subroutine sln_outer_check(this, hncg, lrch) +! ****************************************************************************** +! sln_outer_check +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(NumericalSolutionType), intent(inout) :: this + real(DP), intent(inout) :: hncg + integer(I4B), intent(inout) :: lrch + ! -- local + integer(I4B) :: nb + real(DP) :: bigch + real(DP) :: abigch + integer(I4B) :: n + real(DP) :: hdif + real(DP) :: ahdif +! ------------------------------------------------------------------------------ + ! + nb = 1 + bigch = DZERO + abigch = DZERO + do n = 1, this%neq + if(this%active(n) < 1) cycle + hdif = this%x(n) - this%xtemp(n) + ahdif = abs(hdif) + if (ahdif >= abigch) then + bigch = hdif + abigch = ahdif + nb = n + end if + end do + ! + !-----store maximum change value and location + hncg = bigch + lrch = nb + ! + ! -- return + return + end subroutine sln_outer_check + + subroutine sln_get_loc(this, nodesln, str) +! ****************************************************************************** +! sln_get_loc +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(NumericalSolutionType), intent(inout) :: this + integer(I4B), intent(in) :: nodesln + character(len=*), intent(inout) :: str + ! -- local + class(NumericalModelType),pointer :: mp + integer(I4B) :: i + integer(I4B) :: istart + integer(I4B) :: iend + integer(I4B) :: noder +! ------------------------------------------------------------------------------ + ! + ! -- calculate and set offsets + noder = 0 + str = '' + do i = 1, this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, i) + call mp%get_mrange(istart, iend) + if (nodesln >= istart .and. nodesln <= iend) then + noder = nodesln - istart + 1 + call mp%get_mcellid(noder, str) + exit + end if + end do + ! + ! -- return + return + end subroutine sln_get_loc + + subroutine sln_get_nodeu(this, nodesln, im, nodeu) +! ****************************************************************************** +! sln_get_nodeu +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(NumericalSolutionType), intent(inout) :: this + integer(I4B), intent(in) :: nodesln + integer(I4B), intent(inout) :: im + integer(I4B), intent(inout) :: nodeu + ! -- local + class(NumericalModelType),pointer :: mp + integer(I4B) :: i + integer(I4B) :: istart + integer(I4B) :: iend + integer(I4B) :: noder +! ------------------------------------------------------------------------------ + ! + ! -- calculate and set offsets + noder = 0 + do i = 1, this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, i) + call mp%get_mrange(istart, iend) + if (nodesln >= istart .and. nodesln <= iend) then + noder = nodesln - istart + 1 + call mp%get_mnodeu(noder, nodeu) + im = i + exit + end if + end do + ! + ! -- return + return + end subroutine sln_get_nodeu + + function CastAsNumericalSolutionClass(obj) result (res) + implicit none + class(*), pointer, intent(inout) :: obj + class(NumericalSolutionType), pointer :: res + ! + res => null() + if (.not. associated(obj)) return + ! + select type (obj) + class is (NumericalSolutionType) + res => obj + end select + return + end function CastAsNumericalSolutionClass + + function GetNumericalSolutionFromList(list, idx) result (res) + implicit none + ! -- dummy + type(ListType), intent(inout) :: list + integer(I4B), intent(in) :: idx + class(NumericalSolutionType), pointer :: res + ! -- local + class(*), pointer :: obj + ! + obj => list%GetItem(idx) + res => CastAsNumericalSolutionClass(obj) + ! + return + end function GetNumericalSolutionFromList + + + +end module NumericalSolutionModule diff --git a/src/Solution/SolutionGroup.f90 b/src/Solution/SolutionGroup.f90 index f66564d7960..039833d30fd 100644 --- a/src/Solution/SolutionGroup.f90 +++ b/src/Solution/SolutionGroup.f90 @@ -1,227 +1,227 @@ -module SolutionGroupModule - use KindModule, only: DP, I4B - use ListsModule, only: basesolutionlist - use BaseSolutionModule, only: BaseSolutionType, AddBaseSolutionToList, & - GetBaseSolutionFromList - use ListModule, only: ListType - - implicit none - private - public :: SolutionGroupType, AddSolutionGroupToList, & - GetSolutionGroupFromList, solutiongroup_create - private :: CastAsSolutionGroupClass - - type :: SolutionGroupType - integer(I4B), pointer :: id - integer(I4B), pointer :: mxiter - integer(I4B), pointer :: nsolutions - integer(I4B), dimension(:), allocatable :: idsolutions !array of solution ids in basesolutionlist - contains - procedure :: sgp_ca - procedure :: sgp_da - procedure, private :: allocate_scalars - procedure :: add_solution - end type SolutionGroupType - - contains - - subroutine solutiongroup_create(sgp, id) -! ****************************************************************************** -! solutiongroup_create -- Create a new solution group -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - type(SolutionGroupType), pointer :: sgp - integer(I4B), intent(in) :: id -! ------------------------------------------------------------------------------ - ! - allocate(sgp) - call sgp%allocate_scalars() - sgp%id = id - ! - ! -- return - return - end subroutine solutiongroup_create - - subroutine sgp_ca(this) -! ****************************************************************************** -! sgp_ca -- Calculate the solution group -! Solve each solution group and each solution. Start with converge -! flag equal true and reset to zero if any non-convergence triggers -! are encountered. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimVariablesModule, only: iout, isimcnvg - use SimModule, only: store_error, ustop - use TdisModule, only: kstp, kper - ! -- dummy - class(SolutionGroupType) :: this - ! -- local - class(BaseSolutionType), pointer :: sp - integer(I4B) :: kpicard, isgcnvg, isuppress_output - integer(I4B) :: is, isoln - ! -- formats - character(len=*), parameter :: fmtnocnvg = & - "(1X,'Solution Group ', i0, ' did not converge for stress period ', i0, & - &' and time step ', i0)" -! ------------------------------------------------------------------------------ - ! - ! -- Suppress output during picard iterations - if(this%mxiter > 1) then - isuppress_output = 1 - else - isuppress_output = 0 - endif - ! - ! -- Picard loop - picardloop: do kpicard = 1, this%mxiter - if (this%mxiter > 1) then - write(iout,'(/a,i6/)') 'SOLUTION GROUP PICARD ITERATION: ', kpicard - end if - isgcnvg = 1 - do is = 1, this%nsolutions - isoln = this%idsolutions(is) - sp => GetBaseSolutionFromList(basesolutionlist, isoln) - call sp%sln_ca(kpicard, isgcnvg, isuppress_output) - enddo - if(isgcnvg == 1) exit picardloop - enddo picardloop - ! - ! -- if a picard loop was used and the solution group converged - ! then rerun the timestep and save the output. Or if there - ! is only one picard iteration, then do nothing as models - ! are assumed to be explicitly coupled. - if(isgcnvg == 1) then - if(this%mxiter > 1) then - isuppress_output = 0 - do is = 1, this%nsolutions - isoln = this%idsolutions(is) - sp => GetBaseSolutionFromList(basesolutionlist, isoln) - call sp%sln_ca(kpicard, isgcnvg, isuppress_output) - enddo - endif - else - isimcnvg = 0 - write(iout, fmtnocnvg) this%id, kper, kstp - endif - ! - ! -- return - return - end subroutine sgp_ca - - subroutine sgp_da(this) -! ****************************************************************************** -! deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(SolutionGroupType) :: this -! ------------------------------------------------------------------------------ - ! - deallocate(this%id) - deallocate(this%mxiter) - deallocate(this%nsolutions) - deallocate(this%idsolutions) - ! - ! -- return - return - end subroutine sgp_da - - subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(SolutionGroupType) :: this -! ------------------------------------------------------------------------------ - ! - allocate(this%id) - allocate(this%mxiter) - allocate(this%nsolutions) - this%id = 0 - this%mxiter = 1 - this%nsolutions = 0 - ! - ! -- return - return - end subroutine allocate_scalars - - subroutine add_solution(this, isoln, sp) -! ****************************************************************************** -! add_solution -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ArrayHandlersModule, only: ExpandArray - ! -- dummy - class(SolutionGroupType) :: this - integer(I4B), intent(in) :: isoln - class(BaseSolutionType), pointer, intent(in) :: sp - ! -- local - integer(I4B) :: ipos -! ------------------------------------------------------------------------------ - ! - call ExpandArray(this%idsolutions) - ipos = size(this%idsolutions) - this%idsolutions(ipos) = isoln - this%nsolutions = this%nsolutions + 1 - ! - ! -- return - return - end subroutine add_solution - - function CastAsSolutionGroupClass(obj) result (res) - implicit none - class(*), pointer, intent(inout) :: obj - class(SolutionGroupType), pointer :: res - ! - res => null() - if (.not. associated(obj)) return - ! - select type (obj) - class is (SolutionGroupType) - res => obj - end select - return - end function CastAsSolutionGroupClass - - subroutine AddSolutionGroupToList(list, solutiongroup) - implicit none - ! -- dummy - type(ListType), intent(inout) :: list - type(SolutionGroupType), pointer, intent(inout) :: solutiongroup - ! -- local - class(*), pointer :: obj - ! - obj => solutiongroup - call list%Add(obj) - ! - return - end subroutine AddSolutionGroupToList - - function GetSolutionGroupFromList(list, idx) result (res) - implicit none - ! -- dummy - type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx - class(SolutionGroupType), pointer :: res - ! -- local - class(*), pointer :: obj - ! - obj => list%GetItem(idx) - res => CastAsSolutionGroupClass(obj) - ! - return - end function GetSolutionGroupFromList - -end module SolutionGroupModule +module SolutionGroupModule + use KindModule, only: DP, I4B + use ListsModule, only: basesolutionlist + use BaseSolutionModule, only: BaseSolutionType, AddBaseSolutionToList, & + GetBaseSolutionFromList + use ListModule, only: ListType + + implicit none + private + public :: SolutionGroupType, AddSolutionGroupToList, & + GetSolutionGroupFromList, solutiongroup_create + private :: CastAsSolutionGroupClass + + type :: SolutionGroupType + integer(I4B), pointer :: id + integer(I4B), pointer :: mxiter + integer(I4B), pointer :: nsolutions + integer(I4B), dimension(:), allocatable :: idsolutions !array of solution ids in basesolutionlist + contains + procedure :: sgp_ca + procedure :: sgp_da + procedure, private :: allocate_scalars + procedure :: add_solution + end type SolutionGroupType + + contains + + subroutine solutiongroup_create(sgp, id) +! ****************************************************************************** +! solutiongroup_create -- Create a new solution group +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + type(SolutionGroupType), pointer :: sgp + integer(I4B), intent(in) :: id +! ------------------------------------------------------------------------------ + ! + allocate(sgp) + call sgp%allocate_scalars() + sgp%id = id + ! + ! -- return + return + end subroutine solutiongroup_create + + subroutine sgp_ca(this) +! ****************************************************************************** +! sgp_ca -- Calculate the solution group +! Solve each solution group and each solution. Start with converge +! flag equal true and reset to zero if any non-convergence triggers +! are encountered. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimVariablesModule, only: iout, isimcnvg + use SimModule, only: store_error, ustop + use TdisModule, only: kstp, kper + ! -- dummy + class(SolutionGroupType) :: this + ! -- local + class(BaseSolutionType), pointer :: sp + integer(I4B) :: kpicard, isgcnvg, isuppress_output + integer(I4B) :: is, isoln + ! -- formats + character(len=*), parameter :: fmtnocnvg = & + "(1X,'Solution Group ', i0, ' did not converge for stress period ', i0, & + &' and time step ', i0)" +! ------------------------------------------------------------------------------ + ! + ! -- Suppress output during picard iterations + if(this%mxiter > 1) then + isuppress_output = 1 + else + isuppress_output = 0 + endif + ! + ! -- Picard loop + picardloop: do kpicard = 1, this%mxiter + if (this%mxiter > 1) then + write(iout,'(/a,i6/)') 'SOLUTION GROUP PICARD ITERATION: ', kpicard + end if + isgcnvg = 1 + do is = 1, this%nsolutions + isoln = this%idsolutions(is) + sp => GetBaseSolutionFromList(basesolutionlist, isoln) + call sp%sln_ca(kpicard, isgcnvg, isuppress_output) + enddo + if(isgcnvg == 1) exit picardloop + enddo picardloop + ! + ! -- if a picard loop was used and the solution group converged + ! then rerun the timestep and save the output. Or if there + ! is only one picard iteration, then do nothing as models + ! are assumed to be explicitly coupled. + if(isgcnvg == 1) then + if(this%mxiter > 1) then + isuppress_output = 0 + do is = 1, this%nsolutions + isoln = this%idsolutions(is) + sp => GetBaseSolutionFromList(basesolutionlist, isoln) + call sp%sln_ca(kpicard, isgcnvg, isuppress_output) + enddo + endif + else + isimcnvg = 0 + write(iout, fmtnocnvg) this%id, kper, kstp + endif + ! + ! -- return + return + end subroutine sgp_ca + + subroutine sgp_da(this) +! ****************************************************************************** +! deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(SolutionGroupType) :: this +! ------------------------------------------------------------------------------ + ! + deallocate(this%id) + deallocate(this%mxiter) + deallocate(this%nsolutions) + deallocate(this%idsolutions) + ! + ! -- return + return + end subroutine sgp_da + + subroutine allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(SolutionGroupType) :: this +! ------------------------------------------------------------------------------ + ! + allocate(this%id) + allocate(this%mxiter) + allocate(this%nsolutions) + this%id = 0 + this%mxiter = 1 + this%nsolutions = 0 + ! + ! -- return + return + end subroutine allocate_scalars + + subroutine add_solution(this, isoln, sp) +! ****************************************************************************** +! add_solution +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ArrayHandlersModule, only: ExpandArray + ! -- dummy + class(SolutionGroupType) :: this + integer(I4B), intent(in) :: isoln + class(BaseSolutionType), pointer, intent(in) :: sp + ! -- local + integer(I4B) :: ipos +! ------------------------------------------------------------------------------ + ! + call ExpandArray(this%idsolutions) + ipos = size(this%idsolutions) + this%idsolutions(ipos) = isoln + this%nsolutions = this%nsolutions + 1 + ! + ! -- return + return + end subroutine add_solution + + function CastAsSolutionGroupClass(obj) result (res) + implicit none + class(*), pointer, intent(inout) :: obj + class(SolutionGroupType), pointer :: res + ! + res => null() + if (.not. associated(obj)) return + ! + select type (obj) + class is (SolutionGroupType) + res => obj + end select + return + end function CastAsSolutionGroupClass + + subroutine AddSolutionGroupToList(list, solutiongroup) + implicit none + ! -- dummy + type(ListType), intent(inout) :: list + type(SolutionGroupType), pointer, intent(inout) :: solutiongroup + ! -- local + class(*), pointer :: obj + ! + obj => solutiongroup + call list%Add(obj) + ! + return + end subroutine AddSolutionGroupToList + + function GetSolutionGroupFromList(list, idx) result (res) + implicit none + ! -- dummy + type(ListType), intent(inout) :: list + integer(I4B), intent(in) :: idx + class(SolutionGroupType), pointer :: res + ! -- local + class(*), pointer :: obj + ! + obj => list%GetItem(idx) + res => CastAsSolutionGroupClass(obj) + ! + return + end function GetSolutionGroupFromList + +end module SolutionGroupModule diff --git a/src/Solution/SparseMatrixSolver/ims8linear.f90 b/src/Solution/SparseMatrixSolver/ims8linear.f90 index 1c8bd5b0223..190a54ce816 100644 --- a/src/Solution/SparseMatrixSolver/ims8linear.f90 +++ b/src/Solution/SparseMatrixSolver/ims8linear.f90 @@ -1,2883 +1,2883 @@ - MODULE IMSLinearModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH, LENSOLUTIONNAME, & - IZERO, DZERO, DPREC, DSAME, & - DEM8, DEM6, DEM5, DEM4, DEM3, DEM2, DEM1, & - DHALF, DONE, DTWO, & - VDEBUG - use GenericUtilitiesModule, only: sim_message, IS_SAME - use IMSReorderingModule, only: ims_genrcm, ims_odrv, ims_dperm, ims_vperm - use BlockParserModule, only: BlockParserType - - IMPLICIT NONE - private - - TYPE, PUBLIC :: IMSLINEAR_DATA - CHARACTER (LEN=20) :: ORIGIN - integer(I4B), POINTER :: iout => NULL() - integer(I4B), POINTER :: IPRIMS => NULL() - integer(I4B), POINTER :: ILINMETH => NULL() - integer(I4B), POINTER :: ITER1 => NULL() - integer(I4B), POINTER :: IPC => NULL() - integer(I4B), POINTER :: ISCL => NULL() - integer(I4B), POINTER :: IORD => NULL() - integer(I4B), POINTER :: NORTH => NULL() - integer(I4B), POINTER :: ICNVGOPT => NULL() - integer(I4B), POINTER :: IACPC => NULL() - integer(I4B), POINTER :: NITERC => NULL() - integer(I4B), POINTER :: NIABCGS => NULL() - integer(I4B), POINTER :: NIAPC => NULL() - integer(I4B), POINTER :: NJAPC => NULL() - real(DP), POINTER :: HCLOSE => NULL() - real(DP), POINTER :: RCLOSE => NULL() - real(DP), POINTER :: RELAX => NULL() - real(DP), POINTER :: EPFACT => NULL() - real(DP), POINTER :: L2NORM0 => NULL() - ! ILUT VARIABLES - integer(I4B), POINTER :: LEVEL => NULL() - real(DP), POINTER :: DROPTOL => NULL() - integer(I4B), POINTER :: NJLU => NULL() - integer(I4B), POINTER :: NJW => NULL() - integer(I4B), POINTER :: NWLU => NULL() - ! POINTERS TO SOLUTION VARIABLES - integer(I4B), POINTER :: NEQ => NULL() - integer(I4B), POINTER :: NJA => NULL() - integer(I4B), dimension(:), pointer, contiguous :: IA => NULL() - integer(I4B), dimension(:), pointer, contiguous :: JA => NULL() - real(DP), dimension(:), pointer, contiguous :: AMAT => NULL() - real(DP), dimension(:), pointer, contiguous :: RHS => NULL() - real(DP), dimension(:), pointer, contiguous :: X => NULL() - ! VECTORS - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: DSCALE => NULL() - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: DSCALE2 => NULL() - integer(I4B), POINTER,DIMENSION(:),CONTIGUOUS :: IAPC => NULL() - integer(I4B), POINTER,DIMENSION(:),CONTIGUOUS :: JAPC => NULL() - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: APC => NULL() - integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: LORDER => NULL() - integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: IORDER => NULL() - integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: IARO => NULL() - integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: JARO => NULL() - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: ARO => NULL() - ! WORKING ARRAYS - integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: IW => NULL() - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: W => NULL() - integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: ID => NULL() - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: D => NULL() - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: P => NULL() - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: Q => NULL() - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: Z => NULL() - ! BICGSTAB WORKING ARRAYS - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: T => NULL() - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: V => NULL() - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: DHAT => NULL() - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: PHAT => NULL() - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: QHAT => NULL() - ! POINTERS FOR USE WITH BOTH ORIGINAL AND RCM ORDERINGS - integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: IA0 => NULL() - integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: JA0 => NULL() - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: A0 => NULL() - ! ILUT WORKING ARRAYS - integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: JLU => NULL() - integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: JW => NULL() - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: WLU => NULL() - - ! PROCEDURES (METHODS) - CONTAINS - PROCEDURE :: IMSLINEAR_ALLOCATE => IMSLINEAR_AR - procedure :: imslinear_summary - PROCEDURE :: IMSLINEAR_APPLY => IMSLINEAR_AP - procedure :: IMSLINEAR_DA - procedure, private :: allocate_scalars - ! -- PRIVATE PROCEDURES - PROCEDURE, PRIVATE :: SET_IMSLINEAR_INPUT - END TYPE IMSLINEAR_DATA - - type(BlockParserType), private :: parser - - - CONTAINS - SUBROUTINE IMSLINEAR_AR(THIS, NAME, IN, IOUT, IPRIMS, MXITER, IFDPARAM, & - IMSLINEARM, NEQ, NJA, IA, JA, AMAT, RHS, X, & - NINNER, LFINDBLOCK) -! ****************************************************************** -! ALLOCATE STORAGE FOR PCG ARRAYS AND READ IMSLINEAR DATA -! ****************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------ - use MemoryManagerModule, only: mem_allocate - use SimModule, only: ustop, store_error, count_errors - !IMPLICIT NONE -! + + + DUMMY VARIABLES + + + - CLASS(IMSLINEAR_DATA), INTENT(INOUT) :: THIS - CHARACTER (LEN=LENSOLUTIONNAME), INTENT(IN) :: NAME - integer(I4B), INTENT(IN) :: IN - integer(I4B), INTENT(IN) :: IOUT - integer(I4B), TARGET, INTENT(IN) :: IPRIMS - integer(I4B), INTENT(IN) :: MXITER - integer(I4B), INTENT(IN) :: IFDPARAM - integer(I4B), INTENT(INOUT) :: IMSLINEARM - integer(I4B), TARGET, INTENT(IN) :: NEQ - integer(I4B), TARGET, INTENT(IN) :: NJA - integer(I4B), DIMENSION(NEQ+1), TARGET, INTENT(IN) :: IA - integer(I4B), DIMENSION(NJA), TARGET, INTENT(IN) :: JA - real(DP), DIMENSION(NJA), TARGET, INTENT(IN) :: AMAT - real(DP), DIMENSION(NEQ), TARGET, INTENT(INOUT) :: RHS - real(DP), DIMENSION(NEQ), TARGET, INTENT(INOUT) :: X - integer(I4B), TARGET, INTENT(INOUT) :: NINNER - integer(I4B), INTENT(IN), OPTIONAL :: LFINDBLOCK -! + + + LOCAL VARIABLES + + + - LOGICAL :: lreaddata - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: i, n - integer(I4B) :: i0 - integer(I4B) :: iscllen, iolen - integer(I4B) :: ierr - real(DP) :: r - logical :: isfound, endOfBlock - integer(I4B) :: ijlu - integer(I4B) :: ijw - integer(I4B) :: iwlu - integer(I4B) :: iwk -! + + + PARAMETERS + + + -! + + + OUTPUT FORMATS + + + -!------------------------------------------------------------------ -! -!-------SET LREADDATA - IF (PRESENT(LFINDBLOCK)) THEN - IF (LFINDBLOCK < 1) THEN - lreaddata = .FALSE. - ELSE - lreaddata = .TRUE. - END IF - ELSE - lreaddata = .TRUE. - END IF -! -!-------DEFINE NAME - THIS%ORIGIN = TRIM(NAME) // ' IMSLINEAR' -! -!-------SET POINTERS TO SOLUTION STORAGE - THIS%IPRIMS => IPRIMS - THIS%NEQ => NEQ - THIS%NJA => NJA - THIS%IA => IA - THIS%JA => JA - THIS%AMAT => AMAT - THIS%RHS => RHS - THIS%X => X -!-------ALLOCATE SCALAR VARIABLES - call this%allocate_scalars() -! -!-------initialize iout - this%iout = iout -! -!-------DEFAULT VALUES - THIS%IORD = 0 - THIS%ISCL = 0 - THIS%IPC = 0 - THIS%LEVEL = 0 - - !clevel = '' - !cdroptol = '' -! -!-------TRANSFER COMMON VARIABLES FROM IMS TO IMSLINEAR - THIS%ILINMETH = 0 - - THIS%IACPC = 0 - THIS%RELAX = DZERO !0.97 - - THIS%DROPTOL = DZERO - - THIS%NORTH = 0 - - THIS%ICNVGOPT = 0 -! -!-------PRINT A MESSAGE IDENTIFYING IMSLINEAR SOLVER PACKAGE - write(iout,2000) -02000 FORMAT (1X,/1X,'IMSLINEAR -- UNSTRUCTURED LINEAR SOLUTION', & - & ' PACKAGE, VERSION 8, 04/28/2017') -! -!-------SET DEFAULT IMSLINEAR PARAMETERS - CALL THIS%SET_IMSLINEAR_INPUT(IFDPARAM) - NINNER = this%iter1 -! -!-------Initialize block parser - call parser%Initialize(in, iout) -! -! -- get IMSLINEAR block - if (lreaddata) then - call parser%GetBlock('LINEAR', isfound, ierr, & - supportOpenClose=.true., blockRequired=.FALSE.) - else - isfound = .FALSE. - end if -! -! -- parse IMSLINEAR block if detected - if (isfound) then - write(iout,'(/1x,a)')'PROCESSING LINEAR DATA' - do - call parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call parser%GetStringCaps(keyword) - ! -- parse keyword - select case (keyword) - case ('INNER_HCLOSE') - this%hclose = parser%GetDouble() - case ('INNER_RCLOSE') - this%rclose = parser%GetDouble() - ! -- look for additional key words - call parser%GetStringCaps(keyword) - if (keyword == 'STRICT') then - THIS%ICNVGOPT = 1 - else if (keyword == 'L2NORM_RCLOSE') then - THIS%ICNVGOPT = 2 - else if (keyword == 'RELATIVE_RCLOSE') then - THIS%ICNVGOPT = 3 - else if (keyword == 'L2NORM_RELATIVE_RCLOSE') then - THIS%ICNVGOPT = 4 - end if - case ('INNER_MAXIMUM') - i = parser%GetInteger() - this%iter1 = i - NINNER = i - case ('LINEAR_ACCELERATION') - call parser%GetStringCaps(keyword) - if (keyword.eq.'CG') then - THIS%ILINMETH = 1 - else if (keyword.eq.'BICGSTAB') then - THIS%ILINMETH = 2 - else - THIS%ILINMETH = 0 - write(errmsg,'(4x,a,a)') & - & '****ERROR. UNKNOWN IMSLINEAR LINEAR_ACCELERATION METHOD: ', & - & trim(keyword) - call store_error(errmsg) - end if - case ('SCALING_METHOD') - call parser%GetStringCaps(keyword) - i = 0 - if (keyword.eq.'NONE') then - i = 0 - else if (keyword.eq.'DIAGONAL') then - i = 1 - else if (keyword.eq.'L2NORM') then - i = 2 - else - write(errmsg,'(4x,a,a)') & - & '****ERROR. UNKNOWN IMSLINEAR SCALING_METHOD: ', & - & trim(keyword) - call store_error(errmsg) - end if - THIS%ISCL = i - case ('RED_BLACK_ORDERING') - i = 0 - case ('REORDERING_METHOD') - call parser%GetStringCaps(keyword) - i = 0 - if (keyword == 'NONE') then - i = 0 - else if (keyword == 'RCM') then - i = 1 - else if (keyword == 'MD') then - i = 2 - else - write(errmsg,'(4x,a,a)') & - & '****ERROR. UNKNOWN IMSLINEAR REORDERING_METHOD: ', & - trim(keyword) - call store_error(errmsg) - end if - THIS%IORD = i - case ('NUMBER_ORTHOGONALIZATIONS') - this%north = parser%GetInteger() - case ('RELAXATION_FACTOR') - this%relax = parser%GetDouble() - case ('PRECONDITIONER_LEVELS') - i = parser%GetInteger() - this%level = i - if (i < 0) then - write(errmsg,'(4x,a,a)') & - & '****ERROR. PRECONDITIONER_LEVELS: ', & - & 'MUST BE GREATER THAN OR EQUAL TO ZERO' - call store_error(errmsg) - end if - !write(clevel, '(i15)') i - case ('PRECONDITIONER_DROP_TOLERANCE') - r = parser%GetDouble() - THIS%DROPTOL = r - if (r < DZERO) then - write(errmsg,'(4x,a,a)') & - & '****ERROR. PRECONDITIONER_DROP_TOLERANCE: ', & - & 'MUST BE GREATER THAN OR EQUAL TO ZERO' - call store_error(errmsg) - end if - !write(cdroptol, '(e15.5)') r - case default - write(errmsg,'(4x,a,a)') & - & '****WARNING. UNKNOWN IMSLINEAR KEYWORD: ', & - & trim(keyword) - call store_error(errmsg) - end select - end do - write(iout,'(1x,a)') 'END OF LINEAR DATA' - else - if (IFDPARAM == 0) THEN - write(errmsg,'(1x,a)') 'NO LINEAR BLOCK DETECTED.' - call store_error(errmsg) - end if - end if - - IMSLINEARM = THIS%ILINMETH -! -!-------DETERMINE PRECONDITIONER - IF (THIS%LEVEL > 0 .OR. THIS%DROPTOL > DZERO) THEN - THIS%IPC = 3 - ELSE - THIS%IPC = 1 - END IF - IF (THIS%RELAX > DZERO) THEN - THIS%IPC = THIS%IPC + 1 - END IF -! -!-------ERROR CHECKING FOR OPTIONS - IF (THIS%ISCL < 0 ) THIS%ISCL = 0 - IF (THIS%ISCL > 2 ) THEN - WRITE( errmsg,'(A)' ) 'IMSLINEAR7AR: ISCL MUST BE .LE. 2' - call store_error(errmsg) - END IF - IF (THIS%IORD < 0 ) THIS%IORD = 0 - IF (THIS%IORD > 2) THEN - WRITE( errmsg,'(A)' ) 'IMSLINEAR7AR: IORD MUST BE .LE. 2' - call store_error(errmsg) - END IF - IF (THIS%NORTH < 0) THEN - WRITE( errmsg,'(A)' ) 'IMSLINEAR7AR: NORTH MUST .GE. 0' - call store_error(errmsg) - END IF - IF (THIS%RCLOSE == DZERO) THEN - IF (THIS%ICNVGOPT /= 3) THEN - WRITE( errmsg,'(A)' ) 'IMSLINEAR7AR: RCLOSE MUST .NE. 0.0' - call store_error(errmsg) - END IF - END IF - IF (THIS%RELAX < DZERO) THEN - WRITE( errmsg,'(A)' ) 'IMSLINEAR7AR: RELAX MUST BE .GE. 0.0' - call store_error(errmsg) - END IF - IF (THIS%RELAX > DONE) THEN - WRITE( errmsg,'(A)' ) 'IMSLINEAR7AR: RELAX MUST BE .LE. 1.0' - call store_error(errmsg) - END IF - - if (count_errors() > 0) then - call parser%StoreErrorUnit() - call ustop() - endif -! -!-------INITIALIZE IMSLINEAR VARIABLES - THIS%NITERC = 0 -! -!-------ALLOCATE AND INITIALIZE MEMORY FOR IMSLINEAR - iscllen = 1 - IF (THIS%ISCL.NE.0 ) iscllen = NEQ - CALL mem_allocate(THIS%DSCALE, iscllen, 'DSCALE', TRIM(THIS%ORIGIN)) - CALL mem_allocate(THIS%DSCALE2, iscllen, 'DSCALE2', TRIM(THIS%ORIGIN)) - -!-------ALLOCATE MEMORY FOR PRECONDITIONING MATRIX - ijlu = 1 - ijw = 1 - iwlu = 1 - ! -- ILU0 AND MILU0 - THIS%NIAPC = THIS%NEQ - THIS%NJAPC = THIS%NJA - ! -- ILUT AND MILUT - IF (THIS%IPC == 3 .OR. THIS%IPC == 4) THEN - THIS%NIAPC = THIS%NEQ - IF (THIS%LEVEL > 0) THEN - iwk = THIS%NEQ * (THIS%LEVEL * 2 + 1) - ELSE - iwk = 0 - DO n = 1, NEQ - i = IA(n+1) - IA(n) - IF (i > iwk) THEN - iwk = i - END IF - END DO - iwk = THIS%NEQ * iwk - END IF - THIS%NJAPC = iwk - ijlu = iwk - ijw = 2 * THIS%NEQ - iwlu = THIS%NEQ + 1 - END IF - THIS%NJLU = ijlu - THIS%NJW = ijw - THIS%NWLU = iwlu -!-------ALLOCATE BASE PRECONDITIONER VECTORS - CALL mem_allocate(THIS%IAPC, THIS%NIAPC+1, 'IAPC', TRIM(THIS%ORIGIN)) - CALL mem_allocate(THIS%JAPC, THIS%NJAPC, 'JAPC', TRIM(THIS%ORIGIN)) - CALL mem_allocate(THIS%APC, THIS%NJAPC, 'APC', TRIM(THIS%ORIGIN)) -!-------ALLOCATE MEMORY FOR ILU0 AND MILU0 NON-ZERO ROW ENTRY VECTOR - CALL mem_allocate(THIS%IW, THIS%NIAPC, 'IW', TRIM(THIS%ORIGIN)) - CALL mem_allocate(THIS%W, THIS%NIAPC, 'W', TRIM(THIS%ORIGIN)) -!-------ALLOCATE MEMORY FOR ILUT VECTORS - CALL mem_allocate(THIS%JLU, ijlu, 'JLU', TRIM(THIS%ORIGIN)) - CALL mem_allocate(THIS%JW, ijw, 'JW', TRIM(THIS%ORIGIN)) - CALL mem_allocate(THIS%WLU, iwlu, 'WLU', TRIM(THIS%ORIGIN)) -!-------GENERATE IAPC AND JAPC FOR ILU0 AND MILU0 - IF (THIS%IPC == 1 .OR. THIS%IPC == 2) THEN - CALL IMSLINEARSUB_PCCRS(THIS%NEQ,THIS%NJA,THIS%IA,THIS%JA, & - THIS%IAPC,THIS%JAPC) - END IF -!-------ALLOCATE SPACE FOR PERMUTATION VECTOR - i0 = 1 - iolen = 1 - IF (THIS%IORD.NE.0) THEN - i0 = THIS%NEQ - iolen = THIS%NJA - END IF - CALL mem_allocate(THIS%LORDER, i0, 'LORDER', TRIM(THIS%ORIGIN)) - CALL mem_allocate(THIS%IORDER, i0, 'IORDER', TRIM(THIS%ORIGIN)) - CALL mem_allocate(THIS%IARO, i0+1, 'IARO', TRIM(THIS%ORIGIN)) - CALL mem_allocate(THIS%JARO, iolen, 'JARO', TRIM(THIS%ORIGIN)) - CALL mem_allocate(THIS%ARO, iolen, 'ARO', TRIM(THIS%ORIGIN)) -!-------ALLOCATE WORKING VECTORS FOR IMSLINEAR SOLVER - CALL mem_allocate(THIS%ID, THIS%NEQ, 'ID', TRIM(THIS%ORIGIN)) - CALL mem_allocate(THIS%D, THIS%NEQ, 'D', TRIM(THIS%ORIGIN)) - CALL mem_allocate(THIS%P, THIS%NEQ, 'P', TRIM(THIS%ORIGIN)) - CALL mem_allocate(THIS%Q, THIS%NEQ, 'Q', TRIM(THIS%ORIGIN)) - CALL mem_allocate(THIS%Z, THIS%NEQ, 'Z', TRIM(THIS%ORIGIN)) -!-------ALLOCATE MEMORY FOR BCGS WORKING ARRAYS - THIS%NIABCGS = 1 - IF (THIS%ILINMETH == 2) THEN - THIS%NIABCGS = THIS%NEQ - END IF - CALL mem_allocate(THIS%T, THIS%NIABCGS, 'T', TRIM(THIS%ORIGIN)) - CALL mem_allocate(THIS%V, THIS%NIABCGS, 'V', TRIM(THIS%ORIGIN)) - CALL mem_allocate(THIS%DHAT, THIS%NIABCGS, 'DHAT', TRIM(THIS%ORIGIN)) - CALL mem_allocate(THIS%PHAT, THIS%NIABCGS, 'PHAT', TRIM(THIS%ORIGIN)) - CALL mem_allocate(THIS%QHAT, THIS%NIABCGS, 'QHAT', TRIM(THIS%ORIGIN)) -!-------INITIALIZE IMSLINEAR VECTORS - DO n = 1, iscllen - THIS%DSCALE(n) = DONE - THIS%DSCALE2(n) = DONE - END DO - DO n = 1, THIS%NJAPC - THIS%APC(n) = DZERO - END DO -!-------WORKING VECTORS - DO n = 1, THIS%NEQ - THIS%ID(n) = IZERO - THIS%D(n) = DZERO - THIS%P(n) = DZERO - THIS%Q(n) = DZERO - THIS%Z(n) = DZERO - END DO - DO n = 1, THIS%NIAPC - THIS%IW(n) = IZERO - THIS%W(n) = DZERO - END DO -!-------BCGS WORKING VECTORS - DO n = 1, THIS%NIABCGS - THIS%T(n) = DZERO - THIS%V(n) = DZERO - THIS%DHAT(n) = DZERO - THIS%PHAT(n) = DZERO - THIS%QHAT(n) = DZERO - END DO -!-------ILUT AND MILUT WORKING VECTORS - DO n = 1, ijlu - THIS%JLU(n) = DZERO - END DO - DO n = 1, ijw - THIS%JW(n) = DZERO - END DO - DO n = 1, iwlu - THIS%WLU(n) = DZERO - END DO -!-------REORDERING VECTORS - DO n = 1, i0 + 1 - THIS%IARO(n) = IZERO - END DO - DO n = 1, iolen - THIS%JARO(n) = IZERO - THIS%ARO(n) = DZERO - END DO -! -!-------REVERSE CUTHILL MCKEE AND MINIMUM DEGREE ORDERING - IF (THIS%IORD.NE.0) THEN - CALL IMSLINEARSUB_CALC_ORDER(IOUT, THIS%IPRIMS, THIS%IORD,THIS%NEQ, & - THIS%NJA,THIS%IA,THIS%JA, & - THIS%LORDER,THIS%IORDER) - END IF -! -!-------ALLOCATE MEMORY FOR STORING ITERATION CONVERGENCE DATA - -! -!-------RETURN - RETURN - END SUBROUTINE IMSLINEAR_AR - - subroutine imslinear_summary(this, mxiter) - class(IMSLINEAR_DATA), intent(inout) :: this - integer(I4B), intent(in) :: mxiter -! + + + LOCAL VARIABLES + + + - CHARACTER (LEN= 10) :: clin(0:2) - CHARACTER (LEN= 31) :: clintit(0:2) - CHARACTER (LEN= 20) :: cipc(0:4) - CHARACTER (LEN= 20) :: cscale(0:2) - CHARACTER (LEN= 25) :: corder(0:2) - CHARACTER (LEN= 16), DIMENSION(0:4) :: ccnvgopt - CHARACTER (LEN= 15) :: clevel - CHARACTER (LEN= 15) :: cdroptol - integer(I4B) :: i, j -! + + + PARAMETERS + + + -! DATA - DATA clin /'UNKNOWN ', & - 'CG ', & - & 'BCGS '/ - DATA clintit /' UNKNOWN ', & - ' CONJUGATE-GRADIENT ', & - & 'BICONJUGATE-GRADIENT STABILIZED'/ - DATA cipc /'UNKNOWN ', & - & 'INCOMPLETE LU ', & - & 'MOD. INCOMPLETE LU ', & - & 'INCOMPLETE LUT ', & - & 'MOD. INCOMPLETE LUT '/ - DATA cscale/'NO SCALING ', & - & 'SYMMETRIC SCALING ', & - & 'L2 NORM SCALING '/ - DATA corder/'ORIGINAL ORDERING ', & - & 'RCM ORDERING ', & - & 'MINIMUM DEGREE ORDERING '/ - DATA ccnvgopt /'INFINITY NORM ', & - & 'INFINITY NORM S ', & - & 'L2 NORM ', & - & 'RELATIVE L2NORM ', & - 'L2 NORM W. REL. '/ -! OUTPUT FORMATS -02010 FORMAT (1X,/,7X,'SOLUTION BY THE',1X,A31,1X,'METHOD', & - & /,1X,66('-'),/, & - & ' MAXIMUM OF ',I6,' CALLS OF SOLUTION ROUTINE',/, & - & ' MAXIMUM OF ',I6, & - & ' INTERNAL ITERATIONS PER CALL TO SOLUTION ROUTINE',/, & - & ' LINEAR ACCELERATION METHOD =',1X,A,/, & - & ' MATRIX PRECONDITIONING TYPE =',1X,A,/, & - & ' MATRIX SCALING APPROACH =',1X,A,/, & - & ' MATRIX REORDERING APPROACH =',1X,A,/, & - & ' NUMBER OF ORTHOGONALIZATIONS =',I9,/, & - & ' HEAD CHANGE CRITERION FOR CLOSURE =',E15.5,/, & - & ' RESIDUAL CHANGE CRITERION FOR CLOSURE =',E15.5,/, & - & ' RESIDUAL CONVERGENCE OPTION =',I9,/, & - & ' RESIDUAL CONVERGENCE NORM =',1X,A,/, & - & ' RELAXATION FACTOR =',E15.5) -02015 FORMAT (' NUMBER OF LEVELS =',A15,/, & - & ' DROP TOLERANCE =',A15,//) -2030 FORMAT(1X,A20,1X,6(I6,1X)) -2040 FORMAT(1X,20('-'),1X,6(6('-'),1X)) -2050 FORMAT(1X,62('-'),/) ! -!------------------------------------------------------------------ - ! - ! -- initialize clevel and cdroptol - clevel = '' - cdroptol = '' - ! - ! -- PRINT MXITER,ITER1,IPC,ISCL,IORD,HCLOSE,RCLOSE - write(this%iout,2010) & - clintit(THIS%ILINMETH), MXITER, THIS%ITER1, & - clin(THIS%ILINMETH), cipc(THIS%IPC), & - cscale(THIS%ISCL), corder(THIS%IORD), & - THIS%NORTH, THIS%HCLOSE, THIS%RCLOSE, & - THIS%ICNVGOPT, ccnvgopt(THIS%ICNVGOPT), & - THIS%RELAX - if (this%level > 0) then - write(clevel, '(i15)') this%level - end if - if (this%droptol > DZERO) then - write(cdroptol, '(e15.5)') this%droptol - end if - IF (this%level > 0 .or. this%droptol > DZERO) THEN - write(this%iout,2015) trim(adjustl(clevel)), & - trim(adjustl(cdroptol)) - ELSE - write(this%iout,'(//)') - END IF - - if (this%iord /= 0) then - ! - ! -- WRITE SUMMARY OF REORDERING INFORMATION TO LIST FILE - if (this%iprims == 2) then - DO i = 1, this%neq, 6 - write(this%iout,2030) 'ORIGINAL NODE :', & - (j,j=i,MIN(i+5,this%neq)) - write(this%iout,2040) - write(this%iout,2030) 'REORDERED INDEX :', & - (this%lorder(j),j=i,MIN(i+5,this%neq)) - write(this%iout,2030) 'REORDERED NODE :', & - (this%iorder(j),j=i,MIN(i+5,this%neq)) - write(this%iout,2050) - END DO - END IF - end if - ! - ! -- return - return - end subroutine imslinear_summary - - subroutine allocate_scalars(this) - use MemoryManagerModule, only: mem_allocate - class(IMSLINEAR_DATA), intent(inout) :: this - ! - ! -- scalars - call mem_allocate(this%iout, 'IOUT', this%origin) - call mem_allocate(this%ilinmeth, 'ILINMETH', this%origin) - call mem_allocate(this%iter1, 'ITER1', this%origin) - call mem_allocate(this%ipc, 'IPC', this%origin) - call mem_allocate(this%iscl, 'ISCL', this%origin) - call mem_allocate(this%iord, 'IORD', this%origin) - call mem_allocate(this%north, 'NORTH', this%origin) - call mem_allocate(this%icnvgopt, 'ICNVGOPT', this%origin) - call mem_allocate(this%iacpc, 'IACPC', this%origin) - call mem_allocate(this%niterc, 'NITERC', this%origin) - call mem_allocate(this%niabcgs, 'NIABCGS', this%origin) - call mem_allocate(this%niapc, 'NIAPC', this%origin) - call mem_allocate(this%njapc, 'NJAPC', this%origin) - call mem_allocate(this%hclose, 'HCLOSE', this%origin) - call mem_allocate(this%rclose, 'RCLOSE', this%origin) - call mem_allocate(this%relax, 'RELAX', this%origin) - call mem_allocate(this%epfact, 'EPFACT', this%origin) - call mem_allocate(this%l2norm0, 'L2NORM0', this%origin) - call mem_allocate(this%droptol, 'DROPTOL', this%origin) - call mem_allocate(this%level, 'LEVEL', this%origin) - call mem_allocate(this%njlu, 'NJLU', this%origin) - call mem_allocate(this%njw, 'NJW', this%origin) - call mem_allocate(this%nwlu, 'NWLU', this%origin) - ! - ! -- initialize - this%iout = 0 - this%ilinmeth = 0 - this%iter1 = 0 - this%ipc = 0 - this%iscl = 0 - this%iord = 0 - this%north = 0 - this%icnvgopt = 0 - this%iacpc = 0 - this%niterc = 0 - this%niabcgs = 0 - this%niapc = 0 - this%njapc = 0 - this%hclose = DZERO - this%rclose = DZERO - this%relax = DZERO - this%epfact = DZERO - this%l2norm0 = 0 - this%droptol = DZERO - this%level = 0 - this%njlu = 0 - this%njw = 0 - this%nwlu = 0 - ! - ! --Return - return - end subroutine allocate_scalars - - subroutine IMSLINEAR_DA(this) - use MemoryManagerModule, only: mem_deallocate - class(IMSLINEAR_DATA), intent(inout) :: this - ! - ! -- arrays - call mem_deallocate(this%dscale) - call mem_deallocate(this%dscale2) - call mem_deallocate(this%iapc) - call mem_deallocate(this%japc) - call mem_deallocate(this%apc) - call mem_deallocate(this%iw) - call mem_deallocate(this%w) - call mem_deallocate(this%jlu) - call mem_deallocate(this%jw) - call mem_deallocate(this%wlu) - call mem_deallocate(this%lorder) - call mem_deallocate(this%iorder) - call mem_deallocate(this%iaro) - call mem_deallocate(this%jaro) - call mem_deallocate(this%aro) - call mem_deallocate(this%id) - call mem_deallocate(this%d) - call mem_deallocate(this%p) - call mem_deallocate(this%q) - call mem_deallocate(this%z) - call mem_deallocate(this%t) - call mem_deallocate(this%v) - call mem_deallocate(this%dhat) - call mem_deallocate(this%phat) - call mem_deallocate(this%qhat) - ! - ! -- scalars - call mem_deallocate(this%iout) - call mem_deallocate(this%ilinmeth) - call mem_deallocate(this%iter1) - call mem_deallocate(this%ipc) - call mem_deallocate(this%iscl) - call mem_deallocate(this%iord) - call mem_deallocate(this%north) - call mem_deallocate(this%icnvgopt) - call mem_deallocate(this%iacpc) - call mem_deallocate(this%niterc) - call mem_deallocate(this%niabcgs) - call mem_deallocate(this%niapc) - call mem_deallocate(this%njapc) - call mem_deallocate(this%hclose) - call mem_deallocate(this%rclose) - call mem_deallocate(this%relax) - call mem_deallocate(this%epfact) - call mem_deallocate(this%l2norm0) - call mem_deallocate(this%droptol) - call mem_deallocate(this%level) - call mem_deallocate(this%njlu) - call mem_deallocate(this%njw) - call mem_deallocate(this%nwlu) - ! - ! -- nullify pointers - nullify(this%iprims) - nullify(this%neq) - nullify(this%nja) - nullify(this%ia) - nullify(this%ja) - nullify(this%amat) - nullify(this%rhs) - nullify(this%x) - ! - ! --Return - return - end subroutine IMSLINEAR_DA - - SUBROUTINE SET_IMSLINEAR_INPUT(THIS, IFDPARAM) - IMPLICIT NONE -! + + + DUMMY ARGUMENTS + + + - CLASS(IMSLINEAR_DATA), INTENT(INOUT) :: THIS - integer(I4B), INTENT(IN) :: IFDPARAM -! + + + LOCAL DEFINITIONS + + + -! + + + PARAMETERS + + + -! + + + FUNCTIONS + + + -! -! + + + CODE + + + - SELECT CASE ( IFDPARAM ) - ! Simple option - CASE(1) - THIS%ITER1 = 50 - THIS%ILINMETH=1 - THIS%IPC = 1 - THIS%ISCL = 0 - THIS%IORD = 0 - THIS%HCLOSE = DEM3 - THIS%RCLOSE = DEM1 - THIS%RELAX = DZERO - THIS%LEVEL = 0 - THIS%DROPTOL = DZERO - THIS%NORTH = 0 - ! Moderate - CASE(2) - THIS%ITER1 = 100 - THIS%ILINMETH=2 - THIS%IPC = 2 - THIS%ISCL = 0 - THIS%IORD = 0 - THIS%HCLOSE = DEM2 - THIS%RCLOSE = DEM1 - THIS%RELAX = 0.97D0 - THIS%LEVEL = 0 - THIS%DROPTOL = DZERO - THIS%NORTH = 0 - ! Complex - CASE(3) - THIS%ITER1 = 500 - THIS%ILINMETH=2 - THIS%IPC = 3 - THIS%ISCL = 0 - THIS%IORD = 0 - THIS%HCLOSE = DEM1 - THIS%RCLOSE = DEM1 - THIS%RELAX = DZERO - THIS%LEVEL = 5 - THIS%DROPTOL = DEM4 - THIS%NORTH = 2 - END SELECT - RETURN - END SUBROUTINE SET_IMSLINEAR_INPUT - - SUBROUTINE IMSLINEAR_AP(THIS,ICNVG,KSTP,KITER,IN_ITER, & - NCONV, CONVNMOD, CONVMODSTART, LOCDV, LOCDR, & - CACCEL, ITINNER, CONVLOCDV, CONVLOCDR, & - DVMAX, DRMAX, CONVDVMAX, CONVDRMAX) -! -! ****************************************************************** -! SOLUTION BY THE CONJUGATE GRADIENT METHOD - -! UP TO ITER1 ITERATIONS -! ****************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------ - USE SimModule - IMPLICIT NONE -! + + + DUMMY ARGUMENTS + + + - CLASS(IMSLINEAR_DATA), INTENT(INOUT) :: THIS - integer(I4B), INTENT(INOUT) :: ICNVG - integer(I4B), INTENT(IN) :: KSTP - integer(I4B), INTENT(IN) :: KITER - integer(I4B), INTENT(INOUT) :: IN_ITER - ! CONVERGENCE INFORMATION - integer(I4B), INTENT(IN) :: NCONV - integer(I4B), INTENT(IN) :: CONVNMOD - integer(I4B), DIMENSION(CONVNMOD+1), INTENT(INOUT) ::CONVMODSTART - integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDV - integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDR - character(len=31), DIMENSION(NCONV), INTENT(INOUT) :: CACCEL - integer(I4B), DIMENSION(NCONV), INTENT(INOUT) :: ITINNER - integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDV - integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDR - real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DVMAX - real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DRMAX - real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDVMAX - real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDRMAX - -! + + + LOCAL DEFINITIONS + + + - integer(I4B) :: n - integer(I4B) :: innerit - integer(I4B) :: irc - integer(I4B) :: itmax - real(DP) :: tv - real(DP) :: rmax -! + + + PARAMETERS + + + -! + + + FUNCTIONS + + + -! -! + + + CODE + + + -! -!-------SET EPFACT BASED ON MFUSG TIMESTEP - IF (THIS%ICNVGOPT == 2) THEN - IF (KSTP == 1) THEN - THIS%EPFACT = 0.01 - ELSE - THIS%EPFACT = 0.10 - END IF - ELSE IF (THIS%ICNVGOPT == 4) THEN - THIS%EPFACT = DEM4 - ELSE - THIS%EPFACT = DONE - END IF - -!-------SCALE PROBLEM - IF (THIS%ISCL.NE.0) THEN - CALL IMSLINEARSUB_SCALE(0,THIS%ISCL, & - THIS%NEQ,THIS%NJA,THIS%IA,THIS%JA, & - THIS%AMAT,THIS%X,THIS%RHS, & - THIS%DSCALE,THIS%DSCALE2) - END IF -! -!-------PERMUTE ROWS, COLUMNS, AND RHS - IF (THIS%IORD.NE.0) THEN - CALL ims_dperm(THIS%NEQ, THIS%NJA, THIS%AMAT,THIS%JA,THIS%IA, & - & THIS%ARO,THIS%JARO,THIS%IARO,THIS%LORDER,THIS%ID,1) - CALL ims_vperm(THIS%NEQ, THIS%X, THIS%LORDER) - CALL ims_vperm(THIS%NEQ, THIS%RHS, THIS%LORDER) - THIS%IA0 => THIS%IARO - THIS%JA0 => THIS%JARO - THIS%A0 => THIS%ARO - ELSE - THIS%IA0 => THIS%IA - THIS%JA0 => THIS%JA - THIS%A0 => THIS%AMAT - END IF -! -!-------UPDATE PRECONDITIONER - CALL IMSLINEARSUB_PCU(this%iout,THIS%NJA,THIS%NEQ,THIS%NIAPC,THIS%NJAPC, & - THIS%IPC, THIS%RELAX, THIS%A0, THIS%IA0, THIS%JA0, & - THIS%APC,THIS%IAPC,THIS%JAPC,THIS%IW,THIS%W, & - THIS%LEVEL, THIS%DROPTOL, THIS%NJLU, THIS%NJW, & - THIS%NWLU, THIS%JLU, THIS%JW, THIS%WLU) -!-------INITIALIZE SOLUTION VARIABLE AND ARRAYS - IF (KITER == 1 ) THIS%NITERC = 0 - irc = 1 - ICNVG = 0 - DO n = 1, THIS%NEQ - THIS%D(n) = DZERO - THIS%P(n) = DZERO - THIS%Q(n) = DZERO - THIS%Z(n) = DZERO - END DO -!-------CALCULATE INITIAL RESIDUAL - CALL IMSLINEARSUB_MV(THIS%NJA,THIS%NEQ,THIS%A0,THIS%X,THIS%D, & - THIS%IA0,THIS%JA0) - rmax = DZERO - THIS%L2NORM0 = DZERO - DO n = 1, THIS%NEQ - tv = THIS%D(n) - THIS%D(n) = THIS%RHS(n) - tv - IF (ABS( THIS%D(n) ) > rmax ) rmax = ABS( THIS%D(n) ) - THIS%L2NORM0 = THIS%L2NORM0 + THIS%D(n) * THIS%D(n) - END DO - THIS%L2NORM0 = SQRT(THIS%L2NORM0) -!-------CHECK FOR EXACT SOLUTION - itmax = THIS%ITER1 - IF (rmax == DZERO) THEN - itmax = 0 - ICNVG = 1 - END IF -!-------SOLUTION BY THE CONJUGATE GRADIENT METHOD - IF (THIS%ILINMETH == 1) THEN - CALL IMSLINEARSUB_CG(ICNVG, itmax, innerit, & - THIS%NEQ, THIS%NJA, THIS%NIAPC, THIS%NJAPC, & - THIS%IPC, THIS%NITERC, THIS%ICNVGOPT, THIS%NORTH, & - THIS%HCLOSE, THIS%RCLOSE, THIS%L2NORM0, & - THIS%EPFACT, THIS%IA0, THIS%JA0, THIS%A0, & - THIS%IAPC, THIS%JAPC, THIS%APC, & - THIS%X, THIS%RHS, THIS%D, THIS%P, THIS%Q, THIS%Z, & - THIS%NJLU, THIS%IW, THIS%JLU, & - NCONV, CONVNMOD, CONVMODSTART, LOCDV, LOCDR, & - CACCEL, ITINNER, CONVLOCDV, CONVLOCDR, & - DVMAX, DRMAX, CONVDVMAX, CONVDRMAX) -!-------SOLUTION BY THE BICONJUGATE GRADIENT STABILIZED METHOD - ELSE IF (THIS%ILINMETH == 2) THEN - CALL IMSLINEARSUB_BCGS(ICNVG, itmax, innerit, & - THIS%NEQ, THIS%NJA, THIS%NIAPC, THIS%NJAPC, & - THIS%IPC, THIS%NITERC, THIS%ICNVGOPT, THIS%NORTH,& - THIS%ISCL, THIS%DSCALE, & - THIS%HCLOSE, THIS%RCLOSE, THIS%L2NORM0, & - THIS%EPFACT, THIS%IA0, THIS%JA0, THIS%A0, & - THIS%IAPC, THIS%JAPC, THIS%APC, & - THIS%X, THIS%RHS, THIS%D, THIS%P, THIS%Q, & - THIS%T, THIS%V, THIS%DHAT, THIS%PHAT, THIS%QHAT, & - THIS%NJLU, THIS%IW, THIS%JLU, & - NCONV, CONVNMOD, CONVMODSTART, LOCDV, LOCDR, & - CACCEL, ITINNER, CONVLOCDV, CONVLOCDR, & - DVMAX, DRMAX, CONVDVMAX, CONVDRMAX) - END IF -! -!-------BACK PERMUTE AMAT, SOLUTION, AND RHS - IF (THIS%IORD.NE.0) THEN - CALL ims_dperm(THIS%NEQ, THIS%NJA, THIS%A0, THIS%JA0, THIS%IA0, & - & THIS%AMAT, THIS%JA,THIS%IA,THIS%IORDER,THIS%ID,1) - CALL ims_vperm(THIS%NEQ, THIS%X, THIS%IORDER) - CALL ims_vperm(THIS%NEQ, THIS%RHS, THIS%IORDER) - END IF -! -!-------UNSCALE PROBLEM - IF (THIS%ISCL.NE.0) THEN - CALL IMSLINEARSUB_SCALE(1, THIS%ISCL, & - THIS%NEQ, THIS%NJA, THIS%IA, THIS%JA, & - THIS%AMAT, THIS%X, THIS%RHS, & - THIS%DSCALE, THIS%DSCALE2) - END IF -! -!-------SET IMS INNER ITERATION NUMBER (IN_ITER) TO NUMBER OF -! IMSLINEAR INNER ITERATIONS (innerit) - IN_ITER = innerit -! -!-------RETURN - RETURN -! - END SUBROUTINE IMSLINEAR_AP - - -! -- IMSLinearModule subroutines that do not depend on data stored in the IMSLinearModule class -! all data is passed through subroutine calls -! -!-------ROUTINE TO CALCULATE LORDER AND IORDER FOR REORDERING - SUBROUTINE IMSLINEARSUB_CALC_ORDER(IOUT, IPRIMS, IORD, NEQ, NJA, IA, JA, & - & LORDER, IORDER) - use SimModule, only: ustop, store_error, count_errors - IMPLICIT NONE -! + + + DUMMY ARGUMENTS + + + - integer(I4B), INTENT(IN) :: IOUT - integer(I4B), INTENT(IN) :: IPRIMS - integer(I4B), INTENT(IN) :: IORD - integer(I4B), INTENT(IN) :: NEQ - integer(I4B), INTENT(IN) :: NJA - integer(I4B), DIMENSION(NEQ+1), INTENT(IN) :: IA - integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA - integer(I4B), DIMENSION(NEQ), INTENT(INOUT) :: LORDER - integer(I4B), DIMENSION(NEQ), INTENT(INOUT) :: IORDER -! + + + LOCAL DEFINITIONS + + + - character (len=LINELENGTH) :: errmsg - integer(I4B) :: n - integer(I4B) :: nsp - integer(I4B), DIMENSION(:), ALLOCATABLE :: iwork0, iwork1 - integer(I4B) :: iflag -! + + + PARAMETERS + + + -! + + + FUNCTIONS + + + -! + + + FORMATS + + + -! + + + CODE + + + - DO n = 1, NEQ - LORDER(n) = IZERO - IORDER(n) = IZERO - END DO - ALLOCATE ( iwork0(NEQ) ) - SELECT CASE ( IORD ) - CASE ( 1 ) - ALLOCATE ( iwork1(NEQ) ) - CALL ims_genrcm(NEQ, NJA, IA, JA, & - & LORDER, iwork0, iwork1 ) - CASE ( 2 ) - nsp = 3 * NEQ + 4 * NJA - ALLOCATE ( iwork1(nsp) ) - CALL ims_odrv(NEQ, NJA, nsp, IA, JA, LORDER, iwork0, & - iwork1, iflag) - IF (iflag.NE.0) THEN - write(errmsg,'(A)') 'ERROR CREATING MINIMUM DEGREE '// & - & 'ORDER PERMUTATION ' - call store_error(errmsg) - !call ustop() - END IF - END SELECT -! -! GENERATE INVERSE OF LORDER - DO n = 1, NEQ - IORDER( LORDER(n) ) = n - END DO -! -! DEALLOCATE TEMPORARY STORAGE - DEALLOCATE ( iwork0, iwork1 ) -! - if (count_errors() > 0) then - call parser%StoreErrorUnit() - call ustop() - endif -! -!---------RETURN - RETURN - END SUBROUTINE IMSLINEARSUB_CALC_ORDER -! -!-------ROUTINE TO SCALE THE COEFFICIENT MATRIX (AMAT), -! THE RHS (B), AND THE ESTIMATE OF X (X) - SUBROUTINE IMSLINEARSUB_SCALE(IOPT, ISCL, NEQ, NJA, IA, JA, AMAT, X, B, & - & DSCALE, DSCALE2) - IMPLICIT NONE -! + + + DUMMY ARGUMENTS + + + - integer(I4B), INTENT(IN) :: IOPT - integer(I4B), INTENT(IN) :: ISCL - integer(I4B), INTENT(IN) :: NEQ - integer(I4B), INTENT(IN) :: NJA - integer(I4B), DIMENSION(NEQ+1), INTENT(IN) :: IA - integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA - real(DP), DIMENSION(NJA), INTENT(INOUT) :: AMAT - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: X - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: B - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: DSCALE - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: DSCALE2 -! + + + LOCAL DEFINITIONS + + + - integer(I4B) :: i, n - integer(I4B) :: id, jc - integer(I4B) :: i0, i1 - real(DP) :: v, c1, c2 -! + + + FUNCTIONS + + + -! + + + CODE + + + -! -!---------SCALE SCALE AMAT, X, AND B - IF (IOPT == 0) THEN -!-----------SYMMETRIC SCALING - SELECT CASE ( ISCL ) - CASE ( 1 ) - DO n = 1, NEQ - id = IA(n) - v = AMAT(id) - c1 = DONE / SQRT( ABS( v ) ) - DSCALE(n) = c1 - DSCALE2(n) = c1 - END DO -! SCALE AMAT -- AMAT = DSCALE(row) * AMAT(i) * DSCALE2(col) - DO n = 1, NEQ - c1 = DSCALE(n) - i0 = IA(n) - i1 = IA(n+1) - 1 - DO i = i0, i1 - jc = JA(i) - c2 = DSCALE2(jc) - AMAT(i) = c1 * AMAT(i) * c2 - END DO - END DO -!-----------L-2 NORM SCALING - CASE ( 2 ) -! SCALE EACH ROW SO THAT THE L-2 NORM IS 1 - DO n = 1, NEQ - c1 = DZERO - i0 = IA(n) - i1 = IA(n+1) - 1 - DO i = i0, i1 - c1 = c1 + AMAT(i) * AMAT(i) - END DO - c1 = SQRT( c1 ) - IF (c1 == DZERO) THEN - c1 = DONE - ELSE - c1 = DONE / c1 - END IF - DSCALE(n) = c1 -! INITIAL SCALING OF AMAT -- AMAT = DSCALE(row) * AMAT(i) - DO i = i0, i1 - AMAT(i) = c1 * AMAT(i) - END DO - END DO -! SCALE EACH COLUMN SO THAT THE L-2 NORM IS 1 - DO n = 1, NEQ - DSCALE2(n) = DZERO - END DO - c2 = DZERO - DO n = 1, NEQ - i0 = IA(n) - i1 = IA(n+1) - 1 - DO i = i0, i1 - jc = JA(i) - c2 = AMAT(i) - DSCALE2(jc) = DSCALE2(jc) + c2 * c2 - END DO - END DO - DO n = 1, NEQ - c2 = DSCALE2(n) - IF (c2 == DZERO) THEN - c2 = DONE - ELSE - c2 = DONE / SQRT( c2 ) - END IF - DSCALE2(n) = c2 - END DO -! FINAL SCALING OF AMAT -- AMAT = DSCALE2(col) * AMAT(i) - DO n = 1, NEQ - i0 = IA(n) - i1 = IA(n+1) - 1 - DO i = i0, i1 - jc = JA(i) - c2 = DSCALE2(jc) - AMAT(i) = c2 * AMAT(i) - END DO - END DO - END SELECT -!-----------SCALE X AND B - DO n = 1, NEQ - c1 = DSCALE(n) - c2 = DSCALE2(n) - X(n) = X(n) / c2 - B(n) = B(n) * c1 - END DO -!---------UNSCALE SCALE AMAT, X, AND B - ELSE - DO n = 1, NEQ - c1 = DSCALE(n) - i0 = IA(n) - i1 = IA(n+1) - 1 -! UNSCALE AMAT - DO i = i0, i1 - jc = JA(i) - c2 = DSCALE2(jc) - AMAT(i) = ( DONE / c1 ) * AMAT(i) * ( DONE / c2 ) - END DO -! UNSCALE X AND B - c2 = DSCALE2(n) - X(n) = X(n) * c2 - B(n) = B(n) / c1 - END DO - END IF -!---------RETURN - RETURN - END SUBROUTINE IMSLINEARSUB_SCALE -! -!-------ROUTINE TO UPDATE THE PRECONDITIONER - SUBROUTINE IMSLINEARSUB_PCU(IOUT, NJA, NEQ, NIAPC, NJAPC, IPC, RELAX, & - AMAT, IA, JA, APC, IAPC, JAPC, IW, W, & - LEVEL, DROPTOL, NJLU, NJW, NWLU, JLU, JW, WLU) - use SimModule, only: ustop, store_error, count_errors -! + + + DUMMY ARGUMENTS + + + - integer(I4B), INTENT(IN) :: IOUT - integer(I4B), INTENT(IN) :: NJA - integer(I4B), INTENT(IN) :: NEQ - integer(I4B), INTENT(IN) :: NIAPC - integer(I4B), INTENT(IN) :: NJAPC - integer(I4B), INTENT(IN) :: IPC - real(DP), INTENT(IN) :: RELAX - real(DP), DIMENSION(NJA), INTENT(IN) :: AMAT - integer(I4B), DIMENSION(NEQ+1), INTENT(IN) :: IA - integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA - real(DP), DIMENSION(NJAPC), INTENT(INOUT) :: APC - integer(I4B), DIMENSION(NIAPC+1), INTENT(INOUT) :: IAPC - integer(I4B), DIMENSION(NJAPC), INTENT(INOUT) :: JAPC - integer(I4B), DIMENSION(NIAPC), INTENT(INOUT) :: IW - real(DP), DIMENSION(NIAPC), INTENT(INOUT) :: W - ! ILUT - integer(I4B), INTENT(IN) :: LEVEL - real(DP), INTENT(IN) :: DROPTOL - integer(I4B), INTENT(IN) :: NJLU - integer(I4B), INTENT(IN) :: NJW - integer(I4B), INTENT(IN) :: NWLU - integer(I4B), DIMENSION(NJLU), INTENT(INOUT) :: JLU - integer(I4B), DIMENSION(NJW), INTENT(INOUT) :: JW - real(DP), DIMENSION(NWLU), INTENT(INOUT) :: WLU -! + + + LOCAL DEFINITIONS + + + - character(len=LINELENGTH) :: errmsg - character(len=80), dimension(3) :: cerr - integer(I4B) :: izero - integer(I4B) :: ierr - real(DP) :: delta -! + + + FUNCTIONS + + + -! + + + DATA + + + - DATA cerr /'INCOMPREHENSIBLE ERROR - MATRIX MUST BE WRONG. ', & - 'INSUFFICIENT STORAGE IN ARRAYS ALU, JLU TO STORE FACTORS. ', & - 'ZERO ROW ENCOUNTERED. '/ - -! + + + FORMATS + + + - 2000 FORMAT (/,' MATRIX IS SEVERELY NON-DIAGONALLY DOMINANT.', & - & /,' ADDING SMALL VALUE TO PIVOT (IMSLINEARSUB_PCU)') -! + + + CODE + + + - izero = 0 - delta = DZERO - PCSCALE: DO - SELECT CASE(IPC) -! ILU0 AND MILU0 - CASE (1,2) - CALL IMSLINEARSUB_PCILU0(NJA, NEQ, AMAT, IA, JA, & - APC, IAPC, JAPC, IW, W, & - RELAX, izero, delta) -! ILUT AND MILUT - CASE (3,4) - ierr = 0 - CALL IMSLINEARSUB_PCMILUT(NEQ, AMAT, JA, IA, & - LEVEL, DROPTOL, RELAX, & - APC, JLU, IW, NJAPC, WLU, JW, ierr, & - izero, delta) - IF (ierr.NE.0) THEN - write(errmsg,'(4x,a,1x,a)') & - '****ERROR. ILUT ERROR: ', cerr(-ierr) - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - END IF -! ADDITIONAL PRECONDITIONERS - CASE DEFAULT - izero = 0 - END SELECT - IF (izero < 1) THEN - EXIT PCSCALE - END IF - delta = 1.5D0 * delta + 0.001 - izero = 0 - IF (delta > DHALF) THEN - WRITE(IOUT,2000) - delta = DHALF - izero = 2 - END IF - END DO PCSCALE -!---------RETURN - RETURN - END SUBROUTINE IMSLINEARSUB_PCU -! -!-------JACOBI PRECONDITIONER - INVERSE OF DIAGONAL - SUBROUTINE IMSLINEARSUB_PCJ(NJA, NEQ, AMAT, APC, IA, JA) -! + + + DUMMY ARGUMENTS + + + - integer(I4B), INTENT(IN) :: NJA - integer(I4B), INTENT(IN) :: NEQ - real(DP), DIMENSION(NJA), INTENT(IN) :: AMAT - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: APC - integer(I4B), DIMENSION(NEQ+1), INTENT(IN) :: IA - integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA -! + + + LOCAL DEFINITIONS + + + - integer(I4B) :: i, n - integer(I4B) :: ic0, ic1 - integer(I4B) :: id - real(DP) :: tv -! + + + PARAMETERS + + + -! + + + FUNCTIONS + + + -! + + + CODE + + + - DO n = 1, NEQ - ic0 = IA(n) - ic1 = IA(n+1) - 1 - id = IA(n) - DO i = ic0, ic1 - IF (JA(i) == n) THEN - id = i - EXIT - END IF - END DO - tv = AMAT(id) - IF (ABS( tv ) > DZERO ) tv = DONE / tv - APC(n) = tv - END DO -!---------RETURN - RETURN - END SUBROUTINE IMSLINEARSUB_PCJ - - SUBROUTINE IMSLINEARSUB_JACA(NEQ, A, D1, D2) - IMPLICIT NONE -! + + + DUMMY ARGUMENTS + + + - integer(I4B), INTENT(IN) :: NEQ - real(DP), DIMENSION(NEQ), INTENT(IN) :: A - real(DP), DIMENSION(NEQ), INTENT(IN) :: D1 - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: D2 -! + + + LOCAL DEFINITIONS + + + - integer(I4B) :: n - real(DP) :: tv -! + + + PARAMETERS + + + -! + + + FUNCTIONS + + + -! + + + CODE + + + - DO n = 1, NEQ - tv = A(n) * D1(n) - D2(n) = tv - END DO -!---------RETURN - RETURN - END SUBROUTINE IMSLINEARSUB_JACA - - SUBROUTINE IMSLINEARSUB_PCILU0(NJA, NEQ, AMAT, IA, JA, & - APC, IAPC, JAPC, IW, W, & - RELAX, IZERO, DELTA) - IMPLICIT NONE -! + + + DUMMY ARGUMENTS + + + - integer(I4B), INTENT(IN) :: NJA - integer(I4B), INTENT(IN) :: NEQ - real(DP), DIMENSION(NJA), INTENT(IN) :: AMAT - integer(I4B), DIMENSION(NEQ+1), INTENT(IN) :: IA - integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA - real(DP), DIMENSION(NJA), INTENT(INOUT) :: APC - integer(I4B), DIMENSION(NEQ+1), INTENT(INOUT) :: IAPC - integer(I4B), DIMENSION(NJA), INTENT(INOUT) :: JAPC - integer(I4B), DIMENSION(NEQ), INTENT(INOUT) :: IW - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: W - real(DP), INTENT(IN) :: RELAX - integer(I4B), INTENT(INOUT) :: IZERO - real(DP), INTENT(IN) :: DELTA -! + + + LOCAL DEFINITIONS + + + - integer(I4B) :: ic0, ic1 - integer(I4B) :: iic0, iic1 - integer(I4B) :: iu, iiu - integer(I4B) :: j, n - integer(I4B) :: jj - integer(I4B) :: jcol, jw - integer(I4B) :: jjcol - real(DP) :: drelax - real(DP) :: sd1 - real(DP) :: tl - real(DP) :: rs - real(DP) :: d -! + + + PARAMETERS + + + -! + + + FUNCTIONS + + + -! + + + CODE + + + - drelax = RELAX - DO n = 1, NEQ - IW(n) = 0 - W(n) = DZERO - END DO - MAIN: DO n = 1, NEQ - ic0 = IA(n) - ic1 = IA(n+1) - 1 - DO j = ic0, ic1 - jcol = JA(j) - IW(jcol) = 1 - W(jcol) = W(jcol) + AMAT(j) - END DO - ic0 = IAPC(n) - ic1 = IAPC(n+1) - 1 - iu = JAPC(n) - rs = DZERO - LOWER: DO j = ic0, iu-1 - jcol = JAPC(j) - iic0 = IAPC(jcol) - iic1 = IAPC(jcol+1) - 1 - iiu = JAPC(jcol) - tl = W(jcol) * APC(jcol) - W(jcol) = tl - DO jj = iiu, iic1 - jjcol = JAPC(jj) - jw = IW(jjcol) - IF (jw.NE.0) THEN - W(jjcol) = W(jjcol) - tl * APC(jj) - ELSE - rs = rs + tl * APC(jj) - END IF - END DO - END DO LOWER -! DIAGONAL - CALCULATE INVERSE OF DIAGONAL FOR SOLUTION - d = W(n) - tl = ( DONE + DELTA ) * d - ( drelax * rs ) -!-----------ENSURE THAT THE SIGN OF THE DIAGONAL HAS NOT CHANGED AND IS - sd1 = SIGN(d,tl) - IF (sd1.NE.d) THEN -! USE SMALL VALUE IF DIAGONAL SCALING IS NOT EFFECTIVE FOR -! PIVOTS THAT CHANGE THE SIGN OF THE DIAGONAL - IF (IZERO > 1) THEN - tl = SIGN(DEM6,d) -! DIAGONAL SCALING CONTINUES TO BE EFFECTIVE - ELSE - IZERO = 1 - EXIT MAIN - END IF - END IF - IF (ABS(tl) == DZERO) THEN -! USE SMALL VALUE IF DIAGONAL SCALING IS NOT EFFECTIVE FOR -! ZERO PIVOTS - IF (IZERO > 1) THEN - tl = SIGN(DEM6,d) -! DIAGONAL SCALING CONTINUES TO BE EFFECTIVE FOR ELIMINATING - ELSE - IZERO = 1 - EXIT MAIN - END IF - END IF - APC(n) = DONE / tl -! RESET POINTER FOR IW TO ZERO - IW(n) = 0 - W(n) = DZERO - DO j = ic0, ic1 - jcol = JAPC(j) - APC(j) = W(jcol) - IW(jcol) = 0 - W(jcol) = DZERO - END DO - END DO MAIN -! -!---------RESET IZERO IF SUCCESSFUL COMPLETION OF MAIN - IZERO = 0 -! -!---------RETURN - RETURN - END SUBROUTINE IMSLINEARSUB_PCILU0 - - SUBROUTINE IMSLINEARSUB_ILU0A(NJA, NEQ, APC, IAPC, JAPC, R, D) - IMPLICIT NONE -! + + + DUMMY ARGUMENTS + + + - integer(I4B), INTENT(IN) :: NJA - integer(I4B), INTENT(IN) :: NEQ - real(DP), DIMENSION(NJA), INTENT(IN) :: APC - integer(I4B), DIMENSION(NEQ+1), INTENT(IN) :: IAPC - integer(I4B), DIMENSION(NJA), INTENT(IN) :: JAPC - real(DP), DIMENSION(NEQ), INTENT(IN) :: R - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: D -! + + + LOCAL DEFINITIONS + + + - integer(I4B) :: ic0, ic1 - integer(I4B) :: iu - integer(I4B) :: jcol - integer(I4B) :: j, n - real(DP) :: tv -! + + + FUNCTIONS + + + -! + + + CODE + + + -! FORWARD SOLVE - APC * D = R - FORWARD: DO n = 1, NEQ - tv = R(n) - ic0 = IAPC(n) - ic1 = IAPC(n+1) - 1 - iu = JAPC(n) - 1 - LOWER: DO j = ic0, iu - jcol = JAPC(j) - tv = tv - APC(j) * D(jcol) - END DO LOWER - D(n) = tv - END DO FORWARD -! BACKWARD SOLVE - D = D / U - BACKWARD: DO n = NEQ, 1, -1 - ic0 = IAPC(n) - ic1 = IAPC(n+1) - 1 - iu = JAPC(n) - tv = D(n) - UPPER: DO j = iu, ic1 - jcol = JAPC(j) - tv = tv - APC(j) * D(jcol) - END DO UPPER -! COMPUTE D FOR DIAGONAL - D = D / U - D(n) = tv * APC(n) - END DO BACKWARD -!---------RETURN - RETURN - END SUBROUTINE IMSLINEARSUB_ILU0A - - SUBROUTINE IMSLINEARSUB_CG(ICNVG, ITMAX, INNERIT, & - NEQ, NJA, NIAPC, NJAPC, & - IPC, NITERC, ICNVGOPT, NORTH, & - HCLOSE, RCLOSE, L2NORM0, EPFACT, & - IA0, JA0, A0, IAPC, JAPC, APC, & - X, B, D, P, Q, Z, & - NJLU, IW, JLU, & - NCONV, CONVNMOD, CONVMODSTART, LOCDV, LOCDR, & - CACCEL, ITINNER, CONVLOCDV, CONVLOCDR, & - DVMAX, DRMAX, CONVDVMAX, CONVDRMAX) - IMPLICIT NONE -! + + + DUMMY ARGUMENTS + + + - integer(I4B), INTENT(INOUT) :: ICNVG - integer(I4B), INTENT(IN) :: ITMAX - integer(I4B), INTENT(INOUT) :: INNERIT - integer(I4B), INTENT(IN) :: NEQ - integer(I4B), INTENT(IN) :: NJA - integer(I4B), INTENT(IN) :: NIAPC - integer(I4B), INTENT(IN) :: NJAPC - integer(I4B), INTENT(IN) :: IPC - integer(I4B), INTENT(INOUT) :: NITERC - integer(I4B), INTENT(IN) :: ICNVGOPT - integer(I4B), INTENT(IN) :: NORTH - real(DP), INTENT(IN) :: HCLOSE - real(DP), INTENT(IN) :: RCLOSE - real(DP), INTENT(IN) :: L2NORM0 - real(DP), INTENT(IN) :: EPFACT - integer(I4B), DIMENSION(NEQ+1), INTENT(IN) :: IA0 - integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA0 - real(DP), DIMENSION(NJA), INTENT(IN) :: A0 - integer(I4B), DIMENSION(NIAPC+1), INTENT(IN) :: IAPC - integer(I4B), DIMENSION(NJAPC), INTENT(IN) :: JAPC - real(DP), DIMENSION(NJAPC), INTENT(IN) :: APC - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: X - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: B - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: D - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: P - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: Q - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: Z - ! ILUT - integer(I4B), INTENT(IN) :: NJLU - integer(I4B), DIMENSION(NIAPC), INTENT(IN) :: IW - integer(I4B), DIMENSION(NJLU), INTENT(IN) :: JLU - ! CONVERGENCE INFORMATION - integer(I4B), INTENT(IN) :: NCONV - integer(I4B), INTENT(IN) :: CONVNMOD - integer(I4B), DIMENSION(CONVNMOD+1), INTENT(INOUT) ::CONVMODSTART - integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDV - integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDR - character(len=31), DIMENSION(NCONV), INTENT(INOUT) :: CACCEL - integer(I4B), DIMENSION(NCONV), INTENT(INOUT) :: ITINNER - integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDV - integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDR - real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DVMAX - real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DRMAX - real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDVMAX - real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDRMAX -! + + + LOCAL DEFINITIONS + + + - LOGICAL :: LORTH - logical :: lsame - character(len=31) :: cval - integer(I4B) :: n - integer(I4B) :: iiter - integer(I4B) :: xloc, rloc - integer(I4B) :: im, im0, im1 - real(DP) :: tv - real(DP) :: deltax - real(DP) :: rmax - real(DP) :: l2norm - real(DP) :: rcnvg - real(DP) :: denom - real(DP) :: alpha, beta - real(DP) :: rho, rho0 -! + + + PARAMETERS + + + -! + + + FUNCTIONS + + + -! -! + + + CODE + + + - rho0 = DZERO - rho = DZERO - INNERIT = 0 -! -!-------INNER ITERATION - INNER: DO iiter = 1, itmax - INNERIT = INNERIT + 1 - NITERC = NITERC + 1 -!----------APPLY PRECONDITIONER - SELECT CASE (IPC) -! ILU0 AND MILU0 - CASE (1,2) - CALL IMSLINEARSUB_ILU0A(NJA, NEQ, APC, IAPC, JAPC, D, Z) -! ILUT AND MILUT - CASE (3,4) - CALL IMSLINEARSUB_PCMILUT_LUSOL(NEQ, D, Z, APC, JLU, IW) - END SELECT - rho = IMSLINEARSUB_DP(NEQ, D, Z) -!-----------COMPUTE DIRECTIONAL VECTORS - IF (IITER == 1) THEN - DO n = 1, NEQ - P(n) = Z(n) - END DO - ELSE - !denom = rho0 + SIGN(DPREC,rho0) - !beta = rho / denom - beta = rho / rho0 - DO n = 1, NEQ - P(n) = Z(n) + beta * P(n) - END DO - END IF -!-----------COMPUTE ITERATES -! UPDATE Q - CALL IMSLINEARSUB_MV(NJA, NEQ, A0, P, Q, IA0, JA0) - denom = IMSLINEARSUB_DP(NEQ, P, Q) - denom = denom + SIGN(DPREC, denom) - alpha = rho / denom -!-----------UPDATE X AND RESIDUAL - deltax = DZERO - rmax = DZERO - l2norm = DZERO - DO im = 1, CONVNMOD - DVMAX(im) = DZERO - DRMAX(im) = DZERO - END DO - im = 1 - im0 = CONVMODSTART(1) - im1 = CONVMODSTART(2) - DO n = 1, NEQ - ! -- determine current model index - if (n == im1) then - im = im + 1 - im0 = CONVMODSTART(im) - im1 = CONVMODSTART(im+1) - end if - ! -- identify deltax and rmax - tv = alpha * P(n) - X(n) = X(n) + tv - IF (ABS(tv) > ABS(deltax)) THEN - deltax = tv - xloc = n - END IF - IF (ABS(tv) > ABS(DVMAX(im))) THEN - DVMAX(im) = tv - LOCDV(im) = n - END IF - tv = D(n) - tv = tv - alpha * Q(n) - D(n) = tv - IF (ABS(tv) > ABS(rmax)) THEN - rmax = tv - rloc = n - END IF - IF (ABS(tv) > ABS(DRMAX(im))) THEN - DRMAX(im) = tv - LOCDR(im) = n - END IF - l2norm = l2norm + tv * tv - END DO - l2norm = SQRT(l2norm) -!-----------SAVE SOLVER CONVERGENCE INFORMATION - IF (NCONV > 1) THEN - n = NITERC - WRITE(cval, '(g15.7)') alpha - CACCEL(n) = cval - ITINNER(n) = iiter - DO im = 1, CONVNMOD - CONVLOCDV(im, n) = LOCDV(im) - CONVLOCDR(im, n) = LOCDR(im) - CONVDVMAX(im, n) = DVMAX(im) - CONVDRMAX(im, n) = DRMAX(im) - END DO - END IF -!-----------TEST FOR SOLVER CONVERGENCE - IF (ICNVGOPT == 2 .OR. ICNVGOPT == 3 .OR. ICNVGOPT == 4) THEN - rcnvg = l2norm - ELSE - rcnvg = rmax - END IF - CALL IMSLINEARSUB_TESTCNVG(ICNVGOPT, ICNVG, INNERIT, & - deltax, rcnvg, & - L2NORM0, EPFACT, HCLOSE, RCLOSE) -! -! CHECK FOR EXACT SOLUTION - IF (rcnvg == DZERO) ICNVG = 1 - IF (ICNVG.NE.0) EXIT INNER -!-----------CHECK THAT CURRENT AND PREVIOUS rho ARE DIFFERENT - lsame = IS_SAME(rho, rho0) - IF (lsame) THEN - EXIT INNER - END IF -!-----------RECALCULATE THE RESIDUAL - IF (NORTH > 0) THEN - LORTH = mod(iiter+1,NORTH) == 0 - IF (LORTH) THEN - CALL IMSLINEARSUB_MV(NJA, NEQ, A0, X, D, IA0, JA0) - CALL IMSLINEARSUB_AXPY(NEQ, B, -DONE, D, D) - END IF - END IF -!-----------SAVE CURRENT INNER ITERATES - rho0 = rho - END DO INNER -!---------RESET ICNVG - IF (ICNVG < 0) ICNVG = 0 -!---------RETURN - RETURN - END SUBROUTINE IMSLINEARSUB_CG - - SUBROUTINE IMSLINEARSUB_BCGS(ICNVG, ITMAX, INNERIT, & - NEQ, NJA, NIAPC, NJAPC, & - IPC, NITERC, ICNVGOPT, NORTH, ISCL, DSCALE, & - HCLOSE, RCLOSE, L2NORM0, EPFACT, & - IA0, JA0, A0, IAPC, JAPC, APC, & - X, B, D, P, Q, & - T, V, DHAT, PHAT, QHAT, & - NJLU, IW, JLU, & - NCONV, CONVNMOD, CONVMODSTART, LOCDV, LOCDR, & - CACCEL, ITINNER, CONVLOCDV, CONVLOCDR, & - DVMAX, DRMAX, CONVDVMAX, CONVDRMAX) - IMPLICIT NONE -! + + + DUMMY ARGUMENTS + + + - integer(I4B), INTENT(INOUT) :: ICNVG - integer(I4B), INTENT(IN) :: ITMAX - integer(I4B), INTENT(INOUT) :: INNERIT - integer(I4B), INTENT(IN) :: NEQ - integer(I4B), INTENT(IN) :: NJA - integer(I4B), INTENT(IN) :: NIAPC - integer(I4B), INTENT(IN) :: NJAPC - integer(I4B), INTENT(IN) :: IPC - integer(I4B), INTENT(INOUT) :: NITERC - integer(I4B), INTENT(IN) :: ICNVGOPT - integer(I4B), INTENT(IN) :: NORTH - integer(I4B), INTENT(IN) :: ISCL - real(DP), DIMENSION(NEQ), INTENT(IN) :: DSCALE - real(DP), INTENT(IN) :: HCLOSE - real(DP), INTENT(IN) :: RCLOSE - real(DP), INTENT(IN) :: L2NORM0 - real(DP), INTENT(IN) :: EPFACT - integer(I4B), DIMENSION(NEQ+1), INTENT(IN) :: IA0 - integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA0 - real(DP), DIMENSION(NJA), INTENT(IN) :: A0 - integer(I4B), DIMENSION(NIAPC+1), INTENT(IN) :: IAPC - integer(I4B), DIMENSION(NJAPC), INTENT(IN) :: JAPC - real(DP), DIMENSION(NJAPC), INTENT(IN) :: APC - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: X - real(DP), DIMENSION(NEQ), INTENT(IN) :: B - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: D - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: P - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: Q - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: T - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: V - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: DHAT - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: PHAT - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: QHAT - ! ILUT - integer(I4B), INTENT(IN) :: NJLU - integer(I4B), DIMENSION(NIAPC), INTENT(IN) :: IW - integer(I4B), DIMENSION(NJLU), INTENT(IN) :: JLU - ! CONVERGENCE INFORMATION - integer(I4B), INTENT(IN) :: NCONV - integer(I4B), INTENT(IN) :: CONVNMOD - integer(I4B), DIMENSION(CONVNMOD+1), INTENT(INOUT) ::CONVMODSTART - integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDV - integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDR - character(len=31), DIMENSION(NCONV), INTENT(INOUT) :: CACCEL - integer(I4B), DIMENSION(NCONV), INTENT(INOUT) :: ITINNER - integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDV - integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDR - real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DVMAX - real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DRMAX - real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDVMAX - real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDRMAX -! + + + LOCAL DEFINITIONS + + + - LOGICAL :: LORTH - logical :: lsame - character(len=15) :: cval1, cval2 - integer(I4B) :: n - integer(I4B) :: iiter - integer(I4B) :: xloc, rloc - integer(I4B) :: im, im0, im1 - real(DP) :: tv - real(DP) :: deltax - real(DP) :: rmax - real(DP) :: l2norm - real(DP) :: rcnvg - real(DP) :: alpha, alpha0 - real(DP) :: beta - real(DP) :: rho, rho0 - real(DP) :: omega, omega0 - real(DP) :: numer, denom -! + + + PARAMETERS + + + -! + + + FUNCTIONS + + + -! -! + + + CODE + + + - INNERIT = 0 - - alpha = DZERO - alpha0 = DZERO - beta = DZERO - rho = DZERO - rho0 = DZERO - omega = DZERO - omega0 = DZERO -! -!-------SAVE INITIAL RESIDUAL - DO n = 1, NEQ - DHAT(n) = D(n) - END DO -! -!-------INNER ITERATION - INNER: DO iiter = 1, itmax - INNERIT = INNERIT + 1 - NITERC = NITERC + 1 -!----------CALCULATE rho - rho = IMSLINEARSUB_DP(NEQ, DHAT, D) -!-----------COMPUTE DIRECTIONAL VECTORS - IF (IITER == 1) THEN - DO n = 1, NEQ - P(n) = D(n) - END DO - ELSE - beta = ( rho / rho0 ) * ( alpha0 / omega0 ) - DO n = 1, NEQ - P(n) = D(n) + beta * ( P(n) - omega0 * V(n) ) - END DO - END IF -!----------APPLY PRECONDITIONER TO UPDATE PHAT - SELECT CASE (IPC) -! ILU0 AND MILU0 - CASE (1,2) - CALL IMSLINEARSUB_ILU0A(NJA, NEQ, APC, IAPC, JAPC, P, PHAT) -! ILUT AND MILUT - CASE (3,4) - CALL IMSLINEARSUB_PCMILUT_LUSOL(NEQ, P, PHAT, APC, JLU, IW) - END SELECT -!-----------COMPUTE ITERATES -! UPDATE V WITH A AND PHAT - CALL IMSLINEARSUB_MV(NJA, NEQ, A0, PHAT, V, IA0, JA0) -! UPDATE alpha WITH DHAT AND V - denom = IMSLINEARSUB_DP(NEQ, DHAT, V) - denom = denom + SIGN(DPREC, denom) - alpha = rho / denom -!-----------UPDATE Q - DO n = 1, NEQ - Q(n) = D(n) - alpha * V(n) - END DO -!!-----------CALCULATE INFINITY NORM OF Q - TEST FOR TERMINATION -!! TERMINATE IF rmax IS LESS THAN MACHINE PRECISION (DPREC) -! rmax = DZERO -! DO n = 1, NEQ -! tv = Q(n) -! IF (ISCL.NE.0 ) tv = tv / DSCALE(n) -! IF (ABS(tv) > ABS(rmax) ) rmax = tv -! END DO -! IF (ABS(rmax).LE.DPREC) THEN -! deltax = DZERO -! DO n = 1, NEQ -! tv = alpha * PHAT(n) -! IF (ISCL.NE.0) THEN -! tv = tv * DSCALE(n) -! END IF -! X(n) = X(n) + tv -! IF (ABS(tv) > ABS(deltax) ) deltax = tv -! END DO -! CALL IMSLINEARSUB_TESTCNVG(ICNVGOPT, ICNVG, INNERIT, & -! deltax, rmax, & -! rmax, EPFACT, HCLOSE, RCLOSE ) -! IF (ICNVG.NE.0 ) EXIT INNER -! END IF -!-----------APPLY PRECONDITIONER TO UPDATE QHAT - SELECT CASE (IPC) -! ILU0 AND MILU0 - CASE (1,2) - CALL IMSLINEARSUB_ILU0A(NJA, NEQ, APC, IAPC, JAPC, Q, QHAT) -! ILUT AND MILUT - CASE (3,4) - CALL IMSLINEARSUB_PCMILUT_LUSOL(NEQ, Q, QHAT, APC, JLU, IW) - END SELECT -! UPDATE T WITH A AND QHAT - CALL IMSLINEARSUB_MV(NJA, NEQ, A0, QHAT, T, IA0, JA0) -!-----------UPDATE omega - numer = IMSLINEARSUB_DP(NEQ, T, Q) - denom = IMSLINEARSUB_DP(NEQ, T, T) - denom = denom + SIGN(DPREC,denom) - omega = numer / denom -!-----------UPDATE X AND RESIDUAL - deltax = DZERO - rmax = DZERO - l2norm = DZERO - DO im = 1, CONVNMOD - DVMAX(im) = DZERO - DRMAX(im) = DZERO - END DO - im = 1 - im0 = CONVMODSTART(1) - im1 = CONVMODSTART(2) - DO n = 1, NEQ - ! -- determine current model index - if (n == im1) then - im = im + 1 - im0 = CONVMODSTART(im) - im1 = CONVMODSTART(im+1) - end if -!-------------X AND DX - tv = alpha * PHAT(n) + omega * QHAT(n) - X(n) = X(n) + tv - IF (ISCL.NE.0) THEN - tv = tv * DSCALE(n) - END IF - IF (ABS(tv) > ABS(deltax)) THEN - deltax = tv - xloc = n - END IF - IF (ABS(tv) > ABS(DRMAX(im))) THEN - DVMAX(im) = tv - LOCDV(im) = n - END IF -!-------------RESIDUAL - tv = Q(n) - omega * T(n) - D(n) = tv - IF (ISCL.NE.0) THEN - tv = tv / DSCALE(n) - END IF - IF (ABS(tv) > ABS(rmax)) THEN - rmax = tv - rloc = n - END IF - IF (ABS(tv) > ABS(DRMAX(im))) THEN - DRMAX(im) = tv - LOCDR(im) = n - END IF - l2norm = l2norm + tv * tv - END DO - l2norm = sqrt(l2norm) -!-----------SAVE SOLVER CONVERGENCE INFORMATION - IF (NCONV > 1) THEN - n = NITERC - WRITE(cval1,'(g15.7)') alpha - WRITE(cval2,'(g15.7)') omega - CACCEL(n) = trim(adjustl(cval1)) // ',' // trim(adjustl(cval2)) - ITINNER(n) = iiter - DO im = 1, CONVNMOD - CONVLOCDV(im, n) = LOCDV(im) - CONVLOCDR(im, n) = LOCDR(im) - CONVDVMAX(im, n) = DVMAX(im) - CONVDRMAX(im, n) = DRMAX(im) - END DO - END IF -!-----------TEST FOR SOLVER CONVERGENCE - IF (ICNVGOPT == 2 .OR. ICNVGOPT == 3 .OR. ICNVGOPT == 4) THEN - rcnvg = l2norm - ELSE - rcnvg = rmax - END IF - CALL IMSLINEARSUB_TESTCNVG(ICNVGOPT, ICNVG, INNERIT, & - deltax, rcnvg, & - L2NORM0, EPFACT, HCLOSE, RCLOSE) -! CHECK FOR EXACT SOLUTION - IF (rcnvg == DZERO) ICNVG = 1 - IF (ICNVG.NE.0) EXIT INNER -!-----------CHECK THAT CURRENT AND PREVIOUS rho, alpha, AND omega ARE -! DIFFERENT - lsame = IS_SAME(rho, rho0) - IF (lsame) THEN - EXIT INNER - END IF - lsame = IS_SAME(alpha, alpha0) - IF (lsame) THEN - EXIT INNER - END IF - lsame = IS_SAME(omega, omega0) - IF (lsame) THEN - EXIT INNER - END IF -!-----------RECALCULATE THE RESIDUAL - IF (NORTH > 0) THEN - LORTH = mod(iiter+1,NORTH) == 0 - IF (LORTH) THEN - CALL IMSLINEARSUB_MV(NJA, NEQ, A0,X , D, IA0, JA0) - CALL IMSLINEARSUB_AXPY(NEQ, B, -DONE, D, D) - !DO n = 1, NEQ - ! tv = D(n) - ! D(n) = B(n) - tv - !END DO - END IF - END IF -!-----------SAVE CURRENT INNER ITERATES - rho0 = rho - alpha0 = alpha - omega0 = omega - END DO INNER -!---------RESET ICNVG - IF (ICNVG < 0) ICNVG = 0 -!---------RETURN - RETURN - END SUBROUTINE IMSLINEARSUB_BCGS -! -!---------TEST FOR SOLVER CONVERGENCE - SUBROUTINE IMSLINEARSUB_TESTCNVG(Icnvgopt, Icnvg, Iiter, & - Hmax, Rmax, & - Rmax0, Epfact, Hclose, Rclose ) - IMPLICIT NONE -! + + + DUMMY ARGUMENTS + + + - integer(I4B), INTENT(IN) :: Icnvgopt - integer(I4B), INTENT(INOUT) :: Icnvg - integer(I4B), INTENT(IN) :: Iiter - real(DP), INTENT(IN) :: Hmax - real(DP), INTENT(IN) :: Rmax - real(DP), INTENT(IN) :: Rmax0 - real(DP), INTENT(IN) :: Epfact - real(DP), INTENT(IN) :: Hclose - real(DP), INTENT(IN) :: Rclose -! + + + LOCAL DEFINITIONS + + + -! + + + FUNCTIONS + + + -! + + + CODE + + + - IF (Icnvgopt == 0) THEN - IF (ABS(Hmax) <= Hclose .AND. ABS(Rmax) <= Rclose) THEN - Icnvg = 1 - END IF - ELSE IF (Icnvgopt == 1) THEN - IF (ABS(Hmax) <= Hclose .AND. ABS(Rmax) <= Rclose .AND. & - iiter == 1) THEN - Icnvg = 1 - END IF - ELSE IF (Icnvgopt == 2) THEN - IF (ABS(Hmax) <= Hclose .OR. Rmax <= Rclose) THEN - Icnvg = 1 - ELSE IF (Rmax <= Rmax0*Epfact) THEN - Icnvg = -1 - END IF - ELSE IF (Icnvgopt == 3) THEN - IF (ABS(Hmax) <= Hclose) THEN - Icnvg = 1 - ELSE IF (Rmax <= Rmax0*Rclose) THEN - Icnvg = -1 - END IF - ELSE IF (Icnvgopt == 4) THEN - IF (ABS(Hmax) <= Hclose .AND. Rmax <= Rclose) THEN - Icnvg = 1 - ELSE IF (Rmax <= Rmax0*Epfact) THEN - Icnvg = -1 - END IF - END IF -!---------RETURN - RETURN - END SUBROUTINE IMSLINEARSUB_TESTCNVG -! -!---------GENERATE IAPC AND JAPC FROM IA AND JA -! JAPC(1:NEQ) HAS THE POSITION OF THE UPPER ENTRY FOR A ROW -! JAPC(NEQ+1:NJA) IS THE COLUMN POSITION FOR ENTRY -! APC(1:NEQ) PRECONDITIONED INVERSE OF THE DIAGONAL -! APC(NEQ+1:NJA) PRECONDITIONED ENTRIES FOR OFF DIAGONALS - SUBROUTINE IMSLINEARSUB_PCCRS(NEQ, NJA, IA, JA, & - IAPC,JAPC) - IMPLICIT NONE -! + + + DUMMY ARGUMENTS + + + - integer(I4B), INTENT(IN) :: NEQ - integer(I4B), INTENT(IN) :: NJA - integer(I4B), DIMENSION(NEQ+1), INTENT(IN) :: IA - integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA - integer(I4B), DIMENSION(NEQ+1), INTENT(INOUT) :: IAPC - integer(I4B), DIMENSION(NJA), INTENT(INOUT) :: JAPC -! + + + LOCAL DEFINITIONS + + + - integer(I4B) :: n, j - integer(I4B) :: i0, i1 - integer(I4B) :: nlen - integer(I4B) :: ic,ip - integer(I4B) :: jcol - integer(I4B), DIMENSION(:), ALLOCATABLE :: iarr -! + + + FUNCTIONS + + + -! + + + CODE + + + - ip = NEQ + 1 - DO n = 1, NEQ - i0 = IA(n) - i1 = IA(n+1) - 1 - nlen = i1 - i0 - ALLOCATE( iarr(nlen) ) - ic = 0 - DO j = i0, i1 - jcol = JA(j) - IF (jcol == n) CYCLE - ic = ic + 1 - iarr(ic) = jcol - END DO - CALL IMSLINEARSUB_ISORT(nlen,iarr) - IAPC(n) = ip - DO j = 1, nlen - jcol = iarr(j) - JAPC(ip) = jcol - ip = ip + 1 - END DO - DEALLOCATE(iarr) - END DO - IAPC(NEQ+1) = NJA + 1 -!---------POSITION OF THE FIRST UPPER ENTRY FOR ROW - DO n = 1, NEQ - i0 = IAPC(n) - i1 = IAPC(n+1) - 1 - JAPC(n) = IAPC(n+1) - DO j = i0, i1 - jcol = JAPC(j) - IF (jcol > n) THEN - JAPC(n) = j - EXIT - END IF - END DO - END DO -!---------RETURN - RETURN - END SUBROUTINE IMSLINEARSUB_PCCRS -! -!-------SIMPLE IN-PLACE SORTING ROUTINE FOR AN INTEGER ARRAY - SUBROUTINE IMSLINEARSUB_ISORT(NVAL, IARRAY) - IMPLICIT NONE -! + + + DUMMY ARGUMENTS + + + - integer(I4B),INTENT(IN) :: NVAL - integer(I4B),DIMENSION(NVAL),INTENT(INOUT) :: IARRAY -! + + + LOCAL DEFINITIONS + + + - integer(I4B) :: i, j, itemp -! + + + FUNCTIONS + + + -! + + + CODE + + + - DO i = 1, NVAL-1 - DO j = i+1, NVAL - if(IARRAY(i) > IARRAY(j)) then - itemp = IARRAY(j) - IARRAY(j) = IARRAY(i) - IARRAY(i) = itemp - END IF - END DO - END DO -!---------RETURN - RETURN - END SUBROUTINE IMSLINEARSUB_ISORT -! -!-------INITIALIZE REAL VECTOR - SUBROUTINE IMSLINEARSUB_SETX(NR, D1, C) - IMPLICIT NONE -! + + + DUMMY ARGUMENTS + + + - integer(I4B), INTENT(IN) :: NR - real(DP), DIMENSION(NR), INTENT(INOUT) :: D1 - real(DP), INTENT(IN) :: C -! + + + LOCAL DEFINITIONS + + + - INTEGER :: n -! + + + FUNCTIONS + + + -! + + + CODE + + + -! - DO n = 1, NR - D1(n) = C - END DO -!---------RETURN - RETURN - END SUBROUTINE IMSLINEARSUB_SETX - -! COPY ONE real(DP) VECTOR TO ANOTHER - SUBROUTINE IMSLINEARSUB_DCOPY(NR, V, R) - IMPLICIT NONE -! + + + DUMMY ARGUMENTS + + + - integer(I4B), INTENT(IN) :: NR - real(DP), DIMENSION(NR), INTENT(IN) :: V - real(DP), DIMENSION(NR), INTENT(INOUT) :: R -! + + + LOCAL DEFINITIONS + + + - integer(I4B) :: n -! + + + FUNCTIONS + + + -! + + + CODE + + + - DO n = 1, NR - R(n) = V(n) - END DO -!---------RETURN - RETURN - END SUBROUTINE IMSLINEARSUB_DCOPY - -! COPY ONE INTEGER VECTOR TO ANOTHER - SUBROUTINE IMSLINEARSUB_ICOPY(NR, V, R) - IMPLICIT NONE -! + + + DUMMY ARGUMENTS + + + - integer(I4B), INTENT(IN) :: NR - integer(I4B), DIMENSION(NR), INTENT(IN) :: V - integer(I4B), DIMENSION(NR), INTENT(INOUT) :: R -! + + + LOCAL DEFINITIONS + + + - integer(I4B) :: n -! + + + FUNCTIONS + + + -! + + + CODE + + + - DO n = 1, NR - R(n) = V(n) - END DO -!---------RETURN - RETURN - END SUBROUTINE IMSLINEARSUB_ICOPY -! -!-------SCALE A REAL VECTOR WITH A CONSTANT - SUBROUTINE IMSLINEARSUB_RSCAL(NR, C, D1) - IMPLICIT NONE -! + + + DUMMY ARGUMENTS + + + - INTEGER, INTENT(IN) :: NR - real(DP), INTENT(IN) :: C - real(DP), DIMENSION(NR), INTENT(INOUT) :: D1 -! + + + LOCAL DEFINITIONS + + + - INTEGER :: n -! + + + FUNCTIONS + + + -! + + + CODE + + + - DO n = 1, NR - D1(n) = C * D1(n) - END DO -!---------RETURN - RETURN - END SUBROUTINE IMSLINEARSUB_RSCAL - - - SUBROUTINE IMSLINEARSUB_MV(NJA, NEQ, A, D1, D2, IA, JA) - IMPLICIT NONE -! + + + DUMMY ARGUMENTS + + + - integer(I4B), INTENT(IN) :: NJA - integer(I4B), INTENT(IN) :: NEQ - real(DP), DIMENSION(NJA), INTENT(IN) :: A - real(DP), DIMENSION(NEQ), INTENT(IN) :: D1 - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: D2 - integer(I4B), DIMENSION(NEQ+1), INTENT(IN) :: IA - integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA -! + + + LOCAL DEFINITIONS + + + - integer(I4B) :: ic0, ic1 - integer(I4B) :: icol - integer(I4B) :: m, n - real(DP) :: tv -! + + + PARAMETERS + + + -! + + + FUNCTIONS + + + -! + + + CODE + + + - DO n = 1, NEQ -! ADD DIAGONAL AND OFF-DIAGONAL TERMS - tv = DZERO - ic0 = IA(n) - ic1 = IA(n+1)-1 - DO m = ic0, ic1 - icol = JA(m) - tv = tv + A(m) * D1(icol) - END DO - D2(n) = tv - END DO -!---------RETURN - RETURN - END SUBROUTINE IMSLINEARSUB_MV - - SUBROUTINE IMSLINEARSUB_AXPY(NEQ, D1, DC, D2, DR) - IMPLICIT NONE -! + + + DUMMY ARGUMENTS + + + - integer(I4B), INTENT(IN) :: NEQ - real(DP), DIMENSION(NEQ), INTENT(IN) :: D1 - real(DP), INTENT(IN) :: DC - real(DP), DIMENSION(NEQ), INTENT(IN) :: D2 - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: DR -! + + + LOCAL DEFINITIONS + + + - integer(I4B) :: n -! + + + FUNCTIONS + + + -! + + + CODE + + + - DO n = 1, NEQ - DR(n) = D1(n) + DC * D2(n) - END DO -!---------RETURN - RETURN - END SUBROUTINE IMSLINEARSUB_AXPY - - - FUNCTION IMSLINEARSUB_DP(neq, a, b) RESULT(c) - ! -- return variable - real(DP) :: c -! + + + dummy arguments + + + - integer(I4B), intent(in) :: neq - real(DP), dimension(neq), intent(in) :: a - real(DP), dimension(neq), intent(in) :: b -! + + + local definitions + + + - integer(I4B) :: n -! + + + parameters + + + -! + + + functions + + + -! + + + code + + + - c = DZERO - do n = 1, neq - c = c + a(n) * b(n) - end do - !---------return - return - END FUNCTION IMSLINEARSUB_DP - - - FUNCTION IMSLINEARSUB_RNRM2(neq, a) RESULT(c) - ! -- return variable - real(DP) :: c -! + + + dummy arguments + + + - integer(I4B), intent(in) :: neq - real(DP), dimension(neq), intent(in) :: a -! + + + local definitions + + + - integer(I4B) :: n - real(DP) :: ssq - real(DP) :: scale - real(DP) :: norm - real(DP) :: absan -! + + + parameters + + + -! + + + functions + + + -! + + + code + + + - if (neq < 1) then - norm = DZERO - else if (neq == 1) then - norm = ABS(a(1)) - else - scale = DZERO - ssq = DONE - do n = 1, neq - if (a(n) /= DZERO) then - absan = abs(a(n)) - if (scale < absan) then - ssq = DONE + ssq * (scale/absan)**2 - scale = absan - else - ssq = ssq + (absan/scale)**2 - end if - end if - end do - norm = scale * sqrt(ssq) - END IF - c = norm - !---------return - return - END FUNCTION IMSLINEARSUB_RNRM2 -! -! -!-------BEGINNING OF SUBROUTINES FROM OTHER LIBRARIES - - ! SUBSET OF SPARSKIT VERSION 2 SOURCE CODE - ! - ! SPARSKIT VERSION 2 SUBROUTINES INCLUDED INCLUDE: - ! - ! 1 - IMSLINEARSUB_PCMILUT - ! 2 - IMSLINEARSUB_PCMILUT_LUSOL - ! 3 - IMSLINEARSUB_PCMILUT_QSPLIT - ! - !----------------------------------------------------------------------- - ! S P A R S K I T V E R S I O N 2. - !----------------------------------------------------------------------- - ! - !Latest update : Tue Mar 8 11:01:12 CST 2005 - ! - !----------------------------------------------------------------------- - ! - !Welcome to SPARSKIT VERSION 2. SPARSKIT is a package of FORTRAN - !subroutines for working with sparse matrices. It includes general - !sparse matrix manipulation routines as well as a few iterative - !solvers, see detailed description of contents below. - ! - ! Copyright (C) 2005, the Regents of the University of Minnesota - ! - !SPARSKIT is free software; you can redistribute it and/or modify it - !under the terms of the GNU Lesser General Public License as published - !by the Free Software Foundation [version 2.1 of the License, or any - !later version.] - ! - !A copy of the licencing agreement is attached in the file LGPL. For - !additional information contact the Free Software Foundation Inc., 59 - !Temple Place - Suite 330, Boston, MA 02111, USA or visit the web-site - ! - ! http://www.gnu.org/copyleft/lesser.html - ! - ! - !DISCLAIMER - !---------- - ! - !SPARSKIT is distributed in the hope that it will be useful, but - !WITHOUT ANY WARRANTY; without even the implied warranty of - !MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - !Lesser General Public License for more details. - ! - !For more information contact saad@cs.umn.edu - ! - ! - - SUBROUTINE IMSLINEARSUB_PCMILUT(n, a, ja, ia, lfil, droptol, relax, & - alu, jlu, ju, iwk, w, jw, ierr, & - izero, delta) - !----------------------------------------------------------------------- - integer(I4B) :: n - real(DP) :: a(*),alu(*),w(n+1),droptol,relax - integer(I4B) :: ja(*),ia(n+1),jlu(*),ju(n),jw(2*n),lfil,iwk,ierr - integer(I4B) :: izero - real(DP) :: delta - !----------------------------------------------------------------------* - ! *** ILUT preconditioner *** * - ! incomplete LU factorization with dual truncation mechanism * - !----------------------------------------------------------------------* - ! Author: Yousef Saad *May, 5, 1990, Latest revision, August 1996 * - !----------------------------------------------------------------------* - ! PARAMETERS - !----------- - ! - ! on entry: - !========== - ! n = integer. The row dimension of the matrix A. The matrix - ! - ! a,ja,ia = matrix stored in Compressed Sparse Row format. - ! - ! lfil = integer. The fill-in parameter. Each row of L and each row - ! of U will have a maximum of lfil elements (excluding the - ! diagonal element). lfil must be .ge. 0. - ! ** WARNING: THE MEANING OF LFIL HAS CHANGED WITH RESPECT TO - ! EARLIER VERSIONS. - ! - ! droptol = real. Sets the threshold for dropping small terms - ! in the factorization. See below for details on dropping - ! strategy. - ! - ! - ! iwk = integer. The lengths of arrays alu and jlu. If the arrays - ! are not big enough to store the ILU factorizations, ilut - ! will stop with an error message. - ! - ! On return: - !=========== - ! - ! alu,jlu = matrix stored in Modified Sparse Row (MSR) format containing - ! the L and U factors together. The diagonal (stored in - ! alu(1:n) ) is inverted. Each i-th row of the alu,jlu matrix - ! contains the i-th row of L (excluding the diagonal entry=1) - ! followed by the i-th row of U. - ! - ! ju = integer array of length n containing the pointers to - ! the beginning of each row of U in the matrix alu,jlu. - ! - ! ierr = integer. Error message with the following meaning. - ! ierr = 0 --> successful return. - ! ierr .gt. 0 --> zero pivot encountered at step number ierr. - ! ierr = -1 --> Error. input matrix may be wrong. - ! (The elimination process has generated a - ! row in L or U whose length is .gt. n.) - ! ierr = -2 --> The matrix L overflows the array al. - ! ierr = -3 --> The matrix U overflows the array alu. - ! ierr = -4 --> Illegal value for lfil. - ! ierr = -5 --> zero row encountered. - ! - ! work arrays: - !============= - ! jw = integer work array of length 2*n. - ! w = real work array of length n+1. - ! - !---------------------------------------------------------------------- - ! w, ju (1:n) store the working array [1:ii-1 = L-part, ii:n = u] - ! jw(n+1:2n) stores nonzero indicators - ! - ! Notes: - ! ------ - ! The diagonal elements of the input matrix must be nonzero (at least - ! 'structurally'). - ! - !----------------------------------------------------------------------* - !---- Dual drop strategy works as follows. * - ! * - ! 1) Thresholding in L and U as set by droptol. Any element whose * - ! magnitude is less than some tolerance (relative to the abs * - ! value of diagonal element in u) is dropped. * - ! * - ! 2) Keeping only the largest lfil elements in the i-th row of L * - ! and the largest lfil elements in the i-th row of U (excluding * - ! diagonal elements). * - ! * - ! Flexibility: one can use droptol=0 to get a strategy based on * - ! keeping the largest elements in each row of L and U. Taking * - ! droptol .ne. 0 but lfil=n will give the usual threshold strategy * - ! (however, fill-in is then unpredictable). * - !----------------------------------------------------------------------* - ! locals - character(len=LINELENGTH) :: line - integer(I4B) :: ju0,k,j1,j2,j,ii,i,lenl,lenu,jj,jrow,jpos,ilen - real(DP) :: tnorm, t, abs, s, fact - real(DP) :: rs, d, sd1, tl - ! format - character(len=*), parameter :: fmterr = "(//,1x,a)" - ! code - if (lfil .lt. 0) goto 998 - !----------------------------------------------------------------------- - ! initialize ju0 (points to next element to be added to alu,jlu) - ! and pointer array. - !----------------------------------------------------------------------- - ju0 = n+2 - jlu(1) = ju0 - ! - ! initialize nonzero indicator array. - ! - do j = 1, n - jw(n+j) = 0 - end do - !----------------------------------------------------------------------- - ! beginning of main loop. - !----------------------------------------------------------------------- - main: do ii = 1, n - j1 = ia(ii) - j2 = ia(ii+1) - 1 - rs = DZERO - tnorm = DZERO - do k = j1, j2 - tnorm = tnorm+abs(a(k)) - end do - if (tnorm .eq. DZERO) goto 999 - tnorm = tnorm/real(j2-j1+1) - ! - ! unpack L-part and U-part of row of A in arrays w - ! - lenu = 1 - lenl = 0 - jw(ii) = ii - w(ii) = DZERO - jw(n+ii) = ii - ! - do j = j1, j2 - k = ja(j) - t = a(j) - if (k .lt. ii) then - lenl = lenl+1 - jw(lenl) = k - w(lenl) = t - jw(n+k) = lenl - else if (k .eq. ii) then - w(ii) = t - else - lenu = lenu+1 - jpos = ii+lenu-1 - jw(jpos) = k - w(jpos) = t - jw(n+k) = jpos - end if - end do - jj = 0 - ilen = 0 - ! - ! eliminate previous rows - ! -150 jj = jj+1 - if (jj .gt. lenl) goto 160 - !----------------------------------------------------------------------- - ! in order to do the elimination in the correct order we must select - ! the smallest column index among jw(k), k=jj+1, ..., lenl. - !----------------------------------------------------------------------- - jrow = jw(jj) - k = jj - ! - ! determine smallest column index - ! - do j = jj+1, lenl - if (jw(j) .lt. jrow) then - jrow = jw(j) - k = j - end if - end do - ! - if (k .ne. jj) then - ! exchange in jw - j = jw(jj) - jw(jj) = jw(k) - jw(k) = j - ! exchange in jr - jw(n+jrow) = jj - jw(n+j) = k - ! exchange in w - s = w(jj) - w(jj) = w(k) - w(k) = s - end if - ! - ! zero out element in row by setting jw(n+jrow) to zero. - ! - jw(n+jrow) = 0 - ! - ! get the multiplier for row to be eliminated (jrow). - ! - fact = w(jj)*alu(jrow) - if (abs(fact) .le. droptol) then - rs = rs + w(jj) - goto 150 - end if - ! - ! combine current row and row jrow - ! - do k = ju(jrow), jlu(jrow+1)-1 - s = fact*alu(k) - j = jlu(k) - jpos = jw(n+j) - if (j .ge. ii) then - ! - ! dealing with upper part. - ! - if (jpos .eq. 0) then - ! - ! this is a fill-in element - ! - lenu = lenu+1 - if (lenu .gt. n) goto 995 - i = ii+lenu-1 - jw(i) = j - jw(n+j) = i - w(i) = - s - else - ! - ! this is not a fill-in element - ! - w(jpos) = w(jpos) - s - - end if - else - ! - ! dealing with lower part. - ! - if (jpos .eq. 0) then - ! - ! this is a fill-in element - ! - lenl = lenl+1 - if (lenl .gt. n) goto 995 - jw(lenl) = j - jw(n+j) = lenl - w(lenl) = - s - else - ! - ! this is not a fill-in element - ! - w(jpos) = w(jpos) - s - end if - end if - end do - ! - ! store this pivot element -- (from left to right -- no danger of - ! overlap with the working elements in L (pivots). - ! - ilen = ilen+1 - w(ilen) = fact - jw(ilen) = jrow - goto 150 -160 continue - ! - ! reset double-pointer to zero (U-part) - ! - do k = 1, lenu - jw(n+jw(ii+k-1)) = 0 - end do - ! - ! update L-matrix - ! - lenl = ilen - ilen = min0(lenl,lfil) - ! - ! sort by quick-split - ! - call IMSLINEARSUB_PCMILUT_QSPLIT(lenl, w, jw, ilen) - ! - ! store L-part - ! - do k = 1, ilen - ! if (ju0 .gt. iwk) goto 996 - if (ju0 .gt. iwk) then - write(line, '(2i10)') ju0, iwk - call sim_message(line, fmt=fmterr, level=VDEBUG) - goto 996 - end if - alu(ju0) = w(k) - jlu(ju0) = jw(k) - ju0 = ju0+1 - end do - ! - ! save pointer to beginning of row ii of U - ! - ju(ii) = ju0 - ! - ! update U-matrix -- first apply dropping strategy - ! - ilen = 0 - do k = 1, lenu-1 - if (abs(w(ii+k)) .gt. droptol*tnorm) then - ilen = ilen+1 - w(ii+ilen) = w(ii+k) - jw(ii+ilen) = jw(ii+k) - else - rs = rs + w(ii+k) - end if - end do - lenu = ilen+1 - ilen = min0(lenu,lfil) - ! - call IMSLINEARSUB_PCMILUT_QSPLIT(lenu-1, w(ii+1), jw(ii+1), ilen) - ! - ! copy - ! - t = abs(w(ii)) - ! if (ilen + ju0 .gt. iwk) goto 997 - if (ilen + ju0 .gt. iwk) then - write(line, '(2i10)') (ilen + ju0), iwk - call sim_message(line, fmt=fmterr, level=VDEBUG) - goto 997 - end if - do k = ii+1, ii+ilen-1 - jlu(ju0) = jw(k) - alu(ju0) = w(k) - t = t + abs(w(k) ) - ju0 = ju0+1 - end do - !! - !! add dropped terms to diagonal element - !! - !IF (relax > DZERO) THEN - ! w(ii) = w(ii) + relax * rs - !END IF - !! - !! store inverse of diagonal element of u - !! - !if (w(ii) == DZERO) w(ii) = (DEM4 + droptol)*tnorm - !! - !alu(ii) = DONE / w(ii) - - ! diagonal - calculate inverse of diagonal for solution - d = w(ii) - tl = ( DONE + delta ) * d + ( relax * rs ) - - ! ensure that the sign of the diagonal has not changed - sd1 = SIGN(d,tl) - IF (sd1.NE.d) THEN - ! use small value if diagonal scaling is not effective for - ! pivots that change the sign of the diagonal - IF (izero > 1) THEN - tl = SIGN(DONE,d) * (DEM4 + droptol) * tnorm - ! diagonal scaling continues to be effective - ELSE - izero = 1 - exit main - END IF - END IF - ! ensure that the diagonal is not zero - IF (ABS(tl) == DZERO) THEN - ! use small value if diagonal scaling is not effective - ! zero pivots - IF (izero > 1) THEN - tl = SIGN(DONE,d) * (DEM4 + droptol) * tnorm - ! diagonal scaling continues to be effective - ELSE - izero = 1 - exit main - END IF - END IF - w(ii) = tl - alu(ii) = DONE / w(ii) - ! - ! update pointer to beginning of next row of U. - ! - jlu(ii+1) = ju0 - !----------------------------------------------------------------------- - ! end main loop - !----------------------------------------------------------------------- - end do main - ierr = 0 - return - ! - ! incomprehensible error. Matrix must be wrong. - ! -995 ierr = -1 - return - ! - ! insufficient storage in L. - ! -996 ierr = -2 - return - ! - ! insufficient storage in U. - ! -997 ierr = -3 - return - ! - ! illegal lfil entered. - ! -998 ierr = -4 - return - ! - ! zero row encountered - ! -999 ierr = -5 - return - !----------------end-of-ilut-------------------------------------------- - !----------------------------------------------------------------------- - END SUBROUTINE IMSLINEARSUB_PCMILUT - - !----------------------------------------------------------------------- - SUBROUTINE IMSLINEARSUB_PCMILUT_LUSOL(n, y, x, alu, jlu, ju) - integer(I4B) :: n - real(DP) :: x(n), y(n), alu(*) - integer(I4B) :: jlu(*), ju(*) - !----------------------------------------------------------------------- - ! - ! This routine solves the system (LU) x = y, - ! given an LU decomposition of a matrix stored in (alu, jlu, ju) - ! modified sparse row format - ! - !----------------------------------------------------------------------- - ! on entry: - ! n = dimension of system - ! y = the right-hand-side vector - ! alu, jlu, ju - ! = the LU matrix as provided from the ILU routines. - ! - ! on return - ! x = solution of LU x = y. - !----------------------------------------------------------------------- - ! - ! Note: routine is in place: call IMSLINEARSUB_PCMILUT_LUSOL (n, x, x, alu, jlu, ju) - ! will solve the system with rhs x and overwrite the result on x . - ! - !----------------------------------------------------------------------- - ! -- local - ! - integer(I4B) :: i, k - ! - ! forward solve - ! - do i = 1, n - x(i) = y(i) - do k = jlu(i), ju(i)-1 - x(i) = x(i) - alu(k)* x(jlu(k)) - end do - end do - ! - ! backward solve. - ! - do i = n, 1, -1 - do k = ju(i), jlu(i+1)-1 - x(i) = x(i) - alu(k)*x(jlu(k)) - end do - x(i) = alu(i)*x(i) - end do - ! - return - !----------------end of IMSLINEARSUB_PCMILUT_LUSOL ------------------------------------------ - !----------------------------------------------------------------------- - END SUBROUTINE IMSLINEARSUB_PCMILUT_LUSOL - - !----------------------------------------------------------------------- - SUBROUTINE IMSLINEARSUB_PCMILUT_QSPLIT(n, a, ind, ncut) - integer(I4B) :: n - real(DP) :: a(n) - integer(I4B) :: ind(n), ncut - !----------------------------------------------------------------------- - ! does a quick-sort split of a real array. - ! on input a(1:n). is a real array - ! on output a(1:n) is permuted such that its elements satisfy: - ! - ! abs(a(i)) .ge. abs(a(ncut)) for i .lt. ncut and - ! abs(a(i)) .le. abs(a(ncut)) for i .gt. ncut - ! - ! ind(1:n) is an integer array which permuted in the same way as a(* - !----------------------------------------------------------------------- - real(DP) :: tmp, abskey - integer(I4B) :: itmp, first, last - integer(I4B) :: mid - integer(I4B) :: j - !----- - first = 1 - last = n - if (ncut .lt. first .or. ncut .gt. last) return - ! - ! outer loop -- while mid .ne. ncut do - ! -00001 mid = first - abskey = abs(a(mid)) - do j = first+1, last - if (abs(a(j)) .gt. abskey) then - mid = mid+1 - ! interchange - tmp = a(mid) - itmp = ind(mid) - a(mid) = a(j) - ind(mid) = ind(j) - a(j) = tmp - ind(j) = itmp - end if - end do - ! - ! interchange - ! - tmp = a(mid) - a(mid) = a(first) - a(first) = tmp - ! - itmp = ind(mid) - ind(mid) = ind(first) - ind(first) = itmp - ! - ! test for while loop - ! - if (mid .eq. ncut) return - if (mid .gt. ncut) then - last = mid-1 - else - first = mid+1 - end if - goto 1 - !----------------end-of-IMSLINEARSUB_PCMILUT_QSPLIT------------------------------------------ - !----------------------------------------------------------------------- - END SUBROUTINE IMSLINEARSUB_PCMILUT_QSPLIT - -END MODULE IMSLinearModule + MODULE IMSLinearModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: LINELENGTH, LENSOLUTIONNAME, & + IZERO, DZERO, DPREC, DSAME, & + DEM8, DEM6, DEM5, DEM4, DEM3, DEM2, DEM1, & + DHALF, DONE, DTWO, & + VDEBUG + use GenericUtilitiesModule, only: sim_message, IS_SAME + use IMSReorderingModule, only: ims_genrcm, ims_odrv, ims_dperm, ims_vperm + use BlockParserModule, only: BlockParserType + + IMPLICIT NONE + private + + TYPE, PUBLIC :: IMSLINEAR_DATA + CHARACTER (LEN=20) :: ORIGIN + integer(I4B), POINTER :: iout => NULL() + integer(I4B), POINTER :: IPRIMS => NULL() + integer(I4B), POINTER :: ILINMETH => NULL() + integer(I4B), POINTER :: ITER1 => NULL() + integer(I4B), POINTER :: IPC => NULL() + integer(I4B), POINTER :: ISCL => NULL() + integer(I4B), POINTER :: IORD => NULL() + integer(I4B), POINTER :: NORTH => NULL() + integer(I4B), POINTER :: ICNVGOPT => NULL() + integer(I4B), POINTER :: IACPC => NULL() + integer(I4B), POINTER :: NITERC => NULL() + integer(I4B), POINTER :: NIABCGS => NULL() + integer(I4B), POINTER :: NIAPC => NULL() + integer(I4B), POINTER :: NJAPC => NULL() + real(DP), POINTER :: HCLOSE => NULL() + real(DP), POINTER :: RCLOSE => NULL() + real(DP), POINTER :: RELAX => NULL() + real(DP), POINTER :: EPFACT => NULL() + real(DP), POINTER :: L2NORM0 => NULL() + ! ILUT VARIABLES + integer(I4B), POINTER :: LEVEL => NULL() + real(DP), POINTER :: DROPTOL => NULL() + integer(I4B), POINTER :: NJLU => NULL() + integer(I4B), POINTER :: NJW => NULL() + integer(I4B), POINTER :: NWLU => NULL() + ! POINTERS TO SOLUTION VARIABLES + integer(I4B), POINTER :: NEQ => NULL() + integer(I4B), POINTER :: NJA => NULL() + integer(I4B), dimension(:), pointer, contiguous :: IA => NULL() + integer(I4B), dimension(:), pointer, contiguous :: JA => NULL() + real(DP), dimension(:), pointer, contiguous :: AMAT => NULL() + real(DP), dimension(:), pointer, contiguous :: RHS => NULL() + real(DP), dimension(:), pointer, contiguous :: X => NULL() + ! VECTORS + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: DSCALE => NULL() + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: DSCALE2 => NULL() + integer(I4B), POINTER,DIMENSION(:),CONTIGUOUS :: IAPC => NULL() + integer(I4B), POINTER,DIMENSION(:),CONTIGUOUS :: JAPC => NULL() + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: APC => NULL() + integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: LORDER => NULL() + integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: IORDER => NULL() + integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: IARO => NULL() + integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: JARO => NULL() + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: ARO => NULL() + ! WORKING ARRAYS + integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: IW => NULL() + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: W => NULL() + integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: ID => NULL() + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: D => NULL() + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: P => NULL() + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: Q => NULL() + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: Z => NULL() + ! BICGSTAB WORKING ARRAYS + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: T => NULL() + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: V => NULL() + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: DHAT => NULL() + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: PHAT => NULL() + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: QHAT => NULL() + ! POINTERS FOR USE WITH BOTH ORIGINAL AND RCM ORDERINGS + integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: IA0 => NULL() + integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: JA0 => NULL() + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: A0 => NULL() + ! ILUT WORKING ARRAYS + integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: JLU => NULL() + integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: JW => NULL() + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: WLU => NULL() + + ! PROCEDURES (METHODS) + CONTAINS + PROCEDURE :: IMSLINEAR_ALLOCATE => IMSLINEAR_AR + procedure :: imslinear_summary + PROCEDURE :: IMSLINEAR_APPLY => IMSLINEAR_AP + procedure :: IMSLINEAR_DA + procedure, private :: allocate_scalars + ! -- PRIVATE PROCEDURES + PROCEDURE, PRIVATE :: SET_IMSLINEAR_INPUT + END TYPE IMSLINEAR_DATA + + type(BlockParserType), private :: parser + + + CONTAINS + SUBROUTINE IMSLINEAR_AR(THIS, NAME, IN, IOUT, IPRIMS, MXITER, IFDPARAM, & + IMSLINEARM, NEQ, NJA, IA, JA, AMAT, RHS, X, & + NINNER, LFINDBLOCK) +! ****************************************************************** +! ALLOCATE STORAGE FOR PCG ARRAYS AND READ IMSLINEAR DATA +! ****************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------ + use MemoryManagerModule, only: mem_allocate + use SimModule, only: ustop, store_error, count_errors + !IMPLICIT NONE +! + + + DUMMY VARIABLES + + + + CLASS(IMSLINEAR_DATA), INTENT(INOUT) :: THIS + CHARACTER (LEN=LENSOLUTIONNAME), INTENT(IN) :: NAME + integer(I4B), INTENT(IN) :: IN + integer(I4B), INTENT(IN) :: IOUT + integer(I4B), TARGET, INTENT(IN) :: IPRIMS + integer(I4B), INTENT(IN) :: MXITER + integer(I4B), INTENT(IN) :: IFDPARAM + integer(I4B), INTENT(INOUT) :: IMSLINEARM + integer(I4B), TARGET, INTENT(IN) :: NEQ + integer(I4B), TARGET, INTENT(IN) :: NJA + integer(I4B), DIMENSION(NEQ+1), TARGET, INTENT(IN) :: IA + integer(I4B), DIMENSION(NJA), TARGET, INTENT(IN) :: JA + real(DP), DIMENSION(NJA), TARGET, INTENT(IN) :: AMAT + real(DP), DIMENSION(NEQ), TARGET, INTENT(INOUT) :: RHS + real(DP), DIMENSION(NEQ), TARGET, INTENT(INOUT) :: X + integer(I4B), TARGET, INTENT(INOUT) :: NINNER + integer(I4B), INTENT(IN), OPTIONAL :: LFINDBLOCK +! + + + LOCAL VARIABLES + + + + LOGICAL :: lreaddata + character(len=LINELENGTH) :: errmsg, keyword + integer(I4B) :: i, n + integer(I4B) :: i0 + integer(I4B) :: iscllen, iolen + integer(I4B) :: ierr + real(DP) :: r + logical :: isfound, endOfBlock + integer(I4B) :: ijlu + integer(I4B) :: ijw + integer(I4B) :: iwlu + integer(I4B) :: iwk +! + + + PARAMETERS + + + +! + + + OUTPUT FORMATS + + + +!------------------------------------------------------------------ +! +!-------SET LREADDATA + IF (PRESENT(LFINDBLOCK)) THEN + IF (LFINDBLOCK < 1) THEN + lreaddata = .FALSE. + ELSE + lreaddata = .TRUE. + END IF + ELSE + lreaddata = .TRUE. + END IF +! +!-------DEFINE NAME + THIS%ORIGIN = TRIM(NAME) // ' IMSLINEAR' +! +!-------SET POINTERS TO SOLUTION STORAGE + THIS%IPRIMS => IPRIMS + THIS%NEQ => NEQ + THIS%NJA => NJA + THIS%IA => IA + THIS%JA => JA + THIS%AMAT => AMAT + THIS%RHS => RHS + THIS%X => X +!-------ALLOCATE SCALAR VARIABLES + call this%allocate_scalars() +! +!-------initialize iout + this%iout = iout +! +!-------DEFAULT VALUES + THIS%IORD = 0 + THIS%ISCL = 0 + THIS%IPC = 0 + THIS%LEVEL = 0 + + !clevel = '' + !cdroptol = '' +! +!-------TRANSFER COMMON VARIABLES FROM IMS TO IMSLINEAR + THIS%ILINMETH = 0 + + THIS%IACPC = 0 + THIS%RELAX = DZERO !0.97 + + THIS%DROPTOL = DZERO + + THIS%NORTH = 0 + + THIS%ICNVGOPT = 0 +! +!-------PRINT A MESSAGE IDENTIFYING IMSLINEAR SOLVER PACKAGE + write(iout,2000) +02000 FORMAT (1X,/1X,'IMSLINEAR -- UNSTRUCTURED LINEAR SOLUTION', & + & ' PACKAGE, VERSION 8, 04/28/2017') +! +!-------SET DEFAULT IMSLINEAR PARAMETERS + CALL THIS%SET_IMSLINEAR_INPUT(IFDPARAM) + NINNER = this%iter1 +! +!-------Initialize block parser + call parser%Initialize(in, iout) +! +! -- get IMSLINEAR block + if (lreaddata) then + call parser%GetBlock('LINEAR', isfound, ierr, & + supportOpenClose=.true., blockRequired=.FALSE.) + else + isfound = .FALSE. + end if +! +! -- parse IMSLINEAR block if detected + if (isfound) then + write(iout,'(/1x,a)')'PROCESSING LINEAR DATA' + do + call parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call parser%GetStringCaps(keyword) + ! -- parse keyword + select case (keyword) + case ('INNER_HCLOSE') + this%hclose = parser%GetDouble() + case ('INNER_RCLOSE') + this%rclose = parser%GetDouble() + ! -- look for additional key words + call parser%GetStringCaps(keyword) + if (keyword == 'STRICT') then + THIS%ICNVGOPT = 1 + else if (keyword == 'L2NORM_RCLOSE') then + THIS%ICNVGOPT = 2 + else if (keyword == 'RELATIVE_RCLOSE') then + THIS%ICNVGOPT = 3 + else if (keyword == 'L2NORM_RELATIVE_RCLOSE') then + THIS%ICNVGOPT = 4 + end if + case ('INNER_MAXIMUM') + i = parser%GetInteger() + this%iter1 = i + NINNER = i + case ('LINEAR_ACCELERATION') + call parser%GetStringCaps(keyword) + if (keyword.eq.'CG') then + THIS%ILINMETH = 1 + else if (keyword.eq.'BICGSTAB') then + THIS%ILINMETH = 2 + else + THIS%ILINMETH = 0 + write(errmsg,'(4x,a,a)') & + & '****ERROR. UNKNOWN IMSLINEAR LINEAR_ACCELERATION METHOD: ', & + & trim(keyword) + call store_error(errmsg) + end if + case ('SCALING_METHOD') + call parser%GetStringCaps(keyword) + i = 0 + if (keyword.eq.'NONE') then + i = 0 + else if (keyword.eq.'DIAGONAL') then + i = 1 + else if (keyword.eq.'L2NORM') then + i = 2 + else + write(errmsg,'(4x,a,a)') & + & '****ERROR. UNKNOWN IMSLINEAR SCALING_METHOD: ', & + & trim(keyword) + call store_error(errmsg) + end if + THIS%ISCL = i + case ('RED_BLACK_ORDERING') + i = 0 + case ('REORDERING_METHOD') + call parser%GetStringCaps(keyword) + i = 0 + if (keyword == 'NONE') then + i = 0 + else if (keyword == 'RCM') then + i = 1 + else if (keyword == 'MD') then + i = 2 + else + write(errmsg,'(4x,a,a)') & + & '****ERROR. UNKNOWN IMSLINEAR REORDERING_METHOD: ', & + trim(keyword) + call store_error(errmsg) + end if + THIS%IORD = i + case ('NUMBER_ORTHOGONALIZATIONS') + this%north = parser%GetInteger() + case ('RELAXATION_FACTOR') + this%relax = parser%GetDouble() + case ('PRECONDITIONER_LEVELS') + i = parser%GetInteger() + this%level = i + if (i < 0) then + write(errmsg,'(4x,a,a)') & + & '****ERROR. PRECONDITIONER_LEVELS: ', & + & 'MUST BE GREATER THAN OR EQUAL TO ZERO' + call store_error(errmsg) + end if + !write(clevel, '(i15)') i + case ('PRECONDITIONER_DROP_TOLERANCE') + r = parser%GetDouble() + THIS%DROPTOL = r + if (r < DZERO) then + write(errmsg,'(4x,a,a)') & + & '****ERROR. PRECONDITIONER_DROP_TOLERANCE: ', & + & 'MUST BE GREATER THAN OR EQUAL TO ZERO' + call store_error(errmsg) + end if + !write(cdroptol, '(e15.5)') r + case default + write(errmsg,'(4x,a,a)') & + & '****WARNING. UNKNOWN IMSLINEAR KEYWORD: ', & + & trim(keyword) + call store_error(errmsg) + end select + end do + write(iout,'(1x,a)') 'END OF LINEAR DATA' + else + if (IFDPARAM == 0) THEN + write(errmsg,'(1x,a)') 'NO LINEAR BLOCK DETECTED.' + call store_error(errmsg) + end if + end if + + IMSLINEARM = THIS%ILINMETH +! +!-------DETERMINE PRECONDITIONER + IF (THIS%LEVEL > 0 .OR. THIS%DROPTOL > DZERO) THEN + THIS%IPC = 3 + ELSE + THIS%IPC = 1 + END IF + IF (THIS%RELAX > DZERO) THEN + THIS%IPC = THIS%IPC + 1 + END IF +! +!-------ERROR CHECKING FOR OPTIONS + IF (THIS%ISCL < 0 ) THIS%ISCL = 0 + IF (THIS%ISCL > 2 ) THEN + WRITE( errmsg,'(A)' ) 'IMSLINEAR7AR: ISCL MUST BE .LE. 2' + call store_error(errmsg) + END IF + IF (THIS%IORD < 0 ) THIS%IORD = 0 + IF (THIS%IORD > 2) THEN + WRITE( errmsg,'(A)' ) 'IMSLINEAR7AR: IORD MUST BE .LE. 2' + call store_error(errmsg) + END IF + IF (THIS%NORTH < 0) THEN + WRITE( errmsg,'(A)' ) 'IMSLINEAR7AR: NORTH MUST .GE. 0' + call store_error(errmsg) + END IF + IF (THIS%RCLOSE == DZERO) THEN + IF (THIS%ICNVGOPT /= 3) THEN + WRITE( errmsg,'(A)' ) 'IMSLINEAR7AR: RCLOSE MUST .NE. 0.0' + call store_error(errmsg) + END IF + END IF + IF (THIS%RELAX < DZERO) THEN + WRITE( errmsg,'(A)' ) 'IMSLINEAR7AR: RELAX MUST BE .GE. 0.0' + call store_error(errmsg) + END IF + IF (THIS%RELAX > DONE) THEN + WRITE( errmsg,'(A)' ) 'IMSLINEAR7AR: RELAX MUST BE .LE. 1.0' + call store_error(errmsg) + END IF + + if (count_errors() > 0) then + call parser%StoreErrorUnit() + call ustop() + endif +! +!-------INITIALIZE IMSLINEAR VARIABLES + THIS%NITERC = 0 +! +!-------ALLOCATE AND INITIALIZE MEMORY FOR IMSLINEAR + iscllen = 1 + IF (THIS%ISCL.NE.0 ) iscllen = NEQ + CALL mem_allocate(THIS%DSCALE, iscllen, 'DSCALE', TRIM(THIS%ORIGIN)) + CALL mem_allocate(THIS%DSCALE2, iscllen, 'DSCALE2', TRIM(THIS%ORIGIN)) + +!-------ALLOCATE MEMORY FOR PRECONDITIONING MATRIX + ijlu = 1 + ijw = 1 + iwlu = 1 + ! -- ILU0 AND MILU0 + THIS%NIAPC = THIS%NEQ + THIS%NJAPC = THIS%NJA + ! -- ILUT AND MILUT + IF (THIS%IPC == 3 .OR. THIS%IPC == 4) THEN + THIS%NIAPC = THIS%NEQ + IF (THIS%LEVEL > 0) THEN + iwk = THIS%NEQ * (THIS%LEVEL * 2 + 1) + ELSE + iwk = 0 + DO n = 1, NEQ + i = IA(n+1) - IA(n) + IF (i > iwk) THEN + iwk = i + END IF + END DO + iwk = THIS%NEQ * iwk + END IF + THIS%NJAPC = iwk + ijlu = iwk + ijw = 2 * THIS%NEQ + iwlu = THIS%NEQ + 1 + END IF + THIS%NJLU = ijlu + THIS%NJW = ijw + THIS%NWLU = iwlu +!-------ALLOCATE BASE PRECONDITIONER VECTORS + CALL mem_allocate(THIS%IAPC, THIS%NIAPC+1, 'IAPC', TRIM(THIS%ORIGIN)) + CALL mem_allocate(THIS%JAPC, THIS%NJAPC, 'JAPC', TRIM(THIS%ORIGIN)) + CALL mem_allocate(THIS%APC, THIS%NJAPC, 'APC', TRIM(THIS%ORIGIN)) +!-------ALLOCATE MEMORY FOR ILU0 AND MILU0 NON-ZERO ROW ENTRY VECTOR + CALL mem_allocate(THIS%IW, THIS%NIAPC, 'IW', TRIM(THIS%ORIGIN)) + CALL mem_allocate(THIS%W, THIS%NIAPC, 'W', TRIM(THIS%ORIGIN)) +!-------ALLOCATE MEMORY FOR ILUT VECTORS + CALL mem_allocate(THIS%JLU, ijlu, 'JLU', TRIM(THIS%ORIGIN)) + CALL mem_allocate(THIS%JW, ijw, 'JW', TRIM(THIS%ORIGIN)) + CALL mem_allocate(THIS%WLU, iwlu, 'WLU', TRIM(THIS%ORIGIN)) +!-------GENERATE IAPC AND JAPC FOR ILU0 AND MILU0 + IF (THIS%IPC == 1 .OR. THIS%IPC == 2) THEN + CALL IMSLINEARSUB_PCCRS(THIS%NEQ,THIS%NJA,THIS%IA,THIS%JA, & + THIS%IAPC,THIS%JAPC) + END IF +!-------ALLOCATE SPACE FOR PERMUTATION VECTOR + i0 = 1 + iolen = 1 + IF (THIS%IORD.NE.0) THEN + i0 = THIS%NEQ + iolen = THIS%NJA + END IF + CALL mem_allocate(THIS%LORDER, i0, 'LORDER', TRIM(THIS%ORIGIN)) + CALL mem_allocate(THIS%IORDER, i0, 'IORDER', TRIM(THIS%ORIGIN)) + CALL mem_allocate(THIS%IARO, i0+1, 'IARO', TRIM(THIS%ORIGIN)) + CALL mem_allocate(THIS%JARO, iolen, 'JARO', TRIM(THIS%ORIGIN)) + CALL mem_allocate(THIS%ARO, iolen, 'ARO', TRIM(THIS%ORIGIN)) +!-------ALLOCATE WORKING VECTORS FOR IMSLINEAR SOLVER + CALL mem_allocate(THIS%ID, THIS%NEQ, 'ID', TRIM(THIS%ORIGIN)) + CALL mem_allocate(THIS%D, THIS%NEQ, 'D', TRIM(THIS%ORIGIN)) + CALL mem_allocate(THIS%P, THIS%NEQ, 'P', TRIM(THIS%ORIGIN)) + CALL mem_allocate(THIS%Q, THIS%NEQ, 'Q', TRIM(THIS%ORIGIN)) + CALL mem_allocate(THIS%Z, THIS%NEQ, 'Z', TRIM(THIS%ORIGIN)) +!-------ALLOCATE MEMORY FOR BCGS WORKING ARRAYS + THIS%NIABCGS = 1 + IF (THIS%ILINMETH == 2) THEN + THIS%NIABCGS = THIS%NEQ + END IF + CALL mem_allocate(THIS%T, THIS%NIABCGS, 'T', TRIM(THIS%ORIGIN)) + CALL mem_allocate(THIS%V, THIS%NIABCGS, 'V', TRIM(THIS%ORIGIN)) + CALL mem_allocate(THIS%DHAT, THIS%NIABCGS, 'DHAT', TRIM(THIS%ORIGIN)) + CALL mem_allocate(THIS%PHAT, THIS%NIABCGS, 'PHAT', TRIM(THIS%ORIGIN)) + CALL mem_allocate(THIS%QHAT, THIS%NIABCGS, 'QHAT', TRIM(THIS%ORIGIN)) +!-------INITIALIZE IMSLINEAR VECTORS + DO n = 1, iscllen + THIS%DSCALE(n) = DONE + THIS%DSCALE2(n) = DONE + END DO + DO n = 1, THIS%NJAPC + THIS%APC(n) = DZERO + END DO +!-------WORKING VECTORS + DO n = 1, THIS%NEQ + THIS%ID(n) = IZERO + THIS%D(n) = DZERO + THIS%P(n) = DZERO + THIS%Q(n) = DZERO + THIS%Z(n) = DZERO + END DO + DO n = 1, THIS%NIAPC + THIS%IW(n) = IZERO + THIS%W(n) = DZERO + END DO +!-------BCGS WORKING VECTORS + DO n = 1, THIS%NIABCGS + THIS%T(n) = DZERO + THIS%V(n) = DZERO + THIS%DHAT(n) = DZERO + THIS%PHAT(n) = DZERO + THIS%QHAT(n) = DZERO + END DO +!-------ILUT AND MILUT WORKING VECTORS + DO n = 1, ijlu + THIS%JLU(n) = DZERO + END DO + DO n = 1, ijw + THIS%JW(n) = DZERO + END DO + DO n = 1, iwlu + THIS%WLU(n) = DZERO + END DO +!-------REORDERING VECTORS + DO n = 1, i0 + 1 + THIS%IARO(n) = IZERO + END DO + DO n = 1, iolen + THIS%JARO(n) = IZERO + THIS%ARO(n) = DZERO + END DO +! +!-------REVERSE CUTHILL MCKEE AND MINIMUM DEGREE ORDERING + IF (THIS%IORD.NE.0) THEN + CALL IMSLINEARSUB_CALC_ORDER(IOUT, THIS%IPRIMS, THIS%IORD,THIS%NEQ, & + THIS%NJA,THIS%IA,THIS%JA, & + THIS%LORDER,THIS%IORDER) + END IF +! +!-------ALLOCATE MEMORY FOR STORING ITERATION CONVERGENCE DATA + +! +!-------RETURN + RETURN + END SUBROUTINE IMSLINEAR_AR + + subroutine imslinear_summary(this, mxiter) + class(IMSLINEAR_DATA), intent(inout) :: this + integer(I4B), intent(in) :: mxiter +! + + + LOCAL VARIABLES + + + + CHARACTER (LEN= 10) :: clin(0:2) + CHARACTER (LEN= 31) :: clintit(0:2) + CHARACTER (LEN= 20) :: cipc(0:4) + CHARACTER (LEN= 20) :: cscale(0:2) + CHARACTER (LEN= 25) :: corder(0:2) + CHARACTER (LEN= 16), DIMENSION(0:4) :: ccnvgopt + CHARACTER (LEN= 15) :: clevel + CHARACTER (LEN= 15) :: cdroptol + integer(I4B) :: i, j +! + + + PARAMETERS + + + +! DATA + DATA clin /'UNKNOWN ', & + 'CG ', & + & 'BCGS '/ + DATA clintit /' UNKNOWN ', & + ' CONJUGATE-GRADIENT ', & + & 'BICONJUGATE-GRADIENT STABILIZED'/ + DATA cipc /'UNKNOWN ', & + & 'INCOMPLETE LU ', & + & 'MOD. INCOMPLETE LU ', & + & 'INCOMPLETE LUT ', & + & 'MOD. INCOMPLETE LUT '/ + DATA cscale/'NO SCALING ', & + & 'SYMMETRIC SCALING ', & + & 'L2 NORM SCALING '/ + DATA corder/'ORIGINAL ORDERING ', & + & 'RCM ORDERING ', & + & 'MINIMUM DEGREE ORDERING '/ + DATA ccnvgopt /'INFINITY NORM ', & + & 'INFINITY NORM S ', & + & 'L2 NORM ', & + & 'RELATIVE L2NORM ', & + 'L2 NORM W. REL. '/ +! OUTPUT FORMATS +02010 FORMAT (1X,/,7X,'SOLUTION BY THE',1X,A31,1X,'METHOD', & + & /,1X,66('-'),/, & + & ' MAXIMUM OF ',I6,' CALLS OF SOLUTION ROUTINE',/, & + & ' MAXIMUM OF ',I6, & + & ' INTERNAL ITERATIONS PER CALL TO SOLUTION ROUTINE',/, & + & ' LINEAR ACCELERATION METHOD =',1X,A,/, & + & ' MATRIX PRECONDITIONING TYPE =',1X,A,/, & + & ' MATRIX SCALING APPROACH =',1X,A,/, & + & ' MATRIX REORDERING APPROACH =',1X,A,/, & + & ' NUMBER OF ORTHOGONALIZATIONS =',I9,/, & + & ' HEAD CHANGE CRITERION FOR CLOSURE =',E15.5,/, & + & ' RESIDUAL CHANGE CRITERION FOR CLOSURE =',E15.5,/, & + & ' RESIDUAL CONVERGENCE OPTION =',I9,/, & + & ' RESIDUAL CONVERGENCE NORM =',1X,A,/, & + & ' RELAXATION FACTOR =',E15.5) +02015 FORMAT (' NUMBER OF LEVELS =',A15,/, & + & ' DROP TOLERANCE =',A15,//) +2030 FORMAT(1X,A20,1X,6(I6,1X)) +2040 FORMAT(1X,20('-'),1X,6(6('-'),1X)) +2050 FORMAT(1X,62('-'),/) ! +!------------------------------------------------------------------ + ! + ! -- initialize clevel and cdroptol + clevel = '' + cdroptol = '' + ! + ! -- PRINT MXITER,ITER1,IPC,ISCL,IORD,HCLOSE,RCLOSE + write(this%iout,2010) & + clintit(THIS%ILINMETH), MXITER, THIS%ITER1, & + clin(THIS%ILINMETH), cipc(THIS%IPC), & + cscale(THIS%ISCL), corder(THIS%IORD), & + THIS%NORTH, THIS%HCLOSE, THIS%RCLOSE, & + THIS%ICNVGOPT, ccnvgopt(THIS%ICNVGOPT), & + THIS%RELAX + if (this%level > 0) then + write(clevel, '(i15)') this%level + end if + if (this%droptol > DZERO) then + write(cdroptol, '(e15.5)') this%droptol + end if + IF (this%level > 0 .or. this%droptol > DZERO) THEN + write(this%iout,2015) trim(adjustl(clevel)), & + trim(adjustl(cdroptol)) + ELSE + write(this%iout,'(//)') + END IF + + if (this%iord /= 0) then + ! + ! -- WRITE SUMMARY OF REORDERING INFORMATION TO LIST FILE + if (this%iprims == 2) then + DO i = 1, this%neq, 6 + write(this%iout,2030) 'ORIGINAL NODE :', & + (j,j=i,MIN(i+5,this%neq)) + write(this%iout,2040) + write(this%iout,2030) 'REORDERED INDEX :', & + (this%lorder(j),j=i,MIN(i+5,this%neq)) + write(this%iout,2030) 'REORDERED NODE :', & + (this%iorder(j),j=i,MIN(i+5,this%neq)) + write(this%iout,2050) + END DO + END IF + end if + ! + ! -- return + return + end subroutine imslinear_summary + + subroutine allocate_scalars(this) + use MemoryManagerModule, only: mem_allocate + class(IMSLINEAR_DATA), intent(inout) :: this + ! + ! -- scalars + call mem_allocate(this%iout, 'IOUT', this%origin) + call mem_allocate(this%ilinmeth, 'ILINMETH', this%origin) + call mem_allocate(this%iter1, 'ITER1', this%origin) + call mem_allocate(this%ipc, 'IPC', this%origin) + call mem_allocate(this%iscl, 'ISCL', this%origin) + call mem_allocate(this%iord, 'IORD', this%origin) + call mem_allocate(this%north, 'NORTH', this%origin) + call mem_allocate(this%icnvgopt, 'ICNVGOPT', this%origin) + call mem_allocate(this%iacpc, 'IACPC', this%origin) + call mem_allocate(this%niterc, 'NITERC', this%origin) + call mem_allocate(this%niabcgs, 'NIABCGS', this%origin) + call mem_allocate(this%niapc, 'NIAPC', this%origin) + call mem_allocate(this%njapc, 'NJAPC', this%origin) + call mem_allocate(this%hclose, 'HCLOSE', this%origin) + call mem_allocate(this%rclose, 'RCLOSE', this%origin) + call mem_allocate(this%relax, 'RELAX', this%origin) + call mem_allocate(this%epfact, 'EPFACT', this%origin) + call mem_allocate(this%l2norm0, 'L2NORM0', this%origin) + call mem_allocate(this%droptol, 'DROPTOL', this%origin) + call mem_allocate(this%level, 'LEVEL', this%origin) + call mem_allocate(this%njlu, 'NJLU', this%origin) + call mem_allocate(this%njw, 'NJW', this%origin) + call mem_allocate(this%nwlu, 'NWLU', this%origin) + ! + ! -- initialize + this%iout = 0 + this%ilinmeth = 0 + this%iter1 = 0 + this%ipc = 0 + this%iscl = 0 + this%iord = 0 + this%north = 0 + this%icnvgopt = 0 + this%iacpc = 0 + this%niterc = 0 + this%niabcgs = 0 + this%niapc = 0 + this%njapc = 0 + this%hclose = DZERO + this%rclose = DZERO + this%relax = DZERO + this%epfact = DZERO + this%l2norm0 = 0 + this%droptol = DZERO + this%level = 0 + this%njlu = 0 + this%njw = 0 + this%nwlu = 0 + ! + ! --Return + return + end subroutine allocate_scalars + + subroutine IMSLINEAR_DA(this) + use MemoryManagerModule, only: mem_deallocate + class(IMSLINEAR_DATA), intent(inout) :: this + ! + ! -- arrays + call mem_deallocate(this%dscale) + call mem_deallocate(this%dscale2) + call mem_deallocate(this%iapc) + call mem_deallocate(this%japc) + call mem_deallocate(this%apc) + call mem_deallocate(this%iw) + call mem_deallocate(this%w) + call mem_deallocate(this%jlu) + call mem_deallocate(this%jw) + call mem_deallocate(this%wlu) + call mem_deallocate(this%lorder) + call mem_deallocate(this%iorder) + call mem_deallocate(this%iaro) + call mem_deallocate(this%jaro) + call mem_deallocate(this%aro) + call mem_deallocate(this%id) + call mem_deallocate(this%d) + call mem_deallocate(this%p) + call mem_deallocate(this%q) + call mem_deallocate(this%z) + call mem_deallocate(this%t) + call mem_deallocate(this%v) + call mem_deallocate(this%dhat) + call mem_deallocate(this%phat) + call mem_deallocate(this%qhat) + ! + ! -- scalars + call mem_deallocate(this%iout) + call mem_deallocate(this%ilinmeth) + call mem_deallocate(this%iter1) + call mem_deallocate(this%ipc) + call mem_deallocate(this%iscl) + call mem_deallocate(this%iord) + call mem_deallocate(this%north) + call mem_deallocate(this%icnvgopt) + call mem_deallocate(this%iacpc) + call mem_deallocate(this%niterc) + call mem_deallocate(this%niabcgs) + call mem_deallocate(this%niapc) + call mem_deallocate(this%njapc) + call mem_deallocate(this%hclose) + call mem_deallocate(this%rclose) + call mem_deallocate(this%relax) + call mem_deallocate(this%epfact) + call mem_deallocate(this%l2norm0) + call mem_deallocate(this%droptol) + call mem_deallocate(this%level) + call mem_deallocate(this%njlu) + call mem_deallocate(this%njw) + call mem_deallocate(this%nwlu) + ! + ! -- nullify pointers + nullify(this%iprims) + nullify(this%neq) + nullify(this%nja) + nullify(this%ia) + nullify(this%ja) + nullify(this%amat) + nullify(this%rhs) + nullify(this%x) + ! + ! --Return + return + end subroutine IMSLINEAR_DA + + SUBROUTINE SET_IMSLINEAR_INPUT(THIS, IFDPARAM) + IMPLICIT NONE +! + + + DUMMY ARGUMENTS + + + + CLASS(IMSLINEAR_DATA), INTENT(INOUT) :: THIS + integer(I4B), INTENT(IN) :: IFDPARAM +! + + + LOCAL DEFINITIONS + + + +! + + + PARAMETERS + + + +! + + + FUNCTIONS + + + +! +! + + + CODE + + + + SELECT CASE ( IFDPARAM ) + ! Simple option + CASE(1) + THIS%ITER1 = 50 + THIS%ILINMETH=1 + THIS%IPC = 1 + THIS%ISCL = 0 + THIS%IORD = 0 + THIS%HCLOSE = DEM3 + THIS%RCLOSE = DEM1 + THIS%RELAX = DZERO + THIS%LEVEL = 0 + THIS%DROPTOL = DZERO + THIS%NORTH = 0 + ! Moderate + CASE(2) + THIS%ITER1 = 100 + THIS%ILINMETH=2 + THIS%IPC = 2 + THIS%ISCL = 0 + THIS%IORD = 0 + THIS%HCLOSE = DEM2 + THIS%RCLOSE = DEM1 + THIS%RELAX = 0.97D0 + THIS%LEVEL = 0 + THIS%DROPTOL = DZERO + THIS%NORTH = 0 + ! Complex + CASE(3) + THIS%ITER1 = 500 + THIS%ILINMETH=2 + THIS%IPC = 3 + THIS%ISCL = 0 + THIS%IORD = 0 + THIS%HCLOSE = DEM1 + THIS%RCLOSE = DEM1 + THIS%RELAX = DZERO + THIS%LEVEL = 5 + THIS%DROPTOL = DEM4 + THIS%NORTH = 2 + END SELECT + RETURN + END SUBROUTINE SET_IMSLINEAR_INPUT + + SUBROUTINE IMSLINEAR_AP(THIS,ICNVG,KSTP,KITER,IN_ITER, & + NCONV, CONVNMOD, CONVMODSTART, LOCDV, LOCDR, & + CACCEL, ITINNER, CONVLOCDV, CONVLOCDR, & + DVMAX, DRMAX, CONVDVMAX, CONVDRMAX) +! +! ****************************************************************** +! SOLUTION BY THE CONJUGATE GRADIENT METHOD - +! UP TO ITER1 ITERATIONS +! ****************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------ + USE SimModule + IMPLICIT NONE +! + + + DUMMY ARGUMENTS + + + + CLASS(IMSLINEAR_DATA), INTENT(INOUT) :: THIS + integer(I4B), INTENT(INOUT) :: ICNVG + integer(I4B), INTENT(IN) :: KSTP + integer(I4B), INTENT(IN) :: KITER + integer(I4B), INTENT(INOUT) :: IN_ITER + ! CONVERGENCE INFORMATION + integer(I4B), INTENT(IN) :: NCONV + integer(I4B), INTENT(IN) :: CONVNMOD + integer(I4B), DIMENSION(CONVNMOD+1), INTENT(INOUT) ::CONVMODSTART + integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDV + integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDR + character(len=31), DIMENSION(NCONV), INTENT(INOUT) :: CACCEL + integer(I4B), DIMENSION(NCONV), INTENT(INOUT) :: ITINNER + integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDV + integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDR + real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DVMAX + real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DRMAX + real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDVMAX + real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDRMAX + +! + + + LOCAL DEFINITIONS + + + + integer(I4B) :: n + integer(I4B) :: innerit + integer(I4B) :: irc + integer(I4B) :: itmax + real(DP) :: tv + real(DP) :: rmax +! + + + PARAMETERS + + + +! + + + FUNCTIONS + + + +! +! + + + CODE + + + +! +!-------SET EPFACT BASED ON MFUSG TIMESTEP + IF (THIS%ICNVGOPT == 2) THEN + IF (KSTP == 1) THEN + THIS%EPFACT = 0.01 + ELSE + THIS%EPFACT = 0.10 + END IF + ELSE IF (THIS%ICNVGOPT == 4) THEN + THIS%EPFACT = DEM4 + ELSE + THIS%EPFACT = DONE + END IF + +!-------SCALE PROBLEM + IF (THIS%ISCL.NE.0) THEN + CALL IMSLINEARSUB_SCALE(0,THIS%ISCL, & + THIS%NEQ,THIS%NJA,THIS%IA,THIS%JA, & + THIS%AMAT,THIS%X,THIS%RHS, & + THIS%DSCALE,THIS%DSCALE2) + END IF +! +!-------PERMUTE ROWS, COLUMNS, AND RHS + IF (THIS%IORD.NE.0) THEN + CALL ims_dperm(THIS%NEQ, THIS%NJA, THIS%AMAT,THIS%JA,THIS%IA, & + & THIS%ARO,THIS%JARO,THIS%IARO,THIS%LORDER,THIS%ID,1) + CALL ims_vperm(THIS%NEQ, THIS%X, THIS%LORDER) + CALL ims_vperm(THIS%NEQ, THIS%RHS, THIS%LORDER) + THIS%IA0 => THIS%IARO + THIS%JA0 => THIS%JARO + THIS%A0 => THIS%ARO + ELSE + THIS%IA0 => THIS%IA + THIS%JA0 => THIS%JA + THIS%A0 => THIS%AMAT + END IF +! +!-------UPDATE PRECONDITIONER + CALL IMSLINEARSUB_PCU(this%iout,THIS%NJA,THIS%NEQ,THIS%NIAPC,THIS%NJAPC, & + THIS%IPC, THIS%RELAX, THIS%A0, THIS%IA0, THIS%JA0, & + THIS%APC,THIS%IAPC,THIS%JAPC,THIS%IW,THIS%W, & + THIS%LEVEL, THIS%DROPTOL, THIS%NJLU, THIS%NJW, & + THIS%NWLU, THIS%JLU, THIS%JW, THIS%WLU) +!-------INITIALIZE SOLUTION VARIABLE AND ARRAYS + IF (KITER == 1 ) THIS%NITERC = 0 + irc = 1 + ICNVG = 0 + DO n = 1, THIS%NEQ + THIS%D(n) = DZERO + THIS%P(n) = DZERO + THIS%Q(n) = DZERO + THIS%Z(n) = DZERO + END DO +!-------CALCULATE INITIAL RESIDUAL + CALL IMSLINEARSUB_MV(THIS%NJA,THIS%NEQ,THIS%A0,THIS%X,THIS%D, & + THIS%IA0,THIS%JA0) + rmax = DZERO + THIS%L2NORM0 = DZERO + DO n = 1, THIS%NEQ + tv = THIS%D(n) + THIS%D(n) = THIS%RHS(n) - tv + IF (ABS( THIS%D(n) ) > rmax ) rmax = ABS( THIS%D(n) ) + THIS%L2NORM0 = THIS%L2NORM0 + THIS%D(n) * THIS%D(n) + END DO + THIS%L2NORM0 = SQRT(THIS%L2NORM0) +!-------CHECK FOR EXACT SOLUTION + itmax = THIS%ITER1 + IF (rmax == DZERO) THEN + itmax = 0 + ICNVG = 1 + END IF +!-------SOLUTION BY THE CONJUGATE GRADIENT METHOD + IF (THIS%ILINMETH == 1) THEN + CALL IMSLINEARSUB_CG(ICNVG, itmax, innerit, & + THIS%NEQ, THIS%NJA, THIS%NIAPC, THIS%NJAPC, & + THIS%IPC, THIS%NITERC, THIS%ICNVGOPT, THIS%NORTH, & + THIS%HCLOSE, THIS%RCLOSE, THIS%L2NORM0, & + THIS%EPFACT, THIS%IA0, THIS%JA0, THIS%A0, & + THIS%IAPC, THIS%JAPC, THIS%APC, & + THIS%X, THIS%RHS, THIS%D, THIS%P, THIS%Q, THIS%Z, & + THIS%NJLU, THIS%IW, THIS%JLU, & + NCONV, CONVNMOD, CONVMODSTART, LOCDV, LOCDR, & + CACCEL, ITINNER, CONVLOCDV, CONVLOCDR, & + DVMAX, DRMAX, CONVDVMAX, CONVDRMAX) +!-------SOLUTION BY THE BICONJUGATE GRADIENT STABILIZED METHOD + ELSE IF (THIS%ILINMETH == 2) THEN + CALL IMSLINEARSUB_BCGS(ICNVG, itmax, innerit, & + THIS%NEQ, THIS%NJA, THIS%NIAPC, THIS%NJAPC, & + THIS%IPC, THIS%NITERC, THIS%ICNVGOPT, THIS%NORTH,& + THIS%ISCL, THIS%DSCALE, & + THIS%HCLOSE, THIS%RCLOSE, THIS%L2NORM0, & + THIS%EPFACT, THIS%IA0, THIS%JA0, THIS%A0, & + THIS%IAPC, THIS%JAPC, THIS%APC, & + THIS%X, THIS%RHS, THIS%D, THIS%P, THIS%Q, & + THIS%T, THIS%V, THIS%DHAT, THIS%PHAT, THIS%QHAT, & + THIS%NJLU, THIS%IW, THIS%JLU, & + NCONV, CONVNMOD, CONVMODSTART, LOCDV, LOCDR, & + CACCEL, ITINNER, CONVLOCDV, CONVLOCDR, & + DVMAX, DRMAX, CONVDVMAX, CONVDRMAX) + END IF +! +!-------BACK PERMUTE AMAT, SOLUTION, AND RHS + IF (THIS%IORD.NE.0) THEN + CALL ims_dperm(THIS%NEQ, THIS%NJA, THIS%A0, THIS%JA0, THIS%IA0, & + & THIS%AMAT, THIS%JA,THIS%IA,THIS%IORDER,THIS%ID,1) + CALL ims_vperm(THIS%NEQ, THIS%X, THIS%IORDER) + CALL ims_vperm(THIS%NEQ, THIS%RHS, THIS%IORDER) + END IF +! +!-------UNSCALE PROBLEM + IF (THIS%ISCL.NE.0) THEN + CALL IMSLINEARSUB_SCALE(1, THIS%ISCL, & + THIS%NEQ, THIS%NJA, THIS%IA, THIS%JA, & + THIS%AMAT, THIS%X, THIS%RHS, & + THIS%DSCALE, THIS%DSCALE2) + END IF +! +!-------SET IMS INNER ITERATION NUMBER (IN_ITER) TO NUMBER OF +! IMSLINEAR INNER ITERATIONS (innerit) + IN_ITER = innerit +! +!-------RETURN + RETURN +! + END SUBROUTINE IMSLINEAR_AP + + +! -- IMSLinearModule subroutines that do not depend on data stored in the IMSLinearModule class +! all data is passed through subroutine calls +! +!-------ROUTINE TO CALCULATE LORDER AND IORDER FOR REORDERING + SUBROUTINE IMSLINEARSUB_CALC_ORDER(IOUT, IPRIMS, IORD, NEQ, NJA, IA, JA, & + & LORDER, IORDER) + use SimModule, only: ustop, store_error, count_errors + IMPLICIT NONE +! + + + DUMMY ARGUMENTS + + + + integer(I4B), INTENT(IN) :: IOUT + integer(I4B), INTENT(IN) :: IPRIMS + integer(I4B), INTENT(IN) :: IORD + integer(I4B), INTENT(IN) :: NEQ + integer(I4B), INTENT(IN) :: NJA + integer(I4B), DIMENSION(NEQ+1), INTENT(IN) :: IA + integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA + integer(I4B), DIMENSION(NEQ), INTENT(INOUT) :: LORDER + integer(I4B), DIMENSION(NEQ), INTENT(INOUT) :: IORDER +! + + + LOCAL DEFINITIONS + + + + character (len=LINELENGTH) :: errmsg + integer(I4B) :: n + integer(I4B) :: nsp + integer(I4B), DIMENSION(:), ALLOCATABLE :: iwork0, iwork1 + integer(I4B) :: iflag +! + + + PARAMETERS + + + +! + + + FUNCTIONS + + + +! + + + FORMATS + + + +! + + + CODE + + + + DO n = 1, NEQ + LORDER(n) = IZERO + IORDER(n) = IZERO + END DO + ALLOCATE ( iwork0(NEQ) ) + SELECT CASE ( IORD ) + CASE ( 1 ) + ALLOCATE ( iwork1(NEQ) ) + CALL ims_genrcm(NEQ, NJA, IA, JA, & + & LORDER, iwork0, iwork1 ) + CASE ( 2 ) + nsp = 3 * NEQ + 4 * NJA + ALLOCATE ( iwork1(nsp) ) + CALL ims_odrv(NEQ, NJA, nsp, IA, JA, LORDER, iwork0, & + iwork1, iflag) + IF (iflag.NE.0) THEN + write(errmsg,'(A)') 'ERROR CREATING MINIMUM DEGREE '// & + & 'ORDER PERMUTATION ' + call store_error(errmsg) + !call ustop() + END IF + END SELECT +! +! GENERATE INVERSE OF LORDER + DO n = 1, NEQ + IORDER( LORDER(n) ) = n + END DO +! +! DEALLOCATE TEMPORARY STORAGE + DEALLOCATE ( iwork0, iwork1 ) +! + if (count_errors() > 0) then + call parser%StoreErrorUnit() + call ustop() + endif +! +!---------RETURN + RETURN + END SUBROUTINE IMSLINEARSUB_CALC_ORDER +! +!-------ROUTINE TO SCALE THE COEFFICIENT MATRIX (AMAT), +! THE RHS (B), AND THE ESTIMATE OF X (X) + SUBROUTINE IMSLINEARSUB_SCALE(IOPT, ISCL, NEQ, NJA, IA, JA, AMAT, X, B, & + & DSCALE, DSCALE2) + IMPLICIT NONE +! + + + DUMMY ARGUMENTS + + + + integer(I4B), INTENT(IN) :: IOPT + integer(I4B), INTENT(IN) :: ISCL + integer(I4B), INTENT(IN) :: NEQ + integer(I4B), INTENT(IN) :: NJA + integer(I4B), DIMENSION(NEQ+1), INTENT(IN) :: IA + integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA + real(DP), DIMENSION(NJA), INTENT(INOUT) :: AMAT + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: X + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: B + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: DSCALE + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: DSCALE2 +! + + + LOCAL DEFINITIONS + + + + integer(I4B) :: i, n + integer(I4B) :: id, jc + integer(I4B) :: i0, i1 + real(DP) :: v, c1, c2 +! + + + FUNCTIONS + + + +! + + + CODE + + + +! +!---------SCALE SCALE AMAT, X, AND B + IF (IOPT == 0) THEN +!-----------SYMMETRIC SCALING + SELECT CASE ( ISCL ) + CASE ( 1 ) + DO n = 1, NEQ + id = IA(n) + v = AMAT(id) + c1 = DONE / SQRT( ABS( v ) ) + DSCALE(n) = c1 + DSCALE2(n) = c1 + END DO +! SCALE AMAT -- AMAT = DSCALE(row) * AMAT(i) * DSCALE2(col) + DO n = 1, NEQ + c1 = DSCALE(n) + i0 = IA(n) + i1 = IA(n+1) - 1 + DO i = i0, i1 + jc = JA(i) + c2 = DSCALE2(jc) + AMAT(i) = c1 * AMAT(i) * c2 + END DO + END DO +!-----------L-2 NORM SCALING + CASE ( 2 ) +! SCALE EACH ROW SO THAT THE L-2 NORM IS 1 + DO n = 1, NEQ + c1 = DZERO + i0 = IA(n) + i1 = IA(n+1) - 1 + DO i = i0, i1 + c1 = c1 + AMAT(i) * AMAT(i) + END DO + c1 = SQRT( c1 ) + IF (c1 == DZERO) THEN + c1 = DONE + ELSE + c1 = DONE / c1 + END IF + DSCALE(n) = c1 +! INITIAL SCALING OF AMAT -- AMAT = DSCALE(row) * AMAT(i) + DO i = i0, i1 + AMAT(i) = c1 * AMAT(i) + END DO + END DO +! SCALE EACH COLUMN SO THAT THE L-2 NORM IS 1 + DO n = 1, NEQ + DSCALE2(n) = DZERO + END DO + c2 = DZERO + DO n = 1, NEQ + i0 = IA(n) + i1 = IA(n+1) - 1 + DO i = i0, i1 + jc = JA(i) + c2 = AMAT(i) + DSCALE2(jc) = DSCALE2(jc) + c2 * c2 + END DO + END DO + DO n = 1, NEQ + c2 = DSCALE2(n) + IF (c2 == DZERO) THEN + c2 = DONE + ELSE + c2 = DONE / SQRT( c2 ) + END IF + DSCALE2(n) = c2 + END DO +! FINAL SCALING OF AMAT -- AMAT = DSCALE2(col) * AMAT(i) + DO n = 1, NEQ + i0 = IA(n) + i1 = IA(n+1) - 1 + DO i = i0, i1 + jc = JA(i) + c2 = DSCALE2(jc) + AMAT(i) = c2 * AMAT(i) + END DO + END DO + END SELECT +!-----------SCALE X AND B + DO n = 1, NEQ + c1 = DSCALE(n) + c2 = DSCALE2(n) + X(n) = X(n) / c2 + B(n) = B(n) * c1 + END DO +!---------UNSCALE SCALE AMAT, X, AND B + ELSE + DO n = 1, NEQ + c1 = DSCALE(n) + i0 = IA(n) + i1 = IA(n+1) - 1 +! UNSCALE AMAT + DO i = i0, i1 + jc = JA(i) + c2 = DSCALE2(jc) + AMAT(i) = ( DONE / c1 ) * AMAT(i) * ( DONE / c2 ) + END DO +! UNSCALE X AND B + c2 = DSCALE2(n) + X(n) = X(n) * c2 + B(n) = B(n) / c1 + END DO + END IF +!---------RETURN + RETURN + END SUBROUTINE IMSLINEARSUB_SCALE +! +!-------ROUTINE TO UPDATE THE PRECONDITIONER + SUBROUTINE IMSLINEARSUB_PCU(IOUT, NJA, NEQ, NIAPC, NJAPC, IPC, RELAX, & + AMAT, IA, JA, APC, IAPC, JAPC, IW, W, & + LEVEL, DROPTOL, NJLU, NJW, NWLU, JLU, JW, WLU) + use SimModule, only: ustop, store_error, count_errors +! + + + DUMMY ARGUMENTS + + + + integer(I4B), INTENT(IN) :: IOUT + integer(I4B), INTENT(IN) :: NJA + integer(I4B), INTENT(IN) :: NEQ + integer(I4B), INTENT(IN) :: NIAPC + integer(I4B), INTENT(IN) :: NJAPC + integer(I4B), INTENT(IN) :: IPC + real(DP), INTENT(IN) :: RELAX + real(DP), DIMENSION(NJA), INTENT(IN) :: AMAT + integer(I4B), DIMENSION(NEQ+1), INTENT(IN) :: IA + integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA + real(DP), DIMENSION(NJAPC), INTENT(INOUT) :: APC + integer(I4B), DIMENSION(NIAPC+1), INTENT(INOUT) :: IAPC + integer(I4B), DIMENSION(NJAPC), INTENT(INOUT) :: JAPC + integer(I4B), DIMENSION(NIAPC), INTENT(INOUT) :: IW + real(DP), DIMENSION(NIAPC), INTENT(INOUT) :: W + ! ILUT + integer(I4B), INTENT(IN) :: LEVEL + real(DP), INTENT(IN) :: DROPTOL + integer(I4B), INTENT(IN) :: NJLU + integer(I4B), INTENT(IN) :: NJW + integer(I4B), INTENT(IN) :: NWLU + integer(I4B), DIMENSION(NJLU), INTENT(INOUT) :: JLU + integer(I4B), DIMENSION(NJW), INTENT(INOUT) :: JW + real(DP), DIMENSION(NWLU), INTENT(INOUT) :: WLU +! + + + LOCAL DEFINITIONS + + + + character(len=LINELENGTH) :: errmsg + character(len=80), dimension(3) :: cerr + integer(I4B) :: izero + integer(I4B) :: ierr + real(DP) :: delta +! + + + FUNCTIONS + + + +! + + + DATA + + + + DATA cerr /'INCOMPREHENSIBLE ERROR - MATRIX MUST BE WRONG. ', & + 'INSUFFICIENT STORAGE IN ARRAYS ALU, JLU TO STORE FACTORS. ', & + 'ZERO ROW ENCOUNTERED. '/ + +! + + + FORMATS + + + + 2000 FORMAT (/,' MATRIX IS SEVERELY NON-DIAGONALLY DOMINANT.', & + & /,' ADDING SMALL VALUE TO PIVOT (IMSLINEARSUB_PCU)') +! + + + CODE + + + + izero = 0 + delta = DZERO + PCSCALE: DO + SELECT CASE(IPC) +! ILU0 AND MILU0 + CASE (1,2) + CALL IMSLINEARSUB_PCILU0(NJA, NEQ, AMAT, IA, JA, & + APC, IAPC, JAPC, IW, W, & + RELAX, izero, delta) +! ILUT AND MILUT + CASE (3,4) + ierr = 0 + CALL IMSLINEARSUB_PCMILUT(NEQ, AMAT, JA, IA, & + LEVEL, DROPTOL, RELAX, & + APC, JLU, IW, NJAPC, WLU, JW, ierr, & + izero, delta) + IF (ierr.NE.0) THEN + write(errmsg,'(4x,a,1x,a)') & + '****ERROR. ILUT ERROR: ', cerr(-ierr) + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + END IF +! ADDITIONAL PRECONDITIONERS + CASE DEFAULT + izero = 0 + END SELECT + IF (izero < 1) THEN + EXIT PCSCALE + END IF + delta = 1.5D0 * delta + 0.001 + izero = 0 + IF (delta > DHALF) THEN + WRITE(IOUT,2000) + delta = DHALF + izero = 2 + END IF + END DO PCSCALE +!---------RETURN + RETURN + END SUBROUTINE IMSLINEARSUB_PCU +! +!-------JACOBI PRECONDITIONER - INVERSE OF DIAGONAL + SUBROUTINE IMSLINEARSUB_PCJ(NJA, NEQ, AMAT, APC, IA, JA) +! + + + DUMMY ARGUMENTS + + + + integer(I4B), INTENT(IN) :: NJA + integer(I4B), INTENT(IN) :: NEQ + real(DP), DIMENSION(NJA), INTENT(IN) :: AMAT + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: APC + integer(I4B), DIMENSION(NEQ+1), INTENT(IN) :: IA + integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA +! + + + LOCAL DEFINITIONS + + + + integer(I4B) :: i, n + integer(I4B) :: ic0, ic1 + integer(I4B) :: id + real(DP) :: tv +! + + + PARAMETERS + + + +! + + + FUNCTIONS + + + +! + + + CODE + + + + DO n = 1, NEQ + ic0 = IA(n) + ic1 = IA(n+1) - 1 + id = IA(n) + DO i = ic0, ic1 + IF (JA(i) == n) THEN + id = i + EXIT + END IF + END DO + tv = AMAT(id) + IF (ABS( tv ) > DZERO ) tv = DONE / tv + APC(n) = tv + END DO +!---------RETURN + RETURN + END SUBROUTINE IMSLINEARSUB_PCJ + + SUBROUTINE IMSLINEARSUB_JACA(NEQ, A, D1, D2) + IMPLICIT NONE +! + + + DUMMY ARGUMENTS + + + + integer(I4B), INTENT(IN) :: NEQ + real(DP), DIMENSION(NEQ), INTENT(IN) :: A + real(DP), DIMENSION(NEQ), INTENT(IN) :: D1 + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: D2 +! + + + LOCAL DEFINITIONS + + + + integer(I4B) :: n + real(DP) :: tv +! + + + PARAMETERS + + + +! + + + FUNCTIONS + + + +! + + + CODE + + + + DO n = 1, NEQ + tv = A(n) * D1(n) + D2(n) = tv + END DO +!---------RETURN + RETURN + END SUBROUTINE IMSLINEARSUB_JACA + + SUBROUTINE IMSLINEARSUB_PCILU0(NJA, NEQ, AMAT, IA, JA, & + APC, IAPC, JAPC, IW, W, & + RELAX, IZERO, DELTA) + IMPLICIT NONE +! + + + DUMMY ARGUMENTS + + + + integer(I4B), INTENT(IN) :: NJA + integer(I4B), INTENT(IN) :: NEQ + real(DP), DIMENSION(NJA), INTENT(IN) :: AMAT + integer(I4B), DIMENSION(NEQ+1), INTENT(IN) :: IA + integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA + real(DP), DIMENSION(NJA), INTENT(INOUT) :: APC + integer(I4B), DIMENSION(NEQ+1), INTENT(INOUT) :: IAPC + integer(I4B), DIMENSION(NJA), INTENT(INOUT) :: JAPC + integer(I4B), DIMENSION(NEQ), INTENT(INOUT) :: IW + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: W + real(DP), INTENT(IN) :: RELAX + integer(I4B), INTENT(INOUT) :: IZERO + real(DP), INTENT(IN) :: DELTA +! + + + LOCAL DEFINITIONS + + + + integer(I4B) :: ic0, ic1 + integer(I4B) :: iic0, iic1 + integer(I4B) :: iu, iiu + integer(I4B) :: j, n + integer(I4B) :: jj + integer(I4B) :: jcol, jw + integer(I4B) :: jjcol + real(DP) :: drelax + real(DP) :: sd1 + real(DP) :: tl + real(DP) :: rs + real(DP) :: d +! + + + PARAMETERS + + + +! + + + FUNCTIONS + + + +! + + + CODE + + + + drelax = RELAX + DO n = 1, NEQ + IW(n) = 0 + W(n) = DZERO + END DO + MAIN: DO n = 1, NEQ + ic0 = IA(n) + ic1 = IA(n+1) - 1 + DO j = ic0, ic1 + jcol = JA(j) + IW(jcol) = 1 + W(jcol) = W(jcol) + AMAT(j) + END DO + ic0 = IAPC(n) + ic1 = IAPC(n+1) - 1 + iu = JAPC(n) + rs = DZERO + LOWER: DO j = ic0, iu-1 + jcol = JAPC(j) + iic0 = IAPC(jcol) + iic1 = IAPC(jcol+1) - 1 + iiu = JAPC(jcol) + tl = W(jcol) * APC(jcol) + W(jcol) = tl + DO jj = iiu, iic1 + jjcol = JAPC(jj) + jw = IW(jjcol) + IF (jw.NE.0) THEN + W(jjcol) = W(jjcol) - tl * APC(jj) + ELSE + rs = rs + tl * APC(jj) + END IF + END DO + END DO LOWER +! DIAGONAL - CALCULATE INVERSE OF DIAGONAL FOR SOLUTION + d = W(n) + tl = ( DONE + DELTA ) * d - ( drelax * rs ) +!-----------ENSURE THAT THE SIGN OF THE DIAGONAL HAS NOT CHANGED AND IS + sd1 = SIGN(d,tl) + IF (sd1.NE.d) THEN +! USE SMALL VALUE IF DIAGONAL SCALING IS NOT EFFECTIVE FOR +! PIVOTS THAT CHANGE THE SIGN OF THE DIAGONAL + IF (IZERO > 1) THEN + tl = SIGN(DEM6,d) +! DIAGONAL SCALING CONTINUES TO BE EFFECTIVE + ELSE + IZERO = 1 + EXIT MAIN + END IF + END IF + IF (ABS(tl) == DZERO) THEN +! USE SMALL VALUE IF DIAGONAL SCALING IS NOT EFFECTIVE FOR +! ZERO PIVOTS + IF (IZERO > 1) THEN + tl = SIGN(DEM6,d) +! DIAGONAL SCALING CONTINUES TO BE EFFECTIVE FOR ELIMINATING + ELSE + IZERO = 1 + EXIT MAIN + END IF + END IF + APC(n) = DONE / tl +! RESET POINTER FOR IW TO ZERO + IW(n) = 0 + W(n) = DZERO + DO j = ic0, ic1 + jcol = JAPC(j) + APC(j) = W(jcol) + IW(jcol) = 0 + W(jcol) = DZERO + END DO + END DO MAIN +! +!---------RESET IZERO IF SUCCESSFUL COMPLETION OF MAIN + IZERO = 0 +! +!---------RETURN + RETURN + END SUBROUTINE IMSLINEARSUB_PCILU0 + + SUBROUTINE IMSLINEARSUB_ILU0A(NJA, NEQ, APC, IAPC, JAPC, R, D) + IMPLICIT NONE +! + + + DUMMY ARGUMENTS + + + + integer(I4B), INTENT(IN) :: NJA + integer(I4B), INTENT(IN) :: NEQ + real(DP), DIMENSION(NJA), INTENT(IN) :: APC + integer(I4B), DIMENSION(NEQ+1), INTENT(IN) :: IAPC + integer(I4B), DIMENSION(NJA), INTENT(IN) :: JAPC + real(DP), DIMENSION(NEQ), INTENT(IN) :: R + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: D +! + + + LOCAL DEFINITIONS + + + + integer(I4B) :: ic0, ic1 + integer(I4B) :: iu + integer(I4B) :: jcol + integer(I4B) :: j, n + real(DP) :: tv +! + + + FUNCTIONS + + + +! + + + CODE + + + +! FORWARD SOLVE - APC * D = R + FORWARD: DO n = 1, NEQ + tv = R(n) + ic0 = IAPC(n) + ic1 = IAPC(n+1) - 1 + iu = JAPC(n) - 1 + LOWER: DO j = ic0, iu + jcol = JAPC(j) + tv = tv - APC(j) * D(jcol) + END DO LOWER + D(n) = tv + END DO FORWARD +! BACKWARD SOLVE - D = D / U + BACKWARD: DO n = NEQ, 1, -1 + ic0 = IAPC(n) + ic1 = IAPC(n+1) - 1 + iu = JAPC(n) + tv = D(n) + UPPER: DO j = iu, ic1 + jcol = JAPC(j) + tv = tv - APC(j) * D(jcol) + END DO UPPER +! COMPUTE D FOR DIAGONAL - D = D / U + D(n) = tv * APC(n) + END DO BACKWARD +!---------RETURN + RETURN + END SUBROUTINE IMSLINEARSUB_ILU0A + + SUBROUTINE IMSLINEARSUB_CG(ICNVG, ITMAX, INNERIT, & + NEQ, NJA, NIAPC, NJAPC, & + IPC, NITERC, ICNVGOPT, NORTH, & + HCLOSE, RCLOSE, L2NORM0, EPFACT, & + IA0, JA0, A0, IAPC, JAPC, APC, & + X, B, D, P, Q, Z, & + NJLU, IW, JLU, & + NCONV, CONVNMOD, CONVMODSTART, LOCDV, LOCDR, & + CACCEL, ITINNER, CONVLOCDV, CONVLOCDR, & + DVMAX, DRMAX, CONVDVMAX, CONVDRMAX) + IMPLICIT NONE +! + + + DUMMY ARGUMENTS + + + + integer(I4B), INTENT(INOUT) :: ICNVG + integer(I4B), INTENT(IN) :: ITMAX + integer(I4B), INTENT(INOUT) :: INNERIT + integer(I4B), INTENT(IN) :: NEQ + integer(I4B), INTENT(IN) :: NJA + integer(I4B), INTENT(IN) :: NIAPC + integer(I4B), INTENT(IN) :: NJAPC + integer(I4B), INTENT(IN) :: IPC + integer(I4B), INTENT(INOUT) :: NITERC + integer(I4B), INTENT(IN) :: ICNVGOPT + integer(I4B), INTENT(IN) :: NORTH + real(DP), INTENT(IN) :: HCLOSE + real(DP), INTENT(IN) :: RCLOSE + real(DP), INTENT(IN) :: L2NORM0 + real(DP), INTENT(IN) :: EPFACT + integer(I4B), DIMENSION(NEQ+1), INTENT(IN) :: IA0 + integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA0 + real(DP), DIMENSION(NJA), INTENT(IN) :: A0 + integer(I4B), DIMENSION(NIAPC+1), INTENT(IN) :: IAPC + integer(I4B), DIMENSION(NJAPC), INTENT(IN) :: JAPC + real(DP), DIMENSION(NJAPC), INTENT(IN) :: APC + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: X + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: B + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: D + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: P + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: Q + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: Z + ! ILUT + integer(I4B), INTENT(IN) :: NJLU + integer(I4B), DIMENSION(NIAPC), INTENT(IN) :: IW + integer(I4B), DIMENSION(NJLU), INTENT(IN) :: JLU + ! CONVERGENCE INFORMATION + integer(I4B), INTENT(IN) :: NCONV + integer(I4B), INTENT(IN) :: CONVNMOD + integer(I4B), DIMENSION(CONVNMOD+1), INTENT(INOUT) ::CONVMODSTART + integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDV + integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDR + character(len=31), DIMENSION(NCONV), INTENT(INOUT) :: CACCEL + integer(I4B), DIMENSION(NCONV), INTENT(INOUT) :: ITINNER + integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDV + integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDR + real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DVMAX + real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DRMAX + real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDVMAX + real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDRMAX +! + + + LOCAL DEFINITIONS + + + + LOGICAL :: LORTH + logical :: lsame + character(len=31) :: cval + integer(I4B) :: n + integer(I4B) :: iiter + integer(I4B) :: xloc, rloc + integer(I4B) :: im, im0, im1 + real(DP) :: tv + real(DP) :: deltax + real(DP) :: rmax + real(DP) :: l2norm + real(DP) :: rcnvg + real(DP) :: denom + real(DP) :: alpha, beta + real(DP) :: rho, rho0 +! + + + PARAMETERS + + + +! + + + FUNCTIONS + + + +! +! + + + CODE + + + + rho0 = DZERO + rho = DZERO + INNERIT = 0 +! +!-------INNER ITERATION + INNER: DO iiter = 1, itmax + INNERIT = INNERIT + 1 + NITERC = NITERC + 1 +!----------APPLY PRECONDITIONER + SELECT CASE (IPC) +! ILU0 AND MILU0 + CASE (1,2) + CALL IMSLINEARSUB_ILU0A(NJA, NEQ, APC, IAPC, JAPC, D, Z) +! ILUT AND MILUT + CASE (3,4) + CALL IMSLINEARSUB_PCMILUT_LUSOL(NEQ, D, Z, APC, JLU, IW) + END SELECT + rho = IMSLINEARSUB_DP(NEQ, D, Z) +!-----------COMPUTE DIRECTIONAL VECTORS + IF (IITER == 1) THEN + DO n = 1, NEQ + P(n) = Z(n) + END DO + ELSE + !denom = rho0 + SIGN(DPREC,rho0) + !beta = rho / denom + beta = rho / rho0 + DO n = 1, NEQ + P(n) = Z(n) + beta * P(n) + END DO + END IF +!-----------COMPUTE ITERATES +! UPDATE Q + CALL IMSLINEARSUB_MV(NJA, NEQ, A0, P, Q, IA0, JA0) + denom = IMSLINEARSUB_DP(NEQ, P, Q) + denom = denom + SIGN(DPREC, denom) + alpha = rho / denom +!-----------UPDATE X AND RESIDUAL + deltax = DZERO + rmax = DZERO + l2norm = DZERO + DO im = 1, CONVNMOD + DVMAX(im) = DZERO + DRMAX(im) = DZERO + END DO + im = 1 + im0 = CONVMODSTART(1) + im1 = CONVMODSTART(2) + DO n = 1, NEQ + ! -- determine current model index + if (n == im1) then + im = im + 1 + im0 = CONVMODSTART(im) + im1 = CONVMODSTART(im+1) + end if + ! -- identify deltax and rmax + tv = alpha * P(n) + X(n) = X(n) + tv + IF (ABS(tv) > ABS(deltax)) THEN + deltax = tv + xloc = n + END IF + IF (ABS(tv) > ABS(DVMAX(im))) THEN + DVMAX(im) = tv + LOCDV(im) = n + END IF + tv = D(n) + tv = tv - alpha * Q(n) + D(n) = tv + IF (ABS(tv) > ABS(rmax)) THEN + rmax = tv + rloc = n + END IF + IF (ABS(tv) > ABS(DRMAX(im))) THEN + DRMAX(im) = tv + LOCDR(im) = n + END IF + l2norm = l2norm + tv * tv + END DO + l2norm = SQRT(l2norm) +!-----------SAVE SOLVER CONVERGENCE INFORMATION + IF (NCONV > 1) THEN + n = NITERC + WRITE(cval, '(g15.7)') alpha + CACCEL(n) = cval + ITINNER(n) = iiter + DO im = 1, CONVNMOD + CONVLOCDV(im, n) = LOCDV(im) + CONVLOCDR(im, n) = LOCDR(im) + CONVDVMAX(im, n) = DVMAX(im) + CONVDRMAX(im, n) = DRMAX(im) + END DO + END IF +!-----------TEST FOR SOLVER CONVERGENCE + IF (ICNVGOPT == 2 .OR. ICNVGOPT == 3 .OR. ICNVGOPT == 4) THEN + rcnvg = l2norm + ELSE + rcnvg = rmax + END IF + CALL IMSLINEARSUB_TESTCNVG(ICNVGOPT, ICNVG, INNERIT, & + deltax, rcnvg, & + L2NORM0, EPFACT, HCLOSE, RCLOSE) +! +! CHECK FOR EXACT SOLUTION + IF (rcnvg == DZERO) ICNVG = 1 + IF (ICNVG.NE.0) EXIT INNER +!-----------CHECK THAT CURRENT AND PREVIOUS rho ARE DIFFERENT + lsame = IS_SAME(rho, rho0) + IF (lsame) THEN + EXIT INNER + END IF +!-----------RECALCULATE THE RESIDUAL + IF (NORTH > 0) THEN + LORTH = mod(iiter+1,NORTH) == 0 + IF (LORTH) THEN + CALL IMSLINEARSUB_MV(NJA, NEQ, A0, X, D, IA0, JA0) + CALL IMSLINEARSUB_AXPY(NEQ, B, -DONE, D, D) + END IF + END IF +!-----------SAVE CURRENT INNER ITERATES + rho0 = rho + END DO INNER +!---------RESET ICNVG + IF (ICNVG < 0) ICNVG = 0 +!---------RETURN + RETURN + END SUBROUTINE IMSLINEARSUB_CG + + SUBROUTINE IMSLINEARSUB_BCGS(ICNVG, ITMAX, INNERIT, & + NEQ, NJA, NIAPC, NJAPC, & + IPC, NITERC, ICNVGOPT, NORTH, ISCL, DSCALE, & + HCLOSE, RCLOSE, L2NORM0, EPFACT, & + IA0, JA0, A0, IAPC, JAPC, APC, & + X, B, D, P, Q, & + T, V, DHAT, PHAT, QHAT, & + NJLU, IW, JLU, & + NCONV, CONVNMOD, CONVMODSTART, LOCDV, LOCDR, & + CACCEL, ITINNER, CONVLOCDV, CONVLOCDR, & + DVMAX, DRMAX, CONVDVMAX, CONVDRMAX) + IMPLICIT NONE +! + + + DUMMY ARGUMENTS + + + + integer(I4B), INTENT(INOUT) :: ICNVG + integer(I4B), INTENT(IN) :: ITMAX + integer(I4B), INTENT(INOUT) :: INNERIT + integer(I4B), INTENT(IN) :: NEQ + integer(I4B), INTENT(IN) :: NJA + integer(I4B), INTENT(IN) :: NIAPC + integer(I4B), INTENT(IN) :: NJAPC + integer(I4B), INTENT(IN) :: IPC + integer(I4B), INTENT(INOUT) :: NITERC + integer(I4B), INTENT(IN) :: ICNVGOPT + integer(I4B), INTENT(IN) :: NORTH + integer(I4B), INTENT(IN) :: ISCL + real(DP), DIMENSION(NEQ), INTENT(IN) :: DSCALE + real(DP), INTENT(IN) :: HCLOSE + real(DP), INTENT(IN) :: RCLOSE + real(DP), INTENT(IN) :: L2NORM0 + real(DP), INTENT(IN) :: EPFACT + integer(I4B), DIMENSION(NEQ+1), INTENT(IN) :: IA0 + integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA0 + real(DP), DIMENSION(NJA), INTENT(IN) :: A0 + integer(I4B), DIMENSION(NIAPC+1), INTENT(IN) :: IAPC + integer(I4B), DIMENSION(NJAPC), INTENT(IN) :: JAPC + real(DP), DIMENSION(NJAPC), INTENT(IN) :: APC + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: X + real(DP), DIMENSION(NEQ), INTENT(IN) :: B + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: D + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: P + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: Q + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: T + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: V + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: DHAT + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: PHAT + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: QHAT + ! ILUT + integer(I4B), INTENT(IN) :: NJLU + integer(I4B), DIMENSION(NIAPC), INTENT(IN) :: IW + integer(I4B), DIMENSION(NJLU), INTENT(IN) :: JLU + ! CONVERGENCE INFORMATION + integer(I4B), INTENT(IN) :: NCONV + integer(I4B), INTENT(IN) :: CONVNMOD + integer(I4B), DIMENSION(CONVNMOD+1), INTENT(INOUT) ::CONVMODSTART + integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDV + integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDR + character(len=31), DIMENSION(NCONV), INTENT(INOUT) :: CACCEL + integer(I4B), DIMENSION(NCONV), INTENT(INOUT) :: ITINNER + integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDV + integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDR + real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DVMAX + real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DRMAX + real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDVMAX + real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDRMAX +! + + + LOCAL DEFINITIONS + + + + LOGICAL :: LORTH + logical :: lsame + character(len=15) :: cval1, cval2 + integer(I4B) :: n + integer(I4B) :: iiter + integer(I4B) :: xloc, rloc + integer(I4B) :: im, im0, im1 + real(DP) :: tv + real(DP) :: deltax + real(DP) :: rmax + real(DP) :: l2norm + real(DP) :: rcnvg + real(DP) :: alpha, alpha0 + real(DP) :: beta + real(DP) :: rho, rho0 + real(DP) :: omega, omega0 + real(DP) :: numer, denom +! + + + PARAMETERS + + + +! + + + FUNCTIONS + + + +! +! + + + CODE + + + + INNERIT = 0 + + alpha = DZERO + alpha0 = DZERO + beta = DZERO + rho = DZERO + rho0 = DZERO + omega = DZERO + omega0 = DZERO +! +!-------SAVE INITIAL RESIDUAL + DO n = 1, NEQ + DHAT(n) = D(n) + END DO +! +!-------INNER ITERATION + INNER: DO iiter = 1, itmax + INNERIT = INNERIT + 1 + NITERC = NITERC + 1 +!----------CALCULATE rho + rho = IMSLINEARSUB_DP(NEQ, DHAT, D) +!-----------COMPUTE DIRECTIONAL VECTORS + IF (IITER == 1) THEN + DO n = 1, NEQ + P(n) = D(n) + END DO + ELSE + beta = ( rho / rho0 ) * ( alpha0 / omega0 ) + DO n = 1, NEQ + P(n) = D(n) + beta * ( P(n) - omega0 * V(n) ) + END DO + END IF +!----------APPLY PRECONDITIONER TO UPDATE PHAT + SELECT CASE (IPC) +! ILU0 AND MILU0 + CASE (1,2) + CALL IMSLINEARSUB_ILU0A(NJA, NEQ, APC, IAPC, JAPC, P, PHAT) +! ILUT AND MILUT + CASE (3,4) + CALL IMSLINEARSUB_PCMILUT_LUSOL(NEQ, P, PHAT, APC, JLU, IW) + END SELECT +!-----------COMPUTE ITERATES +! UPDATE V WITH A AND PHAT + CALL IMSLINEARSUB_MV(NJA, NEQ, A0, PHAT, V, IA0, JA0) +! UPDATE alpha WITH DHAT AND V + denom = IMSLINEARSUB_DP(NEQ, DHAT, V) + denom = denom + SIGN(DPREC, denom) + alpha = rho / denom +!-----------UPDATE Q + DO n = 1, NEQ + Q(n) = D(n) - alpha * V(n) + END DO +!!-----------CALCULATE INFINITY NORM OF Q - TEST FOR TERMINATION +!! TERMINATE IF rmax IS LESS THAN MACHINE PRECISION (DPREC) +! rmax = DZERO +! DO n = 1, NEQ +! tv = Q(n) +! IF (ISCL.NE.0 ) tv = tv / DSCALE(n) +! IF (ABS(tv) > ABS(rmax) ) rmax = tv +! END DO +! IF (ABS(rmax).LE.DPREC) THEN +! deltax = DZERO +! DO n = 1, NEQ +! tv = alpha * PHAT(n) +! IF (ISCL.NE.0) THEN +! tv = tv * DSCALE(n) +! END IF +! X(n) = X(n) + tv +! IF (ABS(tv) > ABS(deltax) ) deltax = tv +! END DO +! CALL IMSLINEARSUB_TESTCNVG(ICNVGOPT, ICNVG, INNERIT, & +! deltax, rmax, & +! rmax, EPFACT, HCLOSE, RCLOSE ) +! IF (ICNVG.NE.0 ) EXIT INNER +! END IF +!-----------APPLY PRECONDITIONER TO UPDATE QHAT + SELECT CASE (IPC) +! ILU0 AND MILU0 + CASE (1,2) + CALL IMSLINEARSUB_ILU0A(NJA, NEQ, APC, IAPC, JAPC, Q, QHAT) +! ILUT AND MILUT + CASE (3,4) + CALL IMSLINEARSUB_PCMILUT_LUSOL(NEQ, Q, QHAT, APC, JLU, IW) + END SELECT +! UPDATE T WITH A AND QHAT + CALL IMSLINEARSUB_MV(NJA, NEQ, A0, QHAT, T, IA0, JA0) +!-----------UPDATE omega + numer = IMSLINEARSUB_DP(NEQ, T, Q) + denom = IMSLINEARSUB_DP(NEQ, T, T) + denom = denom + SIGN(DPREC,denom) + omega = numer / denom +!-----------UPDATE X AND RESIDUAL + deltax = DZERO + rmax = DZERO + l2norm = DZERO + DO im = 1, CONVNMOD + DVMAX(im) = DZERO + DRMAX(im) = DZERO + END DO + im = 1 + im0 = CONVMODSTART(1) + im1 = CONVMODSTART(2) + DO n = 1, NEQ + ! -- determine current model index + if (n == im1) then + im = im + 1 + im0 = CONVMODSTART(im) + im1 = CONVMODSTART(im+1) + end if +!-------------X AND DX + tv = alpha * PHAT(n) + omega * QHAT(n) + X(n) = X(n) + tv + IF (ISCL.NE.0) THEN + tv = tv * DSCALE(n) + END IF + IF (ABS(tv) > ABS(deltax)) THEN + deltax = tv + xloc = n + END IF + IF (ABS(tv) > ABS(DRMAX(im))) THEN + DVMAX(im) = tv + LOCDV(im) = n + END IF +!-------------RESIDUAL + tv = Q(n) - omega * T(n) + D(n) = tv + IF (ISCL.NE.0) THEN + tv = tv / DSCALE(n) + END IF + IF (ABS(tv) > ABS(rmax)) THEN + rmax = tv + rloc = n + END IF + IF (ABS(tv) > ABS(DRMAX(im))) THEN + DRMAX(im) = tv + LOCDR(im) = n + END IF + l2norm = l2norm + tv * tv + END DO + l2norm = sqrt(l2norm) +!-----------SAVE SOLVER CONVERGENCE INFORMATION + IF (NCONV > 1) THEN + n = NITERC + WRITE(cval1,'(g15.7)') alpha + WRITE(cval2,'(g15.7)') omega + CACCEL(n) = trim(adjustl(cval1)) // ',' // trim(adjustl(cval2)) + ITINNER(n) = iiter + DO im = 1, CONVNMOD + CONVLOCDV(im, n) = LOCDV(im) + CONVLOCDR(im, n) = LOCDR(im) + CONVDVMAX(im, n) = DVMAX(im) + CONVDRMAX(im, n) = DRMAX(im) + END DO + END IF +!-----------TEST FOR SOLVER CONVERGENCE + IF (ICNVGOPT == 2 .OR. ICNVGOPT == 3 .OR. ICNVGOPT == 4) THEN + rcnvg = l2norm + ELSE + rcnvg = rmax + END IF + CALL IMSLINEARSUB_TESTCNVG(ICNVGOPT, ICNVG, INNERIT, & + deltax, rcnvg, & + L2NORM0, EPFACT, HCLOSE, RCLOSE) +! CHECK FOR EXACT SOLUTION + IF (rcnvg == DZERO) ICNVG = 1 + IF (ICNVG.NE.0) EXIT INNER +!-----------CHECK THAT CURRENT AND PREVIOUS rho, alpha, AND omega ARE +! DIFFERENT + lsame = IS_SAME(rho, rho0) + IF (lsame) THEN + EXIT INNER + END IF + lsame = IS_SAME(alpha, alpha0) + IF (lsame) THEN + EXIT INNER + END IF + lsame = IS_SAME(omega, omega0) + IF (lsame) THEN + EXIT INNER + END IF +!-----------RECALCULATE THE RESIDUAL + IF (NORTH > 0) THEN + LORTH = mod(iiter+1,NORTH) == 0 + IF (LORTH) THEN + CALL IMSLINEARSUB_MV(NJA, NEQ, A0,X , D, IA0, JA0) + CALL IMSLINEARSUB_AXPY(NEQ, B, -DONE, D, D) + !DO n = 1, NEQ + ! tv = D(n) + ! D(n) = B(n) - tv + !END DO + END IF + END IF +!-----------SAVE CURRENT INNER ITERATES + rho0 = rho + alpha0 = alpha + omega0 = omega + END DO INNER +!---------RESET ICNVG + IF (ICNVG < 0) ICNVG = 0 +!---------RETURN + RETURN + END SUBROUTINE IMSLINEARSUB_BCGS +! +!---------TEST FOR SOLVER CONVERGENCE + SUBROUTINE IMSLINEARSUB_TESTCNVG(Icnvgopt, Icnvg, Iiter, & + Hmax, Rmax, & + Rmax0, Epfact, Hclose, Rclose ) + IMPLICIT NONE +! + + + DUMMY ARGUMENTS + + + + integer(I4B), INTENT(IN) :: Icnvgopt + integer(I4B), INTENT(INOUT) :: Icnvg + integer(I4B), INTENT(IN) :: Iiter + real(DP), INTENT(IN) :: Hmax + real(DP), INTENT(IN) :: Rmax + real(DP), INTENT(IN) :: Rmax0 + real(DP), INTENT(IN) :: Epfact + real(DP), INTENT(IN) :: Hclose + real(DP), INTENT(IN) :: Rclose +! + + + LOCAL DEFINITIONS + + + +! + + + FUNCTIONS + + + +! + + + CODE + + + + IF (Icnvgopt == 0) THEN + IF (ABS(Hmax) <= Hclose .AND. ABS(Rmax) <= Rclose) THEN + Icnvg = 1 + END IF + ELSE IF (Icnvgopt == 1) THEN + IF (ABS(Hmax) <= Hclose .AND. ABS(Rmax) <= Rclose .AND. & + iiter == 1) THEN + Icnvg = 1 + END IF + ELSE IF (Icnvgopt == 2) THEN + IF (ABS(Hmax) <= Hclose .OR. Rmax <= Rclose) THEN + Icnvg = 1 + ELSE IF (Rmax <= Rmax0*Epfact) THEN + Icnvg = -1 + END IF + ELSE IF (Icnvgopt == 3) THEN + IF (ABS(Hmax) <= Hclose) THEN + Icnvg = 1 + ELSE IF (Rmax <= Rmax0*Rclose) THEN + Icnvg = -1 + END IF + ELSE IF (Icnvgopt == 4) THEN + IF (ABS(Hmax) <= Hclose .AND. Rmax <= Rclose) THEN + Icnvg = 1 + ELSE IF (Rmax <= Rmax0*Epfact) THEN + Icnvg = -1 + END IF + END IF +!---------RETURN + RETURN + END SUBROUTINE IMSLINEARSUB_TESTCNVG +! +!---------GENERATE IAPC AND JAPC FROM IA AND JA +! JAPC(1:NEQ) HAS THE POSITION OF THE UPPER ENTRY FOR A ROW +! JAPC(NEQ+1:NJA) IS THE COLUMN POSITION FOR ENTRY +! APC(1:NEQ) PRECONDITIONED INVERSE OF THE DIAGONAL +! APC(NEQ+1:NJA) PRECONDITIONED ENTRIES FOR OFF DIAGONALS + SUBROUTINE IMSLINEARSUB_PCCRS(NEQ, NJA, IA, JA, & + IAPC,JAPC) + IMPLICIT NONE +! + + + DUMMY ARGUMENTS + + + + integer(I4B), INTENT(IN) :: NEQ + integer(I4B), INTENT(IN) :: NJA + integer(I4B), DIMENSION(NEQ+1), INTENT(IN) :: IA + integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA + integer(I4B), DIMENSION(NEQ+1), INTENT(INOUT) :: IAPC + integer(I4B), DIMENSION(NJA), INTENT(INOUT) :: JAPC +! + + + LOCAL DEFINITIONS + + + + integer(I4B) :: n, j + integer(I4B) :: i0, i1 + integer(I4B) :: nlen + integer(I4B) :: ic,ip + integer(I4B) :: jcol + integer(I4B), DIMENSION(:), ALLOCATABLE :: iarr +! + + + FUNCTIONS + + + +! + + + CODE + + + + ip = NEQ + 1 + DO n = 1, NEQ + i0 = IA(n) + i1 = IA(n+1) - 1 + nlen = i1 - i0 + ALLOCATE( iarr(nlen) ) + ic = 0 + DO j = i0, i1 + jcol = JA(j) + IF (jcol == n) CYCLE + ic = ic + 1 + iarr(ic) = jcol + END DO + CALL IMSLINEARSUB_ISORT(nlen,iarr) + IAPC(n) = ip + DO j = 1, nlen + jcol = iarr(j) + JAPC(ip) = jcol + ip = ip + 1 + END DO + DEALLOCATE(iarr) + END DO + IAPC(NEQ+1) = NJA + 1 +!---------POSITION OF THE FIRST UPPER ENTRY FOR ROW + DO n = 1, NEQ + i0 = IAPC(n) + i1 = IAPC(n+1) - 1 + JAPC(n) = IAPC(n+1) + DO j = i0, i1 + jcol = JAPC(j) + IF (jcol > n) THEN + JAPC(n) = j + EXIT + END IF + END DO + END DO +!---------RETURN + RETURN + END SUBROUTINE IMSLINEARSUB_PCCRS +! +!-------SIMPLE IN-PLACE SORTING ROUTINE FOR AN INTEGER ARRAY + SUBROUTINE IMSLINEARSUB_ISORT(NVAL, IARRAY) + IMPLICIT NONE +! + + + DUMMY ARGUMENTS + + + + integer(I4B),INTENT(IN) :: NVAL + integer(I4B),DIMENSION(NVAL),INTENT(INOUT) :: IARRAY +! + + + LOCAL DEFINITIONS + + + + integer(I4B) :: i, j, itemp +! + + + FUNCTIONS + + + +! + + + CODE + + + + DO i = 1, NVAL-1 + DO j = i+1, NVAL + if(IARRAY(i) > IARRAY(j)) then + itemp = IARRAY(j) + IARRAY(j) = IARRAY(i) + IARRAY(i) = itemp + END IF + END DO + END DO +!---------RETURN + RETURN + END SUBROUTINE IMSLINEARSUB_ISORT +! +!-------INITIALIZE REAL VECTOR + SUBROUTINE IMSLINEARSUB_SETX(NR, D1, C) + IMPLICIT NONE +! + + + DUMMY ARGUMENTS + + + + integer(I4B), INTENT(IN) :: NR + real(DP), DIMENSION(NR), INTENT(INOUT) :: D1 + real(DP), INTENT(IN) :: C +! + + + LOCAL DEFINITIONS + + + + INTEGER :: n +! + + + FUNCTIONS + + + +! + + + CODE + + + +! + DO n = 1, NR + D1(n) = C + END DO +!---------RETURN + RETURN + END SUBROUTINE IMSLINEARSUB_SETX + +! COPY ONE real(DP) VECTOR TO ANOTHER + SUBROUTINE IMSLINEARSUB_DCOPY(NR, V, R) + IMPLICIT NONE +! + + + DUMMY ARGUMENTS + + + + integer(I4B), INTENT(IN) :: NR + real(DP), DIMENSION(NR), INTENT(IN) :: V + real(DP), DIMENSION(NR), INTENT(INOUT) :: R +! + + + LOCAL DEFINITIONS + + + + integer(I4B) :: n +! + + + FUNCTIONS + + + +! + + + CODE + + + + DO n = 1, NR + R(n) = V(n) + END DO +!---------RETURN + RETURN + END SUBROUTINE IMSLINEARSUB_DCOPY + +! COPY ONE INTEGER VECTOR TO ANOTHER + SUBROUTINE IMSLINEARSUB_ICOPY(NR, V, R) + IMPLICIT NONE +! + + + DUMMY ARGUMENTS + + + + integer(I4B), INTENT(IN) :: NR + integer(I4B), DIMENSION(NR), INTENT(IN) :: V + integer(I4B), DIMENSION(NR), INTENT(INOUT) :: R +! + + + LOCAL DEFINITIONS + + + + integer(I4B) :: n +! + + + FUNCTIONS + + + +! + + + CODE + + + + DO n = 1, NR + R(n) = V(n) + END DO +!---------RETURN + RETURN + END SUBROUTINE IMSLINEARSUB_ICOPY +! +!-------SCALE A REAL VECTOR WITH A CONSTANT + SUBROUTINE IMSLINEARSUB_RSCAL(NR, C, D1) + IMPLICIT NONE +! + + + DUMMY ARGUMENTS + + + + INTEGER, INTENT(IN) :: NR + real(DP), INTENT(IN) :: C + real(DP), DIMENSION(NR), INTENT(INOUT) :: D1 +! + + + LOCAL DEFINITIONS + + + + INTEGER :: n +! + + + FUNCTIONS + + + +! + + + CODE + + + + DO n = 1, NR + D1(n) = C * D1(n) + END DO +!---------RETURN + RETURN + END SUBROUTINE IMSLINEARSUB_RSCAL + + + SUBROUTINE IMSLINEARSUB_MV(NJA, NEQ, A, D1, D2, IA, JA) + IMPLICIT NONE +! + + + DUMMY ARGUMENTS + + + + integer(I4B), INTENT(IN) :: NJA + integer(I4B), INTENT(IN) :: NEQ + real(DP), DIMENSION(NJA), INTENT(IN) :: A + real(DP), DIMENSION(NEQ), INTENT(IN) :: D1 + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: D2 + integer(I4B), DIMENSION(NEQ+1), INTENT(IN) :: IA + integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA +! + + + LOCAL DEFINITIONS + + + + integer(I4B) :: ic0, ic1 + integer(I4B) :: icol + integer(I4B) :: m, n + real(DP) :: tv +! + + + PARAMETERS + + + +! + + + FUNCTIONS + + + +! + + + CODE + + + + DO n = 1, NEQ +! ADD DIAGONAL AND OFF-DIAGONAL TERMS + tv = DZERO + ic0 = IA(n) + ic1 = IA(n+1)-1 + DO m = ic0, ic1 + icol = JA(m) + tv = tv + A(m) * D1(icol) + END DO + D2(n) = tv + END DO +!---------RETURN + RETURN + END SUBROUTINE IMSLINEARSUB_MV + + SUBROUTINE IMSLINEARSUB_AXPY(NEQ, D1, DC, D2, DR) + IMPLICIT NONE +! + + + DUMMY ARGUMENTS + + + + integer(I4B), INTENT(IN) :: NEQ + real(DP), DIMENSION(NEQ), INTENT(IN) :: D1 + real(DP), INTENT(IN) :: DC + real(DP), DIMENSION(NEQ), INTENT(IN) :: D2 + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: DR +! + + + LOCAL DEFINITIONS + + + + integer(I4B) :: n +! + + + FUNCTIONS + + + +! + + + CODE + + + + DO n = 1, NEQ + DR(n) = D1(n) + DC * D2(n) + END DO +!---------RETURN + RETURN + END SUBROUTINE IMSLINEARSUB_AXPY + + + FUNCTION IMSLINEARSUB_DP(neq, a, b) RESULT(c) + ! -- return variable + real(DP) :: c +! + + + dummy arguments + + + + integer(I4B), intent(in) :: neq + real(DP), dimension(neq), intent(in) :: a + real(DP), dimension(neq), intent(in) :: b +! + + + local definitions + + + + integer(I4B) :: n +! + + + parameters + + + +! + + + functions + + + +! + + + code + + + + c = DZERO + do n = 1, neq + c = c + a(n) * b(n) + end do + !---------return + return + END FUNCTION IMSLINEARSUB_DP + + + FUNCTION IMSLINEARSUB_RNRM2(neq, a) RESULT(c) + ! -- return variable + real(DP) :: c +! + + + dummy arguments + + + + integer(I4B), intent(in) :: neq + real(DP), dimension(neq), intent(in) :: a +! + + + local definitions + + + + integer(I4B) :: n + real(DP) :: ssq + real(DP) :: scale + real(DP) :: norm + real(DP) :: absan +! + + + parameters + + + +! + + + functions + + + +! + + + code + + + + if (neq < 1) then + norm = DZERO + else if (neq == 1) then + norm = ABS(a(1)) + else + scale = DZERO + ssq = DONE + do n = 1, neq + if (a(n) /= DZERO) then + absan = abs(a(n)) + if (scale < absan) then + ssq = DONE + ssq * (scale/absan)**2 + scale = absan + else + ssq = ssq + (absan/scale)**2 + end if + end if + end do + norm = scale * sqrt(ssq) + END IF + c = norm + !---------return + return + END FUNCTION IMSLINEARSUB_RNRM2 +! +! +!-------BEGINNING OF SUBROUTINES FROM OTHER LIBRARIES + + ! SUBSET OF SPARSKIT VERSION 2 SOURCE CODE + ! + ! SPARSKIT VERSION 2 SUBROUTINES INCLUDED INCLUDE: + ! + ! 1 - IMSLINEARSUB_PCMILUT + ! 2 - IMSLINEARSUB_PCMILUT_LUSOL + ! 3 - IMSLINEARSUB_PCMILUT_QSPLIT + ! + !----------------------------------------------------------------------- + ! S P A R S K I T V E R S I O N 2. + !----------------------------------------------------------------------- + ! + !Latest update : Tue Mar 8 11:01:12 CST 2005 + ! + !----------------------------------------------------------------------- + ! + !Welcome to SPARSKIT VERSION 2. SPARSKIT is a package of FORTRAN + !subroutines for working with sparse matrices. It includes general + !sparse matrix manipulation routines as well as a few iterative + !solvers, see detailed description of contents below. + ! + ! Copyright (C) 2005, the Regents of the University of Minnesota + ! + !SPARSKIT is free software; you can redistribute it and/or modify it + !under the terms of the GNU Lesser General Public License as published + !by the Free Software Foundation [version 2.1 of the License, or any + !later version.] + ! + !A copy of the licencing agreement is attached in the file LGPL. For + !additional information contact the Free Software Foundation Inc., 59 + !Temple Place - Suite 330, Boston, MA 02111, USA or visit the web-site + ! + ! http://www.gnu.org/copyleft/lesser.html + ! + ! + !DISCLAIMER + !---------- + ! + !SPARSKIT is distributed in the hope that it will be useful, but + !WITHOUT ANY WARRANTY; without even the implied warranty of + !MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + !Lesser General Public License for more details. + ! + !For more information contact saad@cs.umn.edu + ! + ! + + SUBROUTINE IMSLINEARSUB_PCMILUT(n, a, ja, ia, lfil, droptol, relax, & + alu, jlu, ju, iwk, w, jw, ierr, & + izero, delta) + !----------------------------------------------------------------------- + integer(I4B) :: n + real(DP) :: a(*),alu(*),w(n+1),droptol,relax + integer(I4B) :: ja(*),ia(n+1),jlu(*),ju(n),jw(2*n),lfil,iwk,ierr + integer(I4B) :: izero + real(DP) :: delta + !----------------------------------------------------------------------* + ! *** ILUT preconditioner *** * + ! incomplete LU factorization with dual truncation mechanism * + !----------------------------------------------------------------------* + ! Author: Yousef Saad *May, 5, 1990, Latest revision, August 1996 * + !----------------------------------------------------------------------* + ! PARAMETERS + !----------- + ! + ! on entry: + !========== + ! n = integer. The row dimension of the matrix A. The matrix + ! + ! a,ja,ia = matrix stored in Compressed Sparse Row format. + ! + ! lfil = integer. The fill-in parameter. Each row of L and each row + ! of U will have a maximum of lfil elements (excluding the + ! diagonal element). lfil must be .ge. 0. + ! ** WARNING: THE MEANING OF LFIL HAS CHANGED WITH RESPECT TO + ! EARLIER VERSIONS. + ! + ! droptol = real. Sets the threshold for dropping small terms + ! in the factorization. See below for details on dropping + ! strategy. + ! + ! + ! iwk = integer. The lengths of arrays alu and jlu. If the arrays + ! are not big enough to store the ILU factorizations, ilut + ! will stop with an error message. + ! + ! On return: + !=========== + ! + ! alu,jlu = matrix stored in Modified Sparse Row (MSR) format containing + ! the L and U factors together. The diagonal (stored in + ! alu(1:n) ) is inverted. Each i-th row of the alu,jlu matrix + ! contains the i-th row of L (excluding the diagonal entry=1) + ! followed by the i-th row of U. + ! + ! ju = integer array of length n containing the pointers to + ! the beginning of each row of U in the matrix alu,jlu. + ! + ! ierr = integer. Error message with the following meaning. + ! ierr = 0 --> successful return. + ! ierr .gt. 0 --> zero pivot encountered at step number ierr. + ! ierr = -1 --> Error. input matrix may be wrong. + ! (The elimination process has generated a + ! row in L or U whose length is .gt. n.) + ! ierr = -2 --> The matrix L overflows the array al. + ! ierr = -3 --> The matrix U overflows the array alu. + ! ierr = -4 --> Illegal value for lfil. + ! ierr = -5 --> zero row encountered. + ! + ! work arrays: + !============= + ! jw = integer work array of length 2*n. + ! w = real work array of length n+1. + ! + !---------------------------------------------------------------------- + ! w, ju (1:n) store the working array [1:ii-1 = L-part, ii:n = u] + ! jw(n+1:2n) stores nonzero indicators + ! + ! Notes: + ! ------ + ! The diagonal elements of the input matrix must be nonzero (at least + ! 'structurally'). + ! + !----------------------------------------------------------------------* + !---- Dual drop strategy works as follows. * + ! * + ! 1) Thresholding in L and U as set by droptol. Any element whose * + ! magnitude is less than some tolerance (relative to the abs * + ! value of diagonal element in u) is dropped. * + ! * + ! 2) Keeping only the largest lfil elements in the i-th row of L * + ! and the largest lfil elements in the i-th row of U (excluding * + ! diagonal elements). * + ! * + ! Flexibility: one can use droptol=0 to get a strategy based on * + ! keeping the largest elements in each row of L and U. Taking * + ! droptol .ne. 0 but lfil=n will give the usual threshold strategy * + ! (however, fill-in is then unpredictable). * + !----------------------------------------------------------------------* + ! locals + character(len=LINELENGTH) :: line + integer(I4B) :: ju0,k,j1,j2,j,ii,i,lenl,lenu,jj,jrow,jpos,ilen + real(DP) :: tnorm, t, abs, s, fact + real(DP) :: rs, d, sd1, tl + ! format + character(len=*), parameter :: fmterr = "(//,1x,a)" + ! code + if (lfil .lt. 0) goto 998 + !----------------------------------------------------------------------- + ! initialize ju0 (points to next element to be added to alu,jlu) + ! and pointer array. + !----------------------------------------------------------------------- + ju0 = n+2 + jlu(1) = ju0 + ! + ! initialize nonzero indicator array. + ! + do j = 1, n + jw(n+j) = 0 + end do + !----------------------------------------------------------------------- + ! beginning of main loop. + !----------------------------------------------------------------------- + main: do ii = 1, n + j1 = ia(ii) + j2 = ia(ii+1) - 1 + rs = DZERO + tnorm = DZERO + do k = j1, j2 + tnorm = tnorm+abs(a(k)) + end do + if (tnorm .eq. DZERO) goto 999 + tnorm = tnorm/real(j2-j1+1) + ! + ! unpack L-part and U-part of row of A in arrays w + ! + lenu = 1 + lenl = 0 + jw(ii) = ii + w(ii) = DZERO + jw(n+ii) = ii + ! + do j = j1, j2 + k = ja(j) + t = a(j) + if (k .lt. ii) then + lenl = lenl+1 + jw(lenl) = k + w(lenl) = t + jw(n+k) = lenl + else if (k .eq. ii) then + w(ii) = t + else + lenu = lenu+1 + jpos = ii+lenu-1 + jw(jpos) = k + w(jpos) = t + jw(n+k) = jpos + end if + end do + jj = 0 + ilen = 0 + ! + ! eliminate previous rows + ! +150 jj = jj+1 + if (jj .gt. lenl) goto 160 + !----------------------------------------------------------------------- + ! in order to do the elimination in the correct order we must select + ! the smallest column index among jw(k), k=jj+1, ..., lenl. + !----------------------------------------------------------------------- + jrow = jw(jj) + k = jj + ! + ! determine smallest column index + ! + do j = jj+1, lenl + if (jw(j) .lt. jrow) then + jrow = jw(j) + k = j + end if + end do + ! + if (k .ne. jj) then + ! exchange in jw + j = jw(jj) + jw(jj) = jw(k) + jw(k) = j + ! exchange in jr + jw(n+jrow) = jj + jw(n+j) = k + ! exchange in w + s = w(jj) + w(jj) = w(k) + w(k) = s + end if + ! + ! zero out element in row by setting jw(n+jrow) to zero. + ! + jw(n+jrow) = 0 + ! + ! get the multiplier for row to be eliminated (jrow). + ! + fact = w(jj)*alu(jrow) + if (abs(fact) .le. droptol) then + rs = rs + w(jj) + goto 150 + end if + ! + ! combine current row and row jrow + ! + do k = ju(jrow), jlu(jrow+1)-1 + s = fact*alu(k) + j = jlu(k) + jpos = jw(n+j) + if (j .ge. ii) then + ! + ! dealing with upper part. + ! + if (jpos .eq. 0) then + ! + ! this is a fill-in element + ! + lenu = lenu+1 + if (lenu .gt. n) goto 995 + i = ii+lenu-1 + jw(i) = j + jw(n+j) = i + w(i) = - s + else + ! + ! this is not a fill-in element + ! + w(jpos) = w(jpos) - s + + end if + else + ! + ! dealing with lower part. + ! + if (jpos .eq. 0) then + ! + ! this is a fill-in element + ! + lenl = lenl+1 + if (lenl .gt. n) goto 995 + jw(lenl) = j + jw(n+j) = lenl + w(lenl) = - s + else + ! + ! this is not a fill-in element + ! + w(jpos) = w(jpos) - s + end if + end if + end do + ! + ! store this pivot element -- (from left to right -- no danger of + ! overlap with the working elements in L (pivots). + ! + ilen = ilen+1 + w(ilen) = fact + jw(ilen) = jrow + goto 150 +160 continue + ! + ! reset double-pointer to zero (U-part) + ! + do k = 1, lenu + jw(n+jw(ii+k-1)) = 0 + end do + ! + ! update L-matrix + ! + lenl = ilen + ilen = min0(lenl,lfil) + ! + ! sort by quick-split + ! + call IMSLINEARSUB_PCMILUT_QSPLIT(lenl, w, jw, ilen) + ! + ! store L-part + ! + do k = 1, ilen + ! if (ju0 .gt. iwk) goto 996 + if (ju0 .gt. iwk) then + write(line, '(2i10)') ju0, iwk + call sim_message(line, fmt=fmterr, level=VDEBUG) + goto 996 + end if + alu(ju0) = w(k) + jlu(ju0) = jw(k) + ju0 = ju0+1 + end do + ! + ! save pointer to beginning of row ii of U + ! + ju(ii) = ju0 + ! + ! update U-matrix -- first apply dropping strategy + ! + ilen = 0 + do k = 1, lenu-1 + if (abs(w(ii+k)) .gt. droptol*tnorm) then + ilen = ilen+1 + w(ii+ilen) = w(ii+k) + jw(ii+ilen) = jw(ii+k) + else + rs = rs + w(ii+k) + end if + end do + lenu = ilen+1 + ilen = min0(lenu,lfil) + ! + call IMSLINEARSUB_PCMILUT_QSPLIT(lenu-1, w(ii+1), jw(ii+1), ilen) + ! + ! copy + ! + t = abs(w(ii)) + ! if (ilen + ju0 .gt. iwk) goto 997 + if (ilen + ju0 .gt. iwk) then + write(line, '(2i10)') (ilen + ju0), iwk + call sim_message(line, fmt=fmterr, level=VDEBUG) + goto 997 + end if + do k = ii+1, ii+ilen-1 + jlu(ju0) = jw(k) + alu(ju0) = w(k) + t = t + abs(w(k) ) + ju0 = ju0+1 + end do + !! + !! add dropped terms to diagonal element + !! + !IF (relax > DZERO) THEN + ! w(ii) = w(ii) + relax * rs + !END IF + !! + !! store inverse of diagonal element of u + !! + !if (w(ii) == DZERO) w(ii) = (DEM4 + droptol)*tnorm + !! + !alu(ii) = DONE / w(ii) + + ! diagonal - calculate inverse of diagonal for solution + d = w(ii) + tl = ( DONE + delta ) * d + ( relax * rs ) + + ! ensure that the sign of the diagonal has not changed + sd1 = SIGN(d,tl) + IF (sd1.NE.d) THEN + ! use small value if diagonal scaling is not effective for + ! pivots that change the sign of the diagonal + IF (izero > 1) THEN + tl = SIGN(DONE,d) * (DEM4 + droptol) * tnorm + ! diagonal scaling continues to be effective + ELSE + izero = 1 + exit main + END IF + END IF + ! ensure that the diagonal is not zero + IF (ABS(tl) == DZERO) THEN + ! use small value if diagonal scaling is not effective + ! zero pivots + IF (izero > 1) THEN + tl = SIGN(DONE,d) * (DEM4 + droptol) * tnorm + ! diagonal scaling continues to be effective + ELSE + izero = 1 + exit main + END IF + END IF + w(ii) = tl + alu(ii) = DONE / w(ii) + ! + ! update pointer to beginning of next row of U. + ! + jlu(ii+1) = ju0 + !----------------------------------------------------------------------- + ! end main loop + !----------------------------------------------------------------------- + end do main + ierr = 0 + return + ! + ! incomprehensible error. Matrix must be wrong. + ! +995 ierr = -1 + return + ! + ! insufficient storage in L. + ! +996 ierr = -2 + return + ! + ! insufficient storage in U. + ! +997 ierr = -3 + return + ! + ! illegal lfil entered. + ! +998 ierr = -4 + return + ! + ! zero row encountered + ! +999 ierr = -5 + return + !----------------end-of-ilut-------------------------------------------- + !----------------------------------------------------------------------- + END SUBROUTINE IMSLINEARSUB_PCMILUT + + !----------------------------------------------------------------------- + SUBROUTINE IMSLINEARSUB_PCMILUT_LUSOL(n, y, x, alu, jlu, ju) + integer(I4B) :: n + real(DP) :: x(n), y(n), alu(*) + integer(I4B) :: jlu(*), ju(*) + !----------------------------------------------------------------------- + ! + ! This routine solves the system (LU) x = y, + ! given an LU decomposition of a matrix stored in (alu, jlu, ju) + ! modified sparse row format + ! + !----------------------------------------------------------------------- + ! on entry: + ! n = dimension of system + ! y = the right-hand-side vector + ! alu, jlu, ju + ! = the LU matrix as provided from the ILU routines. + ! + ! on return + ! x = solution of LU x = y. + !----------------------------------------------------------------------- + ! + ! Note: routine is in place: call IMSLINEARSUB_PCMILUT_LUSOL (n, x, x, alu, jlu, ju) + ! will solve the system with rhs x and overwrite the result on x . + ! + !----------------------------------------------------------------------- + ! -- local + ! + integer(I4B) :: i, k + ! + ! forward solve + ! + do i = 1, n + x(i) = y(i) + do k = jlu(i), ju(i)-1 + x(i) = x(i) - alu(k)* x(jlu(k)) + end do + end do + ! + ! backward solve. + ! + do i = n, 1, -1 + do k = ju(i), jlu(i+1)-1 + x(i) = x(i) - alu(k)*x(jlu(k)) + end do + x(i) = alu(i)*x(i) + end do + ! + return + !----------------end of IMSLINEARSUB_PCMILUT_LUSOL ------------------------------------------ + !----------------------------------------------------------------------- + END SUBROUTINE IMSLINEARSUB_PCMILUT_LUSOL + + !----------------------------------------------------------------------- + SUBROUTINE IMSLINEARSUB_PCMILUT_QSPLIT(n, a, ind, ncut) + integer(I4B) :: n + real(DP) :: a(n) + integer(I4B) :: ind(n), ncut + !----------------------------------------------------------------------- + ! does a quick-sort split of a real array. + ! on input a(1:n). is a real array + ! on output a(1:n) is permuted such that its elements satisfy: + ! + ! abs(a(i)) .ge. abs(a(ncut)) for i .lt. ncut and + ! abs(a(i)) .le. abs(a(ncut)) for i .gt. ncut + ! + ! ind(1:n) is an integer array which permuted in the same way as a(* + !----------------------------------------------------------------------- + real(DP) :: tmp, abskey + integer(I4B) :: itmp, first, last + integer(I4B) :: mid + integer(I4B) :: j + !----- + first = 1 + last = n + if (ncut .lt. first .or. ncut .gt. last) return + ! + ! outer loop -- while mid .ne. ncut do + ! +00001 mid = first + abskey = abs(a(mid)) + do j = first+1, last + if (abs(a(j)) .gt. abskey) then + mid = mid+1 + ! interchange + tmp = a(mid) + itmp = ind(mid) + a(mid) = a(j) + ind(mid) = ind(j) + a(j) = tmp + ind(j) = itmp + end if + end do + ! + ! interchange + ! + tmp = a(mid) + a(mid) = a(first) + a(first) = tmp + ! + itmp = ind(mid) + ind(mid) = ind(first) + ind(first) = itmp + ! + ! test for while loop + ! + if (mid .eq. ncut) return + if (mid .gt. ncut) then + last = mid-1 + else + first = mid+1 + end if + goto 1 + !----------------end-of-IMSLINEARSUB_PCMILUT_QSPLIT------------------------------------------ + !----------------------------------------------------------------------- + END SUBROUTINE IMSLINEARSUB_PCMILUT_QSPLIT + +END MODULE IMSLinearModule diff --git a/src/Solution/SparseMatrixSolver/ims8reordering.f90 b/src/Solution/SparseMatrixSolver/ims8reordering.f90 index 7a32601e927..c6a66e7b3df 100644 --- a/src/Solution/SparseMatrixSolver/ims8reordering.f90 +++ b/src/Solution/SparseMatrixSolver/ims8reordering.f90 @@ -1,1659 +1,1659 @@ - MODULE IMSReorderingModule - use KindModule, only: DP, I4B - private - public :: ims_genrcm, ims_odrv, ims_dperm, ims_vperm - contains - - !----- subroutine ims_genrcm - ! - ! purpose - ims_genrcm finds the reverse cuthill-mckee - ! ordering for a general graph. for each connected - ! component in the graph, ims_genrcm obtains the ordering - ! by calling the subroutine ims_rcm. - ! - ! input parameters - - ! neqns - number of equations - ! (xadj0, adjncy) - array pair containing the adjacency - ! structure of the graph of the matrix. - ! - ! output parameter - - ! perm - vector that contains the rcm ordering. - ! - ! working parameters - - ! xadj - working ia of the matrix - ! mask - is used to mark variables that have been - ! numbered during the ordering process. it is - ! initialized to 1, and set to zero as each node - ! is numbered. - ! xls - the index vector for a level structure. the - ! level structure is stored in the currently - ! unused spaces in the permutation vector perm. - ! - ! program subroutines - - ! ims_fnroot, ims_rcm. - ! - !*************************************************************** - ! - subroutine ims_genrcm(neqns, nja, xadj0, adjncy, perm, mask, xls) - ! - !*************************************************************** - ! - implicit none - - ! -- dummy variables - integer(I4B), intent(in) :: neqns, nja - integer(I4B), dimension(neqns+1), intent(in) :: xadj0 - integer(I4B), dimension(nja), intent(in) :: adjncy - integer(I4B), dimension(neqns), intent(inout) :: perm - integer(I4B), dimension(neqns), intent(inout) :: mask - integer(I4B), dimension(neqns+1), intent(inout) :: xls - - ! -- locals - integer(I4B) :: i - integer(I4B) :: ccsize - integer(I4B) :: lperm - integer(I4B) :: nlvl - integer(I4B) :: num - integer(I4B) :: root - integer(I4B), allocatable, dimension(:) :: xadj - ! - !*************************************************************** - ! - ! allocate local storage - allocate(xadj(neqns+1)) - ! - ! initialize mask and working xadj - do i = 1, neqns - mask(i) = 1 - xadj(i) = xadj0(i) - end do - xadj(neqns+1) = xadj0(neqns+1) - - num = 1 - louter: do i = 1, neqns - ! - !for each masked connected component - if (mask(i) == 0) cycle - root = i - ! - ! first find a pseudo-peripheral node root. - ! note that the level structure found by - ! ims_fnroot is stored starting at perm(num). - ! then ims_rcm is called to order the component - ! using root as the starting node. - ! - ! mi - lperm = neqns - num + 1 - ! mi - call ims_fnroot(lperm, neqns, nja, root, xadj, adjncy, mask, & - nlvl, xls, perm(num)) - call ims_rcm(lperm, neqns, nja, root, xadj, adjncy, mask, & - perm(num), ccsize, xls ) - num = num + ccsize - if (num > neqns) exit louter - end do louter - ! - ! allocate local storage - deallocate(xadj) - - return - end subroutine ims_genrcm - - ! subroutine ims_fnroot - ! - ! find pseudo-peripheral node - ! - ! purpose - ims_fnroot implements a modified version of the - ! scheme by gibbs, poole, and stockmeyer to find pseudo- - ! peripheral nodes. it determines such a node for the - ! section subgraph specified by mask and root. - ! - ! input parameters - - ! (xadj, adjncy) - adjacency structure pair for the graph. - ! mask - specifies a section subgraph. nodes for which - ! mask is zero are ignored by ims_fnroot. - ! - ! updated parameter - - ! root - on input, it (along with mask) defines the - ! component for which a pseudo-peripheral node is - ! to be found. on output, it is the node obtained. - ! - ! output parameters - - ! nlvl - is the number of levels in the level structure - ! rooted at the node root. - ! (xls,ls) - the level structure array pair containing - ! the level structure found. - ! - ! program subroutines - - ! ims_rootls. - ! - !*************************************************************** - ! - subroutine ims_fnroot (lls, neqns, nja, root, xadj, adjncy, mask, & - nlvl, xls, ls ) - implicit none - - ! -- dummy variables - integer(I4B), intent(in) :: lls - integer(I4B), intent(in) :: neqns - integer(I4B), intent(in) :: nja - integer(I4B), intent(inout) :: root - integer(I4B), dimension(neqns+1), intent(in) :: xadj - integer(I4B), dimension(nja), intent(in) :: adjncy - integer(I4B), dimension(neqns), intent(inout) :: mask - integer(I4B), intent(inout) :: nlvl - integer(I4B), dimension(neqns+1), intent(inout) :: xls - integer(I4B), dimension(lls), intent(inout) :: ls - - ! -- local - integer(I4B) :: ccsize - integer(I4B) :: j - integer(I4B) :: k - integer(I4B) :: jstrt - integer(I4B) :: kstrt - integer(I4B) :: kstop - integer(I4B) :: mindeg - integer(I4B) :: nabor - integer(I4B) :: ndeg - integer(I4B) :: node - integer(I4B) :: nunlvl - ! - ! determine the level structure rooted at root. - call ims_rootls(lls, neqns, nja, root, xadj, adjncy, mask, & - nlvl, xls, ls) - ccsize = xls(nlvl+1) - 1 - if ( nlvl == 1 .or. nlvl == ccsize ) return - ! - ! pick a node with minimum degree from the last level. - 100 jstrt = xls(nlvl) - mindeg = ccsize - root = ls(jstrt) - if ( ccsize == jstrt ) go to 400 - louter: do j = jstrt, ccsize - node = ls(j) - ndeg = 0 - kstrt = xadj(node) - kstop = xadj(node+1) - 1 - linner: do k = kstrt, kstop - nabor = adjncy(k) - if (mask(nabor) > 0) ndeg = ndeg + 1 - end do linner - if (ndeg >= mindeg) cycle louter - root = node - mindeg = ndeg - end do louter - ! - ! and generate its rooted level structure. - 400 call ims_rootls(lls, neqns, nja, root, xadj, adjncy, mask, & - nunlvl, xls, ls) - if (nunlvl <= nlvl) return - nlvl = nunlvl - if (nlvl < ccsize) go to 100 - return - end subroutine ims_fnroot - - - ! subroutine ims_rcm - ! - ! reverse cuthill-mckee ordering - ! - ! purpose - rcm numbers a connected component specified by - ! mask and root, using the rcm algorithm. - ! the numbering is to be started at the node root. - ! - ! input parameters - - ! root - is the node that defines the connected - ! component and it is used as the starting - ! node for the rcm ordering. - ! (xadj, adjncy) - adjacency structure pair for - ! the graph. - ! - ! updated parameters - - ! mask - only those nodes with nonzero input mask - ! values are considered by the routine. the - ! nodes numbered by rcm will have their - ! mask values set to zero. - ! - ! output parameters - - ! perm - will contain the rcm ordering. - ! ccsize - is the size of the connected component - ! that has been numbered by rcm. - ! - ! working parameter - - ! deg - is a temporary vector used to hold the degree - ! of the nodes in the section graph specified - ! by mask and root. - ! - ! program subroutines - - ! ims_degree. - ! - !*************************************************************** - ! - subroutine ims_rcm(llperm, neqns, nja, root, xadj, adjncy, & - mask, perm, ccsize, deg) - ! - implicit none - - ! -- dummy variables - integer(I4B), intent(in) :: llperm - integer(I4B), intent(in) :: neqns - integer(I4B), intent(in) :: nja - integer(I4B), intent(in) :: root - integer(I4B), dimension(neqns+1), intent(inout) :: xadj - integer(I4B), dimension(nja), intent(in) :: adjncy - integer(I4B), dimension(neqns), intent(inout) :: mask - integer(I4B), dimension(llperm), intent(inout) :: perm - integer(I4B), intent(inout) :: ccsize - integer(I4B), dimension(neqns), intent(inout) :: deg - - ! -- local - integer(I4B) :: fnbr - integer(I4B) :: i - integer(I4B) :: j - integer(I4B) :: jstop - integer(I4B) :: jstrt - integer(I4B) :: k - integer(I4B) :: l - integer(I4B) :: lbegin - integer(I4B) :: lnbr - integer(I4B) :: lperm - integer(I4B) :: lvlend - integer(I4B) :: nbr - integer(I4B) :: node - ! code - ! find the degrees of the nodes in the - ! component specified by mask and root. - call ims_degree(llperm, neqns, nja, root, xadj, adjncy, mask, & - deg, ccsize, perm) - mask(root) = 0 - if (ccsize <= 1) return - lvlend = 0 - lnbr = 1 - ! - ! lbegin and lvlend point to the beginning and - ! the end of the current level respectively. -100 lbegin = lvlend + 1 - lvlend = lnbr - lbegend: do i = lbegin, lvlend - ! - ! for each node in current level ... - node = perm(i) - jstrt = xadj(node) - jstop = xadj(node+1) - 1 - ! - ! find the unnumbered neighbors of node. - ! fnbr and lnbr point to the first and last - ! unnumbered neighbors respectively of the current - ! node in perm. - fnbr = lnbr + 1 - lunn: do j = jstrt, jstop - nbr = adjncy(j) - if (mask(nbr) == 0) cycle lunn - lnbr = lnbr + 1 - mask(nbr) = 0 - perm(lnbr) = nbr - end do lunn - if (fnbr >= lnbr) cycle lbegend - ! - ! sort the neighbors of node in increasing - ! order by degree. linear insertion is used. - k = fnbr -300 l = k - k = k + 1 - nbr = perm(k) -400 if (l < fnbr) go to 500 - lperm = perm(l) - if (deg(lperm) <= deg(nbr)) go to 500 - perm(l+1) = lperm - l = l - 1 - go to 400 -500 perm(l+1) = nbr - if (k < lnbr) go to 300 - end do lbegend - if (lnbr > lvlend) go to 100 - ! - ! we now have the cuthill mckee ordering. - ! reverse it below ... - k = ccsize/2 - l = ccsize - do i = 1, k - lperm = perm(l) - perm(l) = perm(i) - perm(i) = lperm - l = l - 1 - end do - return - end subroutine ims_rcm - - - !----- subroutine ims_degree - ! degree in masked component ******** - ! - ! purpose - this routine computes the degrees of the nodes - ! in the connected component specified by mask and root. - ! nodes for which mask is zero are ignored. - ! - ! input parameter - - ! root - is the input node that defines the component. - ! (xadj, adjncy) - adjacency structure pair. - ! mask - specifies a section subgraph. - ! - ! output parameters - - ! deg - array containing the degrees of the nodes in - ! the component. - ! ccsize-size of the component specified by mask and root - ! - ! working parameter - - ! ls - a temporary vector used to store the nodes of the - ! component level by level. - ! - !*************************************************************** - ! - subroutine ims_degree(lls, neqns, nja, root, xadj, adjncy, mask, & - deg, ccsize, ls) - ! - !*************************************************************** - ! - implicit none - - ! -- dummy variables - integer(I4B), intent(in) :: lls - integer(I4B), intent(in) :: neqns - integer(I4B), intent(in) :: nja - integer(I4B), intent(in) :: root - integer(I4B), dimension(neqns+1), intent(inout) :: xadj - integer(I4B), dimension(nja), intent(in) :: adjncy - integer(I4B), dimension(neqns), intent(in) :: mask - integer(I4B), dimension(neqns), intent(inout) :: deg - integer(I4B), intent(inout) :: ccsize - integer(I4B), dimension(lls), intent(inout) :: ls - - ! -- local - integer(I4B) :: i - integer(I4B) :: ideg - integer(I4B) :: j - integer(I4B) :: jstop - integer(I4B) :: jstrt - integer(I4B) :: lbegin - integer(I4B) :: lvlend - integer(I4B) :: lvsize - integer(I4B) :: nbr - integer(I4B) :: node - - ! code - ! - ! initialization ... - ! the array xadj is used as a temporary marker to - ! indicate which nodes have been considered so far. - ls(1) = root - xadj(root) = -xadj(root) - lvlend = 0 - ccsize = 1 - ! - ! lbegin is the pointer to the beginning of the current - ! level, and lvlend points to the end of this level. -100 lbegin = lvlend + 1 - lvlend = ccsize - ! - ! find the degrees of nodes in the current level, - ! and at the same time, generate the next level. - louter: do i = lbegin, lvlend - node = ls(i) - jstrt = -xadj(node) - jstop = iabs(xadj(node + 1)) - 1 - ideg = 0 - if (jstop < jstrt) go to 300 - linner: do j = jstrt, jstop - nbr = adjncy(j) - if (mask(nbr) == 0) cycle linner - ideg = ideg + 1 - if (xadj(nbr) < 0) cycle linner - xadj(nbr) = -xadj(nbr) - ccsize = ccsize + 1 - ls(ccsize) = nbr - end do linner -300 deg(node) = ideg - end do louter - ! - ! compute the current level width. - ! if it is nonzero , generate another level. - lvsize = ccsize - lvlend - if (lvsize > 0) go to 100 - ! - ! reset xadj to its correct sign and return. - do i = 1, ccsize - node = ls(i) - xadj(node) = -xadj(node) - end do - return - end subroutine ims_degree - - - ! subroutine ims_rootls - ! - ! rooted level structure - ! - ! purpose - ims_rootls generates the level structure rooted - ! at the input node called root. only those nodes for - ! which mask is nonzero will be considered. - ! - ! input parameters - - ! root - the node at which the level structure is to - ! be rooted. - ! (xadj, adjncy) - adjacency structure pair for the - ! given graph. - ! mask - is used to specify a section subgraph. nodes - ! with mask(i)=0 are ignored. - ! - ! output parameters - - ! nlvl - is the number of levels in the level structure. - ! (xls, ls) - array pair for the rooted level structure. - ! - !*************************************************************** - ! - subroutine ims_rootls(lls, neqns, nja, root, xadj, adjncy, mask, & - nlvl, xls, ls ) - - implicit none - - ! -- dummy variables - integer(I4B), intent(in) :: lls - integer(I4B), intent(in) :: neqns - integer(I4B), intent(in) :: nja - integer(I4B), intent(in) :: root - integer(I4B), dimension(neqns+1), intent(in) :: xadj - integer(I4B), dimension(nja), intent(in) :: adjncy - integer(I4B), dimension(neqns), intent(inout) :: mask - integer(I4B), intent(inout) :: nlvl - integer(I4B), dimension(neqns+1), intent(inout) :: xls - integer(I4B), dimension(lls), intent(inout) :: ls - - ! -- local - integer(I4B) :: i - integer(I4B) :: j - integer(I4B) :: jstop - integer(I4B) :: jstrt - integer(I4B) :: lbegin - integer(I4B) :: ccsize - integer(I4B) :: lvlend - integer(I4B) :: lvsize - integer(I4B) :: nbr - integer(I4B) :: node - ! - ! code - ! - ! initialization ... - mask(root) = 0 - ls(1) = root - nlvl = 0 - lvlend = 0 - ccsize = 1 - ! - ! lbegin is the pointer to the beginning of the current - ! level, and lvlend points to the end of this level. -200 lbegin = lvlend + 1 - lvlend = ccsize - nlvl = nlvl + 1 - xls(nlvl) = lbegin - ! - ! generate the next level by finding all the masked - ! neighbors of nodes in the current level. - louter: do i = lbegin, lvlend - node = ls(i) - jstrt = xadj(node) - jstop = xadj(node + 1) - 1 - if (jstop < jstrt) cycle louter - linner: do j = jstrt, jstop - nbr = adjncy(j) - if (mask(nbr) == 0) cycle linner - ccsize = ccsize + 1 - ls(ccsize) = nbr - mask(nbr) = 0 - end do linner - end do louter - ! - ! compute the current level width. - ! if it is nonzero, generate the next level. - lvsize = ccsize - lvlend - if (lvsize > 0 ) go to 200 - ! - ! reset mask to one for the nodes in the level structure. - xls(nlvl+1) = lvlend + 1 - do i = 1, ccsize - node = ls(i) - mask(node) = 1 - end do - return - end subroutine ims_rootls - - - - subroutine ims_odrv(n, nja, nsp, ia, ja, p, ip, isp, flag) - ! - ! 3/12/82 - !*********************************************************************** - ! odrv -- driver for sparse matrix reordering routines - !*********************************************************************** - ! - ! description - ! - ! odrv finds a minimum degree ordering of the rows and columns - ! of a matrix m stored in (ia,ja,a) format (see below). for the - ! reordered matrix, the work and storage required to perform - ! gaussian elimination is (usually) significantly less. - ! - ! note.. odrv and its subordinate routines have been modified to - ! compute orderings for general matrices, not necessarily having any - ! symmetry. the minimum degree ordering is computed for the - ! structure of the symmetric matrix m + m-transpose. - ! modifications to the original odrv module have been made in - ! the coding in subroutine mdi, and in the initial comments in - ! subroutines odrv and md. - ! - ! if only the nonzero entries in the upper triangle of m are being - ! stored, then odrv symmetrically reorders (ia,ja,a), (optionally) - ! with the diagonal entries placed first in each row. this is to - ! ensure that if m(i,j) will be in the upper triangle of m with - ! respect to the new ordering, then m(i,j) is stored in row i (and - ! thus m(j,i) is not stored), whereas if m(i,j) will be in the - ! strict lower triangle of m, then m(j,i) is stored in row j (and - ! thus m(i,j) is not stored). - ! - ! - ! storage of sparse matrices - ! - ! the nonzero entries of the matrix m are stored row-by-row in the - ! array a. to identify the individual nonzero entries in each row, - ! we need to know in which column each entry lies. these column - ! indices are stored in the array ja. i.e., if a(k) = m(i,j), then - ! ja(k) = j. to identify the individual rows, we need to know where - ! each row starts. these row pointers are stored in the array ia. - ! i.e., if m(i,j) is the first nonzero entry (stored) in the i-th row - ! and a(k) = m(i,j), then ia(i) = k. moreover, ia(n+1) points to - ! the first location following the last element in the last row. - ! thus, the number of entries in the i-th row is ia(i+1) - ia(i), - ! the nonzero entries in the i-th row are stored consecutively in - ! - ! a(ia(i)), a(ia(i)+1), ..., a(ia(i+1)-1), - ! - ! and the corresponding column indices are stored consecutively in - ! - ! ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1). - ! - ! since the coefficient matrix is symmetric, only the nonzero entries - ! in the upper triangle need be stored. for example, the matrix - ! - ! ( 1 0 2 3 0 ) - ! ( 0 4 0 0 0 ) - ! m = ( 2 0 5 6 0 ) - ! ( 3 0 6 7 8 ) - ! ( 0 0 0 8 9 ) - ! - ! could be stored as - ! - ! - 1 2 3 4 5 6 7 8 9 10 11 12 13 - ! ---+-------------------------------------- - ! ia - 1 4 5 8 12 14 - ! ja - 1 3 4 2 1 3 4 1 3 4 5 4 5 - ! a - 1 2 3 4 2 5 6 3 6 7 8 8 9 - ! - ! or (symmetrically) as - ! - ! - 1 2 3 4 5 6 7 8 9 - ! ---+-------------------------- - ! ia - 1 4 5 7 9 10 - ! ja - 1 3 4 2 3 4 4 5 5 - ! a - 1 2 3 4 5 6 7 8 9 . - ! - ! - ! parameters - ! - ! n - order of the matrix - ! - ! nja - number of nonzeroes in the matrix - ! - ! nsp - declared dimension of the one-dimensional array isp. nsp - ! must be at least 3n+4k, where k is the number of nonzeroes - ! in the strict upper triangle of m - ! - ! ia - integer one-dimensional array containing pointers to delimit - ! rows in ja and a. dimension = n+1 - ! - ! ja - integer one-dimensional array containing the column indices - ! corresponding to the elements of a. dimension = number of - ! nonzero entries in (the upper triangle of) m - ! - ! a - real one-dimensional array containing the nonzero entries in - ! (the upper triangle of) m, stored by rows. dimension = - ! number of nonzero entries in (the upper triangle of) m - ! - ! p - integer one-dimensional array used to return the permutation - ! of the rows and columns of m corresponding to the minimum - ! degree ordering. dimension = n - ! - ! ip - integer one-dimensional array used to return the inverse of - ! the permutation returned in p. dimension = n - ! - ! isp - integer one-dimensional array used for working storage. - ! dimension = nsp - ! - ! path - integer path specification. values and their meanings are - - ! 1 find minimum degree ordering only - ! 2 find minimum degree ordering and reorder symmetrically - ! stored matrix (used when only the nonzero entries in - ! the upper triangle of m are being stored) - ! 3 reorder symmetrically stored matrix as specified by - ! input permutation (used when an ordering has already - ! been determined and only the nonzero entries in the - ! upper triangle of m are being stored) - ! 4 same as 2 but put diagonal entries at start of each row - ! 5 same as 3 but put diagonal entries at start of each row - ! - ! flag - integer error flag. values and their meanings are - - ! 0 no errors detected - ! 9n+k insufficient storage in md - ! 10n+1 insufficient storage in odrv - ! 11n+1 illegal path specification - ! - ! - ! conversion from real to double precision - ! - ! change the real declarations in odrv and sro to double precision - ! declarations. - ! - !----------------------------------------------------------------------- - ! - implicit none - - ! -- dummy variables - integer(I4B), intent(in) :: n - integer(I4B), intent(in) :: nja - integer(I4B), intent(in) :: nsp - integer(I4B), dimension(n+1), intent(in) :: ia - integer(I4B), dimension(nja), intent(in) :: ja - integer(I4B), dimension(n), intent(inout) :: p - integer(I4B), dimension(n), intent(inout) :: ip - integer(I4B), dimension(nsp), intent(inout) :: isp - integer(I4B), intent(inout) :: flag - - ! -- local - integer(I4B) :: v - integer(I4B) :: l - integer(I4B) :: head - integer(I4B) :: mmax - integer(I4B) :: next - integer(I4B) :: path - ! - ! set path for finding ordering only - ! - path = 1 - ! - ! - ! initialize error flag and validate path specification - flag = 0 - if (path < 1 .or. 5 < path) go to 111 - ! - ! find minimum degree ordering - mmax = (nsp-n)/2 - v = 1 - l = v + mmax - head = l + mmax - next = head + n - if (mmax < n) go to 110 - ! - call ims_md(n, nja, ia, ja, mmax, isp(v), isp(l), isp(head), p, & - ip, isp(v), flag) - if (flag.ne.0) go to 100 - ! - return - ! - ! ** error -- error detected in md - ! flag = 9 * n + vi from routine mdi. - ! -100 return - ! ** error -- insufficient storage -110 flag = 10*n + 1 - return - ! ** error -- illegal path specified -111 flag = 11*n + 1 - return - end subroutine ims_odrv - - - - subroutine ims_md(n, nja, ia, ja, mmax, v, l, head, last, next, & - mark, flag) - ! - !***************************************************************** - ! ims_md -- minimum degree algorithm (based on element model) - !***************************************************************** - ! - ! description - ! - ! ims_md finds a minimum degree ordering of the rows and - ! columns of a general sparse matrix m stored in (ia,ja,a) - ! format. when the structure of m is nonsymmetric, the ordering - ! is that obtained for the symmetric matrix m + m-transpose. - ! - ! - ! additional parameters - ! - ! mmax - declared dimension of the one-dimensional arrays v and l. - ! mmax must be at least n+2k, where k is the number of - ! nonzeroes in the strict upper triangle of m - ! - ! v - integer one-dimensional work array. dimension = mmax - ! - ! l - integer one-dimensional work array. dimension = mmax - ! - ! head - integer one-dimensional work array. dimension = n - ! - ! last - integer one-dimensional array used to return the permutation - ! of the rows and columns of m corresponding to the minimum - ! degree ordering. dimension = n - ! - ! next - integer one-dimensional array used to return the inverse of - ! the permutation returned in last. dimension = n - ! - ! mark - integer one-dimensional work array (may be the same as v). - ! dimension = n - ! - ! flag - integer error flag. values and their meanings are - - ! 0 no errors detected - ! 11n+1 insufficient storage in md - ! - ! - ! definitions of internal parameters - ! - ! ---------+--------------------------------------------------------- - ! v(s) - value field of list entry - ! ---------+--------------------------------------------------------- - ! l(s) - link field of list entry (0 =) end of list) - ! ---------+--------------------------------------------------------- - ! l(vi) - pointer to element list of uneliminated vertex vi - ! ---------+--------------------------------------------------------- - ! l(ej) - pointer to boundary list of active element ej - ! ---------+--------------------------------------------------------- - ! head(d) - vj =) vj head of d-list d - ! - 0 =) no vertex in d-list d - ! - ! - ! - vi uneliminated vertex - ! - vi in ek - vi not in ek - ! ---------+-----------------------------+--------------------------- - ! next(vi) - undefined but nonnegative - vj =) vj next in d-list - ! - - 0 =) vi tail of d-list - ! ---------+-----------------------------+--------------------------- - ! last(vi) - (not set until mdp) - -d =) vi head of d-list d - ! --vk =) compute degree - vj =) vj last in d-list - ! - ej =) vi prototype of ej - 0 =) vi not in any d-list - ! - 0 =) do not compute degree - - ! ---------+-----------------------------+--------------------------- - ! mark(vi) - mark(vk) - nonneg. tag .lt. mark(vk) - ! - ! - ! - vi eliminated vertex - ! - ei active element - otherwise - ! ---------+-----------------------------+--------------------------- - ! next(vi) - -j =) vi was j-th vertex - -j =) vi was j-th vertex - ! - to be eliminated - to be eliminated - ! ---------+-----------------------------+--------------------------- - ! last(vi) - m =) size of ei = m - undefined - ! ---------+-----------------------------+--------------------------- - ! mark(vi) - -m =) overlap count of ei - undefined - ! - with ek = m - - ! - otherwise nonnegative tag - - ! - .lt. mark(vk) - - ! - !----------------------------------------------------------------------- - ! - implicit none - - ! -- dummy variables - integer(I4B), intent(in) :: n - integer(I4B), intent(in) :: nja - integer(I4B), dimension(n+1), intent(in) :: ia - integer(I4B), dimension(nja), intent(in) :: ja - integer(I4B), intent(in) :: mmax - integer(I4B), dimension(mmax), intent(inout) :: v - integer(I4B), dimension(mmax), intent(inout) :: l - integer(I4B), dimension(n), intent(inout) :: head - integer(I4B), dimension(n), intent(inout) :: last - integer(I4B), dimension(n), intent(inout) :: next - integer(I4B), dimension(n), intent(inout) :: mark - integer(I4B), intent(inout) :: flag - - ! -- local - integer(I4B) :: tag - integer(I4B) :: dmin - integer(I4B) :: vk - integer(I4B) :: ek - integer(I4B) :: tail - integer(I4B) :: k - - equivalence(vk, ek) - ! - ! initialization - tag = 0 - call ims_mdi(n, nja, ia, ja, mmax ,v, l, head, last, next, & - mark, tag, flag) - if (flag.ne.0) return - ! - k = 0 - dmin = 1 - ! - ! while k .lt. n do -1 if (k >= n) go to 4 - ! - ! search for vertex of minimum degree -2 if (head(dmin) > 0) go to 3 - dmin = dmin + 1 - go to 2 - ! - ! remove vertex vk of minimum degree from degree list -3 vk = head(dmin) - head(dmin) = next(vk) - if (head(dmin) > 0) last(head(dmin)) = -dmin - ! - ! number vertex vk, adjust tag, and tag vk - k = k+1 - next(vk) = -k - last(ek) = dmin - 1 - tag = tag + last(ek) - mark(vk) = tag - ! - ! form element ek from uneliminated neighbors of vk - call ims_mdm(n, mmax, vk, tail, v, l, last, next, mark) - ! - ! purge inactive elements and do mass elimination - call ims_mdp(n, mmax, k, ek, tail, v, l, head, last, next, mark) - ! - ! update degrees of uneliminated vertices in ek - call ims_mdu(n, mmax, ek, dmin, v, l, head, last, next, mark) - ! - go to 1 - ! - ! generate inverse permutation from permutation -4 do k = 1, n - next(k) = -next(k) - last(next(k)) = k - end do - ! - return - end subroutine ims_md - - - subroutine ims_mdi(n, nja, ia, ja, mmax, v, l, head, last, next, & - mark, tag, flag) - ! - !*********************************************************************** - ! ims_mdi -- initialization - !*********************************************************************** - implicit none - - ! -- dummy variables - integer(I4B), intent(in) :: n - integer(I4B), intent(in) :: nja - integer(I4B), dimension(n+1), intent(in) :: ia - integer(I4B), dimension(nja), intent(in) :: ja - integer(I4B), intent(in) :: mmax - integer(I4B), dimension(mmax), intent(inout) :: v - integer(I4B), dimension(mmax), intent(inout) :: l - integer(I4B), dimension(n), intent(inout) :: head - integer(I4B), dimension(n), intent(inout) :: last - integer(I4B), dimension(n), intent(inout) :: next - integer(I4B), dimension(n), intent(inout) :: mark - integer(I4B), intent(in) :: tag - integer(I4B), intent(inout) :: flag - - ! -- local - integer(I4B) :: sfs - integer(I4B) :: vi - integer(I4B) :: dvi - integer(I4B) :: vj - integer(I4B) :: jmin - integer(I4B) :: jmax - integer(I4B) :: j - integer(I4B) :: lvk - integer(I4B) :: kmax - integer(I4B) :: k - integer(I4B) :: nextvi - integer(I4B) :: ieval - ! - ! initialize degrees, element lists, and degree lists - do vi = 1, n - mark(vi) = 1 - l(vi) = 0 - head(vi) = 0 - end do - sfs = n + 1 - ! - ! create nonzero structure - ! for each nonzero entry a(vi,vj) - louter: do vi = 1, n - jmin = ia(vi) - jmax = ia(vi+1) - 1 - if (jmin > jmax) cycle louter - linner1: do j = jmin, jmax !5 - vj = ja(j) - !if (vj-vi) 2, 5, 4 - ieval = vj - vi - if (ieval == 0) cycle linner1 !5 - if (ieval > 0) go to 4 - ! - ! if a(vi,vj) is in strict lower triangle - ! check for previous occurrence of a(vj,vi) - lvk = vi - kmax = mark(vi) - 1 - if (kmax == 0) go to 4 - linner2: do k = 1, kmax - lvk = l(lvk) - if (v(lvk) == vj) cycle linner1 !5 - end do linner2 - ! for unentered entries a(vi,vj) -4 if (sfs >= mmax) go to 101 - ! - ! enter vj in element list for vi - mark(vi) = mark(vi) + 1 - v(sfs) = vj - l(sfs) = l(vi) - l(vi) = sfs - sfs = sfs+1 - ! - ! enter vi in element list for vj - mark(vj) = mark(vj) + 1 - v(sfs) = vi - l(sfs) = l(vj) - l(vj) = sfs - sfs = sfs + 1 - end do linner1 - end do louter - ! - ! create degree lists and initialize mark vector - do vi = 1, n - dvi = mark(vi) - next(vi) = head(dvi) - head(dvi) = vi - last(vi) = -dvi - nextvi = next(vi) - if (nextvi > 0) last(nextvi) = vi - mark(vi) = tag - end do - ! - return - ! - ! ** error- insufficient storage -101 flag = 9*n + vi - return - end subroutine ims_mdi - - - - subroutine ims_mdm(n, mmax, vk, tail, v, l, last, next, mark) - ! - !*********************************************************************** - ! ims_mdm -- form element from uneliminated neighbors of vk - !*********************************************************************** - implicit none - - ! -- dummy variables - integer(I4B), intent(in) :: n - integer(I4B), intent(in) :: mmax - integer(I4B), intent(in) :: vk - integer(I4B), intent(inout) :: tail - integer(I4B), dimension(mmax), intent(inout) :: v - integer(I4B), dimension(mmax), intent(inout) :: l - integer(I4B), dimension(n), intent(inout) :: last - integer(I4B), dimension(n), intent(inout) :: next - integer(I4B), dimension(n), intent(inout) :: mark - - ! -- local - integer(I4B) :: tag - integer(I4B) :: s - integer(I4B) :: ls - integer(I4B) :: vs - integer(I4B) :: es - integer(I4B) :: b - integer(I4B) :: lb - integer(I4B) :: vb - integer(I4B) :: blp - integer(I4B) :: blpmax - - equivalence (vs, es) - ! - ! initialize tag and list of uneliminated neighbors - tag = mark(vk) - tail = vk - ! - ! for each vertex/element vs/es in element list of vk - ls = l(vk) -1 s = ls - if (s == 0) go to 5 - ls = l(s) - vs = v(s) - if (next(vs) < 0) go to 2 - ! - ! if vs is uneliminated vertex, then tag and append to list of - ! uneliminated neighbors - mark(vs) = tag - l(tail) = s - tail = s - go to 4 - ! - ! if es is active element, then ... - ! for each vertex vb in boundary list of element es -2 lb = l(es) - blpmax = last(es) - louter: do blp = 1, blpmax !3 - b = lb - lb = l(b) - vb = v(b) - ! - ! if vb is untagged vertex, then tag and append to list of - ! uneliminated neighbors - if (mark(vb) >= tag) cycle louter !3 - mark(vb) = tag - l(tail) = b - tail = b - end do louter - ! - ! mark es inactive - mark(es) = tag - ! -4 go to 1 - ! - ! terminate list of uneliminated neighbors -5 l(tail) = 0 - ! - return - end subroutine ims_mdm - - - subroutine ims_mdp(n, mmax, k, ek, tail, v, l, head, last, next, mark) - ! - !*********************************************************************** - ! ims_mdp -- purge inactive elements and do mass elimination - !*********************************************************************** - implicit none - - ! -- dummy variables - integer(I4B), intent(in) :: n - integer(I4B), intent(in) :: mmax - integer(I4B), intent(inout) :: k - integer(I4B), intent(in) :: ek - integer(I4B), intent(inout) :: tail - integer(I4B), dimension(mmax), intent(inout) :: v - integer(I4B), dimension(mmax), intent(inout) :: l - integer(I4B), dimension(n), intent(inout) :: head - integer(I4B), dimension(n), intent(inout) :: last - integer(I4B), dimension(n), intent(inout) :: next - integer(I4B), dimension(n), intent(inout) :: mark - - ! -- local - integer(I4B) :: tag - integer(I4B) :: free - integer(I4B) :: li - integer(I4B) :: vi - integer(I4B) :: lvi - integer(I4B) :: evi - integer(I4B) :: s - integer(I4B) :: ls - integer(I4B) :: es - integer(I4B) :: ilp - integer(I4B) :: ilpmax - integer(I4B) :: i - ! - ! initialize tag - tag = mark(ek) - ! - ! for each vertex vi in ek - li = ek - ilpmax = last(ek) - if (ilpmax <= 0) go to 12 - louter: do ilp = 1, ilpmax !11 - i = li - li = l(i) - vi = v(li) - ! - ! remove vi from degree list - if (last(vi) == 0) go to 3 - if (last(vi) > 0) go to 1 - head(-last(vi)) = next(vi) - go to 2 -1 next(last(vi)) = next(vi) -2 if (next(vi) > 0) last(next(vi)) = last(vi) - ! - ! remove inactive items from element list of vi -3 ls = vi -4 s = ls - ls = l(s) - if (ls == 0) go to 6 - es = v(ls) - if (mark(es) < tag) go to 5 - free = ls - l(s) = l(ls) - ls = s -5 go to 4 - ! - ! if vi is interior vertex, then remove from list and eliminate - -6 lvi = l(vi) - if (lvi.ne.0) go to 7 - l(i) = l(li) - li = i - ! - k = k + 1 - next(vi) = -k - last(ek) = last(ek) - 1 - cycle louter !11 - ! - ! else ... - ! classify vertex vi -7 if (l(lvi).ne.0) go to 9 - evi = v(lvi) - if (next(evi) >= 0) go to 9 - if (mark(evi) < 0) go to 8 - ! - ! if vi is prototype vertex, then mark as such, initialize - ! overlap count for corresponding element, and move vi to end - ! of boundary list - last(vi) = evi - mark(evi) = -1 - l(tail) = li - tail = li - l(i) = l(li) - li = i - go to 10 - ! - ! else if vi is duplicate vertex, then mark as such and adjust - ! overlap count for corresponding element -8 last(vi) = 0 - mark(evi) = mark(evi) - 1 - go to 10 - ! - ! else mark vi to compute degree -9 last(vi) = -ek - ! - ! insert ek in element list of vi -10 v(free) = ek - l(free) = l(vi) - l(vi) = free - end do louter !11 - ! - ! terminate boundary list -12 l(tail) = 0 - ! - return - end subroutine ims_mdp - - - - subroutine ims_mdu(n, mmax, ek, dmin, v, l, head, last, next, mark) - ! - !*********************************************************************** - ! ims_mdu -- update degrees of uneliminated vertices in ek - !*********************************************************************** - implicit none - - ! -- dummy variables - integer(I4B), intent(in) :: n - integer(I4B), intent(in) :: mmax - integer(I4B), intent(in) :: ek - integer(I4B), intent(inout) :: dmin - integer(I4B), dimension(mmax), intent(inout) :: v - integer(I4B), dimension(mmax), intent(inout) :: l - integer(I4B), dimension(n), intent(inout) :: head - integer(I4B), dimension(n), intent(inout) :: last - integer(I4B), dimension(n), intent(inout) :: next - integer(I4B), dimension(n), intent(inout) :: mark - - ! -- local - integer(I4B) :: tag - integer(I4B) :: vi - integer(I4B) :: evi - integer(I4B) :: dvi - integer(I4B) :: s - integer(I4B) :: vs - integer(I4B) :: es - integer(I4B) :: b - integer(I4B) :: vb - integer(I4B) :: ilp - integer(I4B) :: ilpmax - integer(I4B) :: blp - integer(I4B) :: blpmax - integer(I4B) :: i - - equivalence (vs, es) - ! - ! initialize tag - tag = mark(ek) - last(ek) - ! - ! for each vertex vi in ek - i = ek - ilpmax = last(ek) - if (ilpmax <= 0) go to 11 - louter: do ilp = 1, ilpmax !10 - i = l(i) - vi = v(i) - !if (last(vi)) 1, 10, 8 - if (last(vi) == 0) cycle louter !10 - if (last(vi) > 0) goto 8 - ! - ! if vi neither prototype nor duplicate vertex, then merge elements - ! to compute degree - tag = tag + 1 - dvi = last(ek) - ! - ! for each vertex/element vs/es in element list of vi - s = l(vi) -2 s = l(s) - if (s == 0) go to 9 - vs = v(s) - if (next(vs) < 0) go to 3 - ! - ! if vs is uneliminated vertex, then tag and adjust degree - mark(vs) = tag - dvi = dvi + 1 - go to 5 - ! - ! if es is active element, then expand - ! check for outmatched vertex -3 if (mark(es) < 0) go to 6 - ! - ! for each vertex vb in es - b = es - blpmax = last(es) - linner: do blp = 1, blpmax !4 - b = l(b) - vb = v(b) - ! - ! if vb is untagged, then tag and adjust degree - if (mark(vb) >= tag) cycle linner !4 - mark(vb) = tag - dvi = dvi + 1 - end do linner !4 - ! -5 go to 2 - ! - ! else if vi is outmatched vertex, then adjust overlaps but do not - ! compute degree -6 last(vi) = 0 - mark(es) = mark(es) - 1 -7 s = l(s) - if (s == 0) cycle louter !10 - es = v(s) - if (mark(es) < 0) mark(es) = mark(es) - 1 - go to 7 - ! - ! else if vi is prototype vertex, then calculate degree by - ! inclusion/exclusion and reset overlap count -8 evi = last(vi) - dvi = last(ek) + last(evi) + mark(evi) - mark(evi) = 0 - ! - ! insert vi in appropriate degree list -9 next(vi) = head(dvi) - head(dvi) = vi - last(vi) = -dvi - if (next(vi) > 0) last(next(vi)) = vi - if (dvi < dmin) dmin = dvi - ! - end do louter !10 - ! -11 return - end subroutine ims_mdu - - ! - ! ROUTINES FROM SPARSKIT TO PERMUTATE A LINEAR SYSTEM OF EQUATIONS - ! IN ORDER TO REORDER THE MATRIX TO MINIMIZE THE BANDWIDTH USING - ! THE REVERSE CUTHILL MCKEE OR MINIMUM DEGREE ORDERING ALGORITHMS - ! - subroutine ims_dperm(nrow, nja, a, ja, ia, ao, jao, iao, & - perm, qperm, job) - implicit none - - ! -- dummy variables - integer(I4B), intent(in) :: nrow - integer(I4B), intent(in) :: nja - real(DP), dimension(nja), intent(in) :: a - integer(I4B), dimension(nja), intent(in) :: ja - integer(I4B), dimension(nrow+1), intent(in) :: ia - real(DP), dimension(nja), intent(inout) :: ao - integer(I4B), dimension(nja), intent(inout) :: jao - integer(I4B), dimension(nrow+1), intent(inout) :: iao - integer(I4B), dimension(nrow), intent(inout) :: perm - integer(I4B), dimension(nrow), intent(inout) :: qperm - integer(I4B), intent(in) :: job - !----------------------------------------------------------------------- - ! This routine permutes the rows and columns of a matrix stored in CSR - ! format. i.e., it computes P A Q, where P, Q are permutation matrices. - ! P maps row i into row perm(i) and Q maps column j into column qperm(j) - ! a(i,j) becomes a(perm(i),qperm(j)) in new matrix - ! In the particular case where Q is the transpose of P (symmetric - ! permutation of A) then qperm is not needed. - ! note that qperm should be of length ncol (number of columns) but this - ! is not checked. - !----------------------------------------------------------------------- - ! Y. Saad, Sep. 21 1989 / recoded Jan. 28 1991. - !----------------------------------------------------------------------- - ! on entry: - !---------- - ! n = dimension of the matrix - ! a, ja, - ! ia = input matrix in a, ja, ia format - ! perm = integer array of length n containing the permutation arra - ! for the rows: perm(i) is the destination of row i in the - ! permuted matrix -- also the destination of column i in case - ! permutation is symmetric (job .le. 2) - ! - ! qperm = same thing for the columns. This should be provided only - ! if job=3 or job=4, i.e., only in the case of a nonsymmetric - ! permutation of rows and columns. Otherwise qperm is a dummy - ! - ! job = integer indicating the work to be done: - ! * job = 1,2 permutation is symmetric Ao :== P * A * transp(P) - ! job = 1 permute a, ja, ia into ao, jao, iao - ! job = 2 permute matrix ignoring real values. - ! * job = 3,4 permutation is non-symmetric Ao :== P * A * Q - ! job = 3 permute a, ja, ia into ao, jao, iao - ! job = 4 permute matrix ignoring real values. - ! - ! on return: - !----------- - ! ao, jao, iao = input matrix in a, ja, ia format - ! - ! in case job .eq. 2 or job .eq. 4, a and ao are never referred to - ! and can be dummy arguments. - ! Notes: - !------- - ! 1) algorithm is in place - ! 2) column indices may not be sorted on return eventhough they may be - ! on entry. - !---------------------------------------------------------------------- - ! -- local - integer(I4B) :: locjob, mod - ! - ! locjob indicates whether or not real values must be copied. - ! - locjob = mod(job,2) - ! - ! permute rows first - ! - call ims_rperm(nrow, nja, a, ja, ia, ao, jao, iao, perm, locjob) - ! - ! then permute columns - ! - locjob = 0 - ! - if (job .le. 2) then - call ims_cperm(nrow, nja, ao, jao, iao, ao, jao, iao, perm, locjob) - else - call ims_cperm(nrow, nja, ao, jao, iao, ao, jao, iao, qperm, locjob) - endif - ! - return - !-------end-of-ims_dperm---------------------------------------------------- - end subroutine ims_dperm - - - !----------------------------------------------------------------------- - subroutine ims_rperm (nrow, nja, a, ja, ia, ao, jao, iao, perm, job) - implicit none - - ! -- dummy variables - integer(I4B), intent(in) :: nrow - integer(I4B), intent(in) :: nja - real(DP), dimension(nja), intent(in) :: a - integer(I4B), dimension(nja), intent(in) :: ja - integer(I4B), dimension(nrow+1), intent(in) :: ia - real(DP), dimension(nja), intent(inout) :: ao - integer(I4B), dimension(nja), intent(inout) :: jao - integer(I4B), dimension(nrow+1), intent(inout) :: iao - integer(I4B), dimension(nrow), intent(inout) :: perm - integer(I4B), intent(in) :: job - !----------------------------------------------------------------------- - ! this subroutine permutes the rows of a matrix in CSR format. - ! ims_rperm computes B = P A where P is a permutation matrix. - ! the permutation P is defined through the array perm: for each j, - ! perm(j) represents the destination row number of row number j. - ! Youcef Saad -- recoded Jan 28, 1991. - !----------------------------------------------------------------------- - ! on entry: - !---------- - ! n = dimension of the matrix - ! a, ja, ia = input matrix in csr format - ! perm = integer array of length nrow containing the permutation a - ! for the rows: perm(i) is the destination of row i in the - ! permuted matrix. - ! ---> a(i,j) in the original matrix becomes a(perm(i),j) - ! in the output matrix. - ! - ! job = integer indicating the work to be done: - ! job = 1 permute a, ja, ia into ao, jao, iao - ! (including the copying of real values ao and - ! the array iao). - ! job .ne. 1 : ignore real values. - ! (in which case arrays a and ao are not needed nor - ! used). - ! - !------------ - ! on return: - !------------ - ! ao, jao, iao = input matrix in a, ja, ia format - ! note : - ! if (job.ne.1) then the arrays a and ao are not used. - !----------------------------------------------------------------------c - ! Y. Saad, May 2, 1990 c - !----------------------------------------------------------------------c - ! -- local - logical :: values - integer(I4B) :: i - integer(I4B) :: j - integer(I4B) :: k - integer(I4B) :: ii - integer(I4B) :: ko - - values = (job .eq. 1) - ! - ! determine pointers for output matrix. - ! - do j=1,nrow - i = perm(j) - iao(i+1) = ia(j+1) - ia(j) - end do - ! - ! get pointers from lengths - ! - iao(1) = 1 - do j=1,nrow - iao(j+1) = iao(j+1) + iao(j) - end do - ! - ! copying - ! - do ii=1,nrow - ! - ! old row = ii -- new row = iperm(ii) -- ko = new pointer - ! - ko = iao(perm(ii)) - do k = ia(ii), ia(ii+1)-1 - jao(ko) = ja(k) - if (values) ao(ko) = a(k) - ko = ko+1 - end do - end do - ! - return - !---------end-of-ims_rperm ------------------------------------------------- - !----------------------------------------------------------------------- - end subroutine ims_rperm - - - - !----------------------------------------------------------------------- - subroutine ims_cperm (nrow, nja, a, ja, ia, ao, jao, iao, perm, job) - implicit none - - ! -- dummy variables - integer(I4B), intent(in) :: nrow - integer(I4B), intent(in) :: nja - real(DP), dimension(nja), intent(in) :: a - integer(I4B), dimension(nja), intent(in) :: ja - integer(I4B), dimension(nrow+1), intent(in) :: ia - real(DP), dimension(nja), intent(inout) :: ao - integer(I4B), dimension(nja), intent(inout) :: jao - integer(I4B), dimension(nrow+1), intent(inout) :: iao - integer(I4B), dimension(nrow), intent(inout) :: perm - integer(I4B), intent(in) :: job - - !----------------------------------------------------------------------- - ! this subroutine permutes the columns of a matrix a, ja, ia. - ! the result is written in the output matrix ao, jao, iao. - ! cperm computes B = A P, where P is a permutation matrix - ! that maps column j into column perm(j), i.e., on return - ! a(i,j) becomes a(i,perm(j)) in new matrix - ! Y. Saad, May 2, 1990 / modified Jan. 28, 1991. - !----------------------------------------------------------------------- - ! on entry: - !---------- - ! nrow = row dimension of the matrix - ! - ! a, ja, ia = input matrix in csr format. - ! - ! perm = integer array of length ncol (number of columns of A - ! containing the permutation array the columns: - ! a(i,j) in the original matrix becomes a(i,perm(j)) - ! in the output matrix. - ! - ! job = integer indicating the work to be done: - ! job = 1 permute a, ja, ia into ao, jao, iao - ! (including the copying of real values ao and - ! the array iao). - ! job .ne. 1 : ignore real values ao and ignore iao. - ! - !------------ - ! on return: - !------------ - ! ao, jao, iao = input matrix in a, ja, ia format (array ao not needed) - ! - ! Notes: - !------- - ! 1. if job=1 then ao, iao are not used. - ! 2. This routine is in place: ja, jao can be the same. - ! 3. If the matrix is initially sorted (by increasing column number) - ! then ao,jao,iao may not be on return. - ! - !----------------------------------------------------------------------c - ! -- local - integer(I4B) :: k, i - ! - do k=1, nja - jao(k) = perm(ja(k)) - end do - ! - ! done with ja array. return if no need to touch values. - ! - if (job .ne. 1) return - ! - ! else get new pointers -- and copy values too. - ! - do i=1, nrow+1 - iao(i) = ia(i) - end do - ! - do k=1, nja - ao(k) = a(k) - end do - ! - return - !---------end-of-ims_cperm-------------------------------------------------- - !----------------------------------------------------------------------- - end subroutine ims_cperm - - - !----------------------------------------------------------------------- - subroutine ims_vperm (n, x, perm) - implicit none - - ! -- dummy variables - integer(I4B), intent(in) :: n - integer(I4B), dimension(n), intent(inout) :: perm - real(DP), dimension(n), intent(inout) :: x - !----------------------------------------------------------------------- - ! this subroutine performs an in-place permutation of a real vector x - ! according to the permutation array perm(*), i.e., on return, - ! the vector x satisfies, - ! - ! x(perm(j)) :== x(j), j=1,2,.., n - ! - !----------------------------------------------------------------------- - ! on entry: - !--------- - ! n = length of vector x. - ! perm = integer array of length n containing the permutation array. - ! x = input vector - ! - ! on return: - !---------- - ! x = vector x permuted according to x(perm(*)) := x(*) - ! - !----------------------------------------------------------------------c - ! Y. Saad, Sep. 21 1989 c - !----------------------------------------------------------------------c - ! -- local - integer(I4B) :: j - integer(I4B) :: k - integer(I4B) :: ii - integer(I4B) :: init - integer(I4B) :: next - real(DP) :: tmp, tmp1 - ! - init = 1 - tmp = x(init) - ii = perm(init) - perm(init)= -perm(init) - k = 0 - ! - ! loop - ! -6 k = k + 1 - ! - ! save the chased element -- - ! - tmp1 = x(ii) - x(ii) = tmp - next = perm(ii) - if (next < 0 ) goto 65 - ! - ! test for end - ! - if (k > n) go to 101 - tmp = tmp1 - perm(ii) = -perm(ii) - ii = next - ! - ! end loop - ! - go to 6 - ! - ! reinitialize cycle -- - ! -65 init = init + 1 - if (init > n) go to 101 - if (perm(init) < 0) go to 65 - tmp = x(init) - ii = perm(init) - perm(init)= -perm(init) - go to 6 - ! -101 continue - do j = 1, n - perm(j) = -perm(j) - end do - ! - return - !-------------------end-of-ims_vperm--------------------------------------- - !----------------------------------------------------------------------- - end subroutine ims_vperm - + MODULE IMSReorderingModule + use KindModule, only: DP, I4B + private + public :: ims_genrcm, ims_odrv, ims_dperm, ims_vperm + contains + + !----- subroutine ims_genrcm + ! + ! purpose - ims_genrcm finds the reverse cuthill-mckee + ! ordering for a general graph. for each connected + ! component in the graph, ims_genrcm obtains the ordering + ! by calling the subroutine ims_rcm. + ! + ! input parameters - + ! neqns - number of equations + ! (xadj0, adjncy) - array pair containing the adjacency + ! structure of the graph of the matrix. + ! + ! output parameter - + ! perm - vector that contains the rcm ordering. + ! + ! working parameters - + ! xadj - working ia of the matrix + ! mask - is used to mark variables that have been + ! numbered during the ordering process. it is + ! initialized to 1, and set to zero as each node + ! is numbered. + ! xls - the index vector for a level structure. the + ! level structure is stored in the currently + ! unused spaces in the permutation vector perm. + ! + ! program subroutines - + ! ims_fnroot, ims_rcm. + ! + !*************************************************************** + ! + subroutine ims_genrcm(neqns, nja, xadj0, adjncy, perm, mask, xls) + ! + !*************************************************************** + ! + implicit none + + ! -- dummy variables + integer(I4B), intent(in) :: neqns, nja + integer(I4B), dimension(neqns+1), intent(in) :: xadj0 + integer(I4B), dimension(nja), intent(in) :: adjncy + integer(I4B), dimension(neqns), intent(inout) :: perm + integer(I4B), dimension(neqns), intent(inout) :: mask + integer(I4B), dimension(neqns+1), intent(inout) :: xls + + ! -- locals + integer(I4B) :: i + integer(I4B) :: ccsize + integer(I4B) :: lperm + integer(I4B) :: nlvl + integer(I4B) :: num + integer(I4B) :: root + integer(I4B), allocatable, dimension(:) :: xadj + ! + !*************************************************************** + ! + ! allocate local storage + allocate(xadj(neqns+1)) + ! + ! initialize mask and working xadj + do i = 1, neqns + mask(i) = 1 + xadj(i) = xadj0(i) + end do + xadj(neqns+1) = xadj0(neqns+1) + + num = 1 + louter: do i = 1, neqns + ! + !for each masked connected component + if (mask(i) == 0) cycle + root = i + ! + ! first find a pseudo-peripheral node root. + ! note that the level structure found by + ! ims_fnroot is stored starting at perm(num). + ! then ims_rcm is called to order the component + ! using root as the starting node. + ! + ! mi + lperm = neqns - num + 1 + ! mi + call ims_fnroot(lperm, neqns, nja, root, xadj, adjncy, mask, & + nlvl, xls, perm(num)) + call ims_rcm(lperm, neqns, nja, root, xadj, adjncy, mask, & + perm(num), ccsize, xls ) + num = num + ccsize + if (num > neqns) exit louter + end do louter + ! + ! allocate local storage + deallocate(xadj) + + return + end subroutine ims_genrcm + + ! subroutine ims_fnroot + ! + ! find pseudo-peripheral node + ! + ! purpose - ims_fnroot implements a modified version of the + ! scheme by gibbs, poole, and stockmeyer to find pseudo- + ! peripheral nodes. it determines such a node for the + ! section subgraph specified by mask and root. + ! + ! input parameters - + ! (xadj, adjncy) - adjacency structure pair for the graph. + ! mask - specifies a section subgraph. nodes for which + ! mask is zero are ignored by ims_fnroot. + ! + ! updated parameter - + ! root - on input, it (along with mask) defines the + ! component for which a pseudo-peripheral node is + ! to be found. on output, it is the node obtained. + ! + ! output parameters - + ! nlvl - is the number of levels in the level structure + ! rooted at the node root. + ! (xls,ls) - the level structure array pair containing + ! the level structure found. + ! + ! program subroutines - + ! ims_rootls. + ! + !*************************************************************** + ! + subroutine ims_fnroot (lls, neqns, nja, root, xadj, adjncy, mask, & + nlvl, xls, ls ) + implicit none + + ! -- dummy variables + integer(I4B), intent(in) :: lls + integer(I4B), intent(in) :: neqns + integer(I4B), intent(in) :: nja + integer(I4B), intent(inout) :: root + integer(I4B), dimension(neqns+1), intent(in) :: xadj + integer(I4B), dimension(nja), intent(in) :: adjncy + integer(I4B), dimension(neqns), intent(inout) :: mask + integer(I4B), intent(inout) :: nlvl + integer(I4B), dimension(neqns+1), intent(inout) :: xls + integer(I4B), dimension(lls), intent(inout) :: ls + + ! -- local + integer(I4B) :: ccsize + integer(I4B) :: j + integer(I4B) :: k + integer(I4B) :: jstrt + integer(I4B) :: kstrt + integer(I4B) :: kstop + integer(I4B) :: mindeg + integer(I4B) :: nabor + integer(I4B) :: ndeg + integer(I4B) :: node + integer(I4B) :: nunlvl + ! + ! determine the level structure rooted at root. + call ims_rootls(lls, neqns, nja, root, xadj, adjncy, mask, & + nlvl, xls, ls) + ccsize = xls(nlvl+1) - 1 + if ( nlvl == 1 .or. nlvl == ccsize ) return + ! + ! pick a node with minimum degree from the last level. + 100 jstrt = xls(nlvl) + mindeg = ccsize + root = ls(jstrt) + if ( ccsize == jstrt ) go to 400 + louter: do j = jstrt, ccsize + node = ls(j) + ndeg = 0 + kstrt = xadj(node) + kstop = xadj(node+1) - 1 + linner: do k = kstrt, kstop + nabor = adjncy(k) + if (mask(nabor) > 0) ndeg = ndeg + 1 + end do linner + if (ndeg >= mindeg) cycle louter + root = node + mindeg = ndeg + end do louter + ! + ! and generate its rooted level structure. + 400 call ims_rootls(lls, neqns, nja, root, xadj, adjncy, mask, & + nunlvl, xls, ls) + if (nunlvl <= nlvl) return + nlvl = nunlvl + if (nlvl < ccsize) go to 100 + return + end subroutine ims_fnroot + + + ! subroutine ims_rcm + ! + ! reverse cuthill-mckee ordering + ! + ! purpose - rcm numbers a connected component specified by + ! mask and root, using the rcm algorithm. + ! the numbering is to be started at the node root. + ! + ! input parameters - + ! root - is the node that defines the connected + ! component and it is used as the starting + ! node for the rcm ordering. + ! (xadj, adjncy) - adjacency structure pair for + ! the graph. + ! + ! updated parameters - + ! mask - only those nodes with nonzero input mask + ! values are considered by the routine. the + ! nodes numbered by rcm will have their + ! mask values set to zero. + ! + ! output parameters - + ! perm - will contain the rcm ordering. + ! ccsize - is the size of the connected component + ! that has been numbered by rcm. + ! + ! working parameter - + ! deg - is a temporary vector used to hold the degree + ! of the nodes in the section graph specified + ! by mask and root. + ! + ! program subroutines - + ! ims_degree. + ! + !*************************************************************** + ! + subroutine ims_rcm(llperm, neqns, nja, root, xadj, adjncy, & + mask, perm, ccsize, deg) + ! + implicit none + + ! -- dummy variables + integer(I4B), intent(in) :: llperm + integer(I4B), intent(in) :: neqns + integer(I4B), intent(in) :: nja + integer(I4B), intent(in) :: root + integer(I4B), dimension(neqns+1), intent(inout) :: xadj + integer(I4B), dimension(nja), intent(in) :: adjncy + integer(I4B), dimension(neqns), intent(inout) :: mask + integer(I4B), dimension(llperm), intent(inout) :: perm + integer(I4B), intent(inout) :: ccsize + integer(I4B), dimension(neqns), intent(inout) :: deg + + ! -- local + integer(I4B) :: fnbr + integer(I4B) :: i + integer(I4B) :: j + integer(I4B) :: jstop + integer(I4B) :: jstrt + integer(I4B) :: k + integer(I4B) :: l + integer(I4B) :: lbegin + integer(I4B) :: lnbr + integer(I4B) :: lperm + integer(I4B) :: lvlend + integer(I4B) :: nbr + integer(I4B) :: node + ! code + ! find the degrees of the nodes in the + ! component specified by mask and root. + call ims_degree(llperm, neqns, nja, root, xadj, adjncy, mask, & + deg, ccsize, perm) + mask(root) = 0 + if (ccsize <= 1) return + lvlend = 0 + lnbr = 1 + ! + ! lbegin and lvlend point to the beginning and + ! the end of the current level respectively. +100 lbegin = lvlend + 1 + lvlend = lnbr + lbegend: do i = lbegin, lvlend + ! + ! for each node in current level ... + node = perm(i) + jstrt = xadj(node) + jstop = xadj(node+1) - 1 + ! + ! find the unnumbered neighbors of node. + ! fnbr and lnbr point to the first and last + ! unnumbered neighbors respectively of the current + ! node in perm. + fnbr = lnbr + 1 + lunn: do j = jstrt, jstop + nbr = adjncy(j) + if (mask(nbr) == 0) cycle lunn + lnbr = lnbr + 1 + mask(nbr) = 0 + perm(lnbr) = nbr + end do lunn + if (fnbr >= lnbr) cycle lbegend + ! + ! sort the neighbors of node in increasing + ! order by degree. linear insertion is used. + k = fnbr +300 l = k + k = k + 1 + nbr = perm(k) +400 if (l < fnbr) go to 500 + lperm = perm(l) + if (deg(lperm) <= deg(nbr)) go to 500 + perm(l+1) = lperm + l = l - 1 + go to 400 +500 perm(l+1) = nbr + if (k < lnbr) go to 300 + end do lbegend + if (lnbr > lvlend) go to 100 + ! + ! we now have the cuthill mckee ordering. + ! reverse it below ... + k = ccsize/2 + l = ccsize + do i = 1, k + lperm = perm(l) + perm(l) = perm(i) + perm(i) = lperm + l = l - 1 + end do + return + end subroutine ims_rcm + + + !----- subroutine ims_degree + ! degree in masked component ******** + ! + ! purpose - this routine computes the degrees of the nodes + ! in the connected component specified by mask and root. + ! nodes for which mask is zero are ignored. + ! + ! input parameter - + ! root - is the input node that defines the component. + ! (xadj, adjncy) - adjacency structure pair. + ! mask - specifies a section subgraph. + ! + ! output parameters - + ! deg - array containing the degrees of the nodes in + ! the component. + ! ccsize-size of the component specified by mask and root + ! + ! working parameter - + ! ls - a temporary vector used to store the nodes of the + ! component level by level. + ! + !*************************************************************** + ! + subroutine ims_degree(lls, neqns, nja, root, xadj, adjncy, mask, & + deg, ccsize, ls) + ! + !*************************************************************** + ! + implicit none + + ! -- dummy variables + integer(I4B), intent(in) :: lls + integer(I4B), intent(in) :: neqns + integer(I4B), intent(in) :: nja + integer(I4B), intent(in) :: root + integer(I4B), dimension(neqns+1), intent(inout) :: xadj + integer(I4B), dimension(nja), intent(in) :: adjncy + integer(I4B), dimension(neqns), intent(in) :: mask + integer(I4B), dimension(neqns), intent(inout) :: deg + integer(I4B), intent(inout) :: ccsize + integer(I4B), dimension(lls), intent(inout) :: ls + + ! -- local + integer(I4B) :: i + integer(I4B) :: ideg + integer(I4B) :: j + integer(I4B) :: jstop + integer(I4B) :: jstrt + integer(I4B) :: lbegin + integer(I4B) :: lvlend + integer(I4B) :: lvsize + integer(I4B) :: nbr + integer(I4B) :: node + + ! code + ! + ! initialization ... + ! the array xadj is used as a temporary marker to + ! indicate which nodes have been considered so far. + ls(1) = root + xadj(root) = -xadj(root) + lvlend = 0 + ccsize = 1 + ! + ! lbegin is the pointer to the beginning of the current + ! level, and lvlend points to the end of this level. +100 lbegin = lvlend + 1 + lvlend = ccsize + ! + ! find the degrees of nodes in the current level, + ! and at the same time, generate the next level. + louter: do i = lbegin, lvlend + node = ls(i) + jstrt = -xadj(node) + jstop = iabs(xadj(node + 1)) - 1 + ideg = 0 + if (jstop < jstrt) go to 300 + linner: do j = jstrt, jstop + nbr = adjncy(j) + if (mask(nbr) == 0) cycle linner + ideg = ideg + 1 + if (xadj(nbr) < 0) cycle linner + xadj(nbr) = -xadj(nbr) + ccsize = ccsize + 1 + ls(ccsize) = nbr + end do linner +300 deg(node) = ideg + end do louter + ! + ! compute the current level width. + ! if it is nonzero , generate another level. + lvsize = ccsize - lvlend + if (lvsize > 0) go to 100 + ! + ! reset xadj to its correct sign and return. + do i = 1, ccsize + node = ls(i) + xadj(node) = -xadj(node) + end do + return + end subroutine ims_degree + + + ! subroutine ims_rootls + ! + ! rooted level structure + ! + ! purpose - ims_rootls generates the level structure rooted + ! at the input node called root. only those nodes for + ! which mask is nonzero will be considered. + ! + ! input parameters - + ! root - the node at which the level structure is to + ! be rooted. + ! (xadj, adjncy) - adjacency structure pair for the + ! given graph. + ! mask - is used to specify a section subgraph. nodes + ! with mask(i)=0 are ignored. + ! + ! output parameters - + ! nlvl - is the number of levels in the level structure. + ! (xls, ls) - array pair for the rooted level structure. + ! + !*************************************************************** + ! + subroutine ims_rootls(lls, neqns, nja, root, xadj, adjncy, mask, & + nlvl, xls, ls ) + + implicit none + + ! -- dummy variables + integer(I4B), intent(in) :: lls + integer(I4B), intent(in) :: neqns + integer(I4B), intent(in) :: nja + integer(I4B), intent(in) :: root + integer(I4B), dimension(neqns+1), intent(in) :: xadj + integer(I4B), dimension(nja), intent(in) :: adjncy + integer(I4B), dimension(neqns), intent(inout) :: mask + integer(I4B), intent(inout) :: nlvl + integer(I4B), dimension(neqns+1), intent(inout) :: xls + integer(I4B), dimension(lls), intent(inout) :: ls + + ! -- local + integer(I4B) :: i + integer(I4B) :: j + integer(I4B) :: jstop + integer(I4B) :: jstrt + integer(I4B) :: lbegin + integer(I4B) :: ccsize + integer(I4B) :: lvlend + integer(I4B) :: lvsize + integer(I4B) :: nbr + integer(I4B) :: node + ! + ! code + ! + ! initialization ... + mask(root) = 0 + ls(1) = root + nlvl = 0 + lvlend = 0 + ccsize = 1 + ! + ! lbegin is the pointer to the beginning of the current + ! level, and lvlend points to the end of this level. +200 lbegin = lvlend + 1 + lvlend = ccsize + nlvl = nlvl + 1 + xls(nlvl) = lbegin + ! + ! generate the next level by finding all the masked + ! neighbors of nodes in the current level. + louter: do i = lbegin, lvlend + node = ls(i) + jstrt = xadj(node) + jstop = xadj(node + 1) - 1 + if (jstop < jstrt) cycle louter + linner: do j = jstrt, jstop + nbr = adjncy(j) + if (mask(nbr) == 0) cycle linner + ccsize = ccsize + 1 + ls(ccsize) = nbr + mask(nbr) = 0 + end do linner + end do louter + ! + ! compute the current level width. + ! if it is nonzero, generate the next level. + lvsize = ccsize - lvlend + if (lvsize > 0 ) go to 200 + ! + ! reset mask to one for the nodes in the level structure. + xls(nlvl+1) = lvlend + 1 + do i = 1, ccsize + node = ls(i) + mask(node) = 1 + end do + return + end subroutine ims_rootls + + + + subroutine ims_odrv(n, nja, nsp, ia, ja, p, ip, isp, flag) + ! + ! 3/12/82 + !*********************************************************************** + ! odrv -- driver for sparse matrix reordering routines + !*********************************************************************** + ! + ! description + ! + ! odrv finds a minimum degree ordering of the rows and columns + ! of a matrix m stored in (ia,ja,a) format (see below). for the + ! reordered matrix, the work and storage required to perform + ! gaussian elimination is (usually) significantly less. + ! + ! note.. odrv and its subordinate routines have been modified to + ! compute orderings for general matrices, not necessarily having any + ! symmetry. the minimum degree ordering is computed for the + ! structure of the symmetric matrix m + m-transpose. + ! modifications to the original odrv module have been made in + ! the coding in subroutine mdi, and in the initial comments in + ! subroutines odrv and md. + ! + ! if only the nonzero entries in the upper triangle of m are being + ! stored, then odrv symmetrically reorders (ia,ja,a), (optionally) + ! with the diagonal entries placed first in each row. this is to + ! ensure that if m(i,j) will be in the upper triangle of m with + ! respect to the new ordering, then m(i,j) is stored in row i (and + ! thus m(j,i) is not stored), whereas if m(i,j) will be in the + ! strict lower triangle of m, then m(j,i) is stored in row j (and + ! thus m(i,j) is not stored). + ! + ! + ! storage of sparse matrices + ! + ! the nonzero entries of the matrix m are stored row-by-row in the + ! array a. to identify the individual nonzero entries in each row, + ! we need to know in which column each entry lies. these column + ! indices are stored in the array ja. i.e., if a(k) = m(i,j), then + ! ja(k) = j. to identify the individual rows, we need to know where + ! each row starts. these row pointers are stored in the array ia. + ! i.e., if m(i,j) is the first nonzero entry (stored) in the i-th row + ! and a(k) = m(i,j), then ia(i) = k. moreover, ia(n+1) points to + ! the first location following the last element in the last row. + ! thus, the number of entries in the i-th row is ia(i+1) - ia(i), + ! the nonzero entries in the i-th row are stored consecutively in + ! + ! a(ia(i)), a(ia(i)+1), ..., a(ia(i+1)-1), + ! + ! and the corresponding column indices are stored consecutively in + ! + ! ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1). + ! + ! since the coefficient matrix is symmetric, only the nonzero entries + ! in the upper triangle need be stored. for example, the matrix + ! + ! ( 1 0 2 3 0 ) + ! ( 0 4 0 0 0 ) + ! m = ( 2 0 5 6 0 ) + ! ( 3 0 6 7 8 ) + ! ( 0 0 0 8 9 ) + ! + ! could be stored as + ! + ! - 1 2 3 4 5 6 7 8 9 10 11 12 13 + ! ---+-------------------------------------- + ! ia - 1 4 5 8 12 14 + ! ja - 1 3 4 2 1 3 4 1 3 4 5 4 5 + ! a - 1 2 3 4 2 5 6 3 6 7 8 8 9 + ! + ! or (symmetrically) as + ! + ! - 1 2 3 4 5 6 7 8 9 + ! ---+-------------------------- + ! ia - 1 4 5 7 9 10 + ! ja - 1 3 4 2 3 4 4 5 5 + ! a - 1 2 3 4 5 6 7 8 9 . + ! + ! + ! parameters + ! + ! n - order of the matrix + ! + ! nja - number of nonzeroes in the matrix + ! + ! nsp - declared dimension of the one-dimensional array isp. nsp + ! must be at least 3n+4k, where k is the number of nonzeroes + ! in the strict upper triangle of m + ! + ! ia - integer one-dimensional array containing pointers to delimit + ! rows in ja and a. dimension = n+1 + ! + ! ja - integer one-dimensional array containing the column indices + ! corresponding to the elements of a. dimension = number of + ! nonzero entries in (the upper triangle of) m + ! + ! a - real one-dimensional array containing the nonzero entries in + ! (the upper triangle of) m, stored by rows. dimension = + ! number of nonzero entries in (the upper triangle of) m + ! + ! p - integer one-dimensional array used to return the permutation + ! of the rows and columns of m corresponding to the minimum + ! degree ordering. dimension = n + ! + ! ip - integer one-dimensional array used to return the inverse of + ! the permutation returned in p. dimension = n + ! + ! isp - integer one-dimensional array used for working storage. + ! dimension = nsp + ! + ! path - integer path specification. values and their meanings are - + ! 1 find minimum degree ordering only + ! 2 find minimum degree ordering and reorder symmetrically + ! stored matrix (used when only the nonzero entries in + ! the upper triangle of m are being stored) + ! 3 reorder symmetrically stored matrix as specified by + ! input permutation (used when an ordering has already + ! been determined and only the nonzero entries in the + ! upper triangle of m are being stored) + ! 4 same as 2 but put diagonal entries at start of each row + ! 5 same as 3 but put diagonal entries at start of each row + ! + ! flag - integer error flag. values and their meanings are - + ! 0 no errors detected + ! 9n+k insufficient storage in md + ! 10n+1 insufficient storage in odrv + ! 11n+1 illegal path specification + ! + ! + ! conversion from real to double precision + ! + ! change the real declarations in odrv and sro to double precision + ! declarations. + ! + !----------------------------------------------------------------------- + ! + implicit none + + ! -- dummy variables + integer(I4B), intent(in) :: n + integer(I4B), intent(in) :: nja + integer(I4B), intent(in) :: nsp + integer(I4B), dimension(n+1), intent(in) :: ia + integer(I4B), dimension(nja), intent(in) :: ja + integer(I4B), dimension(n), intent(inout) :: p + integer(I4B), dimension(n), intent(inout) :: ip + integer(I4B), dimension(nsp), intent(inout) :: isp + integer(I4B), intent(inout) :: flag + + ! -- local + integer(I4B) :: v + integer(I4B) :: l + integer(I4B) :: head + integer(I4B) :: mmax + integer(I4B) :: next + integer(I4B) :: path + ! + ! set path for finding ordering only + ! + path = 1 + ! + ! + ! initialize error flag and validate path specification + flag = 0 + if (path < 1 .or. 5 < path) go to 111 + ! + ! find minimum degree ordering + mmax = (nsp-n)/2 + v = 1 + l = v + mmax + head = l + mmax + next = head + n + if (mmax < n) go to 110 + ! + call ims_md(n, nja, ia, ja, mmax, isp(v), isp(l), isp(head), p, & + ip, isp(v), flag) + if (flag.ne.0) go to 100 + ! + return + ! + ! ** error -- error detected in md + ! flag = 9 * n + vi from routine mdi. + ! +100 return + ! ** error -- insufficient storage +110 flag = 10*n + 1 + return + ! ** error -- illegal path specified +111 flag = 11*n + 1 + return + end subroutine ims_odrv + + + + subroutine ims_md(n, nja, ia, ja, mmax, v, l, head, last, next, & + mark, flag) + ! + !***************************************************************** + ! ims_md -- minimum degree algorithm (based on element model) + !***************************************************************** + ! + ! description + ! + ! ims_md finds a minimum degree ordering of the rows and + ! columns of a general sparse matrix m stored in (ia,ja,a) + ! format. when the structure of m is nonsymmetric, the ordering + ! is that obtained for the symmetric matrix m + m-transpose. + ! + ! + ! additional parameters + ! + ! mmax - declared dimension of the one-dimensional arrays v and l. + ! mmax must be at least n+2k, where k is the number of + ! nonzeroes in the strict upper triangle of m + ! + ! v - integer one-dimensional work array. dimension = mmax + ! + ! l - integer one-dimensional work array. dimension = mmax + ! + ! head - integer one-dimensional work array. dimension = n + ! + ! last - integer one-dimensional array used to return the permutation + ! of the rows and columns of m corresponding to the minimum + ! degree ordering. dimension = n + ! + ! next - integer one-dimensional array used to return the inverse of + ! the permutation returned in last. dimension = n + ! + ! mark - integer one-dimensional work array (may be the same as v). + ! dimension = n + ! + ! flag - integer error flag. values and their meanings are - + ! 0 no errors detected + ! 11n+1 insufficient storage in md + ! + ! + ! definitions of internal parameters + ! + ! ---------+--------------------------------------------------------- + ! v(s) - value field of list entry + ! ---------+--------------------------------------------------------- + ! l(s) - link field of list entry (0 =) end of list) + ! ---------+--------------------------------------------------------- + ! l(vi) - pointer to element list of uneliminated vertex vi + ! ---------+--------------------------------------------------------- + ! l(ej) - pointer to boundary list of active element ej + ! ---------+--------------------------------------------------------- + ! head(d) - vj =) vj head of d-list d + ! - 0 =) no vertex in d-list d + ! + ! + ! - vi uneliminated vertex + ! - vi in ek - vi not in ek + ! ---------+-----------------------------+--------------------------- + ! next(vi) - undefined but nonnegative - vj =) vj next in d-list + ! - - 0 =) vi tail of d-list + ! ---------+-----------------------------+--------------------------- + ! last(vi) - (not set until mdp) - -d =) vi head of d-list d + ! --vk =) compute degree - vj =) vj last in d-list + ! - ej =) vi prototype of ej - 0 =) vi not in any d-list + ! - 0 =) do not compute degree - + ! ---------+-----------------------------+--------------------------- + ! mark(vi) - mark(vk) - nonneg. tag .lt. mark(vk) + ! + ! + ! - vi eliminated vertex + ! - ei active element - otherwise + ! ---------+-----------------------------+--------------------------- + ! next(vi) - -j =) vi was j-th vertex - -j =) vi was j-th vertex + ! - to be eliminated - to be eliminated + ! ---------+-----------------------------+--------------------------- + ! last(vi) - m =) size of ei = m - undefined + ! ---------+-----------------------------+--------------------------- + ! mark(vi) - -m =) overlap count of ei - undefined + ! - with ek = m - + ! - otherwise nonnegative tag - + ! - .lt. mark(vk) - + ! + !----------------------------------------------------------------------- + ! + implicit none + + ! -- dummy variables + integer(I4B), intent(in) :: n + integer(I4B), intent(in) :: nja + integer(I4B), dimension(n+1), intent(in) :: ia + integer(I4B), dimension(nja), intent(in) :: ja + integer(I4B), intent(in) :: mmax + integer(I4B), dimension(mmax), intent(inout) :: v + integer(I4B), dimension(mmax), intent(inout) :: l + integer(I4B), dimension(n), intent(inout) :: head + integer(I4B), dimension(n), intent(inout) :: last + integer(I4B), dimension(n), intent(inout) :: next + integer(I4B), dimension(n), intent(inout) :: mark + integer(I4B), intent(inout) :: flag + + ! -- local + integer(I4B) :: tag + integer(I4B) :: dmin + integer(I4B) :: vk + integer(I4B) :: ek + integer(I4B) :: tail + integer(I4B) :: k + + equivalence(vk, ek) + ! + ! initialization + tag = 0 + call ims_mdi(n, nja, ia, ja, mmax ,v, l, head, last, next, & + mark, tag, flag) + if (flag.ne.0) return + ! + k = 0 + dmin = 1 + ! + ! while k .lt. n do +1 if (k >= n) go to 4 + ! + ! search for vertex of minimum degree +2 if (head(dmin) > 0) go to 3 + dmin = dmin + 1 + go to 2 + ! + ! remove vertex vk of minimum degree from degree list +3 vk = head(dmin) + head(dmin) = next(vk) + if (head(dmin) > 0) last(head(dmin)) = -dmin + ! + ! number vertex vk, adjust tag, and tag vk + k = k+1 + next(vk) = -k + last(ek) = dmin - 1 + tag = tag + last(ek) + mark(vk) = tag + ! + ! form element ek from uneliminated neighbors of vk + call ims_mdm(n, mmax, vk, tail, v, l, last, next, mark) + ! + ! purge inactive elements and do mass elimination + call ims_mdp(n, mmax, k, ek, tail, v, l, head, last, next, mark) + ! + ! update degrees of uneliminated vertices in ek + call ims_mdu(n, mmax, ek, dmin, v, l, head, last, next, mark) + ! + go to 1 + ! + ! generate inverse permutation from permutation +4 do k = 1, n + next(k) = -next(k) + last(next(k)) = k + end do + ! + return + end subroutine ims_md + + + subroutine ims_mdi(n, nja, ia, ja, mmax, v, l, head, last, next, & + mark, tag, flag) + ! + !*********************************************************************** + ! ims_mdi -- initialization + !*********************************************************************** + implicit none + + ! -- dummy variables + integer(I4B), intent(in) :: n + integer(I4B), intent(in) :: nja + integer(I4B), dimension(n+1), intent(in) :: ia + integer(I4B), dimension(nja), intent(in) :: ja + integer(I4B), intent(in) :: mmax + integer(I4B), dimension(mmax), intent(inout) :: v + integer(I4B), dimension(mmax), intent(inout) :: l + integer(I4B), dimension(n), intent(inout) :: head + integer(I4B), dimension(n), intent(inout) :: last + integer(I4B), dimension(n), intent(inout) :: next + integer(I4B), dimension(n), intent(inout) :: mark + integer(I4B), intent(in) :: tag + integer(I4B), intent(inout) :: flag + + ! -- local + integer(I4B) :: sfs + integer(I4B) :: vi + integer(I4B) :: dvi + integer(I4B) :: vj + integer(I4B) :: jmin + integer(I4B) :: jmax + integer(I4B) :: j + integer(I4B) :: lvk + integer(I4B) :: kmax + integer(I4B) :: k + integer(I4B) :: nextvi + integer(I4B) :: ieval + ! + ! initialize degrees, element lists, and degree lists + do vi = 1, n + mark(vi) = 1 + l(vi) = 0 + head(vi) = 0 + end do + sfs = n + 1 + ! + ! create nonzero structure + ! for each nonzero entry a(vi,vj) + louter: do vi = 1, n + jmin = ia(vi) + jmax = ia(vi+1) - 1 + if (jmin > jmax) cycle louter + linner1: do j = jmin, jmax !5 + vj = ja(j) + !if (vj-vi) 2, 5, 4 + ieval = vj - vi + if (ieval == 0) cycle linner1 !5 + if (ieval > 0) go to 4 + ! + ! if a(vi,vj) is in strict lower triangle + ! check for previous occurrence of a(vj,vi) + lvk = vi + kmax = mark(vi) - 1 + if (kmax == 0) go to 4 + linner2: do k = 1, kmax + lvk = l(lvk) + if (v(lvk) == vj) cycle linner1 !5 + end do linner2 + ! for unentered entries a(vi,vj) +4 if (sfs >= mmax) go to 101 + ! + ! enter vj in element list for vi + mark(vi) = mark(vi) + 1 + v(sfs) = vj + l(sfs) = l(vi) + l(vi) = sfs + sfs = sfs+1 + ! + ! enter vi in element list for vj + mark(vj) = mark(vj) + 1 + v(sfs) = vi + l(sfs) = l(vj) + l(vj) = sfs + sfs = sfs + 1 + end do linner1 + end do louter + ! + ! create degree lists and initialize mark vector + do vi = 1, n + dvi = mark(vi) + next(vi) = head(dvi) + head(dvi) = vi + last(vi) = -dvi + nextvi = next(vi) + if (nextvi > 0) last(nextvi) = vi + mark(vi) = tag + end do + ! + return + ! + ! ** error- insufficient storage +101 flag = 9*n + vi + return + end subroutine ims_mdi + + + + subroutine ims_mdm(n, mmax, vk, tail, v, l, last, next, mark) + ! + !*********************************************************************** + ! ims_mdm -- form element from uneliminated neighbors of vk + !*********************************************************************** + implicit none + + ! -- dummy variables + integer(I4B), intent(in) :: n + integer(I4B), intent(in) :: mmax + integer(I4B), intent(in) :: vk + integer(I4B), intent(inout) :: tail + integer(I4B), dimension(mmax), intent(inout) :: v + integer(I4B), dimension(mmax), intent(inout) :: l + integer(I4B), dimension(n), intent(inout) :: last + integer(I4B), dimension(n), intent(inout) :: next + integer(I4B), dimension(n), intent(inout) :: mark + + ! -- local + integer(I4B) :: tag + integer(I4B) :: s + integer(I4B) :: ls + integer(I4B) :: vs + integer(I4B) :: es + integer(I4B) :: b + integer(I4B) :: lb + integer(I4B) :: vb + integer(I4B) :: blp + integer(I4B) :: blpmax + + equivalence (vs, es) + ! + ! initialize tag and list of uneliminated neighbors + tag = mark(vk) + tail = vk + ! + ! for each vertex/element vs/es in element list of vk + ls = l(vk) +1 s = ls + if (s == 0) go to 5 + ls = l(s) + vs = v(s) + if (next(vs) < 0) go to 2 + ! + ! if vs is uneliminated vertex, then tag and append to list of + ! uneliminated neighbors + mark(vs) = tag + l(tail) = s + tail = s + go to 4 + ! + ! if es is active element, then ... + ! for each vertex vb in boundary list of element es +2 lb = l(es) + blpmax = last(es) + louter: do blp = 1, blpmax !3 + b = lb + lb = l(b) + vb = v(b) + ! + ! if vb is untagged vertex, then tag and append to list of + ! uneliminated neighbors + if (mark(vb) >= tag) cycle louter !3 + mark(vb) = tag + l(tail) = b + tail = b + end do louter + ! + ! mark es inactive + mark(es) = tag + ! +4 go to 1 + ! + ! terminate list of uneliminated neighbors +5 l(tail) = 0 + ! + return + end subroutine ims_mdm + + + subroutine ims_mdp(n, mmax, k, ek, tail, v, l, head, last, next, mark) + ! + !*********************************************************************** + ! ims_mdp -- purge inactive elements and do mass elimination + !*********************************************************************** + implicit none + + ! -- dummy variables + integer(I4B), intent(in) :: n + integer(I4B), intent(in) :: mmax + integer(I4B), intent(inout) :: k + integer(I4B), intent(in) :: ek + integer(I4B), intent(inout) :: tail + integer(I4B), dimension(mmax), intent(inout) :: v + integer(I4B), dimension(mmax), intent(inout) :: l + integer(I4B), dimension(n), intent(inout) :: head + integer(I4B), dimension(n), intent(inout) :: last + integer(I4B), dimension(n), intent(inout) :: next + integer(I4B), dimension(n), intent(inout) :: mark + + ! -- local + integer(I4B) :: tag + integer(I4B) :: free + integer(I4B) :: li + integer(I4B) :: vi + integer(I4B) :: lvi + integer(I4B) :: evi + integer(I4B) :: s + integer(I4B) :: ls + integer(I4B) :: es + integer(I4B) :: ilp + integer(I4B) :: ilpmax + integer(I4B) :: i + ! + ! initialize tag + tag = mark(ek) + ! + ! for each vertex vi in ek + li = ek + ilpmax = last(ek) + if (ilpmax <= 0) go to 12 + louter: do ilp = 1, ilpmax !11 + i = li + li = l(i) + vi = v(li) + ! + ! remove vi from degree list + if (last(vi) == 0) go to 3 + if (last(vi) > 0) go to 1 + head(-last(vi)) = next(vi) + go to 2 +1 next(last(vi)) = next(vi) +2 if (next(vi) > 0) last(next(vi)) = last(vi) + ! + ! remove inactive items from element list of vi +3 ls = vi +4 s = ls + ls = l(s) + if (ls == 0) go to 6 + es = v(ls) + if (mark(es) < tag) go to 5 + free = ls + l(s) = l(ls) + ls = s +5 go to 4 + ! + ! if vi is interior vertex, then remove from list and eliminate + +6 lvi = l(vi) + if (lvi.ne.0) go to 7 + l(i) = l(li) + li = i + ! + k = k + 1 + next(vi) = -k + last(ek) = last(ek) - 1 + cycle louter !11 + ! + ! else ... + ! classify vertex vi +7 if (l(lvi).ne.0) go to 9 + evi = v(lvi) + if (next(evi) >= 0) go to 9 + if (mark(evi) < 0) go to 8 + ! + ! if vi is prototype vertex, then mark as such, initialize + ! overlap count for corresponding element, and move vi to end + ! of boundary list + last(vi) = evi + mark(evi) = -1 + l(tail) = li + tail = li + l(i) = l(li) + li = i + go to 10 + ! + ! else if vi is duplicate vertex, then mark as such and adjust + ! overlap count for corresponding element +8 last(vi) = 0 + mark(evi) = mark(evi) - 1 + go to 10 + ! + ! else mark vi to compute degree +9 last(vi) = -ek + ! + ! insert ek in element list of vi +10 v(free) = ek + l(free) = l(vi) + l(vi) = free + end do louter !11 + ! + ! terminate boundary list +12 l(tail) = 0 + ! + return + end subroutine ims_mdp + + + + subroutine ims_mdu(n, mmax, ek, dmin, v, l, head, last, next, mark) + ! + !*********************************************************************** + ! ims_mdu -- update degrees of uneliminated vertices in ek + !*********************************************************************** + implicit none + + ! -- dummy variables + integer(I4B), intent(in) :: n + integer(I4B), intent(in) :: mmax + integer(I4B), intent(in) :: ek + integer(I4B), intent(inout) :: dmin + integer(I4B), dimension(mmax), intent(inout) :: v + integer(I4B), dimension(mmax), intent(inout) :: l + integer(I4B), dimension(n), intent(inout) :: head + integer(I4B), dimension(n), intent(inout) :: last + integer(I4B), dimension(n), intent(inout) :: next + integer(I4B), dimension(n), intent(inout) :: mark + + ! -- local + integer(I4B) :: tag + integer(I4B) :: vi + integer(I4B) :: evi + integer(I4B) :: dvi + integer(I4B) :: s + integer(I4B) :: vs + integer(I4B) :: es + integer(I4B) :: b + integer(I4B) :: vb + integer(I4B) :: ilp + integer(I4B) :: ilpmax + integer(I4B) :: blp + integer(I4B) :: blpmax + integer(I4B) :: i + + equivalence (vs, es) + ! + ! initialize tag + tag = mark(ek) - last(ek) + ! + ! for each vertex vi in ek + i = ek + ilpmax = last(ek) + if (ilpmax <= 0) go to 11 + louter: do ilp = 1, ilpmax !10 + i = l(i) + vi = v(i) + !if (last(vi)) 1, 10, 8 + if (last(vi) == 0) cycle louter !10 + if (last(vi) > 0) goto 8 + ! + ! if vi neither prototype nor duplicate vertex, then merge elements + ! to compute degree + tag = tag + 1 + dvi = last(ek) + ! + ! for each vertex/element vs/es in element list of vi + s = l(vi) +2 s = l(s) + if (s == 0) go to 9 + vs = v(s) + if (next(vs) < 0) go to 3 + ! + ! if vs is uneliminated vertex, then tag and adjust degree + mark(vs) = tag + dvi = dvi + 1 + go to 5 + ! + ! if es is active element, then expand + ! check for outmatched vertex +3 if (mark(es) < 0) go to 6 + ! + ! for each vertex vb in es + b = es + blpmax = last(es) + linner: do blp = 1, blpmax !4 + b = l(b) + vb = v(b) + ! + ! if vb is untagged, then tag and adjust degree + if (mark(vb) >= tag) cycle linner !4 + mark(vb) = tag + dvi = dvi + 1 + end do linner !4 + ! +5 go to 2 + ! + ! else if vi is outmatched vertex, then adjust overlaps but do not + ! compute degree +6 last(vi) = 0 + mark(es) = mark(es) - 1 +7 s = l(s) + if (s == 0) cycle louter !10 + es = v(s) + if (mark(es) < 0) mark(es) = mark(es) - 1 + go to 7 + ! + ! else if vi is prototype vertex, then calculate degree by + ! inclusion/exclusion and reset overlap count +8 evi = last(vi) + dvi = last(ek) + last(evi) + mark(evi) + mark(evi) = 0 + ! + ! insert vi in appropriate degree list +9 next(vi) = head(dvi) + head(dvi) = vi + last(vi) = -dvi + if (next(vi) > 0) last(next(vi)) = vi + if (dvi < dmin) dmin = dvi + ! + end do louter !10 + ! +11 return + end subroutine ims_mdu + + ! + ! ROUTINES FROM SPARSKIT TO PERMUTATE A LINEAR SYSTEM OF EQUATIONS + ! IN ORDER TO REORDER THE MATRIX TO MINIMIZE THE BANDWIDTH USING + ! THE REVERSE CUTHILL MCKEE OR MINIMUM DEGREE ORDERING ALGORITHMS + ! + subroutine ims_dperm(nrow, nja, a, ja, ia, ao, jao, iao, & + perm, qperm, job) + implicit none + + ! -- dummy variables + integer(I4B), intent(in) :: nrow + integer(I4B), intent(in) :: nja + real(DP), dimension(nja), intent(in) :: a + integer(I4B), dimension(nja), intent(in) :: ja + integer(I4B), dimension(nrow+1), intent(in) :: ia + real(DP), dimension(nja), intent(inout) :: ao + integer(I4B), dimension(nja), intent(inout) :: jao + integer(I4B), dimension(nrow+1), intent(inout) :: iao + integer(I4B), dimension(nrow), intent(inout) :: perm + integer(I4B), dimension(nrow), intent(inout) :: qperm + integer(I4B), intent(in) :: job + !----------------------------------------------------------------------- + ! This routine permutes the rows and columns of a matrix stored in CSR + ! format. i.e., it computes P A Q, where P, Q are permutation matrices. + ! P maps row i into row perm(i) and Q maps column j into column qperm(j) + ! a(i,j) becomes a(perm(i),qperm(j)) in new matrix + ! In the particular case where Q is the transpose of P (symmetric + ! permutation of A) then qperm is not needed. + ! note that qperm should be of length ncol (number of columns) but this + ! is not checked. + !----------------------------------------------------------------------- + ! Y. Saad, Sep. 21 1989 / recoded Jan. 28 1991. + !----------------------------------------------------------------------- + ! on entry: + !---------- + ! n = dimension of the matrix + ! a, ja, + ! ia = input matrix in a, ja, ia format + ! perm = integer array of length n containing the permutation arra + ! for the rows: perm(i) is the destination of row i in the + ! permuted matrix -- also the destination of column i in case + ! permutation is symmetric (job .le. 2) + ! + ! qperm = same thing for the columns. This should be provided only + ! if job=3 or job=4, i.e., only in the case of a nonsymmetric + ! permutation of rows and columns. Otherwise qperm is a dummy + ! + ! job = integer indicating the work to be done: + ! * job = 1,2 permutation is symmetric Ao :== P * A * transp(P) + ! job = 1 permute a, ja, ia into ao, jao, iao + ! job = 2 permute matrix ignoring real values. + ! * job = 3,4 permutation is non-symmetric Ao :== P * A * Q + ! job = 3 permute a, ja, ia into ao, jao, iao + ! job = 4 permute matrix ignoring real values. + ! + ! on return: + !----------- + ! ao, jao, iao = input matrix in a, ja, ia format + ! + ! in case job .eq. 2 or job .eq. 4, a and ao are never referred to + ! and can be dummy arguments. + ! Notes: + !------- + ! 1) algorithm is in place + ! 2) column indices may not be sorted on return eventhough they may be + ! on entry. + !---------------------------------------------------------------------- + ! -- local + integer(I4B) :: locjob, mod + ! + ! locjob indicates whether or not real values must be copied. + ! + locjob = mod(job,2) + ! + ! permute rows first + ! + call ims_rperm(nrow, nja, a, ja, ia, ao, jao, iao, perm, locjob) + ! + ! then permute columns + ! + locjob = 0 + ! + if (job .le. 2) then + call ims_cperm(nrow, nja, ao, jao, iao, ao, jao, iao, perm, locjob) + else + call ims_cperm(nrow, nja, ao, jao, iao, ao, jao, iao, qperm, locjob) + endif + ! + return + !-------end-of-ims_dperm---------------------------------------------------- + end subroutine ims_dperm + + + !----------------------------------------------------------------------- + subroutine ims_rperm (nrow, nja, a, ja, ia, ao, jao, iao, perm, job) + implicit none + + ! -- dummy variables + integer(I4B), intent(in) :: nrow + integer(I4B), intent(in) :: nja + real(DP), dimension(nja), intent(in) :: a + integer(I4B), dimension(nja), intent(in) :: ja + integer(I4B), dimension(nrow+1), intent(in) :: ia + real(DP), dimension(nja), intent(inout) :: ao + integer(I4B), dimension(nja), intent(inout) :: jao + integer(I4B), dimension(nrow+1), intent(inout) :: iao + integer(I4B), dimension(nrow), intent(inout) :: perm + integer(I4B), intent(in) :: job + !----------------------------------------------------------------------- + ! this subroutine permutes the rows of a matrix in CSR format. + ! ims_rperm computes B = P A where P is a permutation matrix. + ! the permutation P is defined through the array perm: for each j, + ! perm(j) represents the destination row number of row number j. + ! Youcef Saad -- recoded Jan 28, 1991. + !----------------------------------------------------------------------- + ! on entry: + !---------- + ! n = dimension of the matrix + ! a, ja, ia = input matrix in csr format + ! perm = integer array of length nrow containing the permutation a + ! for the rows: perm(i) is the destination of row i in the + ! permuted matrix. + ! ---> a(i,j) in the original matrix becomes a(perm(i),j) + ! in the output matrix. + ! + ! job = integer indicating the work to be done: + ! job = 1 permute a, ja, ia into ao, jao, iao + ! (including the copying of real values ao and + ! the array iao). + ! job .ne. 1 : ignore real values. + ! (in which case arrays a and ao are not needed nor + ! used). + ! + !------------ + ! on return: + !------------ + ! ao, jao, iao = input matrix in a, ja, ia format + ! note : + ! if (job.ne.1) then the arrays a and ao are not used. + !----------------------------------------------------------------------c + ! Y. Saad, May 2, 1990 c + !----------------------------------------------------------------------c + ! -- local + logical :: values + integer(I4B) :: i + integer(I4B) :: j + integer(I4B) :: k + integer(I4B) :: ii + integer(I4B) :: ko + + values = (job .eq. 1) + ! + ! determine pointers for output matrix. + ! + do j=1,nrow + i = perm(j) + iao(i+1) = ia(j+1) - ia(j) + end do + ! + ! get pointers from lengths + ! + iao(1) = 1 + do j=1,nrow + iao(j+1) = iao(j+1) + iao(j) + end do + ! + ! copying + ! + do ii=1,nrow + ! + ! old row = ii -- new row = iperm(ii) -- ko = new pointer + ! + ko = iao(perm(ii)) + do k = ia(ii), ia(ii+1)-1 + jao(ko) = ja(k) + if (values) ao(ko) = a(k) + ko = ko+1 + end do + end do + ! + return + !---------end-of-ims_rperm ------------------------------------------------- + !----------------------------------------------------------------------- + end subroutine ims_rperm + + + + !----------------------------------------------------------------------- + subroutine ims_cperm (nrow, nja, a, ja, ia, ao, jao, iao, perm, job) + implicit none + + ! -- dummy variables + integer(I4B), intent(in) :: nrow + integer(I4B), intent(in) :: nja + real(DP), dimension(nja), intent(in) :: a + integer(I4B), dimension(nja), intent(in) :: ja + integer(I4B), dimension(nrow+1), intent(in) :: ia + real(DP), dimension(nja), intent(inout) :: ao + integer(I4B), dimension(nja), intent(inout) :: jao + integer(I4B), dimension(nrow+1), intent(inout) :: iao + integer(I4B), dimension(nrow), intent(inout) :: perm + integer(I4B), intent(in) :: job + + !----------------------------------------------------------------------- + ! this subroutine permutes the columns of a matrix a, ja, ia. + ! the result is written in the output matrix ao, jao, iao. + ! cperm computes B = A P, where P is a permutation matrix + ! that maps column j into column perm(j), i.e., on return + ! a(i,j) becomes a(i,perm(j)) in new matrix + ! Y. Saad, May 2, 1990 / modified Jan. 28, 1991. + !----------------------------------------------------------------------- + ! on entry: + !---------- + ! nrow = row dimension of the matrix + ! + ! a, ja, ia = input matrix in csr format. + ! + ! perm = integer array of length ncol (number of columns of A + ! containing the permutation array the columns: + ! a(i,j) in the original matrix becomes a(i,perm(j)) + ! in the output matrix. + ! + ! job = integer indicating the work to be done: + ! job = 1 permute a, ja, ia into ao, jao, iao + ! (including the copying of real values ao and + ! the array iao). + ! job .ne. 1 : ignore real values ao and ignore iao. + ! + !------------ + ! on return: + !------------ + ! ao, jao, iao = input matrix in a, ja, ia format (array ao not needed) + ! + ! Notes: + !------- + ! 1. if job=1 then ao, iao are not used. + ! 2. This routine is in place: ja, jao can be the same. + ! 3. If the matrix is initially sorted (by increasing column number) + ! then ao,jao,iao may not be on return. + ! + !----------------------------------------------------------------------c + ! -- local + integer(I4B) :: k, i + ! + do k=1, nja + jao(k) = perm(ja(k)) + end do + ! + ! done with ja array. return if no need to touch values. + ! + if (job .ne. 1) return + ! + ! else get new pointers -- and copy values too. + ! + do i=1, nrow+1 + iao(i) = ia(i) + end do + ! + do k=1, nja + ao(k) = a(k) + end do + ! + return + !---------end-of-ims_cperm-------------------------------------------------- + !----------------------------------------------------------------------- + end subroutine ims_cperm + + + !----------------------------------------------------------------------- + subroutine ims_vperm (n, x, perm) + implicit none + + ! -- dummy variables + integer(I4B), intent(in) :: n + integer(I4B), dimension(n), intent(inout) :: perm + real(DP), dimension(n), intent(inout) :: x + !----------------------------------------------------------------------- + ! this subroutine performs an in-place permutation of a real vector x + ! according to the permutation array perm(*), i.e., on return, + ! the vector x satisfies, + ! + ! x(perm(j)) :== x(j), j=1,2,.., n + ! + !----------------------------------------------------------------------- + ! on entry: + !--------- + ! n = length of vector x. + ! perm = integer array of length n containing the permutation array. + ! x = input vector + ! + ! on return: + !---------- + ! x = vector x permuted according to x(perm(*)) := x(*) + ! + !----------------------------------------------------------------------c + ! Y. Saad, Sep. 21 1989 c + !----------------------------------------------------------------------c + ! -- local + integer(I4B) :: j + integer(I4B) :: k + integer(I4B) :: ii + integer(I4B) :: init + integer(I4B) :: next + real(DP) :: tmp, tmp1 + ! + init = 1 + tmp = x(init) + ii = perm(init) + perm(init)= -perm(init) + k = 0 + ! + ! loop + ! +6 k = k + 1 + ! + ! save the chased element -- + ! + tmp1 = x(ii) + x(ii) = tmp + next = perm(ii) + if (next < 0 ) goto 65 + ! + ! test for end + ! + if (k > n) go to 101 + tmp = tmp1 + perm(ii) = -perm(ii) + ii = next + ! + ! end loop + ! + go to 6 + ! + ! reinitialize cycle -- + ! +65 init = init + 1 + if (init > n) go to 101 + if (perm(init) < 0) go to 65 + tmp = x(init) + ii = perm(init) + perm(init)= -perm(init) + go to 6 + ! +101 continue + do j = 1, n + perm(j) = -perm(j) + end do + ! + return + !-------------------end-of-ims_vperm--------------------------------------- + !----------------------------------------------------------------------- + end subroutine ims_vperm + end module IMSReorderingModule \ No newline at end of file diff --git a/src/Timing/tdis.f90 b/src/Timing/tdis.f90 index 7ffaa29c437..d6f2ea6d9b3 100644 --- a/src/Timing/tdis.f90 +++ b/src/Timing/tdis.f90 @@ -1,730 +1,730 @@ -!stress periods and time stepping is handled by these routines -!convert this to a derived type? May not be necessary since only -!one of them is needed. - - module TdisModule - - use KindModule, only: DP, I4B - use SimVariablesModule, only: iout - use BlockParserModule, only: BlockParserType - use ConstantsModule, only: LINELENGTH, LENDATETIME, VALL - ! - implicit none - ! - private - public :: subtiming_begin - public :: subtiming_end - public :: tdis_cr - public :: tdis_tu - public :: tdis_ot - public :: tdis_da - ! - integer(I4B), public, pointer :: nper !number of stress period - integer(I4B), public, pointer :: itmuni !flag indicating time units - integer(I4B), public, pointer :: kper !current stress period number - integer(I4B), public, pointer :: kstp !current time step number - logical, public, pointer :: readnewdata !flag indicating time to read new data - logical, public, pointer :: endofperiod !flag indicating end of stress period - logical, public, pointer :: endofsimulation !flag indicating end of simulation - real(DP), public, pointer :: delt !length of the current time step - real(DP), public, pointer :: pertim !time relative to start of stress period - real(DP), public, pointer :: totim !time relative to start of simulation - real(DP), public, pointer :: totimc !simulation time at start of time step - real(DP), public, pointer :: deltsav !saved value for delt, used for subtiming - real(DP), public, pointer :: totimsav !saved value for totim, used for subtiming - real(DP), public, pointer :: pertimsav !saved value for pertim, used for subtiming - real(DP), public, pointer :: totalsimtime !time at end of simulation - real(DP), public, dimension(:), pointer, contiguous :: perlen !length of each stress period - integer(I4B), public, dimension(:), pointer, contiguous :: nstp !number of time steps in each stress period - real(DP), public, dimension(:), pointer, contiguous :: tsmult !time step multiplier for each stress period - character(len=LENDATETIME), pointer :: datetime0 !starting date and time for the simulation - ! - type(BlockParserType), private :: parser - - contains - - subroutine tdis_cr(fname) -! ****************************************************************************** -! tdis_cr -- create temporal discretization. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: getunit, openfile - use ConstantsModule, only: LINELENGTH, DZERO - ! -- dummy - character(len=*),intent(in) :: fname - ! -- local - integer(I4B) :: inunit - ! -- formats - character(len=*),parameter :: fmtheader = & - "(1X,/1X,'TDIS -- TEMPORAL DISCRETIZATION PACKAGE,', / & - &' VERSION 1 : 11/13/2014 - INPUT READ FROM UNIT ',I4)" -! ------------------------------------------------------------------------------ - ! - ! -- Allocate the scalar variables - call tdis_allocate_scalars() - ! - ! -- Get a unit number for tdis and open the file if it is not opened - inquire(file=fname, number=inunit) - if(inunit < 0) then - inunit = getunit() - call openfile(inunit, iout, fname, 'TDIS') - endif - ! - ! -- Identify package - write(iout, fmtheader) inunit - ! - ! -- Initialize block parser - call parser%Initialize(inunit, iout) - ! - ! -- Read options - call tdis_read_options() - ! - ! -- Read dimensions and then allocate arrays - call tdis_read_dimensions() - call tdis_allocate_arrays() - ! - ! -- Read timing - call tdis_read_timing() - ! - ! -- Close the file - call parser%Clear() - ! - ! -- return - return - end subroutine tdis_cr - - subroutine tdis_tu() -! ****************************************************************************** -! tdis_tu -- Time Update. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DONE, DZERO - use GenericUtilitiesModule, only: sim_message - ! -- local - character(len=LINELENGTH) :: line - ! -- formats - character(len=*),parameter :: fmtspi = & - "('1',/28X,'STRESS PERIOD NO. ',I4,', LENGTH =',G15.7,/ & - &28X,47('-'),// & - &30X,'NUMBER OF TIME STEPS =',I6,// & - &31X,'MULTIPLIER FOR DELT =',F10.3)" - character(len=*),parameter :: fmttsi = & - "(1X,/28X,'INITIAL TIME STEP SIZE =',G15.7)" - character(len=*),parameter :: fmtspts = & - "(' Solving: Stress period: ',i5,4x,'Time step: ',i5,4x)" -! ------------------------------------------------------------------------------ - ! - ! -- Increment kstp and kper - if(endofperiod) then - kstp = 1 - kper = kper + 1 - else - kstp = kstp + 1 - endif - ! - ! -- Set readnewdata to .false. and change if new stress period - readnewdata = .false. - ! - ! -- Setup new stress period if kstp is 1 - if(kstp == 1) then - ! - ! -- Write stress period information to simulation list file - write(iout,fmtspi) kper, perlen(kper), nstp(kper), tsmult(kper) - ! - ! -- Calculate the first value of delt for this stress period - delt = perlen(kper) / float(nstp(kper)) - if(tsmult(kper) /= DONE) & - delt = perlen(kper) * (DONE-tsmult(kper)) / & - (DONE - tsmult(kper) ** nstp(kper)) - ! - ! -- Print length of first time step - write(iout, fmttsi) delt - ! - ! -- Initialize pertim (Elapsed time within stress period) - pertim = DZERO - ! - ! -- Clear flag that indicates last time step of a stress period - endofperiod = .false. - ! - ! -- Read new data - readnewdata = .true. - ! - endif - ! - ! -- Calculate delt for kstp > 1 - if(kstp /= 1) delt = tsmult(kper) * delt - ! - ! -- Print stress period and time step to console - write(line, fmtspts) kper, kstp - call sim_message(line, level=VALL) - ! - ! -- Store totim and pertim, which are times at end of previous time step - totimsav = totim - pertimsav = pertim - totimc = totim - ! - ! -- Update totim and pertim - totim = totimsav + delt - pertim = pertimsav + delt - ! - ! -- End of stress period and/or simulation? - if(kstp == nstp(kper)) endofperiod = .true. - if(endofperiod .and. kper==nper) then - endofsimulation = .true. - totim = totalsimtime - end if - ! - ! -- return - return - end subroutine tdis_tu - - subroutine tdis_ot(iout) -! ****************************************************************************** -! PRINT SIMULATION TIME -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - integer(I4B), intent(in) :: iout - ! -- local - real(DP) :: zero,cnv,delsec,totsec,persec,sixty,hrday,dayyr, & - delmn,delhr,totmn,tothr,totdy,totyr,permn,perhr,perdy, & - peryr,deldy,delyr -! ------------------------------------------------------------------------------ - WRITE(IOUT,199) KSTP,KPER - 199 FORMAT(1X,///9X,'TIME SUMMARY AT END OF TIME STEP',I5, & - & ' IN STRESS PERIOD ',I4) -!C -!C1------USE TIME UNIT INDICATOR TO GET FACTOR TO CONVERT TO SECONDS. - ZERO=0.d0 - CNV=ZERO - IF(ITMUNI.EQ.1) CNV=1. - IF(ITMUNI.EQ.2) CNV=60. - IF(ITMUNI.EQ.3) CNV=3600. - IF(ITMUNI.EQ.4) CNV=86400. - IF(ITMUNI.EQ.5) CNV=31557600. -!C -!C2------IF FACTOR=0 THEN TIME UNITS ARE NON-STANDARD. - IF(CNV.NE.ZERO) GO TO 100 -!C -!C2A-----PRINT TIMES IN NON-STANDARD TIME UNITS. - WRITE(IOUT,301) DELT,PERTIM,TOTIM - 301 FORMAT(21X,' TIME STEP LENGTH =',G15.6/ & - & 21X,' STRESS PERIOD TIME =',G15.6/ & - & 21X,'TOTAL SIMULATION TIME =',G15.6) -!C -!C2B-----RETURN - RETURN -!C -!C3------CALCULATE LENGTH OF TIME STEP & ELAPSED TIMES IN SECONDS. - 100 DELSEC=CNV*DELT - TOTSEC=CNV*TOTIM - PERSEC=CNV*PERTIM -!C -!C4------CALCULATE TIMES IN MINUTES,HOURS,DAYS AND YEARS. - SIXTY=60. - HRDAY=24. - DAYYR=365.25 - DELMN=DELSEC/SIXTY - DELHR=DELMN/SIXTY - DELDY=DELHR/HRDAY - DELYR=DELDY/DAYYR - TOTMN=TOTSEC/SIXTY - TOTHR=TOTMN/SIXTY - TOTDY=TOTHR/HRDAY - TOTYR=TOTDY/DAYYR - PERMN=PERSEC/SIXTY - PERHR=PERMN/SIXTY - PERDY=PERHR/HRDAY - PERYR=PERDY/DAYYR -!C -!C5------PRINT TIME STEP LENGTH AND ELAPSED TIMES IN ALL TIME UNITS. - WRITE(IOUT,200) - 200 FORMAT(19X,' SECONDS MINUTES HOURS',7X, & - & 'DAYS YEARS'/20X,59('-')) - write(IOUT,201) DELSEC,DELMN,DELHR,DELDY,DELYR - 201 FORMAT(1X,' TIME STEP LENGTH',1P,5G12.5) - WRITE(IOUT,202) PERSEC,PERMN,PERHR,PERDY,PERYR - 202 FORMAT(1X,'STRESS PERIOD TIME',1P,5G12.5) - WRITE(IOUT,203) TOTSEC,TOTMN,TOTHR,TOTDY,TOTYR - 203 FORMAT(1X,' TOTAL TIME',1P,5G12.5,/) -!C -!C6------RETURN - RETURN - END subroutine tdis_ot - - subroutine tdis_da() -! ****************************************************************************** -! tdis_da -- deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use MemoryManagerModule, only: mem_deallocate -! ------------------------------------------------------------------------------ - ! - ! -- Scalars - call mem_deallocate(nper) - call mem_deallocate(itmuni) - call mem_deallocate(kper) - call mem_deallocate(kstp) - call mem_deallocate(readnewdata) - call mem_deallocate(endofperiod) - call mem_deallocate(endofsimulation) - call mem_deallocate(delt) - call mem_deallocate(pertim) - call mem_deallocate(totim) - call mem_deallocate(totimc) - call mem_deallocate(deltsav) - call mem_deallocate(totimsav) - call mem_deallocate(pertimsav) - call mem_deallocate(totalsimtime) - ! - ! -- strings - deallocate(datetime0) - ! - ! -- Arrays - call mem_deallocate(perlen) - call mem_deallocate(nstp) - call mem_deallocate(tsmult) - ! - ! -- Return - return - end subroutine tdis_da - - - subroutine tdis_read_options() -! ****************************************************************************** -! tdis_read_options -- Read the options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error - ! -- dummy - ! -- local - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock - logical :: undspec - ! -- formats - character(len=*), parameter :: fmtitmuni = & - "(4x,'SIMULATION TIME UNIT IS ',A)" - character(len=*), parameter :: fmtdatetime0 = & - "(4x,'SIMULATION STARTING DATE AND TIME IS ',A)" - !data -! ------------------------------------------------------------------------------ - ! - ! -- set variables - itmuni = 0 - undspec = .false. - ! - ! -- get options block - call parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) - ! - ! -- parse options block if detected - if (isfound) then - write(iout,'(1x,a)')'PROCESSING TDIS OPTIONS' - do - call parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call parser%GetStringCaps(keyword) - select case (keyword) - case ('TIME_UNITS') - call parser%GetStringCaps(keyword) - select case (keyword) - case('UNDEFINED') - itmuni = 0 - write(iout, fmtitmuni) 'UNDEFINED' - undspec = .true. - case('SECONDS') - itmuni = 1 - write(iout, fmtitmuni) 'SECONDS' - case('MINUTES') - itmuni = 2 - write(iout, fmtitmuni) 'MINUTES' - case('HOURS') - itmuni = 3 - write(iout, fmtitmuni) 'HOURS' - case('DAYS') - itmuni = 4 - write(iout, fmtitmuni) 'DAYS' - case('YEARS') - itmuni = 5 - write(iout, fmtitmuni) 'YEARS' - case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN TIME_UNITS: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - end select - case ('START_DATE_TIME') - call parser%GetString(datetime0) - write(iout, fmtdatetime0) datetime0 - case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN TDIS OPTION: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - end select - end do - write(iout,'(1x,a)') 'END OF TDIS OPTIONS' - end if - ! - ! -- Set to itmuni to undefined if not specified - if(itmuni == 0) then - if(.not. undspec) then - write(iout, fmtitmuni) 'UNDEFINED' - endif - endif - ! - ! -- Return - return - end subroutine tdis_read_options - - subroutine tdis_allocate_scalars() -! ****************************************************************************** -! tdis_read_dimensions -- Read dimension NPER -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - use ConstantsModule, only: DZERO -! ------------------------------------------------------------------------------ - ! - ! -- memory manager variables - call mem_allocate(nper, 'NPER', 'TDIS') - call mem_allocate(itmuni, 'ITMUNI', 'TDIS') - call mem_allocate(kper, 'KPER', 'TDIS') - call mem_allocate(kstp, 'KSTP', 'TDIS') - call mem_allocate(readnewdata, 'READNEWDATA', 'TDIS') - call mem_allocate(endofperiod, 'ENDOFPERIOD', 'TDIS') - call mem_allocate(endofsimulation, 'ENDOFSIMULATION', 'TDIS') - call mem_allocate(delt, 'DELT', 'TDIS') - call mem_allocate(pertim, 'PERTIM', 'TDIS') - call mem_allocate(totim, 'TOTIM', 'TDIS') - call mem_allocate(totimc, 'TOTIMC', 'TDIS') - call mem_allocate(deltsav, 'DELTSAV', 'TDIS') - call mem_allocate(totimsav, 'TOTIMSAV', 'TDIS') - call mem_allocate(pertimsav, 'PERTIMSAV', 'TDIS') - call mem_allocate(totalsimtime, 'TOTALSIMTIME', 'TDIS') - ! - ! -- strings - allocate(datetime0) - ! - ! -- Initialize variables - nper = 0 - itmuni = 0 - kper = 0 - kstp = 0 - readnewdata = .true. - endofperiod = .true. - endofsimulation = .false. - delt = DZERO - pertim = DZERO - totim = DZERO - totimc = DZERO - deltsav = DZERO - totimsav = DZERO - pertimsav = DZERO - totalsimtime = DZERO - datetime0 = '' - ! - ! -- return - return - end subroutine tdis_allocate_scalars - - - subroutine tdis_allocate_arrays() -! ****************************************************************************** -! tdis_allocate_arrays -- Allocate tdis arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate -! ------------------------------------------------------------------------------ - ! - call mem_allocate(perlen, nper, 'PERLEN', 'TDIS') - call mem_allocate(nstp, nper, 'NSTP', 'TDIS') - call mem_allocate(tsmult, nper, 'TSMULT', 'TDIS') - ! - ! -- return - return - end subroutine tdis_allocate_arrays - - subroutine tdis_read_dimensions() -! ****************************************************************************** -! tdis_read_dimensions -- Read dimension NPER -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error - ! -- dummy - ! -- local - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock - ! -- formats - character(len=*), parameter :: fmtnper = & - "(1X,I4,' STRESS PERIOD(S) IN SIMULATION')" - !data -! ------------------------------------------------------------------------------ - ! - ! -- get DIMENSIONS block - call parser%GetBlock('DIMENSIONS', isfound, ierr, & - supportOpenClose=.true.) - ! - ! -- parse block if detected - if (isfound) then - write(iout,'(1x,a)')'PROCESSING TDIS DIMENSIONS' - do - call parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call parser%GetStringCaps(keyword) - select case (keyword) - case ('NPER') - nper = parser%GetInteger() - write(iout, fmtnper) nper - case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN TDIS DIMENSION: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - end select - end do - write(iout,'(1x,a)') 'END OF TDIS DIMENSIONS' - else - write(errmsg,'(1x,a)')'ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.' - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- Return - return - end subroutine tdis_read_dimensions - - subroutine tdis_read_timing() -! ****************************************************************************** -! tdis_read_timing -- Read timing information -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH, DZERO - use SimModule, only: ustop, store_error, count_errors - ! -- dummy - ! -- local - character(len=LINELENGTH) :: errmsg - integer(I4B) :: ierr - integer(I4B) :: n - logical :: isfound, endOfBlock - ! -- formats - character(len=*), parameter :: fmtheader = & - "(1X,//1X,'STRESS PERIOD LENGTH TIME STEPS', & - &' MULTIPLIER FOR DELT',/1X,76('-'))" - character(len=*), parameter :: fmtrow = & - "(1X,I8,1PG21.7,I7,0PF25.3)" -! ------------------------------------------------------------------------------ - ! - ! -- get PERIODDATA block - call parser%GetBlock('PERIODDATA', isfound, ierr, & - supportOpenClose=.true.) - ! - ! -- parse block if detected - if (isfound) then - write(iout,'(1x,a)')'PROCESSING TDIS PERIODDATA' - write(iout, fmtheader) - do n = 1, nper - call parser%GetNextLine(endOfBlock) - perlen(n) = parser%GetDouble() - nstp(n) = parser%GetInteger() - tsmult(n) = parser%GetDouble() - write(iout, fmtrow) n, perlen(n), nstp(n), tsmult(n) - totalsimtime = totalsimtime + perlen(n) - enddo - ! - ! -- Check timing information - call check_tdis_timing(nper, perlen, nstp, tsmult) - call parser%terminateblock() - ! - ! -- Check for errors - if(count_errors() > 0) then - call parser%StoreErrorUnit() - call ustop() - endif - write(iout,'(1x,a)') 'END OF TDIS PERIODDATA' - else - write(errmsg,'(1x,a)')'ERROR. REQUIRED PERIODDATA BLOCK NOT FOUND.' - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- Return - return - end subroutine tdis_read_timing - - subroutine check_tdis_timing(nper, perlen, nstp, tsmult) -! ****************************************************************************** -! check_tdis_timing -- Check the tdis timing information. Return back to -! tdis_read_timing if an error condition is found and let the ustop -! routine be called there instead so the StoreErrorUnit routine can be -! called to assign the correct file name. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH, DZERO, DONE - use SimModule, only: ustop, store_error, count_errors - ! -- dummy - integer(I4B), intent(in) :: nper - real(DP), dimension(:), contiguous, intent(in) :: perlen - integer(I4B), dimension(:), contiguous, intent(in) :: nstp - real(DP), dimension(:), contiguous, intent(in) :: tsmult - ! -- local - integer(I4B) :: kper, kstp - real(DP) :: tstart, tend, dt - character(len=LINELENGTH) :: errmsg - ! -- formats - character(len=*), parameter :: fmtpwarn = & - &"(1X,/1X,'PERLEN IS ZERO FOR STRESS PERIOD ', I0, & - &'. PERLEN MUST NOT BE ZERO FOR TRANSIENT PERIODS.')" - character(len=*), parameter :: fmtsperror = & - &"(A,' FOR STRESS PERIOD ', I0)" - character(len=*), parameter :: fmtdterror = & - &"('TIME STEP LENGTH OF ', G0, ' IS TOO SMALL IN PERIOD ', I0, & - &' AND TIME STEP ', I0)" -! ------------------------------------------------------------------------------ - ! - ! -- Initialize - tstart = DZERO - ! - ! -- Go through and check each stress period - do kper = 1, nper - ! - ! -- Error if nstp less than or equal to zero - if(nstp(kper) <= 0) then - write(errmsg, fmtsperror) 'NUMBER OF TIME STEPS LESS THAN ONE ', kper - call store_error(errmsg) - return - end if - ! - ! -- Warn if perlen is zero - if(perlen(kper) == DZERO) then - write(iout, fmtpwarn) kper - return - end if - ! - ! -- Error if tsmult is less than zero - if(tsmult(kper) <= DZERO) then - write(errmsg, fmtsperror) 'TSMULT MUST BE GREATER THAN 0.0 ', kper - call store_error(errmsg) - return - end if - ! - ! -- Error if negative period length - if(perlen(kper) < DZERO) then - write(errmsg, fmtsperror) 'PERLEN CANNOT BE LESS THAN 0.0 ', kper - call store_error(errmsg) - return - end if - ! - ! -- Go through all time step lengths and make sure they are valid - do kstp = 1, nstp(kper) - if (kstp == 1) then - dt = perlen(kper) / float(nstp(kper)) - if(tsmult(kper) /= DONE) & - dt = perlen(kper) * (DONE-tsmult(kper)) / & - (DONE - tsmult(kper) ** nstp(kper)) - else - dt = dt * tsmult(kper) - endif - tend = tstart + dt - ! - ! -- Error condition if tstart == tend - if (tstart == tend) then - write(errmsg, fmtdterror) dt, kper, kstp - call store_error(errmsg) - return - endif - enddo - ! - ! -- reset tstart = tend - tstart = tend - ! - enddo - ! -- Return - return - end subroutine check_tdis_timing - - subroutine subtiming_begin(isubtime, nsubtimes, idsolution) -! ****************************************************************************** -! subtiming_begin -- start subtiming -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - integer(I4B), intent(in) :: isubtime - integer(I4B), intent(in) :: nsubtimes - integer(I4B), intent(in) :: idsolution - ! -- formats - character(len=*), parameter :: fmtsub = "(a, i0, a, a, i0, a, i0, a)" - character(len=*), parameter :: fmtdelt = "(a, i0, a, 1pg15.6)" -! ------------------------------------------------------------------------------ - ! - ! -- Save and calculate delt if first subtimestep - if(isubtime == 1) then - deltsav = delt - delt = delt / nsubtimes - else - totimc = totimc + delt - endif - ! - ! -- Write message - if(nsubtimes > 1) then - write(iout, fmtsub) 'SOLUTION ID (', idsolution, '): ', & - 'SUB-TIMESTEP ', isubtime, ' OF ', nsubtimes, ' TOTAL' - write(iout, fmtdelt) 'SOLUTION ID (', idsolution, '): DELT = ', delt - endif - ! - ! -- return - return - end subroutine subtiming_begin - - subroutine subtiming_end() -! ****************************************************************************** -! subtiming_end -- start subtiming -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! - ! -- Reset delt to what it was prior to subtiming - delt = deltsav - ! - ! -- return - return - end subroutine subtiming_end - -end module TdisModule - +!stress periods and time stepping is handled by these routines +!convert this to a derived type? May not be necessary since only +!one of them is needed. + + module TdisModule + + use KindModule, only: DP, I4B + use SimVariablesModule, only: iout + use BlockParserModule, only: BlockParserType + use ConstantsModule, only: LINELENGTH, LENDATETIME, VALL + ! + implicit none + ! + private + public :: subtiming_begin + public :: subtiming_end + public :: tdis_cr + public :: tdis_tu + public :: tdis_ot + public :: tdis_da + ! + integer(I4B), public, pointer :: nper !number of stress period + integer(I4B), public, pointer :: itmuni !flag indicating time units + integer(I4B), public, pointer :: kper !current stress period number + integer(I4B), public, pointer :: kstp !current time step number + logical, public, pointer :: readnewdata !flag indicating time to read new data + logical, public, pointer :: endofperiod !flag indicating end of stress period + logical, public, pointer :: endofsimulation !flag indicating end of simulation + real(DP), public, pointer :: delt !length of the current time step + real(DP), public, pointer :: pertim !time relative to start of stress period + real(DP), public, pointer :: totim !time relative to start of simulation + real(DP), public, pointer :: totimc !simulation time at start of time step + real(DP), public, pointer :: deltsav !saved value for delt, used for subtiming + real(DP), public, pointer :: totimsav !saved value for totim, used for subtiming + real(DP), public, pointer :: pertimsav !saved value for pertim, used for subtiming + real(DP), public, pointer :: totalsimtime !time at end of simulation + real(DP), public, dimension(:), pointer, contiguous :: perlen !length of each stress period + integer(I4B), public, dimension(:), pointer, contiguous :: nstp !number of time steps in each stress period + real(DP), public, dimension(:), pointer, contiguous :: tsmult !time step multiplier for each stress period + character(len=LENDATETIME), pointer :: datetime0 !starting date and time for the simulation + ! + type(BlockParserType), private :: parser + + contains + + subroutine tdis_cr(fname) +! ****************************************************************************** +! tdis_cr -- create temporal discretization. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: getunit, openfile + use ConstantsModule, only: LINELENGTH, DZERO + ! -- dummy + character(len=*),intent(in) :: fname + ! -- local + integer(I4B) :: inunit + ! -- formats + character(len=*),parameter :: fmtheader = & + "(1X,/1X,'TDIS -- TEMPORAL DISCRETIZATION PACKAGE,', / & + &' VERSION 1 : 11/13/2014 - INPUT READ FROM UNIT ',I4)" +! ------------------------------------------------------------------------------ + ! + ! -- Allocate the scalar variables + call tdis_allocate_scalars() + ! + ! -- Get a unit number for tdis and open the file if it is not opened + inquire(file=fname, number=inunit) + if(inunit < 0) then + inunit = getunit() + call openfile(inunit, iout, fname, 'TDIS') + endif + ! + ! -- Identify package + write(iout, fmtheader) inunit + ! + ! -- Initialize block parser + call parser%Initialize(inunit, iout) + ! + ! -- Read options + call tdis_read_options() + ! + ! -- Read dimensions and then allocate arrays + call tdis_read_dimensions() + call tdis_allocate_arrays() + ! + ! -- Read timing + call tdis_read_timing() + ! + ! -- Close the file + call parser%Clear() + ! + ! -- return + return + end subroutine tdis_cr + + subroutine tdis_tu() +! ****************************************************************************** +! tdis_tu -- Time Update. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DONE, DZERO + use GenericUtilitiesModule, only: sim_message + ! -- local + character(len=LINELENGTH) :: line + ! -- formats + character(len=*),parameter :: fmtspi = & + "('1',/28X,'STRESS PERIOD NO. ',I4,', LENGTH =',G15.7,/ & + &28X,47('-'),// & + &30X,'NUMBER OF TIME STEPS =',I6,// & + &31X,'MULTIPLIER FOR DELT =',F10.3)" + character(len=*),parameter :: fmttsi = & + "(1X,/28X,'INITIAL TIME STEP SIZE =',G15.7)" + character(len=*),parameter :: fmtspts = & + "(' Solving: Stress period: ',i5,4x,'Time step: ',i5,4x)" +! ------------------------------------------------------------------------------ + ! + ! -- Increment kstp and kper + if(endofperiod) then + kstp = 1 + kper = kper + 1 + else + kstp = kstp + 1 + endif + ! + ! -- Set readnewdata to .false. and change if new stress period + readnewdata = .false. + ! + ! -- Setup new stress period if kstp is 1 + if(kstp == 1) then + ! + ! -- Write stress period information to simulation list file + write(iout,fmtspi) kper, perlen(kper), nstp(kper), tsmult(kper) + ! + ! -- Calculate the first value of delt for this stress period + delt = perlen(kper) / float(nstp(kper)) + if(tsmult(kper) /= DONE) & + delt = perlen(kper) * (DONE-tsmult(kper)) / & + (DONE - tsmult(kper) ** nstp(kper)) + ! + ! -- Print length of first time step + write(iout, fmttsi) delt + ! + ! -- Initialize pertim (Elapsed time within stress period) + pertim = DZERO + ! + ! -- Clear flag that indicates last time step of a stress period + endofperiod = .false. + ! + ! -- Read new data + readnewdata = .true. + ! + endif + ! + ! -- Calculate delt for kstp > 1 + if(kstp /= 1) delt = tsmult(kper) * delt + ! + ! -- Print stress period and time step to console + write(line, fmtspts) kper, kstp + call sim_message(line, level=VALL) + ! + ! -- Store totim and pertim, which are times at end of previous time step + totimsav = totim + pertimsav = pertim + totimc = totim + ! + ! -- Update totim and pertim + totim = totimsav + delt + pertim = pertimsav + delt + ! + ! -- End of stress period and/or simulation? + if(kstp == nstp(kper)) endofperiod = .true. + if(endofperiod .and. kper==nper) then + endofsimulation = .true. + totim = totalsimtime + end if + ! + ! -- return + return + end subroutine tdis_tu + + subroutine tdis_ot(iout) +! ****************************************************************************** +! PRINT SIMULATION TIME +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + integer(I4B), intent(in) :: iout + ! -- local + real(DP) :: zero,cnv,delsec,totsec,persec,sixty,hrday,dayyr, & + delmn,delhr,totmn,tothr,totdy,totyr,permn,perhr,perdy, & + peryr,deldy,delyr +! ------------------------------------------------------------------------------ + WRITE(IOUT,199) KSTP,KPER + 199 FORMAT(1X,///9X,'TIME SUMMARY AT END OF TIME STEP',I5, & + & ' IN STRESS PERIOD ',I4) +!C +!C1------USE TIME UNIT INDICATOR TO GET FACTOR TO CONVERT TO SECONDS. + ZERO=0.d0 + CNV=ZERO + IF(ITMUNI.EQ.1) CNV=1. + IF(ITMUNI.EQ.2) CNV=60. + IF(ITMUNI.EQ.3) CNV=3600. + IF(ITMUNI.EQ.4) CNV=86400. + IF(ITMUNI.EQ.5) CNV=31557600. +!C +!C2------IF FACTOR=0 THEN TIME UNITS ARE NON-STANDARD. + IF(CNV.NE.ZERO) GO TO 100 +!C +!C2A-----PRINT TIMES IN NON-STANDARD TIME UNITS. + WRITE(IOUT,301) DELT,PERTIM,TOTIM + 301 FORMAT(21X,' TIME STEP LENGTH =',G15.6/ & + & 21X,' STRESS PERIOD TIME =',G15.6/ & + & 21X,'TOTAL SIMULATION TIME =',G15.6) +!C +!C2B-----RETURN + RETURN +!C +!C3------CALCULATE LENGTH OF TIME STEP & ELAPSED TIMES IN SECONDS. + 100 DELSEC=CNV*DELT + TOTSEC=CNV*TOTIM + PERSEC=CNV*PERTIM +!C +!C4------CALCULATE TIMES IN MINUTES,HOURS,DAYS AND YEARS. + SIXTY=60. + HRDAY=24. + DAYYR=365.25 + DELMN=DELSEC/SIXTY + DELHR=DELMN/SIXTY + DELDY=DELHR/HRDAY + DELYR=DELDY/DAYYR + TOTMN=TOTSEC/SIXTY + TOTHR=TOTMN/SIXTY + TOTDY=TOTHR/HRDAY + TOTYR=TOTDY/DAYYR + PERMN=PERSEC/SIXTY + PERHR=PERMN/SIXTY + PERDY=PERHR/HRDAY + PERYR=PERDY/DAYYR +!C +!C5------PRINT TIME STEP LENGTH AND ELAPSED TIMES IN ALL TIME UNITS. + WRITE(IOUT,200) + 200 FORMAT(19X,' SECONDS MINUTES HOURS',7X, & + & 'DAYS YEARS'/20X,59('-')) + write(IOUT,201) DELSEC,DELMN,DELHR,DELDY,DELYR + 201 FORMAT(1X,' TIME STEP LENGTH',1P,5G12.5) + WRITE(IOUT,202) PERSEC,PERMN,PERHR,PERDY,PERYR + 202 FORMAT(1X,'STRESS PERIOD TIME',1P,5G12.5) + WRITE(IOUT,203) TOTSEC,TOTMN,TOTHR,TOTDY,TOTYR + 203 FORMAT(1X,' TOTAL TIME',1P,5G12.5,/) +!C +!C6------RETURN + RETURN + END subroutine tdis_ot + + subroutine tdis_da() +! ****************************************************************************** +! tdis_da -- deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use MemoryManagerModule, only: mem_deallocate +! ------------------------------------------------------------------------------ + ! + ! -- Scalars + call mem_deallocate(nper) + call mem_deallocate(itmuni) + call mem_deallocate(kper) + call mem_deallocate(kstp) + call mem_deallocate(readnewdata) + call mem_deallocate(endofperiod) + call mem_deallocate(endofsimulation) + call mem_deallocate(delt) + call mem_deallocate(pertim) + call mem_deallocate(totim) + call mem_deallocate(totimc) + call mem_deallocate(deltsav) + call mem_deallocate(totimsav) + call mem_deallocate(pertimsav) + call mem_deallocate(totalsimtime) + ! + ! -- strings + deallocate(datetime0) + ! + ! -- Arrays + call mem_deallocate(perlen) + call mem_deallocate(nstp) + call mem_deallocate(tsmult) + ! + ! -- Return + return + end subroutine tdis_da + + + subroutine tdis_read_options() +! ****************************************************************************** +! tdis_read_options -- Read the options +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error + ! -- dummy + ! -- local + character(len=LINELENGTH) :: errmsg, keyword + integer(I4B) :: ierr + logical :: isfound, endOfBlock + logical :: undspec + ! -- formats + character(len=*), parameter :: fmtitmuni = & + "(4x,'SIMULATION TIME UNIT IS ',A)" + character(len=*), parameter :: fmtdatetime0 = & + "(4x,'SIMULATION STARTING DATE AND TIME IS ',A)" + !data +! ------------------------------------------------------------------------------ + ! + ! -- set variables + itmuni = 0 + undspec = .false. + ! + ! -- get options block + call parser%GetBlock('OPTIONS', isfound, ierr, & + supportOpenClose=.true., blockRequired=.false.) + ! + ! -- parse options block if detected + if (isfound) then + write(iout,'(1x,a)')'PROCESSING TDIS OPTIONS' + do + call parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call parser%GetStringCaps(keyword) + select case (keyword) + case ('TIME_UNITS') + call parser%GetStringCaps(keyword) + select case (keyword) + case('UNDEFINED') + itmuni = 0 + write(iout, fmtitmuni) 'UNDEFINED' + undspec = .true. + case('SECONDS') + itmuni = 1 + write(iout, fmtitmuni) 'SECONDS' + case('MINUTES') + itmuni = 2 + write(iout, fmtitmuni) 'MINUTES' + case('HOURS') + itmuni = 3 + write(iout, fmtitmuni) 'HOURS' + case('DAYS') + itmuni = 4 + write(iout, fmtitmuni) 'DAYS' + case('YEARS') + itmuni = 5 + write(iout, fmtitmuni) 'YEARS' + case default + write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN TIME_UNITS: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + end select + case ('START_DATE_TIME') + call parser%GetString(datetime0) + write(iout, fmtdatetime0) datetime0 + case default + write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN TDIS OPTION: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + end select + end do + write(iout,'(1x,a)') 'END OF TDIS OPTIONS' + end if + ! + ! -- Set to itmuni to undefined if not specified + if(itmuni == 0) then + if(.not. undspec) then + write(iout, fmtitmuni) 'UNDEFINED' + endif + endif + ! + ! -- Return + return + end subroutine tdis_read_options + + subroutine tdis_allocate_scalars() +! ****************************************************************************** +! tdis_read_dimensions -- Read dimension NPER +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + use ConstantsModule, only: DZERO +! ------------------------------------------------------------------------------ + ! + ! -- memory manager variables + call mem_allocate(nper, 'NPER', 'TDIS') + call mem_allocate(itmuni, 'ITMUNI', 'TDIS') + call mem_allocate(kper, 'KPER', 'TDIS') + call mem_allocate(kstp, 'KSTP', 'TDIS') + call mem_allocate(readnewdata, 'READNEWDATA', 'TDIS') + call mem_allocate(endofperiod, 'ENDOFPERIOD', 'TDIS') + call mem_allocate(endofsimulation, 'ENDOFSIMULATION', 'TDIS') + call mem_allocate(delt, 'DELT', 'TDIS') + call mem_allocate(pertim, 'PERTIM', 'TDIS') + call mem_allocate(totim, 'TOTIM', 'TDIS') + call mem_allocate(totimc, 'TOTIMC', 'TDIS') + call mem_allocate(deltsav, 'DELTSAV', 'TDIS') + call mem_allocate(totimsav, 'TOTIMSAV', 'TDIS') + call mem_allocate(pertimsav, 'PERTIMSAV', 'TDIS') + call mem_allocate(totalsimtime, 'TOTALSIMTIME', 'TDIS') + ! + ! -- strings + allocate(datetime0) + ! + ! -- Initialize variables + nper = 0 + itmuni = 0 + kper = 0 + kstp = 0 + readnewdata = .true. + endofperiod = .true. + endofsimulation = .false. + delt = DZERO + pertim = DZERO + totim = DZERO + totimc = DZERO + deltsav = DZERO + totimsav = DZERO + pertimsav = DZERO + totalsimtime = DZERO + datetime0 = '' + ! + ! -- return + return + end subroutine tdis_allocate_scalars + + + subroutine tdis_allocate_arrays() +! ****************************************************************************** +! tdis_allocate_arrays -- Allocate tdis arrays +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate +! ------------------------------------------------------------------------------ + ! + call mem_allocate(perlen, nper, 'PERLEN', 'TDIS') + call mem_allocate(nstp, nper, 'NSTP', 'TDIS') + call mem_allocate(tsmult, nper, 'TSMULT', 'TDIS') + ! + ! -- return + return + end subroutine tdis_allocate_arrays + + subroutine tdis_read_dimensions() +! ****************************************************************************** +! tdis_read_dimensions -- Read dimension NPER +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error + ! -- dummy + ! -- local + character(len=LINELENGTH) :: errmsg, keyword + integer(I4B) :: ierr + logical :: isfound, endOfBlock + ! -- formats + character(len=*), parameter :: fmtnper = & + "(1X,I4,' STRESS PERIOD(S) IN SIMULATION')" + !data +! ------------------------------------------------------------------------------ + ! + ! -- get DIMENSIONS block + call parser%GetBlock('DIMENSIONS', isfound, ierr, & + supportOpenClose=.true.) + ! + ! -- parse block if detected + if (isfound) then + write(iout,'(1x,a)')'PROCESSING TDIS DIMENSIONS' + do + call parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call parser%GetStringCaps(keyword) + select case (keyword) + case ('NPER') + nper = parser%GetInteger() + write(iout, fmtnper) nper + case default + write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN TDIS DIMENSION: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + end select + end do + write(iout,'(1x,a)') 'END OF TDIS DIMENSIONS' + else + write(errmsg,'(1x,a)')'ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.' + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- Return + return + end subroutine tdis_read_dimensions + + subroutine tdis_read_timing() +! ****************************************************************************** +! tdis_read_timing -- Read timing information +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH, DZERO + use SimModule, only: ustop, store_error, count_errors + ! -- dummy + ! -- local + character(len=LINELENGTH) :: errmsg + integer(I4B) :: ierr + integer(I4B) :: n + logical :: isfound, endOfBlock + ! -- formats + character(len=*), parameter :: fmtheader = & + "(1X,//1X,'STRESS PERIOD LENGTH TIME STEPS', & + &' MULTIPLIER FOR DELT',/1X,76('-'))" + character(len=*), parameter :: fmtrow = & + "(1X,I8,1PG21.7,I7,0PF25.3)" +! ------------------------------------------------------------------------------ + ! + ! -- get PERIODDATA block + call parser%GetBlock('PERIODDATA', isfound, ierr, & + supportOpenClose=.true.) + ! + ! -- parse block if detected + if (isfound) then + write(iout,'(1x,a)')'PROCESSING TDIS PERIODDATA' + write(iout, fmtheader) + do n = 1, nper + call parser%GetNextLine(endOfBlock) + perlen(n) = parser%GetDouble() + nstp(n) = parser%GetInteger() + tsmult(n) = parser%GetDouble() + write(iout, fmtrow) n, perlen(n), nstp(n), tsmult(n) + totalsimtime = totalsimtime + perlen(n) + enddo + ! + ! -- Check timing information + call check_tdis_timing(nper, perlen, nstp, tsmult) + call parser%terminateblock() + ! + ! -- Check for errors + if(count_errors() > 0) then + call parser%StoreErrorUnit() + call ustop() + endif + write(iout,'(1x,a)') 'END OF TDIS PERIODDATA' + else + write(errmsg,'(1x,a)')'ERROR. REQUIRED PERIODDATA BLOCK NOT FOUND.' + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- Return + return + end subroutine tdis_read_timing + + subroutine check_tdis_timing(nper, perlen, nstp, tsmult) +! ****************************************************************************** +! check_tdis_timing -- Check the tdis timing information. Return back to +! tdis_read_timing if an error condition is found and let the ustop +! routine be called there instead so the StoreErrorUnit routine can be +! called to assign the correct file name. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH, DZERO, DONE + use SimModule, only: ustop, store_error, count_errors + ! -- dummy + integer(I4B), intent(in) :: nper + real(DP), dimension(:), contiguous, intent(in) :: perlen + integer(I4B), dimension(:), contiguous, intent(in) :: nstp + real(DP), dimension(:), contiguous, intent(in) :: tsmult + ! -- local + integer(I4B) :: kper, kstp + real(DP) :: tstart, tend, dt + character(len=LINELENGTH) :: errmsg + ! -- formats + character(len=*), parameter :: fmtpwarn = & + &"(1X,/1X,'PERLEN IS ZERO FOR STRESS PERIOD ', I0, & + &'. PERLEN MUST NOT BE ZERO FOR TRANSIENT PERIODS.')" + character(len=*), parameter :: fmtsperror = & + &"(A,' FOR STRESS PERIOD ', I0)" + character(len=*), parameter :: fmtdterror = & + &"('TIME STEP LENGTH OF ', G0, ' IS TOO SMALL IN PERIOD ', I0, & + &' AND TIME STEP ', I0)" +! ------------------------------------------------------------------------------ + ! + ! -- Initialize + tstart = DZERO + ! + ! -- Go through and check each stress period + do kper = 1, nper + ! + ! -- Error if nstp less than or equal to zero + if(nstp(kper) <= 0) then + write(errmsg, fmtsperror) 'NUMBER OF TIME STEPS LESS THAN ONE ', kper + call store_error(errmsg) + return + end if + ! + ! -- Warn if perlen is zero + if(perlen(kper) == DZERO) then + write(iout, fmtpwarn) kper + return + end if + ! + ! -- Error if tsmult is less than zero + if(tsmult(kper) <= DZERO) then + write(errmsg, fmtsperror) 'TSMULT MUST BE GREATER THAN 0.0 ', kper + call store_error(errmsg) + return + end if + ! + ! -- Error if negative period length + if(perlen(kper) < DZERO) then + write(errmsg, fmtsperror) 'PERLEN CANNOT BE LESS THAN 0.0 ', kper + call store_error(errmsg) + return + end if + ! + ! -- Go through all time step lengths and make sure they are valid + do kstp = 1, nstp(kper) + if (kstp == 1) then + dt = perlen(kper) / float(nstp(kper)) + if(tsmult(kper) /= DONE) & + dt = perlen(kper) * (DONE-tsmult(kper)) / & + (DONE - tsmult(kper) ** nstp(kper)) + else + dt = dt * tsmult(kper) + endif + tend = tstart + dt + ! + ! -- Error condition if tstart == tend + if (tstart == tend) then + write(errmsg, fmtdterror) dt, kper, kstp + call store_error(errmsg) + return + endif + enddo + ! + ! -- reset tstart = tend + tstart = tend + ! + enddo + ! -- Return + return + end subroutine check_tdis_timing + + subroutine subtiming_begin(isubtime, nsubtimes, idsolution) +! ****************************************************************************** +! subtiming_begin -- start subtiming +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + integer(I4B), intent(in) :: isubtime + integer(I4B), intent(in) :: nsubtimes + integer(I4B), intent(in) :: idsolution + ! -- formats + character(len=*), parameter :: fmtsub = "(a, i0, a, a, i0, a, i0, a)" + character(len=*), parameter :: fmtdelt = "(a, i0, a, 1pg15.6)" +! ------------------------------------------------------------------------------ + ! + ! -- Save and calculate delt if first subtimestep + if(isubtime == 1) then + deltsav = delt + delt = delt / nsubtimes + else + totimc = totimc + delt + endif + ! + ! -- Write message + if(nsubtimes > 1) then + write(iout, fmtsub) 'SOLUTION ID (', idsolution, '): ', & + 'SUB-TIMESTEP ', isubtime, ' OF ', nsubtimes, ' TOTAL' + write(iout, fmtdelt) 'SOLUTION ID (', idsolution, '): DELT = ', delt + endif + ! + ! -- return + return + end subroutine subtiming_begin + + subroutine subtiming_end() +! ****************************************************************************** +! subtiming_end -- start subtiming +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! + ! -- Reset delt to what it was prior to subtiming + delt = deltsav + ! + ! -- return + return + end subroutine subtiming_end + +end module TdisModule + diff --git a/src/Utilities/ArrayHandlers.f90 b/src/Utilities/ArrayHandlers.f90 index 97f07fdc8e8..38bb5cf96ea 100644 --- a/src/Utilities/ArrayHandlers.f90 +++ b/src/Utilities/ArrayHandlers.f90 @@ -1,374 +1,374 @@ -module ArrayHandlersModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH, MAXCHARLEN - use SimVariablesModule, only: iout - use GenericUtilitiesModule, only: sim_message, stop_with_error - private - public :: ExpandArray, ExtendPtrArray - public :: ifind - public :: remove_character - - interface ExpandArray - ! This interface is for use with ALLOCATABLE arrays. - ! IMPORTANT: Do not use pointers to elements of arrays when using - ! ExpandArray to increase the array size! The locations of array - ! elements in memory are changed when ExpandArray is invoked. - module procedure expand_integer, expand_double, & - expand_character !, expand_real - end interface ExpandArray - - interface ExtendPtrArray - ! This interface is for use with POINTERS to arrays. - module procedure extend_double, extend_integer - end interface - - interface ifind - module procedure ifind_character, ifind_integer - end interface ifind - -contains - - ! -- Specific procedures that implement ExpandArray for allocatable arrays - - subroutine expand_integer(array, increment) - implicit none - ! -- dummy - integer(I4B), allocatable, intent(inout) :: array(:) - integer(I4B), optional, intent(in) :: increment - ! -- local - integer(I4B) :: inclocal, isize, newsize - integer(I4B), allocatable, dimension(:) :: array_temp - ! - ! -- initialize - if (present(increment)) then - inclocal = increment - else - inclocal = 1 - endif - ! - ! -- increase size of array by inclocal, retaining - ! contained data - if (allocated(array)) then - isize = size(array) - newsize = isize + inclocal - allocate(array_temp(newsize)) - array_temp(1:isize) = array - deallocate(array) - call move_alloc(array_temp, array) - else - allocate(array(inclocal)) - endif - ! - return - end subroutine expand_integer - - subroutine expand_double(array, increment) - implicit none - ! -- dummy - real(DP), allocatable, intent(inout) :: array(:) - integer(I4B), optional, intent(in) :: increment - ! -- local - integer(I4B) :: inclocal, isize, newsize - real(DP), allocatable, dimension(:) :: array_temp - ! - ! -- initialize - if (present(increment)) then - inclocal = increment - else - inclocal = 1 - endif - ! - ! -- increase size of array by inclocal, retaining - ! contained data - if (allocated(array)) then - isize = size(array) - newsize = isize + inclocal - allocate(array_temp(newsize)) - array_temp(1:isize) = array - deallocate(array) - call move_alloc(array_temp, array) - else - allocate(array(inclocal)) - endif - ! - return - end subroutine expand_double - - subroutine expand_character(array, increment) - implicit none - ! -- dummy - character(len=*), allocatable, intent(inout) :: array(:) - integer(I4B), optional, intent(in) :: increment - ! -- local - character(len=LINELENGTH) :: line - character(len=MAXCHARLEN), allocatable, dimension(:) :: array_temp - integer(I4B) :: i, inclocal, isize, lenc, newsize - ! -- format - character(len=*), parameter :: stdfmt = "(/,'ERROR REPORT:',/,1x,a)" - ! - ! -- check character length - lenc = len(array) - if (lenc > MAXCHARLEN) then - write(line, '(a)') 'Error in ArrayHandlersModule: ' // & - 'Need to increase MAXCHARLEN' - call sim_message(line, iunit=iout, fmt=stdfmt) - call sim_message(line, fmt=stdfmt) - ! - ! -- stop message - write(line, '(a)') 'Stopping...' - call sim_message(line, iunit=iout) - call sim_message(line) - call stop_with_error(138) - end if - ! - ! -- initialize - if (present(increment)) then - inclocal = increment - else - inclocal = 1 - endif - ! - ! -- increase size of array by inclocal, retaining - ! contained data - ! [Ned TODO: may be able to use mold here, e.g.: - ! allocate(values(num), mold=proto)] - if (allocated(array)) then - isize = size(array) - newsize = isize + inclocal - allocate(array_temp(isize)) - do i=1,isize - array_temp(i) = array(i) - enddo - deallocate(array) - allocate(array(newsize)) - do i=1,isize - array(i) = array_temp(i) - enddo - do i=isize+1,newsize - array(i) = '' - enddo - deallocate(array_temp) - else - allocate(array(inclocal)) - endif - ! - return - end subroutine expand_character - - ! -- Specific procedures that implement ExtendPtrArray for pointer arrays - - subroutine extend_double(array, increment) - implicit none - ! -- dummy - real(DP), dimension(:), pointer, contiguous, intent(inout) :: array - integer(I4B), optional, intent(in) :: increment - ! -- local - character(len=LINELENGTH) :: line - character(len=100) :: ermsg - integer(I4B) :: i, inclocal, isize, istat, newsize - real(DP), dimension(:), pointer, contiguous :: array_temp => null() - ! -- format - character(len=*), parameter :: stdfmt = "(/,'ERROR REPORT:',/,1x,a)" - ! - ! -- initialize - if (present(increment)) then - inclocal = increment - else - inclocal = 1 - endif - ! - ! -- increase size of array by inclocal, retaining - ! contained data - if (associated(array)) then - isize = size(array) - newsize = isize + inclocal - allocate(array_temp(newsize), stat=istat, errmsg=ermsg) - if (istat /= 0) goto 99 - do i=1,isize - array_temp(i) = array(i) - enddo - deallocate(array) - array => array_temp - else - allocate(array(inclocal)) - endif - ! - ! -- normal return - return - ! - ! -- Error reporting -99 continue - - write(line, '(a)') 'Error in ArrayHandlersModule: ' // & - 'Could not increase array size' - call sim_message(line, iunit=iout, fmt=stdfmt) - call sim_message(line, fmt=stdfmt) - ! - ! -- error message - call sim_message(ermsg, iunit=iout) - call sim_message(ermsg) - ! - ! -- stop message - write(line, '(a)') 'Stopping...' - call sim_message(line, iunit=iout) - call sim_message(line) - call stop_with_error(138) - - end subroutine extend_double - - subroutine extend_integer(array, increment) - implicit none - ! -- dummy - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: array - integer(I4B), optional, intent(in) :: increment - ! -- local - character(len=LINELENGTH) :: line - character(len=100) :: ermsg - integer(I4B) :: i, inclocal, isize, istat, newsize - integer(I4B), dimension(:), pointer, contiguous :: array_temp => null() - ! -- format - character(len=*), parameter :: stdfmt = "(/,'ERROR REPORT:',/,1x,a)" - ! - ! -- initialize - if (present(increment)) then - inclocal = increment - else - inclocal = 1 - endif - ! - ! -- increase size of array by inclocal, retaining - ! contained data - if (associated(array)) then - isize = size(array) - newsize = isize + inclocal - allocate(array_temp(newsize), stat=istat, errmsg=ermsg) - if (istat /= 0) goto 99 - do i=1,isize - array_temp(i) = array(i) - enddo - deallocate(array) - array => array_temp - else - allocate(array(inclocal)) - endif - ! - ! -- normal return - return - ! - ! -- Error reporting -99 continue - - write(line, '(a)') 'Error in ArrayHandlersModule: ' // & - 'Could not increase array size' - call sim_message(line, iunit=iout, fmt=stdfmt) - call sim_message(line, fmt=stdfmt) - ! - ! -- error message - call sim_message(ermsg, iunit=iout) - call sim_message(ermsg) - ! - ! -- stop message - write(line, '(a)') 'Stopping...' - call sim_message(line, iunit=iout) - call sim_message(line) - call stop_with_error(138) - - end subroutine extend_integer - - function ifind_character(array, str) - ! -- Find the first array element containing str - ! -- Return -1 if not found. - implicit none - ! -- return - integer(I4B) :: ifind_character - ! -- dummy - character(len=*), dimension(:) :: array - character(len=*) :: str - ! -- local - integer(I4B) :: i - ifind_character = -1 - findloop: do i=1,size(array) - if(array(i) == str) then - ifind_character = i - exit findloop - endif - enddo findloop - return - end function ifind_character - - function ifind_integer(iarray, ival) - ! -- Find the first array element containing str - ! -- Return -1 if not found. - implicit none - ! -- return - integer(I4B) :: ifind_integer - ! -- dummy - integer(I4B), dimension(:) :: iarray - integer(I4B) :: ival - ! -- local - integer(I4B) :: i - ifind_integer = -1 - findloop: do i = 1, size(iarray) - if(iarray(i) == ival) then - ifind_integer = i - exit findloop - endif - enddo findloop - return - end function ifind_integer - - subroutine remove_character(array, ipos) - !remove the ipos position from array - implicit none - ! -- dummy - character(len=*), allocatable, intent(inout) :: array(:) - integer(I4B), intent(in) :: ipos - ! -- local - character(len=LINELENGTH) :: line - character(len=MAXCHARLEN), allocatable, dimension(:) :: array_temp - integer(I4B) :: i, isize, lenc, newsize, inew - ! -- format - character(len=*), parameter :: stdfmt = "(/,'ERROR REPORT:',/,1x,a)" - ! - ! -- check character length - lenc = len(array) - if (lenc > MAXCHARLEN) then - - write(line, '(a)') 'Error in ArrayHandlersModule: ' // & - 'Need to increase MAXCHARLEN' - call sim_message(line, iunit=iout, fmt=stdfmt) - call sim_message(line, fmt=stdfmt) - ! - ! -- stop message - write(line, '(a)') 'Stopping...' - call sim_message(line, iunit=iout) - call sim_message(line) - call stop_with_error(138) - endif - ! - ! -- calculate sizes - isize = size(array) - newsize = isize - 1 - ! - ! -- copy array to array_temp - allocate(array_temp(isize)) - do i = 1, isize - array_temp(i) = array(i) - enddo - ! - deallocate(array) - allocate(array(newsize)) - inew = 1 - do i = 1, isize - if(i /= ipos) then - array(inew) = array_temp(i) - inew = inew + 1 - endif - enddo - deallocate(array_temp) - ! - return - end subroutine remove_character - -end module ArrayHandlersModule +module ArrayHandlersModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: LINELENGTH, MAXCHARLEN + use SimVariablesModule, only: iout + use GenericUtilitiesModule, only: sim_message, stop_with_error + private + public :: ExpandArray, ExtendPtrArray + public :: ifind + public :: remove_character + + interface ExpandArray + ! This interface is for use with ALLOCATABLE arrays. + ! IMPORTANT: Do not use pointers to elements of arrays when using + ! ExpandArray to increase the array size! The locations of array + ! elements in memory are changed when ExpandArray is invoked. + module procedure expand_integer, expand_double, & + expand_character !, expand_real + end interface ExpandArray + + interface ExtendPtrArray + ! This interface is for use with POINTERS to arrays. + module procedure extend_double, extend_integer + end interface + + interface ifind + module procedure ifind_character, ifind_integer + end interface ifind + +contains + + ! -- Specific procedures that implement ExpandArray for allocatable arrays + + subroutine expand_integer(array, increment) + implicit none + ! -- dummy + integer(I4B), allocatable, intent(inout) :: array(:) + integer(I4B), optional, intent(in) :: increment + ! -- local + integer(I4B) :: inclocal, isize, newsize + integer(I4B), allocatable, dimension(:) :: array_temp + ! + ! -- initialize + if (present(increment)) then + inclocal = increment + else + inclocal = 1 + endif + ! + ! -- increase size of array by inclocal, retaining + ! contained data + if (allocated(array)) then + isize = size(array) + newsize = isize + inclocal + allocate(array_temp(newsize)) + array_temp(1:isize) = array + deallocate(array) + call move_alloc(array_temp, array) + else + allocate(array(inclocal)) + endif + ! + return + end subroutine expand_integer + + subroutine expand_double(array, increment) + implicit none + ! -- dummy + real(DP), allocatable, intent(inout) :: array(:) + integer(I4B), optional, intent(in) :: increment + ! -- local + integer(I4B) :: inclocal, isize, newsize + real(DP), allocatable, dimension(:) :: array_temp + ! + ! -- initialize + if (present(increment)) then + inclocal = increment + else + inclocal = 1 + endif + ! + ! -- increase size of array by inclocal, retaining + ! contained data + if (allocated(array)) then + isize = size(array) + newsize = isize + inclocal + allocate(array_temp(newsize)) + array_temp(1:isize) = array + deallocate(array) + call move_alloc(array_temp, array) + else + allocate(array(inclocal)) + endif + ! + return + end subroutine expand_double + + subroutine expand_character(array, increment) + implicit none + ! -- dummy + character(len=*), allocatable, intent(inout) :: array(:) + integer(I4B), optional, intent(in) :: increment + ! -- local + character(len=LINELENGTH) :: line + character(len=MAXCHARLEN), allocatable, dimension(:) :: array_temp + integer(I4B) :: i, inclocal, isize, lenc, newsize + ! -- format + character(len=*), parameter :: stdfmt = "(/,'ERROR REPORT:',/,1x,a)" + ! + ! -- check character length + lenc = len(array) + if (lenc > MAXCHARLEN) then + write(line, '(a)') 'Error in ArrayHandlersModule: ' // & + 'Need to increase MAXCHARLEN' + call sim_message(line, iunit=iout, fmt=stdfmt) + call sim_message(line, fmt=stdfmt) + ! + ! -- stop message + write(line, '(a)') 'Stopping...' + call sim_message(line, iunit=iout) + call sim_message(line) + call stop_with_error(138) + end if + ! + ! -- initialize + if (present(increment)) then + inclocal = increment + else + inclocal = 1 + endif + ! + ! -- increase size of array by inclocal, retaining + ! contained data + ! [Ned TODO: may be able to use mold here, e.g.: + ! allocate(values(num), mold=proto)] + if (allocated(array)) then + isize = size(array) + newsize = isize + inclocal + allocate(array_temp(isize)) + do i=1,isize + array_temp(i) = array(i) + enddo + deallocate(array) + allocate(array(newsize)) + do i=1,isize + array(i) = array_temp(i) + enddo + do i=isize+1,newsize + array(i) = '' + enddo + deallocate(array_temp) + else + allocate(array(inclocal)) + endif + ! + return + end subroutine expand_character + + ! -- Specific procedures that implement ExtendPtrArray for pointer arrays + + subroutine extend_double(array, increment) + implicit none + ! -- dummy + real(DP), dimension(:), pointer, contiguous, intent(inout) :: array + integer(I4B), optional, intent(in) :: increment + ! -- local + character(len=LINELENGTH) :: line + character(len=100) :: ermsg + integer(I4B) :: i, inclocal, isize, istat, newsize + real(DP), dimension(:), pointer, contiguous :: array_temp => null() + ! -- format + character(len=*), parameter :: stdfmt = "(/,'ERROR REPORT:',/,1x,a)" + ! + ! -- initialize + if (present(increment)) then + inclocal = increment + else + inclocal = 1 + endif + ! + ! -- increase size of array by inclocal, retaining + ! contained data + if (associated(array)) then + isize = size(array) + newsize = isize + inclocal + allocate(array_temp(newsize), stat=istat, errmsg=ermsg) + if (istat /= 0) goto 99 + do i=1,isize + array_temp(i) = array(i) + enddo + deallocate(array) + array => array_temp + else + allocate(array(inclocal)) + endif + ! + ! -- normal return + return + ! + ! -- Error reporting +99 continue + + write(line, '(a)') 'Error in ArrayHandlersModule: ' // & + 'Could not increase array size' + call sim_message(line, iunit=iout, fmt=stdfmt) + call sim_message(line, fmt=stdfmt) + ! + ! -- error message + call sim_message(ermsg, iunit=iout) + call sim_message(ermsg) + ! + ! -- stop message + write(line, '(a)') 'Stopping...' + call sim_message(line, iunit=iout) + call sim_message(line) + call stop_with_error(138) + + end subroutine extend_double + + subroutine extend_integer(array, increment) + implicit none + ! -- dummy + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: array + integer(I4B), optional, intent(in) :: increment + ! -- local + character(len=LINELENGTH) :: line + character(len=100) :: ermsg + integer(I4B) :: i, inclocal, isize, istat, newsize + integer(I4B), dimension(:), pointer, contiguous :: array_temp => null() + ! -- format + character(len=*), parameter :: stdfmt = "(/,'ERROR REPORT:',/,1x,a)" + ! + ! -- initialize + if (present(increment)) then + inclocal = increment + else + inclocal = 1 + endif + ! + ! -- increase size of array by inclocal, retaining + ! contained data + if (associated(array)) then + isize = size(array) + newsize = isize + inclocal + allocate(array_temp(newsize), stat=istat, errmsg=ermsg) + if (istat /= 0) goto 99 + do i=1,isize + array_temp(i) = array(i) + enddo + deallocate(array) + array => array_temp + else + allocate(array(inclocal)) + endif + ! + ! -- normal return + return + ! + ! -- Error reporting +99 continue + + write(line, '(a)') 'Error in ArrayHandlersModule: ' // & + 'Could not increase array size' + call sim_message(line, iunit=iout, fmt=stdfmt) + call sim_message(line, fmt=stdfmt) + ! + ! -- error message + call sim_message(ermsg, iunit=iout) + call sim_message(ermsg) + ! + ! -- stop message + write(line, '(a)') 'Stopping...' + call sim_message(line, iunit=iout) + call sim_message(line) + call stop_with_error(138) + + end subroutine extend_integer + + function ifind_character(array, str) + ! -- Find the first array element containing str + ! -- Return -1 if not found. + implicit none + ! -- return + integer(I4B) :: ifind_character + ! -- dummy + character(len=*), dimension(:) :: array + character(len=*) :: str + ! -- local + integer(I4B) :: i + ifind_character = -1 + findloop: do i=1,size(array) + if(array(i) == str) then + ifind_character = i + exit findloop + endif + enddo findloop + return + end function ifind_character + + function ifind_integer(iarray, ival) + ! -- Find the first array element containing str + ! -- Return -1 if not found. + implicit none + ! -- return + integer(I4B) :: ifind_integer + ! -- dummy + integer(I4B), dimension(:) :: iarray + integer(I4B) :: ival + ! -- local + integer(I4B) :: i + ifind_integer = -1 + findloop: do i = 1, size(iarray) + if(iarray(i) == ival) then + ifind_integer = i + exit findloop + endif + enddo findloop + return + end function ifind_integer + + subroutine remove_character(array, ipos) + !remove the ipos position from array + implicit none + ! -- dummy + character(len=*), allocatable, intent(inout) :: array(:) + integer(I4B), intent(in) :: ipos + ! -- local + character(len=LINELENGTH) :: line + character(len=MAXCHARLEN), allocatable, dimension(:) :: array_temp + integer(I4B) :: i, isize, lenc, newsize, inew + ! -- format + character(len=*), parameter :: stdfmt = "(/,'ERROR REPORT:',/,1x,a)" + ! + ! -- check character length + lenc = len(array) + if (lenc > MAXCHARLEN) then + + write(line, '(a)') 'Error in ArrayHandlersModule: ' // & + 'Need to increase MAXCHARLEN' + call sim_message(line, iunit=iout, fmt=stdfmt) + call sim_message(line, fmt=stdfmt) + ! + ! -- stop message + write(line, '(a)') 'Stopping...' + call sim_message(line, iunit=iout) + call sim_message(line) + call stop_with_error(138) + endif + ! + ! -- calculate sizes + isize = size(array) + newsize = isize - 1 + ! + ! -- copy array to array_temp + allocate(array_temp(isize)) + do i = 1, isize + array_temp(i) = array(i) + enddo + ! + deallocate(array) + allocate(array(newsize)) + inew = 1 + do i = 1, isize + if(i /= ipos) then + array(inew) = array_temp(i) + inew = inew + 1 + endif + enddo + deallocate(array_temp) + ! + return + end subroutine remove_character + +end module ArrayHandlersModule diff --git a/src/Utilities/ArrayReaders.f90 b/src/Utilities/ArrayReaders.f90 index 18aedc1c0d4..841646083b8 100644 --- a/src/Utilities/ArrayReaders.f90 +++ b/src/Utilities/ArrayReaders.f90 @@ -50,7 +50,7 @@ subroutine read_array_int1d(iu, iarr, aname, ndim, jj, iout, k) integer(I4B), intent(in) :: ndim ! dis%ndim integer(I4B), intent(in) :: k ! layer number; 0 to not print ! -- local - integer(I4B) :: iclose, iconst, iprn, j, locat, ncpl, ndig + integer(I4B) :: iclose, iconst, iprn, j, locat, ncpl, ndig integer(I4B) :: nval, nvalt logical :: prowcolnum character(len=100) :: prfmt @@ -96,9 +96,9 @@ subroutine read_array_int1d(iu, iarr, aname, ndim, jj, iout, k) endif else ! -- Read data as binary - locat = -locat - nvalt = 0 - do + locat = -locat + nvalt = 0 + do call read_binary_header(locat, iout, aname, nval) read(locat,iostat=istat,iomsg=ermsgr) (iarr(j), j=nvalt+1, nvalt+nval) if (istat /= 0) then @@ -108,16 +108,16 @@ subroutine read_array_int1d(iu, iarr, aname, ndim, jj, iout, k) call store_error(ermsgr) call store_error_unit(locat) call ustop() - endif - nvalt = nvalt + nval - if (nvalt == size(iarr)) exit - enddo - ! - ! -- multiply array by constant + endif + nvalt = nvalt + nval + if (nvalt == size(iarr)) exit + enddo + ! + ! -- multiply array by constant do j=1,jj iarr(j) = iarr(j) * iconst - enddo - ! + enddo + ! ! -- close the file if (iclose == 1) then close(locat) @@ -144,7 +144,7 @@ subroutine read_array_int2d(iu, iarr, aname, ndim, jj, ii, iout, k) integer(I4B), intent(in) :: ndim ! dis%ndim integer(I4B), intent(in) :: k ! layer number; 0 to not print ! -- local - integer(I4B) :: i, iclose, iconst, iprn, j, locat, ncpl, ndig + integer(I4B) :: i, iclose, iconst, iprn, j, locat, ncpl, ndig integer(I4B) :: nval logical :: prowcolnum character(len=100) :: prfmt @@ -196,7 +196,7 @@ subroutine read_array_int2d(iu, iarr, aname, ndim, jj, ii, iout, k) ! -- Read data as binary locat = -locat call read_binary_header(locat, iout, aname, nval) - do i=1,ii + do i=1,ii read(locat,iostat=istat,iomsg=ermsgr) (iarr(j,i),j=1,jj) if (istat /= 0) then arrname = adjustl(aname) @@ -353,9 +353,9 @@ subroutine read_array_dbl1d(iu, darr, aname, ndim, jj, iout, k) endif else ! -- Read data as binary - locat = -locat - nvalt = 0 - do + locat = -locat + nvalt = 0 + do call read_binary_header(locat, iout, aname, nval) read(locat,iostat=istat,iomsg=ermsgr) (darr(j), j=nvalt+1, nvalt+nval) if (istat /= 0) then @@ -365,16 +365,16 @@ subroutine read_array_dbl1d(iu, darr, aname, ndim, jj, iout, k) call store_error(ermsgr) call store_error_unit(locat) call ustop() - endif - nvalt = nvalt + nval - if (nvalt == size(darr)) exit - enddo - ! - ! -- multiply entire array by constant + endif + nvalt = nvalt + nval + if (nvalt == size(darr)) exit + enddo + ! + ! -- multiply entire array by constant do j = 1, jj darr(j) = darr(j) * cnstnt - enddo - ! + enddo + ! ! -- close the file if (iclose == 1) then close(locat) @@ -401,7 +401,7 @@ subroutine read_array_dbl2d(iu, darr, aname, ndim, jj, ii, iout, k) integer(I4B), intent(in) :: ndim ! dis%ndim integer(I4B), intent(in) :: k ! layer number; 0 to not print ! -- local - integer(I4B) :: i, iclose, iprn, j, locat, ncpl, ndig + integer(I4B) :: i, iclose, iprn, j, locat, ncpl, ndig integer(I4B) :: nval real(DP) :: cnstnt logical :: prowcolnum @@ -454,7 +454,7 @@ subroutine read_array_dbl2d(iu, darr, aname, ndim, jj, ii, iout, k) ! -- Read data as binary locat = -locat call read_binary_header(locat, iout, aname, nval) - do i = 1, ii + do i = 1, ii read(locat,iostat=istat,iomsg=ermsgr) (darr(j,i), j = 1, jj) if (istat /= 0) then arrname = adjustl(aname) @@ -1068,50 +1068,50 @@ subroutine print_array_dbl(darr, aname, iout, jj, ii, k, prfmt, & endif ! return - end subroutine print_array_dbl - - subroutine read_binary_header(locat, iout, arrname, nval) + end subroutine print_array_dbl + + subroutine read_binary_header(locat, iout, arrname, nval) ! -- dummy integer(I4B), intent(in) :: locat - integer(I4B), intent(in) :: iout - character(len=*), intent(in) :: arrname - integer, intent(out) :: nval - ! -- local - integer(I4B) :: istat - integer(I4B) :: kstp, kper, m1, m2, m3 - real(DP) :: pertim, totim - character(len=16) :: text - character(len=MAXCHARLEN) :: ermsg, ermsgr - character(len=*), parameter :: fmthdr = & - "(/,1X,'HEADER FROM BINARY FILE HAS FOLLOWING ENTRIES',& - &/,4X,'KSTP: ',I0,' KPER: ',I0,& - &/,4x,'PERTIM: ',G0,' TOTIM: ',G0,& - &/,4X,'TEXT: ',A,& - &/,4X,'MSIZE 1: ',I0,' MSIZE 2: ',I0,' MSIZE 3: ',I0)" - ! - ! -- Read the header line from the binary file - read(locat, iostat=istat, iomsg=ermsgr) kstp, kper, pertim, totim, text, & - m1, m2, m3 - ! - ! -- Check for errors + integer(I4B), intent(in) :: iout + character(len=*), intent(in) :: arrname + integer, intent(out) :: nval + ! -- local + integer(I4B) :: istat + integer(I4B) :: kstp, kper, m1, m2, m3 + real(DP) :: pertim, totim + character(len=16) :: text + character(len=MAXCHARLEN) :: ermsg, ermsgr + character(len=*), parameter :: fmthdr = & + "(/,1X,'HEADER FROM BINARY FILE HAS FOLLOWING ENTRIES',& + &/,4X,'KSTP: ',I0,' KPER: ',I0,& + &/,4x,'PERTIM: ',G0,' TOTIM: ',G0,& + &/,4X,'TEXT: ',A,& + &/,4X,'MSIZE 1: ',I0,' MSIZE 2: ',I0,' MSIZE 3: ',I0)" + ! + ! -- Read the header line from the binary file + read(locat, iostat=istat, iomsg=ermsgr) kstp, kper, pertim, totim, text, & + m1, m2, m3 + ! + ! -- Check for errors if (istat /= 0) then ermsg = 'Error reading data for array: ' // adjustl(trim(arrname)) call store_error(ermsg) call store_error(ermsgr) call store_error_unit(locat) call ustop() - endif - ! - ! -- Write message about the binary header - if (iout > 0) then - write(iout, fmthdr) kstp, kper, pertim, totim, text, m1, m2, m3 - endif - ! - ! -- Assign the number of values that follow the header - nval = m1 * m2 - ! - ! -- return - return - end subroutine read_binary_header + endif + ! + ! -- Write message about the binary header + if (iout > 0) then + write(iout, fmthdr) kstp, kper, pertim, totim, text, m1, m2, m3 + endif + ! + ! -- Assign the number of values that follow the header + nval = m1 * m2 + ! + ! -- return + return + end subroutine read_binary_header end module ArrayReadersModule diff --git a/src/Utilities/BlockParser.f90 b/src/Utilities/BlockParser.f90 index 16c67b07421..245ffb0c2e9 100644 --- a/src/Utilities/BlockParser.f90 +++ b/src/Utilities/BlockParser.f90 @@ -1,433 +1,433 @@ -module BlockParserModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LENHUGELINE, LINELENGTH, MAXCHARLEN - use VersionModule, only: IDEVELOPMODE - use InputOutputModule, only: uget_block, uget_any_block, uterminate_block, & - u8rdcom, urword, upcase - use SimModule, only: store_error, store_error_unit, ustop - - implicit none - - private - public :: BlockParserType - - type :: BlockParserType - integer(I4B), public :: iuactive ! not used internally, so can be public - integer(I4B), private :: inunit - integer(I4B), private :: iuext - integer(I4B), private :: iout - integer(I4B), private :: linesRead - integer(I4B), private :: lloc - character(len=LINELENGTH), private :: blockName - character(len=LINELENGTH), private :: blockNameFound - character(len=LENHUGELINE), private :: laststring - character(len=LENHUGELINE), private :: line - contains - procedure, public :: Initialize - procedure, public :: Clear - procedure, public :: GetBlock - procedure, public :: GetCellid - procedure, public :: GetCurrentLine - procedure, public :: GetDouble - procedure, public :: GetInteger - procedure, public :: GetLinesRead - procedure, public :: GetNextLine - procedure, public :: GetRemainingLine - procedure, public :: terminateblock - procedure, public :: GetString - procedure, public :: GetStringCaps - procedure, public :: StoreErrorUnit - procedure, public :: DevOpt - procedure, private :: ReadScalarError - end type BlockParserType - -contains - - subroutine Initialize(this, inunit, iout) - ! -- dummy - class(BlockParserType), intent(inout) :: this - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - ! - this%inunit = inunit - this%iuext = inunit - this%iuactive = inunit - this%iout = iout - this%blockName = '' - this%linesRead = 0 - ! - return - end subroutine Initialize - - subroutine Clear(this) - ! Close file(s) and clear member variables - ! -- dummy - class(BlockParserType), intent(inout) :: this - ! -- local - logical :: lop - ! - ! Close any connected files - if (this%inunit > 0) then - inquire(unit=this%inunit, opened=lop) - if (lop) then - close(this%inunit) - endif - endif - ! - if (this%iuext /= this%inunit .and. this%iuext > 0) then - inquire(unit=this%iuext, opened=lop) - if (lop) then - close(this%iuext) - endif - endif - ! - ! Clear all member variables - this%inunit = 0 - this%iuext = 0 - this%iuactive = 0 - this%iout = 0 - this%lloc = 0 - this%linesRead = 0 - this%blockName = '' - this%line = '' - ! - return - end subroutine Clear - - subroutine GetBlock(this, blockName, isFound, ierr, supportOpenClose, & - blockRequired, blockNameFound) - ! -- dummy - class(BlockParserType), intent(inout) :: this - character(len=*), intent(in) :: blockName - logical, intent(out) :: isFound - integer(I4B), intent(out) :: ierr - logical, intent(in), optional :: supportOpenClose ! default false - logical, intent(in), optional :: blockRequired ! default true - character(len=*), intent(inout), optional :: blockNameFound - ! -- local - logical :: continueRead, supportOpenCloseLocal, blockRequiredLocal - ! - if (present(supportOpenClose)) then - supportOpenCloseLocal = supportOpenClose - else - supportOpenCloseLocal = .false. - endif - ! - if (present(blockRequired)) then - blockRequiredLocal = blockRequired - else - blockRequiredLocal = .true. - endif - continueRead = blockRequiredLocal - this%blockName = blockName - this%blockNameFound = '' - ! - if (blockName == '*') then - call uget_any_block(this%inunit, this%iout, isFound, this%lloc, & - this%line, blockNameFound, this%iuext) - if (isFound) then - this%blockNameFound = blockNameFound - ierr = 0 - else - ierr = 1 - endif - else - call uget_block(this%inunit, this%iout, this%blockName, ierr, isFound, & - this%lloc, this%line, this%iuext, continueRead, & - supportOpenCloseLocal) - if (isFound) this%blockNameFound = this%blockName - endif - this%iuactive = this%iuext - this%linesRead = 0 - ! - return - end subroutine GetBlock - - subroutine GetNextLine(this, endOfBlock) - ! -- dummy - class(BlockParserType), intent(inout) :: this - logical, intent(out) :: endOfBlock - ! -- local - integer(I4B) :: ierr, ival - integer(I4B) :: istart, istop - real(DP) :: rval - character(len=10) :: key - character(len=MAXCHARLEN) :: ermsg - logical :: lineread - ! - endOfBlock = .false. - ierr = 0 - lineread = .false. - loop1: do - if (lineread) exit loop1 - call u8rdcom(this%iuext, this%iout, this%line, ierr) - this%lloc = 1 - call urword(this%line, this%lloc, istart, istop, 0, ival, rval, & - this%iout, this%iuext) - key = this%line(istart:istop) - call upcase(key) - if (key == 'END' .or. key == 'BEGIN') then - call uterminate_block(this%inunit, this%iout, key, & - this%blockNameFound, this%lloc, this%line, & - ierr, this%iuext) - this%iuactive = this%iuext - endOfBlock = .true. - lineread = .true. - elseif (key == '') then - ! End of file reached. - ! If this is an OPEN/CLOSE file, close the file and read the next - ! line from this%inunit. - if (this%iuext /= this%inunit) then - close(this%iuext) - this%iuext = this%inunit - this%iuactive = this%inunit - else - ermsg = 'Unexpected end of file reached.' - call store_error(ermsg) - call this%StoreErrorUnit() - call ustop() - endif - else - this%lloc = 1 - this%linesRead = this%linesRead + 1 - lineread = .true. - endif - enddo loop1 - ! - return - end subroutine GetNextLine - - function GetInteger(this) result(i) - ! -- return - integer(I4B) :: i - ! -- dummy - class(BlockParserType), intent(inout) :: this - ! -- local - integer(I4B) :: istart, istop - real(DP) :: rval - ! - call urword(this%line, this%lloc, istart, istop, 2, i, rval, & - this%iout, this%iuext) - ! - ! -- Make sure variable was read before end of line - if (istart == istop .and. istop == len(this%line)) then - call this%ReadScalarError('INTEGER') - endif - ! - return - end function GetInteger - - function GetLinesRead(this) result(nlines) - ! -- return - integer(I4B) :: nlines - ! -- dummy - class(BlockParserType), intent(inout) :: this - ! - nlines = this%linesRead - ! - return - end function GetLinesRead - - function GetDouble(this) result(r) - ! -- return - real(DP) :: R - ! -- dummy - class(BlockParserType), intent(inout) :: this - ! -- local - integer(I4B) :: istart, istop - integer(I4B) :: ival - ! - call urword(this%line, this%lloc, istart, istop, 3, ival, r, & - this%iout, this%iuext) - ! - ! -- Make sure variable was read before end of line - if (istart == istop .and. istop == len(this%line)) then - call this%ReadScalarError('DOUBLE PRECISION') - endif - ! - return - end function GetDouble - - subroutine ReadScalarError(this, vartype) - ! -- dummy - class(BlockParserType), intent(inout) :: this - character(len=*), intent(in) :: vartype - ! -- local - character(len=LINELENGTH) :: errmsg - ! - write(errmsg, '(a, a)') 'Error in block ', trim(this%blockName) - call store_error(errmsg) - write(errmsg, '(a, a, a)') 'Could not read variable of type ', vartype, & - ' from the following line: ' - call store_error(errmsg) - call store_error(trim(adjustl(this%line))) - call this%StoreErrorUnit() - call ustop() - end subroutine ReadScalarError - - subroutine GetString(this, string, convertToUpper) - ! -- dummy - class(BlockParserType), intent(inout) :: this - character(len=*), intent(out) :: string - logical, optional, intent(in) :: convertToUpper ! default false - ! -- local - integer(I4B) :: istart, istop - integer(I4B) :: ival, ncode - real(DP) :: rval - ! - if (present(convertToUpper)) then - if (convertToUpper) then - ncode = 1 - else - ncode = 0 - endif - else - ncode = 0 - endif - ! - call urword(this%line, this%lloc, istart, istop, ncode, & - ival, rval, this%iout, this%iuext) - string = this%line(istart:istop) - this%laststring = this%line(istart:istop) - ! - return - end subroutine GetString - - subroutine GetStringCaps(this, string) - ! -- dummy - class(BlockParserType), intent(inout) :: this - character(len=*), intent(out) :: string - ! - call this%GetString(string, convertToUpper=.true.) - ! - return - end subroutine GetStringCaps - - subroutine GetRemainingLine(this, line) - ! -- dummy - class(BlockParserType), intent(inout) :: this - character(len=*), intent(out) :: line - ! -- local - integer(I4B) :: linelen - ! - linelen = len_trim(this%line) - line = this%line(this%lloc:linelen) - ! - return - end subroutine GetRemainingLine - - subroutine terminateblock(this) - ! -- dummy - class(BlockParserType), intent(inout) :: this - ! -- local - logical :: endofblock - character(len=LINELENGTH) :: errmsg - ! - call this%GetNextLine(endofblock) - if (.not. endofblock) then - errmsg = '****ERROR. LOOKING FOR "END ' // trim(this%blockname) // & - '". FOUND: ' - call store_error(errmsg) - errmsg = '"' // trim(this%line) // '"' - call store_error(errmsg) - call this%StoreErrorUnit() - call ustop() - endif - end subroutine terminateblock - - subroutine GetCellid(this, ndim, cellid, flag_string) - ! -- dummy - class(BlockParserType), intent(inout) :: this - integer(I4B), intent(in) :: ndim - character(len=*), intent(out) :: cellid - logical, optional, intent(in) :: flag_string - ! -- local - integer(I4B) :: i, j, lloc, istart, istop, ival, istat - real(DP) :: rval - character(len=10) :: cint - character(len=100) :: firsttoken - ! format - 10 format(i0) - ! - if (present(flag_string)) then - lloc = this%lloc - call urword(this%line, lloc, istart, istop, 0, ival, rval, this%iout, & - this%iuext) - firsttoken = this%line(istart:istop) - read(firsttoken,*,iostat=istat) ival - if (istat > 0) then - call upcase(firsttoken) - cellid = firsttoken - return - endif - endif - ! - cellid = '' - do i=1,ndim - j = this%GetInteger() - write(cint,10)j - if (i == 1) then - cellid = cint - else - cellid = trim(cellid) // ' ' // cint - endif - enddo - ! - return - end subroutine GetCellid - - subroutine GetCurrentLine(this, line) - ! -- dummy - class(BlockParserType), intent(inout) :: this - character(len=*), intent(out) :: line - ! - line = this%line - ! - return - end subroutine GetCurrentLine - - subroutine StoreErrorUnit(this) - ! -- dummy - class(BlockParserType), intent(inout) :: this - ! - call store_error_unit(this%iuext) - ! - return - end subroutine StoreErrorUnit - - subroutine DevOpt(this) -! ****************************************************************************** -! DevOpt -- development option. This subroutine will cause the program to -! terminate with an error if the IDEVELOPMODE flag is set to 1. This -! is used to allow develop options to be on for development testing but -! not for the public release. For the public release, IDEVELOPMODE is set -! to zero. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(BlockParserType), intent(inout) :: this - ! -- local - character(len=LINELENGTH) :: errmsg - ! -- format - character(len=*), parameter :: fmterr = & - "(4x, 'INVALID KEYWORD **',A,'** DETECTED IN BLOCK **',A,'**')" -! ------------------------------------------------------------------------------ - ! - ! -- If release mode (not develop mode), then option not available. - ! Terminate with an error. - if (IDEVELOPMODE == 0) then - write(errmsg, fmterr) trim(this%laststring), trim(this%blockname) - call store_error(errmsg) - call this%StoreErrorUnit() - call ustop() - endif - ! - ! -- Return - return - end subroutine DevOpt - -end module BlockParserModule +module BlockParserModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: LENHUGELINE, LINELENGTH, MAXCHARLEN + use VersionModule, only: IDEVELOPMODE + use InputOutputModule, only: uget_block, uget_any_block, uterminate_block, & + u8rdcom, urword, upcase + use SimModule, only: store_error, store_error_unit, ustop + + implicit none + + private + public :: BlockParserType + + type :: BlockParserType + integer(I4B), public :: iuactive ! not used internally, so can be public + integer(I4B), private :: inunit + integer(I4B), private :: iuext + integer(I4B), private :: iout + integer(I4B), private :: linesRead + integer(I4B), private :: lloc + character(len=LINELENGTH), private :: blockName + character(len=LINELENGTH), private :: blockNameFound + character(len=LENHUGELINE), private :: laststring + character(len=LENHUGELINE), private :: line + contains + procedure, public :: Initialize + procedure, public :: Clear + procedure, public :: GetBlock + procedure, public :: GetCellid + procedure, public :: GetCurrentLine + procedure, public :: GetDouble + procedure, public :: GetInteger + procedure, public :: GetLinesRead + procedure, public :: GetNextLine + procedure, public :: GetRemainingLine + procedure, public :: terminateblock + procedure, public :: GetString + procedure, public :: GetStringCaps + procedure, public :: StoreErrorUnit + procedure, public :: DevOpt + procedure, private :: ReadScalarError + end type BlockParserType + +contains + + subroutine Initialize(this, inunit, iout) + ! -- dummy + class(BlockParserType), intent(inout) :: this + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + ! + this%inunit = inunit + this%iuext = inunit + this%iuactive = inunit + this%iout = iout + this%blockName = '' + this%linesRead = 0 + ! + return + end subroutine Initialize + + subroutine Clear(this) + ! Close file(s) and clear member variables + ! -- dummy + class(BlockParserType), intent(inout) :: this + ! -- local + logical :: lop + ! + ! Close any connected files + if (this%inunit > 0) then + inquire(unit=this%inunit, opened=lop) + if (lop) then + close(this%inunit) + endif + endif + ! + if (this%iuext /= this%inunit .and. this%iuext > 0) then + inquire(unit=this%iuext, opened=lop) + if (lop) then + close(this%iuext) + endif + endif + ! + ! Clear all member variables + this%inunit = 0 + this%iuext = 0 + this%iuactive = 0 + this%iout = 0 + this%lloc = 0 + this%linesRead = 0 + this%blockName = '' + this%line = '' + ! + return + end subroutine Clear + + subroutine GetBlock(this, blockName, isFound, ierr, supportOpenClose, & + blockRequired, blockNameFound) + ! -- dummy + class(BlockParserType), intent(inout) :: this + character(len=*), intent(in) :: blockName + logical, intent(out) :: isFound + integer(I4B), intent(out) :: ierr + logical, intent(in), optional :: supportOpenClose ! default false + logical, intent(in), optional :: blockRequired ! default true + character(len=*), intent(inout), optional :: blockNameFound + ! -- local + logical :: continueRead, supportOpenCloseLocal, blockRequiredLocal + ! + if (present(supportOpenClose)) then + supportOpenCloseLocal = supportOpenClose + else + supportOpenCloseLocal = .false. + endif + ! + if (present(blockRequired)) then + blockRequiredLocal = blockRequired + else + blockRequiredLocal = .true. + endif + continueRead = blockRequiredLocal + this%blockName = blockName + this%blockNameFound = '' + ! + if (blockName == '*') then + call uget_any_block(this%inunit, this%iout, isFound, this%lloc, & + this%line, blockNameFound, this%iuext) + if (isFound) then + this%blockNameFound = blockNameFound + ierr = 0 + else + ierr = 1 + endif + else + call uget_block(this%inunit, this%iout, this%blockName, ierr, isFound, & + this%lloc, this%line, this%iuext, continueRead, & + supportOpenCloseLocal) + if (isFound) this%blockNameFound = this%blockName + endif + this%iuactive = this%iuext + this%linesRead = 0 + ! + return + end subroutine GetBlock + + subroutine GetNextLine(this, endOfBlock) + ! -- dummy + class(BlockParserType), intent(inout) :: this + logical, intent(out) :: endOfBlock + ! -- local + integer(I4B) :: ierr, ival + integer(I4B) :: istart, istop + real(DP) :: rval + character(len=10) :: key + character(len=MAXCHARLEN) :: ermsg + logical :: lineread + ! + endOfBlock = .false. + ierr = 0 + lineread = .false. + loop1: do + if (lineread) exit loop1 + call u8rdcom(this%iuext, this%iout, this%line, ierr) + this%lloc = 1 + call urword(this%line, this%lloc, istart, istop, 0, ival, rval, & + this%iout, this%iuext) + key = this%line(istart:istop) + call upcase(key) + if (key == 'END' .or. key == 'BEGIN') then + call uterminate_block(this%inunit, this%iout, key, & + this%blockNameFound, this%lloc, this%line, & + ierr, this%iuext) + this%iuactive = this%iuext + endOfBlock = .true. + lineread = .true. + elseif (key == '') then + ! End of file reached. + ! If this is an OPEN/CLOSE file, close the file and read the next + ! line from this%inunit. + if (this%iuext /= this%inunit) then + close(this%iuext) + this%iuext = this%inunit + this%iuactive = this%inunit + else + ermsg = 'Unexpected end of file reached.' + call store_error(ermsg) + call this%StoreErrorUnit() + call ustop() + endif + else + this%lloc = 1 + this%linesRead = this%linesRead + 1 + lineread = .true. + endif + enddo loop1 + ! + return + end subroutine GetNextLine + + function GetInteger(this) result(i) + ! -- return + integer(I4B) :: i + ! -- dummy + class(BlockParserType), intent(inout) :: this + ! -- local + integer(I4B) :: istart, istop + real(DP) :: rval + ! + call urword(this%line, this%lloc, istart, istop, 2, i, rval, & + this%iout, this%iuext) + ! + ! -- Make sure variable was read before end of line + if (istart == istop .and. istop == len(this%line)) then + call this%ReadScalarError('INTEGER') + endif + ! + return + end function GetInteger + + function GetLinesRead(this) result(nlines) + ! -- return + integer(I4B) :: nlines + ! -- dummy + class(BlockParserType), intent(inout) :: this + ! + nlines = this%linesRead + ! + return + end function GetLinesRead + + function GetDouble(this) result(r) + ! -- return + real(DP) :: R + ! -- dummy + class(BlockParserType), intent(inout) :: this + ! -- local + integer(I4B) :: istart, istop + integer(I4B) :: ival + ! + call urword(this%line, this%lloc, istart, istop, 3, ival, r, & + this%iout, this%iuext) + ! + ! -- Make sure variable was read before end of line + if (istart == istop .and. istop == len(this%line)) then + call this%ReadScalarError('DOUBLE PRECISION') + endif + ! + return + end function GetDouble + + subroutine ReadScalarError(this, vartype) + ! -- dummy + class(BlockParserType), intent(inout) :: this + character(len=*), intent(in) :: vartype + ! -- local + character(len=LINELENGTH) :: errmsg + ! + write(errmsg, '(a, a)') 'Error in block ', trim(this%blockName) + call store_error(errmsg) + write(errmsg, '(a, a, a)') 'Could not read variable of type ', vartype, & + ' from the following line: ' + call store_error(errmsg) + call store_error(trim(adjustl(this%line))) + call this%StoreErrorUnit() + call ustop() + end subroutine ReadScalarError + + subroutine GetString(this, string, convertToUpper) + ! -- dummy + class(BlockParserType), intent(inout) :: this + character(len=*), intent(out) :: string + logical, optional, intent(in) :: convertToUpper ! default false + ! -- local + integer(I4B) :: istart, istop + integer(I4B) :: ival, ncode + real(DP) :: rval + ! + if (present(convertToUpper)) then + if (convertToUpper) then + ncode = 1 + else + ncode = 0 + endif + else + ncode = 0 + endif + ! + call urword(this%line, this%lloc, istart, istop, ncode, & + ival, rval, this%iout, this%iuext) + string = this%line(istart:istop) + this%laststring = this%line(istart:istop) + ! + return + end subroutine GetString + + subroutine GetStringCaps(this, string) + ! -- dummy + class(BlockParserType), intent(inout) :: this + character(len=*), intent(out) :: string + ! + call this%GetString(string, convertToUpper=.true.) + ! + return + end subroutine GetStringCaps + + subroutine GetRemainingLine(this, line) + ! -- dummy + class(BlockParserType), intent(inout) :: this + character(len=*), intent(out) :: line + ! -- local + integer(I4B) :: linelen + ! + linelen = len_trim(this%line) + line = this%line(this%lloc:linelen) + ! + return + end subroutine GetRemainingLine + + subroutine terminateblock(this) + ! -- dummy + class(BlockParserType), intent(inout) :: this + ! -- local + logical :: endofblock + character(len=LINELENGTH) :: errmsg + ! + call this%GetNextLine(endofblock) + if (.not. endofblock) then + errmsg = '****ERROR. LOOKING FOR "END ' // trim(this%blockname) // & + '". FOUND: ' + call store_error(errmsg) + errmsg = '"' // trim(this%line) // '"' + call store_error(errmsg) + call this%StoreErrorUnit() + call ustop() + endif + end subroutine terminateblock + + subroutine GetCellid(this, ndim, cellid, flag_string) + ! -- dummy + class(BlockParserType), intent(inout) :: this + integer(I4B), intent(in) :: ndim + character(len=*), intent(out) :: cellid + logical, optional, intent(in) :: flag_string + ! -- local + integer(I4B) :: i, j, lloc, istart, istop, ival, istat + real(DP) :: rval + character(len=10) :: cint + character(len=100) :: firsttoken + ! format + 10 format(i0) + ! + if (present(flag_string)) then + lloc = this%lloc + call urword(this%line, lloc, istart, istop, 0, ival, rval, this%iout, & + this%iuext) + firsttoken = this%line(istart:istop) + read(firsttoken,*,iostat=istat) ival + if (istat > 0) then + call upcase(firsttoken) + cellid = firsttoken + return + endif + endif + ! + cellid = '' + do i=1,ndim + j = this%GetInteger() + write(cint,10)j + if (i == 1) then + cellid = cint + else + cellid = trim(cellid) // ' ' // cint + endif + enddo + ! + return + end subroutine GetCellid + + subroutine GetCurrentLine(this, line) + ! -- dummy + class(BlockParserType), intent(inout) :: this + character(len=*), intent(out) :: line + ! + line = this%line + ! + return + end subroutine GetCurrentLine + + subroutine StoreErrorUnit(this) + ! -- dummy + class(BlockParserType), intent(inout) :: this + ! + call store_error_unit(this%iuext) + ! + return + end subroutine StoreErrorUnit + + subroutine DevOpt(this) +! ****************************************************************************** +! DevOpt -- development option. This subroutine will cause the program to +! terminate with an error if the IDEVELOPMODE flag is set to 1. This +! is used to allow develop options to be on for development testing but +! not for the public release. For the public release, IDEVELOPMODE is set +! to zero. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(BlockParserType), intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + ! -- format + character(len=*), parameter :: fmterr = & + "(4x, 'INVALID KEYWORD **',A,'** DETECTED IN BLOCK **',A,'**')" +! ------------------------------------------------------------------------------ + ! + ! -- If release mode (not develop mode), then option not available. + ! Terminate with an error. + if (IDEVELOPMODE == 0) then + write(errmsg, fmterr) trim(this%laststring), trim(this%blockname) + call store_error(errmsg) + call this%StoreErrorUnit() + call ustop() + endif + ! + ! -- Return + return + end subroutine DevOpt + +end module BlockParserModule diff --git a/src/Utilities/BudgetFileReader.f90 b/src/Utilities/BudgetFileReader.f90 index 30cd7c96561..c7cdbc4c3e5 100644 --- a/src/Utilities/BudgetFileReader.f90 +++ b/src/Utilities/BudgetFileReader.f90 @@ -1,263 +1,263 @@ -module BudgetFileReaderModule - +module BudgetFileReaderModule + use KindModule - use SimModule, only: store_error, store_error_unit, ustop - use ConstantsModule, only: LINELENGTH - - implicit none - - private - public :: BudgetFileReaderType - - type :: BudgetFileReaderType - - logical :: hasimeth1flowja = .false. - integer(I4B) :: inunit - integer(I4B) :: nbudterms - integer(I4B) :: kstp - integer(I4B) :: kper - integer(I4B) :: kstpnext - integer(I4B) :: kpernext - logical :: endoffile - character(len=16) :: budtxt - character(len=16), dimension(:), allocatable :: budtxtarray - integer(I4B) :: nval - integer(I4B) :: idum1 - integer(I4B) :: idum2 - integer(I4B) :: imeth - integer(I4B), dimension(:), allocatable :: imetharray - real(DP) :: delt - real(DP) :: pertim - real(DP) :: totim - character(len=16) :: srcmodelname - character(len=16) :: srcpackagename - integer(I4B) :: ndat - integer(I4B) :: naux - integer(I4B), dimension(:), allocatable :: nauxarray - character(len=16), dimension(:), allocatable :: auxtxt - character(len=16), dimension(:, :), allocatable :: auxtxtarray - integer(I4B) :: nlist - real(DP), dimension(:), allocatable :: flowja - integer(I4B), dimension(:), allocatable :: nodesrc - integer(I4B), dimension(:), allocatable :: nodedst - real(DP), dimension(:), allocatable :: flow - real(DP), dimension(:, :), allocatable :: auxvar - character(len=16) :: dstmodelname - character(len=16) :: dstpackagename - character(len=16), dimension(:), allocatable :: dstpackagenamearray - - contains - - procedure :: initialize - procedure :: read_record - procedure :: finalize - - end type BudgetFileReaderType - - contains - - subroutine initialize(this, iu, iout, ncrbud) -! ****************************************************************************** -! initialize -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(BudgetFileReaderType) :: this - integer(I4B), intent(in) :: iu - integer(I4B), intent(in) :: iout - integer(I4B), intent(out) :: ncrbud - ! -- local - integer(I4B) :: ibudterm - integer(I4B) :: kstp_last, kper_last - integer(I4B) :: maxaux - logical :: success -! ------------------------------------------------------------------------------ - this%inunit = iu - this%endoffile = .false. - this%nbudterms = 0 - ncrbud = 0 - maxaux = 0 - ! - ! -- Determine number of budget terms within a time step - if (iout > 0) & - write(iout, '(a)') & - 'Reading budget file to determine number of terms per time step.' - ! - ! -- Read through the first set of data for time step 1 and stress period 1 - do - call this%read_record(success) - if (.not. success) exit - this%nbudterms = this%nbudterms + 1 - if (this%naux > maxaux) maxaux = this%naux - if (this%kstp /= this%kstpnext .or. this%kper /= this%kpernext) & - exit - end do - kstp_last = this%kstp - kper_last = this%kper - allocate(this%budtxtarray(this%nbudterms)) - allocate(this%imetharray(this%nbudterms)) - allocate(this%dstpackagenamearray(this%nbudterms)) - allocate(this%nauxarray(this%nbudterms)) - allocate(this%auxtxtarray(maxaux, this%nbudterms)) - this%auxtxtarray(:, :) = '' - rewind(this%inunit) - ! - ! -- Now read through again and store budget text names - do ibudterm = 1, this%nbudterms - call this%read_record(success, iout) - if (.not. success) exit - this%budtxtarray(ibudterm) = this%budtxt - this%imetharray(ibudterm) = this%imeth - this%dstpackagenamearray(ibudterm) = this%dstpackagename - this%nauxarray(ibudterm) = this%naux - this%auxtxtarray(1:this%naux, ibudterm) = this%auxtxt(:) - if (this%srcmodelname == this%dstmodelname) then - if(allocated(this%nodesrc)) ncrbud = max(ncrbud, maxval(this%nodesrc)) - endif - enddo - rewind(this%inunit) - if (iout > 0) & - write(iout, '(a, i0, a)') 'Detected ', this%nbudterms, & - ' unique flow terms in budget file.' - ! - ! -- return - return - end subroutine initialize - - subroutine read_record(this, success, iout_opt) -! ****************************************************************************** -! read_record -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: fseek_stream - ! -- dummy - class(BudgetFileReaderType) :: this - logical, intent(out) :: success - integer(I4B), intent(in), optional :: iout_opt - ! -- local - integer(I4B) :: i, n, iostat, iout - character(len=LINELENGTH) :: errmsg -! ------------------------------------------------------------------------------ - ! - if (present(iout_opt)) then - iout = iout_opt - else - iout = 0 - endif - ! - this%kstp = 0 - this%kper = 0 - this%budtxt = '' - this%nval = 0 - this%naux = 0 - this%idum1 = 0 - this%idum2 = 0 - this%srcmodelname = '' - this%srcpackagename = '' - this%dstmodelname = '' - this%dstpackagename = '' - - success = .true. - this%kstpnext = 0 - this%kpernext = 0 - read(this%inunit, iostat=iostat) this%kstp, this%kper, this%budtxt, & - this%nval, this%idum1, this%idum2 - if (iostat /= 0) then - success = .false. - if (iostat < 0) this%endoffile = .true. - return - endif - read(this%inunit) this%imeth, this%delt, this%pertim, this%totim - if(this%imeth == 1) then - if (trim(adjustl(this%budtxt)) == 'FLOW-JA-FACE') then - if(allocated(this%flowja)) deallocate(this%flowja) - allocate(this%flowja(this%nval)) - read(this%inunit) this%flowja - this%hasimeth1flowja = .true. - else - this%nval = this%nval * this%idum1 * abs(this%idum2) - if(allocated(this%flow)) deallocate(this%flow) - allocate(this%flow(this%nval)) - if(allocated(this%nodesrc)) deallocate(this%nodesrc) - allocate(this%nodesrc(this%nval)) - read(this%inunit) this%flow - do i = 1, this%nval - this%nodesrc(i) = i - enddo - endif - elseif (this%imeth == 6) then - ! -- method code 6 - read(this%inunit) this%srcmodelname - read(this%inunit) this%srcpackagename - read(this%inunit) this%dstmodelname - read(this%inunit) this%dstpackagename - read(this%inunit) this%ndat - this%naux = this%ndat - 1 - if(allocated(this%auxtxt)) deallocate(this%auxtxt) - allocate(this%auxtxt(this%naux)) - read(this%inunit) this%auxtxt - read(this%inunit) this%nlist - if(allocated(this%nodesrc)) deallocate(this%nodesrc) - allocate(this%nodesrc(this%nlist)) - if(allocated(this%nodedst)) deallocate(this%nodedst) - allocate(this%nodedst(this%nlist)) - if(allocated(this%flow)) deallocate(this%flow) - allocate(this%flow(this%nlist)) - if(allocated(this%auxvar)) deallocate(this%auxvar) - allocate(this%auxvar(this%naux, this%nlist)) - read(this%inunit) (this%nodesrc(n), this%nodedst(n), this%flow(n), & - (this%auxvar(i, n), i = 1, this%naux), n = 1, this%nlist) - else - write(errmsg, '(a, a)') 'ERROR READING: ', trim(this%budtxt) - call store_error(errmsg) - write(errmsg, '(a, i0)') 'INVALID METHOD CODE DETECTED: ', this%imeth - call store_error(errmsg) - call store_error_unit(this%inunit) - call ustop() - endif - if (iout > 0) then - write(iout, '(1pg15.6, a, 1x, a)') this%totim, this%budtxt, & - this%dstpackagename - endif - ! - ! -- look ahead to next kstp and kper, then backup if read successfully - if (.not. this%endoffile) then - read(this%inunit, iostat=iostat) this%kstpnext, this%kpernext - if (iostat == 0) then - call fseek_stream(this%inunit, -2 * I4B, 1, iostat) - else if (iostat < 0) then - this%endoffile = .true. - end if - endif - ! - ! -- return - return - end subroutine read_record - - subroutine finalize(this) -! ****************************************************************************** -! budgetdata_finalize -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(BudgetFileReaderType) :: this -! ------------------------------------------------------------------------------ - close(this%inunit) - if(allocated(this%auxtxt)) deallocate(this%auxtxt) - if(allocated(this%flowja)) deallocate(this%flowja) - if(allocated(this%nodesrc)) deallocate(this%nodesrc) - if(allocated(this%nodedst)) deallocate(this%nodedst) - if(allocated(this%flow)) deallocate(this%flow) - if(allocated(this%auxvar)) deallocate(this%auxvar) - ! - ! -- return - return - end subroutine finalize - -end module BudgetFileReaderModule + use SimModule, only: store_error, store_error_unit, ustop + use ConstantsModule, only: LINELENGTH + + implicit none + + private + public :: BudgetFileReaderType + + type :: BudgetFileReaderType + + logical :: hasimeth1flowja = .false. + integer(I4B) :: inunit + integer(I4B) :: nbudterms + integer(I4B) :: kstp + integer(I4B) :: kper + integer(I4B) :: kstpnext + integer(I4B) :: kpernext + logical :: endoffile + character(len=16) :: budtxt + character(len=16), dimension(:), allocatable :: budtxtarray + integer(I4B) :: nval + integer(I4B) :: idum1 + integer(I4B) :: idum2 + integer(I4B) :: imeth + integer(I4B), dimension(:), allocatable :: imetharray + real(DP) :: delt + real(DP) :: pertim + real(DP) :: totim + character(len=16) :: srcmodelname + character(len=16) :: srcpackagename + integer(I4B) :: ndat + integer(I4B) :: naux + integer(I4B), dimension(:), allocatable :: nauxarray + character(len=16), dimension(:), allocatable :: auxtxt + character(len=16), dimension(:, :), allocatable :: auxtxtarray + integer(I4B) :: nlist + real(DP), dimension(:), allocatable :: flowja + integer(I4B), dimension(:), allocatable :: nodesrc + integer(I4B), dimension(:), allocatable :: nodedst + real(DP), dimension(:), allocatable :: flow + real(DP), dimension(:, :), allocatable :: auxvar + character(len=16) :: dstmodelname + character(len=16) :: dstpackagename + character(len=16), dimension(:), allocatable :: dstpackagenamearray + + contains + + procedure :: initialize + procedure :: read_record + procedure :: finalize + + end type BudgetFileReaderType + + contains + + subroutine initialize(this, iu, iout, ncrbud) +! ****************************************************************************** +! initialize +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BudgetFileReaderType) :: this + integer(I4B), intent(in) :: iu + integer(I4B), intent(in) :: iout + integer(I4B), intent(out) :: ncrbud + ! -- local + integer(I4B) :: ibudterm + integer(I4B) :: kstp_last, kper_last + integer(I4B) :: maxaux + logical :: success +! ------------------------------------------------------------------------------ + this%inunit = iu + this%endoffile = .false. + this%nbudterms = 0 + ncrbud = 0 + maxaux = 0 + ! + ! -- Determine number of budget terms within a time step + if (iout > 0) & + write(iout, '(a)') & + 'Reading budget file to determine number of terms per time step.' + ! + ! -- Read through the first set of data for time step 1 and stress period 1 + do + call this%read_record(success) + if (.not. success) exit + this%nbudterms = this%nbudterms + 1 + if (this%naux > maxaux) maxaux = this%naux + if (this%kstp /= this%kstpnext .or. this%kper /= this%kpernext) & + exit + end do + kstp_last = this%kstp + kper_last = this%kper + allocate(this%budtxtarray(this%nbudterms)) + allocate(this%imetharray(this%nbudterms)) + allocate(this%dstpackagenamearray(this%nbudterms)) + allocate(this%nauxarray(this%nbudterms)) + allocate(this%auxtxtarray(maxaux, this%nbudterms)) + this%auxtxtarray(:, :) = '' + rewind(this%inunit) + ! + ! -- Now read through again and store budget text names + do ibudterm = 1, this%nbudterms + call this%read_record(success, iout) + if (.not. success) exit + this%budtxtarray(ibudterm) = this%budtxt + this%imetharray(ibudterm) = this%imeth + this%dstpackagenamearray(ibudterm) = this%dstpackagename + this%nauxarray(ibudterm) = this%naux + this%auxtxtarray(1:this%naux, ibudterm) = this%auxtxt(:) + if (this%srcmodelname == this%dstmodelname) then + if(allocated(this%nodesrc)) ncrbud = max(ncrbud, maxval(this%nodesrc)) + endif + enddo + rewind(this%inunit) + if (iout > 0) & + write(iout, '(a, i0, a)') 'Detected ', this%nbudterms, & + ' unique flow terms in budget file.' + ! + ! -- return + return + end subroutine initialize + + subroutine read_record(this, success, iout_opt) +! ****************************************************************************** +! read_record +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: fseek_stream + ! -- dummy + class(BudgetFileReaderType) :: this + logical, intent(out) :: success + integer(I4B), intent(in), optional :: iout_opt + ! -- local + integer(I4B) :: i, n, iostat, iout + character(len=LINELENGTH) :: errmsg +! ------------------------------------------------------------------------------ + ! + if (present(iout_opt)) then + iout = iout_opt + else + iout = 0 + endif + ! + this%kstp = 0 + this%kper = 0 + this%budtxt = '' + this%nval = 0 + this%naux = 0 + this%idum1 = 0 + this%idum2 = 0 + this%srcmodelname = '' + this%srcpackagename = '' + this%dstmodelname = '' + this%dstpackagename = '' + + success = .true. + this%kstpnext = 0 + this%kpernext = 0 + read(this%inunit, iostat=iostat) this%kstp, this%kper, this%budtxt, & + this%nval, this%idum1, this%idum2 + if (iostat /= 0) then + success = .false. + if (iostat < 0) this%endoffile = .true. + return + endif + read(this%inunit) this%imeth, this%delt, this%pertim, this%totim + if(this%imeth == 1) then + if (trim(adjustl(this%budtxt)) == 'FLOW-JA-FACE') then + if(allocated(this%flowja)) deallocate(this%flowja) + allocate(this%flowja(this%nval)) + read(this%inunit) this%flowja + this%hasimeth1flowja = .true. + else + this%nval = this%nval * this%idum1 * abs(this%idum2) + if(allocated(this%flow)) deallocate(this%flow) + allocate(this%flow(this%nval)) + if(allocated(this%nodesrc)) deallocate(this%nodesrc) + allocate(this%nodesrc(this%nval)) + read(this%inunit) this%flow + do i = 1, this%nval + this%nodesrc(i) = i + enddo + endif + elseif (this%imeth == 6) then + ! -- method code 6 + read(this%inunit) this%srcmodelname + read(this%inunit) this%srcpackagename + read(this%inunit) this%dstmodelname + read(this%inunit) this%dstpackagename + read(this%inunit) this%ndat + this%naux = this%ndat - 1 + if(allocated(this%auxtxt)) deallocate(this%auxtxt) + allocate(this%auxtxt(this%naux)) + read(this%inunit) this%auxtxt + read(this%inunit) this%nlist + if(allocated(this%nodesrc)) deallocate(this%nodesrc) + allocate(this%nodesrc(this%nlist)) + if(allocated(this%nodedst)) deallocate(this%nodedst) + allocate(this%nodedst(this%nlist)) + if(allocated(this%flow)) deallocate(this%flow) + allocate(this%flow(this%nlist)) + if(allocated(this%auxvar)) deallocate(this%auxvar) + allocate(this%auxvar(this%naux, this%nlist)) + read(this%inunit) (this%nodesrc(n), this%nodedst(n), this%flow(n), & + (this%auxvar(i, n), i = 1, this%naux), n = 1, this%nlist) + else + write(errmsg, '(a, a)') 'ERROR READING: ', trim(this%budtxt) + call store_error(errmsg) + write(errmsg, '(a, i0)') 'INVALID METHOD CODE DETECTED: ', this%imeth + call store_error(errmsg) + call store_error_unit(this%inunit) + call ustop() + endif + if (iout > 0) then + write(iout, '(1pg15.6, a, 1x, a)') this%totim, this%budtxt, & + this%dstpackagename + endif + ! + ! -- look ahead to next kstp and kper, then backup if read successfully + if (.not. this%endoffile) then + read(this%inunit, iostat=iostat) this%kstpnext, this%kpernext + if (iostat == 0) then + call fseek_stream(this%inunit, -2 * I4B, 1, iostat) + else if (iostat < 0) then + this%endoffile = .true. + end if + endif + ! + ! -- return + return + end subroutine read_record + + subroutine finalize(this) +! ****************************************************************************** +! budgetdata_finalize +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(BudgetFileReaderType) :: this +! ------------------------------------------------------------------------------ + close(this%inunit) + if(allocated(this%auxtxt)) deallocate(this%auxtxt) + if(allocated(this%flowja)) deallocate(this%flowja) + if(allocated(this%nodesrc)) deallocate(this%nodesrc) + if(allocated(this%nodedst)) deallocate(this%nodedst) + if(allocated(this%flow)) deallocate(this%flow) + if(allocated(this%auxvar)) deallocate(this%auxvar) + ! + ! -- return + return + end subroutine finalize + +end module BudgetFileReaderModule diff --git a/src/Utilities/BudgetObject.f90 b/src/Utilities/BudgetObject.f90 index 768863148f6..766f25ceaba 100644 --- a/src/Utilities/BudgetObject.f90 +++ b/src/Utilities/BudgetObject.f90 @@ -1,727 +1,727 @@ -! Comprehensive budget object that stores all of the -! intercell flows, and the inflows and the outflows for -! an advanced package. -module BudgetObjectModule - - use KindModule, only: I4B, DP - use ConstantsModule, only: LENBUDTXT, LINELENGTH, & - TABLEFT, TABCENTER, TABRIGHT, & - TABSTRING, TABUCSTRING, TABINTEGER, TABREAL, & - DZERO, DHALF, DHUNDRED - use BudgetModule, only : BudgetType, budget_cr - use BudgetTermModule, only: BudgetTermType - use TableModule, only: TableType, table_cr - use BaseDisModule, only: DisBaseType - use BudgetFileReaderModule, only: BudgetFileReaderType - - implicit none - - public :: BudgetObjectType - public :: budgetobject_cr - public :: budgetobject_cr_bfr - - type :: BudgetObjectType - ! - ! -- name, number of control volumes, and number of budget terms - character(len=LENBUDTXT) :: name - integer(I4B) :: ncv - integer(I4B) :: nbudterm - ! - ! -- state variables - real(DP), dimension(:), pointer :: xnew => null() - real(DP), dimension(:), pointer :: xold => null() - ! - ! -- csr intercell flows - integer(I4B) :: iflowja - real(DP), dimension(:), pointer :: flowja => null() - ! - ! -- storage - integer(I4B) :: nsto - real(DP), dimension(:, :), pointer :: qsto => null() - ! - ! -- array of budget terms, with one separate entry for each term - ! such as rainfall, et, leakage, etc. - integer(I4B) :: iterm - type(BudgetTermType), dimension(:), allocatable :: budterm - ! - ! -- budget table object, for writing the typical MODFLOW budget - type(BudgetType), pointer :: budtable => null() - ! - ! -- flow table object, for writing the flow budget for - ! each control volume - logical, pointer :: add_cellids => null() - integer(I4B), pointer :: icellid => null() - integer(I4B), pointer :: nflowterms => null() - integer(I4B), dimension(:), pointer :: istart => null() - integer(I4B), dimension(:), pointer :: iflowterms => null() - type(TableType), pointer :: flowtab => null() - ! - ! -- budget file reader, for reading flows from a binary file - type(BudgetFileReaderType), pointer :: bfr => null() - - contains - - procedure :: budgetobject_df - procedure :: flowtable_df - procedure :: accumulate_terms - procedure :: write_budtable - procedure :: write_flowtable - procedure :: save_flows - procedure :: read_flows - procedure :: budgetobject_da - procedure :: bfr_init - procedure :: bfr_advance - procedure :: fill_from_bfr - - end type BudgetObjectType - - contains - - subroutine budgetobject_cr(this, name) -! ****************************************************************************** -! budgetobject_cr -- Create a new budget object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - type(BudgetObjectType), pointer :: this - character(len=*), intent(in) :: name -! ------------------------------------------------------------------------------ - ! - ! -- Create the object - allocate(this) - ! - ! -- initialize variables - this%name = name - this%ncv = 0 - this%nbudterm = 0 - this%iflowja = 0 - this%nsto = 0 - this%iterm = 0 - ! - ! -- initialize budget table - call budget_cr(this%budtable, name) - ! - ! -- Return - return - end subroutine budgetobject_cr - - subroutine budgetobject_df(this, ncv, nbudterm, iflowja, nsto) -! ****************************************************************************** -! budgetobject_df -- Define the new budget object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(BudgetObjectType) :: this - integer(I4B), intent(in) :: ncv - integer(I4B), intent(in) :: nbudterm - integer(I4B), intent(in) :: iflowja - integer(I4B), intent(in) :: nsto -! ------------------------------------------------------------------------------ - ! - ! -- set values - this%ncv = ncv - this%nbudterm = nbudterm - this%iflowja = iflowja - this%nsto = nsto - ! - ! -- allocate space for budterm - allocate(this%budterm(nbudterm)) - ! - ! -- setup the budget table object - ! -- TODO: GET DIMENSIONS (e.g. L**3) IN HERE - call this%budtable%budget_df(nbudterm, this%name) - ! - ! -- Return - return - end subroutine budgetobject_df - - subroutine flowtable_df(this, iout, cellids) -! ****************************************************************************** -! flowtable_df -- Define the new flow table object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(BudgetObjectType) :: this - integer(I4B), intent(in) :: iout - character(len=*), intent(in), optional :: cellids - ! -- local - character(len=LINELENGTH) :: title - character(len=LINELENGTH) :: text - character(len=LENBUDTXT) :: flowtype - character(len=LENBUDTXT) :: tag - character(len=LENBUDTXT) :: coupletype - logical :: lfound - logical :: add_cellids - integer(I4B) :: maxcol - integer(I4B) :: idx - integer(I4B) :: ipos - integer(I4B) :: i -! ------------------------------------------------------------------------------ - ! - ! -- process optional variables - if (present(cellids)) then - add_cellids = .TRUE. - coupletype = cellids - else - add_cellids = .FALSE. - end if - ! - ! -- allocate scalars - allocate(this%add_cellids) - allocate(this%icellid) - allocate(this%nflowterms) - ! - ! -- initialize scalars - this%add_cellids = add_cellids - this%nflowterms = 0 - this%icellid = 0 - ! - ! -- determine the number of columns in the table - maxcol = 3 - if (add_cellids) then - maxcol = maxcol + 1 - end if - do i = 1, this%nbudterm - lfound = .FALSE. - flowtype = this%budterm(i)%get_flowtype() - if (trim(adjustl(flowtype)) == 'FLOW-JA-FACE') then - lfound = .TRUE. - maxcol = maxcol + 2 - else if (trim(adjustl(flowtype)) /= 'AUXILIARY') then - lfound = .TRUE. - maxcol = maxcol + 1 - end if - if (lfound) then - this%nflowterms = this%nflowterms + 1 - if (add_cellids) then - if (trim(adjustl(flowtype)) == trim(adjustl(coupletype))) then - this%icellid = i - end if - end if - end if - end do - ! - ! -- allocate arrays - allocate(this%istart(this%nflowterms)) - allocate(this%iflowterms(this%nflowterms)) - ! - ! -- set up flow tableobj - title = trim(this%name) // ' PACKAGE - SUMMARY OF FLOWS FOR ' // & - 'EACH CONTROL VOLUME' - call table_cr(this%flowtab, this%name, title) - call this%flowtab%table_df(this%ncv, maxcol, iout, transient=.TRUE.) - ! - ! -- Go through and set up flow table budget terms - text = 'NUMBER' - call this%flowtab%initialize_column(text, 10, alignment=TABCENTER) - if (add_cellids) then - text = 'CELLID' - call this%flowtab%initialize_column(text, 20, alignment=TABLEFT) - end if - idx = 1 - do i = 1, this%nbudterm - lfound = .FALSE. - flowtype = this%budterm(i)%get_flowtype() - tag = trim(adjustl(flowtype)) - ipos = index(tag, '-') - if (ipos > 0) then - tag(ipos:ipos) = ' ' - end if - if (trim(adjustl(flowtype)) == 'FLOW-JA-FACE') then - lfound = .TRUE. - text = 'INFLOW' - call this%flowtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'OUTFLOW' - call this%flowtab%initialize_column(text, 12, alignment=TABCENTER) - else if (trim(adjustl(flowtype)) /= 'AUXILIARY') then - lfound = .TRUE. - call this%flowtab%initialize_column(tag, 12, alignment=TABCENTER) - end if - if (lfound) then - this%iflowterms(idx) = i - idx = idx + 1 - end if - end do - text = 'IN - OUT' - call this%flowtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'PERCENT DIFFERENCE' - call this%flowtab%initialize_column(text, 12, alignment=TABCENTER) - ! - ! -- Return - return - end subroutine flowtable_df - - subroutine accumulate_terms(this) -! ****************************************************************************** -! accumulate_terms -- add up accumulators and submit to budget table -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: delt - ! -- dummy - class(BudgetObjectType) :: this - ! -- dummy - character(len=LENBUDTXT) :: flowtype - integer(I4B) :: i - real(DP) :: ratin, ratout -! ------------------------------------------------------------------------------ - ! - ! -- reset the budget table - call this%budtable%reset() - ! - ! -- calculate the budget table terms - do i = 1, this%nbudterm - ! - ! -- accumulate positive and negative flows for each budget term - flowtype = this%budterm(i)%flowtype - select case (trim(adjustl(flowtype))) - case ('FLOW-JA-FACE') - ! skip - case default - ! - ! -- calculate sum of positive and negative flows - call this%budterm(i)%accumulate_flow(ratin, ratout) - ! - ! -- pass accumulators into the budget table - call this%budtable%addentry(ratin, ratout, delt, flowtype) - end select - end do - ! - ! -- return - return - end subroutine accumulate_terms - - subroutine write_flowtable(this, dis) -! ****************************************************************************** -! write_flowtable -- Write the flow table for each advanced package control -! volume -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(BudgetObjectType) :: this - class(DisBaseType), intent(in) :: dis - ! -- dummy - character(len=LENBUDTXT) :: flowtype - character(len=20) :: cellid - integer(I4B) :: nlist - integer(I4B) :: id1 - integer(I4B) :: id2 - integer(I4B) :: icv - integer(I4B) :: idx - integer(I4B) :: i - integer(I4B) :: j - real(DP) :: v - real(DP) :: qin - real(DP) :: qout - real(DP) :: q - real(DP) :: qinflow - real(DP) :: qoutflow - real(DP) :: qerr - real(DP) :: qavg - real(DP) :: qpd - -! ------------------------------------------------------------------------------ - ! - ! -- reset starting position - do j = 1, this%nflowterms - this%istart(j) = 1 - end do - ! - ! -- write the table - do icv = 1, this%ncv - call this%flowtab%add_term(icv) - ! - ! -- initialize flow terms for the control volume - qin = DZERO - qout = DZERO - ! - ! -- add cellid if required - if (this%add_cellids) then - j = this%icellid - idx = this%iflowterms(j) - i = this%istart(j) - id2 = this%budterm(idx)%get_id2(i) - if (id2 > 0) then - call dis%noder_to_string(id2, cellid) - else - cellid = 'NONE' - end if - call this%flowtab%add_term(cellid) - end if - ! - ! -- iterate over the flow terms - do j = 1, this%nflowterms - ! - ! -- initialize flow terms for the row - q = DZERO - qinflow = DZERO - qoutflow = DZERO - ! - ! -- determine the index, flowtype and length of - ! the flowterm - idx = this%iflowterms(j) - flowtype = this%budterm(idx)%get_flowtype() - nlist = this%budterm(idx)%get_nlist() - ! - ! -- iterate over the entries in the flowtype. If id1 is not ordered - ! then need to look through the entire list each time - colterm: do i = this%istart(j), nlist - id1 = this%budterm(idx)%get_id1(i) - if (this%budterm(idx)%ordered_id1) then - if(id1 > icv) then - this%istart(j) = i - exit colterm - end if - else - if (id1 /= icv) cycle colterm - end if - v = this%budterm(idx)%get_flow(i) - if (trim(adjustl(flowtype)) == 'FLOW-JA-FACE') then - if (v < DZERO) then - qoutflow = qoutflow + v - else - qinflow = qinflow + v - end if - end if - ! - ! -- accumulators - q = q + v - if (v < DZERO) then - qout = qout + v - else - qin = qin + v - end if - end do colterm - ! - ! -- add entry to table - if (trim(adjustl(flowtype)) == 'FLOW-JA-FACE') then - call this%flowtab%add_term(qinflow) - call this%flowtab%add_term(qoutflow) - else - call this%flowtab%add_term(q) - end if - end do - ! - ! -- calculate in-out and percent difference - qerr = qin + qout - qavg = DHALF * (qin - qout) - qpd = DZERO - if (qavg > DZERO) then - qpd = DHUNDRED * qerr / qavg - end if - call this%flowtab%add_term(qerr) - call this%flowtab%add_term(qpd) - end do - ! - ! -- return - return - end subroutine write_flowtable - - subroutine write_budtable(this, kstp, kper, iout) -! ****************************************************************************** -! write_budtable -- Write the budget table -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(BudgetObjectType) :: this - integer(I4B),intent(in) :: kstp - integer(I4B),intent(in) :: kper - integer(I4B),intent(in) :: iout - ! -- dummy -! ------------------------------------------------------------------------------ - ! - ! -- write the table - call this%budtable%budget_ot(kstp, kper, iout) - ! - ! -- return - return - end subroutine write_budtable - - subroutine save_flows(this, dis, ibinun, kstp, kper, delt, & - pertim, totim, iout) -! ****************************************************************************** -! write_budtable -- Write the budget table -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(BudgetObjectType) :: this - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: ibinun - integer(I4B), intent(in) :: kstp - integer(I4B), intent(in) :: kper - real(DP), intent(in) :: delt - real(DP), intent(in) :: pertim - real(DP), intent(in) :: totim - integer(I4B), intent(in) :: iout - ! -- dummy - integer(I4B) :: i -! ------------------------------------------------------------------------------ - ! - ! -- save flows for each budget term - do i = 1, this%nbudterm - call this%budterm(i)%save_flows(dis, ibinun, kstp, kper, delt, & - pertim, totim, iout) - end do - ! - ! -- return - return - end subroutine save_flows - - subroutine read_flows(this, dis, ibinun) -! ****************************************************************************** -! read_flows -- Read froms from a binary file into this BudgetObjectType -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(BudgetObjectType) :: this - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: ibinun - ! -- local - integer(I4B) :: kstp - integer(I4B) :: kper - real(DP) :: delt - real(DP) :: pertim - real(DP) :: totim - ! -- dummy - integer(I4B) :: i -! ------------------------------------------------------------------------------ - ! - ! -- read flows for each budget term - do i = 1, this%nbudterm - call this%budterm(i)%read_flows(dis, ibinun, kstp, kper, delt, & - pertim, totim) - end do - ! - ! -- return - return - end subroutine read_flows - - subroutine budgetobject_da(this) -! ****************************************************************************** -! budgetobject_da -- deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(BudgetObjectType) :: this - ! -- dummy - integer(I4B) :: i -! ------------------------------------------------------------------------------ - ! - ! -- save flows for each budget term - do i = 1, this%nbudterm - call this%budterm(i)%deallocate_arrays() - end do - ! - ! -- - if (associated(this%flowtab)) then - deallocate(this%add_cellids) - deallocate(this%icellid) - deallocate(this%nflowterms) - deallocate(this%istart) - deallocate(this%iflowterms) - call this%flowtab%table_da() - deallocate(this%flowtab) - nullify(this%flowtab) - end if - ! - ! -- Return - return - end subroutine budgetobject_da - - subroutine budgetobject_cr_bfr(this, name, ibinun, iout, colconv1, colconv2) -! ****************************************************************************** -! budgetobject_cr_bfr -- Create a new budget object from a binary flow file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - type(BudgetObjectType), pointer :: this - character(len=*), intent(in) :: name - integer(I4B), intent(in) :: ibinun - integer(I4B), intent(in) :: iout - character(len=16), dimension(:), optional :: colconv1 - character(len=16), dimension(:), optional :: colconv2 - ! -- local - integer(I4B) :: ncv, nbudterm - integer(I4B) :: iflowja, nsto - integer(I4B) :: i, j -! ------------------------------------------------------------------------------ - ! - ! -- Create the object - call budgetobject_cr(this, name) - ! - ! -- Initialize the budget file reader - call this%bfr_init(ibinun, ncv, nbudterm, iout) - ! - ! -- Define this budget object using number of control volumes and number - ! of budget terms read from ibinun - iflowja = 0 - nsto = 0 - call this%budgetobject_df(ncv, nbudterm, iflowja, nsto) - ! - ! -- Set the conversion flags, which cause id1 or id2 to be converted from - ! user node numbers to reduced node numbers - if (present(colconv1)) then - do i = 1, nbudterm - do j = 1, size(colconv1) - if (colconv1(j) == adjustl(this%bfr%budtxtarray(i))) then - this%budterm(i)%olconv1 = .true. - exit - end if - end do - end do - end if - if (present(colconv2)) then - do i = 1, nbudterm - do j = 1, size(colconv2) - if (colconv2(j) == adjustl(this%bfr%budtxtarray(i))) then - this%budterm(i)%olconv2 = .true. - exit - end if - end do - end do - end if - ! - ! -- Return - return - end subroutine budgetobject_cr_bfr - - subroutine bfr_init(this, ibinun, ncv, nbudterm, iout) -! ****************************************************************************** -! bfr_init -- initialize the budget file reader -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(BudgetObjectType) :: this - integer(I4B), intent(in) :: ibinun - integer(I4B), intent(inout) :: ncv - integer(I4B), intent(inout) :: nbudterm - integer(I4B), intent(in) :: iout - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- initialize budget file reader - allocate(this%bfr) - call this%bfr%initialize(ibinun, iout, ncv) - nbudterm = this%bfr%nbudterms - ! - ! -- Return - return - end subroutine bfr_init - - subroutine bfr_advance(this, dis, iout) -! ****************************************************************************** -! bfr_advance -- copy the information from the binary file into budterms -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: kstp, kper - ! -- dummy - class(BudgetObjectType) :: this - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: iout - ! -- dummy - logical :: readnext - character(len=*), parameter :: fmtkstpkper = & - "(1x,/1x, a, ' READING BUDGET TERMS FOR KSTP ', i0, ' KPER ', i0)" - character(len=*), parameter :: fmtbudkstpkper = & - "(1x,/1x, a, ' SETTING BUDGET TERMS FOR KSTP ', i0, ' AND KPER ', & - &i0, ' TO BUDGET FILE TERMS FROM KSTP ', i0, ' AND KPER ', i0)" -! ------------------------------------------------------------------------------ - ! - ! -- Do not read the budget if the budget is at end of file or if the next - ! record in the budget file is the first timestep of the next stress - ! period. Also do not read if it is the very first time step because - ! the first chunk of data is read as part of the initialization - readnext = .true. - if (kstp * kper == 1) then - readnext = .false. - else if (kstp * kper > 1) then - if (this%bfr%endoffile) then - readnext = .false. - else - if (this%bfr%kpernext == kper + 1 .and. this%bfr%kstpnext == 1) & - readnext = .false. - endif - endif - ! - ! -- Read the next record - if (readnext) then - ! - ! -- Write the current time step and stress period - if (iout > 0) & - write(iout, fmtkstpkper) this%name, kstp, kper - ! - ! -- read flows from the binary file and copy them into this%budterm(:) - call this%fill_from_bfr(dis, iout) - else - if (iout > 0) & - write(iout, fmtbudkstpkper) trim(this%name), kstp, kper, & - this%bfr%kstp, this%bfr%kper - endif - ! - ! -- Return - return - end subroutine bfr_advance - - subroutine fill_from_bfr(this, dis, iout) -! ****************************************************************************** -! fill_from_bfr -- copy the information from the binary file into budterms -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(BudgetObjectType) :: this - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: iout - ! -- dummy - integer(I4B) :: i - logical :: success -! ------------------------------------------------------------------------------ - ! - ! -- read flows from the binary file and copy them into this%budterm(:) - do i = 1, this%nbudterm - call this%bfr%read_record(success, iout) - call this%budterm(i)%fill_from_bfr(this%bfr, dis) - end do - ! - ! -- Return - return - end subroutine fill_from_bfr - +! Comprehensive budget object that stores all of the +! intercell flows, and the inflows and the outflows for +! an advanced package. +module BudgetObjectModule + + use KindModule, only: I4B, DP + use ConstantsModule, only: LENBUDTXT, LINELENGTH, & + TABLEFT, TABCENTER, TABRIGHT, & + TABSTRING, TABUCSTRING, TABINTEGER, TABREAL, & + DZERO, DHALF, DHUNDRED + use BudgetModule, only : BudgetType, budget_cr + use BudgetTermModule, only: BudgetTermType + use TableModule, only: TableType, table_cr + use BaseDisModule, only: DisBaseType + use BudgetFileReaderModule, only: BudgetFileReaderType + + implicit none + + public :: BudgetObjectType + public :: budgetobject_cr + public :: budgetobject_cr_bfr + + type :: BudgetObjectType + ! + ! -- name, number of control volumes, and number of budget terms + character(len=LENBUDTXT) :: name + integer(I4B) :: ncv + integer(I4B) :: nbudterm + ! + ! -- state variables + real(DP), dimension(:), pointer :: xnew => null() + real(DP), dimension(:), pointer :: xold => null() + ! + ! -- csr intercell flows + integer(I4B) :: iflowja + real(DP), dimension(:), pointer :: flowja => null() + ! + ! -- storage + integer(I4B) :: nsto + real(DP), dimension(:, :), pointer :: qsto => null() + ! + ! -- array of budget terms, with one separate entry for each term + ! such as rainfall, et, leakage, etc. + integer(I4B) :: iterm + type(BudgetTermType), dimension(:), allocatable :: budterm + ! + ! -- budget table object, for writing the typical MODFLOW budget + type(BudgetType), pointer :: budtable => null() + ! + ! -- flow table object, for writing the flow budget for + ! each control volume + logical, pointer :: add_cellids => null() + integer(I4B), pointer :: icellid => null() + integer(I4B), pointer :: nflowterms => null() + integer(I4B), dimension(:), pointer :: istart => null() + integer(I4B), dimension(:), pointer :: iflowterms => null() + type(TableType), pointer :: flowtab => null() + ! + ! -- budget file reader, for reading flows from a binary file + type(BudgetFileReaderType), pointer :: bfr => null() + + contains + + procedure :: budgetobject_df + procedure :: flowtable_df + procedure :: accumulate_terms + procedure :: write_budtable + procedure :: write_flowtable + procedure :: save_flows + procedure :: read_flows + procedure :: budgetobject_da + procedure :: bfr_init + procedure :: bfr_advance + procedure :: fill_from_bfr + + end type BudgetObjectType + + contains + + subroutine budgetobject_cr(this, name) +! ****************************************************************************** +! budgetobject_cr -- Create a new budget object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + type(BudgetObjectType), pointer :: this + character(len=*), intent(in) :: name +! ------------------------------------------------------------------------------ + ! + ! -- Create the object + allocate(this) + ! + ! -- initialize variables + this%name = name + this%ncv = 0 + this%nbudterm = 0 + this%iflowja = 0 + this%nsto = 0 + this%iterm = 0 + ! + ! -- initialize budget table + call budget_cr(this%budtable, name) + ! + ! -- Return + return + end subroutine budgetobject_cr + + subroutine budgetobject_df(this, ncv, nbudterm, iflowja, nsto) +! ****************************************************************************** +! budgetobject_df -- Define the new budget object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(BudgetObjectType) :: this + integer(I4B), intent(in) :: ncv + integer(I4B), intent(in) :: nbudterm + integer(I4B), intent(in) :: iflowja + integer(I4B), intent(in) :: nsto +! ------------------------------------------------------------------------------ + ! + ! -- set values + this%ncv = ncv + this%nbudterm = nbudterm + this%iflowja = iflowja + this%nsto = nsto + ! + ! -- allocate space for budterm + allocate(this%budterm(nbudterm)) + ! + ! -- setup the budget table object + ! -- TODO: GET DIMENSIONS (e.g. L**3) IN HERE + call this%budtable%budget_df(nbudterm, this%name) + ! + ! -- Return + return + end subroutine budgetobject_df + + subroutine flowtable_df(this, iout, cellids) +! ****************************************************************************** +! flowtable_df -- Define the new flow table object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(BudgetObjectType) :: this + integer(I4B), intent(in) :: iout + character(len=*), intent(in), optional :: cellids + ! -- local + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: text + character(len=LENBUDTXT) :: flowtype + character(len=LENBUDTXT) :: tag + character(len=LENBUDTXT) :: coupletype + logical :: lfound + logical :: add_cellids + integer(I4B) :: maxcol + integer(I4B) :: idx + integer(I4B) :: ipos + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + ! -- process optional variables + if (present(cellids)) then + add_cellids = .TRUE. + coupletype = cellids + else + add_cellids = .FALSE. + end if + ! + ! -- allocate scalars + allocate(this%add_cellids) + allocate(this%icellid) + allocate(this%nflowterms) + ! + ! -- initialize scalars + this%add_cellids = add_cellids + this%nflowterms = 0 + this%icellid = 0 + ! + ! -- determine the number of columns in the table + maxcol = 3 + if (add_cellids) then + maxcol = maxcol + 1 + end if + do i = 1, this%nbudterm + lfound = .FALSE. + flowtype = this%budterm(i)%get_flowtype() + if (trim(adjustl(flowtype)) == 'FLOW-JA-FACE') then + lfound = .TRUE. + maxcol = maxcol + 2 + else if (trim(adjustl(flowtype)) /= 'AUXILIARY') then + lfound = .TRUE. + maxcol = maxcol + 1 + end if + if (lfound) then + this%nflowterms = this%nflowterms + 1 + if (add_cellids) then + if (trim(adjustl(flowtype)) == trim(adjustl(coupletype))) then + this%icellid = i + end if + end if + end if + end do + ! + ! -- allocate arrays + allocate(this%istart(this%nflowterms)) + allocate(this%iflowterms(this%nflowterms)) + ! + ! -- set up flow tableobj + title = trim(this%name) // ' PACKAGE - SUMMARY OF FLOWS FOR ' // & + 'EACH CONTROL VOLUME' + call table_cr(this%flowtab, this%name, title) + call this%flowtab%table_df(this%ncv, maxcol, iout, transient=.TRUE.) + ! + ! -- Go through and set up flow table budget terms + text = 'NUMBER' + call this%flowtab%initialize_column(text, 10, alignment=TABCENTER) + if (add_cellids) then + text = 'CELLID' + call this%flowtab%initialize_column(text, 20, alignment=TABLEFT) + end if + idx = 1 + do i = 1, this%nbudterm + lfound = .FALSE. + flowtype = this%budterm(i)%get_flowtype() + tag = trim(adjustl(flowtype)) + ipos = index(tag, '-') + if (ipos > 0) then + tag(ipos:ipos) = ' ' + end if + if (trim(adjustl(flowtype)) == 'FLOW-JA-FACE') then + lfound = .TRUE. + text = 'INFLOW' + call this%flowtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'OUTFLOW' + call this%flowtab%initialize_column(text, 12, alignment=TABCENTER) + else if (trim(adjustl(flowtype)) /= 'AUXILIARY') then + lfound = .TRUE. + call this%flowtab%initialize_column(tag, 12, alignment=TABCENTER) + end if + if (lfound) then + this%iflowterms(idx) = i + idx = idx + 1 + end if + end do + text = 'IN - OUT' + call this%flowtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'PERCENT DIFFERENCE' + call this%flowtab%initialize_column(text, 12, alignment=TABCENTER) + ! + ! -- Return + return + end subroutine flowtable_df + + subroutine accumulate_terms(this) +! ****************************************************************************** +! accumulate_terms -- add up accumulators and submit to budget table +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: delt + ! -- dummy + class(BudgetObjectType) :: this + ! -- dummy + character(len=LENBUDTXT) :: flowtype + integer(I4B) :: i + real(DP) :: ratin, ratout +! ------------------------------------------------------------------------------ + ! + ! -- reset the budget table + call this%budtable%reset() + ! + ! -- calculate the budget table terms + do i = 1, this%nbudterm + ! + ! -- accumulate positive and negative flows for each budget term + flowtype = this%budterm(i)%flowtype + select case (trim(adjustl(flowtype))) + case ('FLOW-JA-FACE') + ! skip + case default + ! + ! -- calculate sum of positive and negative flows + call this%budterm(i)%accumulate_flow(ratin, ratout) + ! + ! -- pass accumulators into the budget table + call this%budtable%addentry(ratin, ratout, delt, flowtype) + end select + end do + ! + ! -- return + return + end subroutine accumulate_terms + + subroutine write_flowtable(this, dis) +! ****************************************************************************** +! write_flowtable -- Write the flow table for each advanced package control +! volume +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(BudgetObjectType) :: this + class(DisBaseType), intent(in) :: dis + ! -- dummy + character(len=LENBUDTXT) :: flowtype + character(len=20) :: cellid + integer(I4B) :: nlist + integer(I4B) :: id1 + integer(I4B) :: id2 + integer(I4B) :: icv + integer(I4B) :: idx + integer(I4B) :: i + integer(I4B) :: j + real(DP) :: v + real(DP) :: qin + real(DP) :: qout + real(DP) :: q + real(DP) :: qinflow + real(DP) :: qoutflow + real(DP) :: qerr + real(DP) :: qavg + real(DP) :: qpd + +! ------------------------------------------------------------------------------ + ! + ! -- reset starting position + do j = 1, this%nflowterms + this%istart(j) = 1 + end do + ! + ! -- write the table + do icv = 1, this%ncv + call this%flowtab%add_term(icv) + ! + ! -- initialize flow terms for the control volume + qin = DZERO + qout = DZERO + ! + ! -- add cellid if required + if (this%add_cellids) then + j = this%icellid + idx = this%iflowterms(j) + i = this%istart(j) + id2 = this%budterm(idx)%get_id2(i) + if (id2 > 0) then + call dis%noder_to_string(id2, cellid) + else + cellid = 'NONE' + end if + call this%flowtab%add_term(cellid) + end if + ! + ! -- iterate over the flow terms + do j = 1, this%nflowterms + ! + ! -- initialize flow terms for the row + q = DZERO + qinflow = DZERO + qoutflow = DZERO + ! + ! -- determine the index, flowtype and length of + ! the flowterm + idx = this%iflowterms(j) + flowtype = this%budterm(idx)%get_flowtype() + nlist = this%budterm(idx)%get_nlist() + ! + ! -- iterate over the entries in the flowtype. If id1 is not ordered + ! then need to look through the entire list each time + colterm: do i = this%istart(j), nlist + id1 = this%budterm(idx)%get_id1(i) + if (this%budterm(idx)%ordered_id1) then + if(id1 > icv) then + this%istart(j) = i + exit colterm + end if + else + if (id1 /= icv) cycle colterm + end if + v = this%budterm(idx)%get_flow(i) + if (trim(adjustl(flowtype)) == 'FLOW-JA-FACE') then + if (v < DZERO) then + qoutflow = qoutflow + v + else + qinflow = qinflow + v + end if + end if + ! + ! -- accumulators + q = q + v + if (v < DZERO) then + qout = qout + v + else + qin = qin + v + end if + end do colterm + ! + ! -- add entry to table + if (trim(adjustl(flowtype)) == 'FLOW-JA-FACE') then + call this%flowtab%add_term(qinflow) + call this%flowtab%add_term(qoutflow) + else + call this%flowtab%add_term(q) + end if + end do + ! + ! -- calculate in-out and percent difference + qerr = qin + qout + qavg = DHALF * (qin - qout) + qpd = DZERO + if (qavg > DZERO) then + qpd = DHUNDRED * qerr / qavg + end if + call this%flowtab%add_term(qerr) + call this%flowtab%add_term(qpd) + end do + ! + ! -- return + return + end subroutine write_flowtable + + subroutine write_budtable(this, kstp, kper, iout) +! ****************************************************************************** +! write_budtable -- Write the budget table +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(BudgetObjectType) :: this + integer(I4B),intent(in) :: kstp + integer(I4B),intent(in) :: kper + integer(I4B),intent(in) :: iout + ! -- dummy +! ------------------------------------------------------------------------------ + ! + ! -- write the table + call this%budtable%budget_ot(kstp, kper, iout) + ! + ! -- return + return + end subroutine write_budtable + + subroutine save_flows(this, dis, ibinun, kstp, kper, delt, & + pertim, totim, iout) +! ****************************************************************************** +! write_budtable -- Write the budget table +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(BudgetObjectType) :: this + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: ibinun + integer(I4B), intent(in) :: kstp + integer(I4B), intent(in) :: kper + real(DP), intent(in) :: delt + real(DP), intent(in) :: pertim + real(DP), intent(in) :: totim + integer(I4B), intent(in) :: iout + ! -- dummy + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + ! -- save flows for each budget term + do i = 1, this%nbudterm + call this%budterm(i)%save_flows(dis, ibinun, kstp, kper, delt, & + pertim, totim, iout) + end do + ! + ! -- return + return + end subroutine save_flows + + subroutine read_flows(this, dis, ibinun) +! ****************************************************************************** +! read_flows -- Read froms from a binary file into this BudgetObjectType +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(BudgetObjectType) :: this + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: ibinun + ! -- local + integer(I4B) :: kstp + integer(I4B) :: kper + real(DP) :: delt + real(DP) :: pertim + real(DP) :: totim + ! -- dummy + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + ! -- read flows for each budget term + do i = 1, this%nbudterm + call this%budterm(i)%read_flows(dis, ibinun, kstp, kper, delt, & + pertim, totim) + end do + ! + ! -- return + return + end subroutine read_flows + + subroutine budgetobject_da(this) +! ****************************************************************************** +! budgetobject_da -- deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(BudgetObjectType) :: this + ! -- dummy + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + ! -- save flows for each budget term + do i = 1, this%nbudterm + call this%budterm(i)%deallocate_arrays() + end do + ! + ! -- + if (associated(this%flowtab)) then + deallocate(this%add_cellids) + deallocate(this%icellid) + deallocate(this%nflowterms) + deallocate(this%istart) + deallocate(this%iflowterms) + call this%flowtab%table_da() + deallocate(this%flowtab) + nullify(this%flowtab) + end if + ! + ! -- Return + return + end subroutine budgetobject_da + + subroutine budgetobject_cr_bfr(this, name, ibinun, iout, colconv1, colconv2) +! ****************************************************************************** +! budgetobject_cr_bfr -- Create a new budget object from a binary flow file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + type(BudgetObjectType), pointer :: this + character(len=*), intent(in) :: name + integer(I4B), intent(in) :: ibinun + integer(I4B), intent(in) :: iout + character(len=16), dimension(:), optional :: colconv1 + character(len=16), dimension(:), optional :: colconv2 + ! -- local + integer(I4B) :: ncv, nbudterm + integer(I4B) :: iflowja, nsto + integer(I4B) :: i, j +! ------------------------------------------------------------------------------ + ! + ! -- Create the object + call budgetobject_cr(this, name) + ! + ! -- Initialize the budget file reader + call this%bfr_init(ibinun, ncv, nbudterm, iout) + ! + ! -- Define this budget object using number of control volumes and number + ! of budget terms read from ibinun + iflowja = 0 + nsto = 0 + call this%budgetobject_df(ncv, nbudterm, iflowja, nsto) + ! + ! -- Set the conversion flags, which cause id1 or id2 to be converted from + ! user node numbers to reduced node numbers + if (present(colconv1)) then + do i = 1, nbudterm + do j = 1, size(colconv1) + if (colconv1(j) == adjustl(this%bfr%budtxtarray(i))) then + this%budterm(i)%olconv1 = .true. + exit + end if + end do + end do + end if + if (present(colconv2)) then + do i = 1, nbudterm + do j = 1, size(colconv2) + if (colconv2(j) == adjustl(this%bfr%budtxtarray(i))) then + this%budterm(i)%olconv2 = .true. + exit + end if + end do + end do + end if + ! + ! -- Return + return + end subroutine budgetobject_cr_bfr + + subroutine bfr_init(this, ibinun, ncv, nbudterm, iout) +! ****************************************************************************** +! bfr_init -- initialize the budget file reader +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(BudgetObjectType) :: this + integer(I4B), intent(in) :: ibinun + integer(I4B), intent(inout) :: ncv + integer(I4B), intent(inout) :: nbudterm + integer(I4B), intent(in) :: iout + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- initialize budget file reader + allocate(this%bfr) + call this%bfr%initialize(ibinun, iout, ncv) + nbudterm = this%bfr%nbudterms + ! + ! -- Return + return + end subroutine bfr_init + + subroutine bfr_advance(this, dis, iout) +! ****************************************************************************** +! bfr_advance -- copy the information from the binary file into budterms +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: kstp, kper + ! -- dummy + class(BudgetObjectType) :: this + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: iout + ! -- dummy + logical :: readnext + character(len=*), parameter :: fmtkstpkper = & + "(1x,/1x, a, ' READING BUDGET TERMS FOR KSTP ', i0, ' KPER ', i0)" + character(len=*), parameter :: fmtbudkstpkper = & + "(1x,/1x, a, ' SETTING BUDGET TERMS FOR KSTP ', i0, ' AND KPER ', & + &i0, ' TO BUDGET FILE TERMS FROM KSTP ', i0, ' AND KPER ', i0)" +! ------------------------------------------------------------------------------ + ! + ! -- Do not read the budget if the budget is at end of file or if the next + ! record in the budget file is the first timestep of the next stress + ! period. Also do not read if it is the very first time step because + ! the first chunk of data is read as part of the initialization + readnext = .true. + if (kstp * kper == 1) then + readnext = .false. + else if (kstp * kper > 1) then + if (this%bfr%endoffile) then + readnext = .false. + else + if (this%bfr%kpernext == kper + 1 .and. this%bfr%kstpnext == 1) & + readnext = .false. + endif + endif + ! + ! -- Read the next record + if (readnext) then + ! + ! -- Write the current time step and stress period + if (iout > 0) & + write(iout, fmtkstpkper) this%name, kstp, kper + ! + ! -- read flows from the binary file and copy them into this%budterm(:) + call this%fill_from_bfr(dis, iout) + else + if (iout > 0) & + write(iout, fmtbudkstpkper) trim(this%name), kstp, kper, & + this%bfr%kstp, this%bfr%kper + endif + ! + ! -- Return + return + end subroutine bfr_advance + + subroutine fill_from_bfr(this, dis, iout) +! ****************************************************************************** +! fill_from_bfr -- copy the information from the binary file into budterms +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(BudgetObjectType) :: this + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: iout + ! -- dummy + integer(I4B) :: i + logical :: success +! ------------------------------------------------------------------------------ + ! + ! -- read flows from the binary file and copy them into this%budterm(:) + do i = 1, this%nbudterm + call this%bfr%read_record(success, iout) + call this%budterm(i)%fill_from_bfr(this%bfr, dis) + end do + ! + ! -- Return + return + end subroutine fill_from_bfr + end module BudgetObjectModule \ No newline at end of file diff --git a/src/Utilities/BudgetTerm.f90 b/src/Utilities/BudgetTerm.f90 index 4cf4c7cc527..9405225ffc0 100644 --- a/src/Utilities/BudgetTerm.f90 +++ b/src/Utilities/BudgetTerm.f90 @@ -1,482 +1,482 @@ -! A budget term is the information needed to describe flow. -! The budget object contains an array of budget terms. -! For an advanced package. The budget object describes all of -! the flows. -module BudgetTermModule - - use KindModule, only: I4B, DP - use ConstantsModule, only: LENBUDTXT, DZERO - use BaseDisModule, only: DisBaseType - use InputOutputModule, only: ubdsv06 - - implicit none - - public :: BudgetTermType - - type :: BudgetTermType - - character(len=LENBUDTXT) :: flowtype ! type of flow (WEL, DRN, ...) - character(len=LENBUDTXT) :: text1id1 ! model - character(len=LENBUDTXT) :: text2id1 ! to model - character(len=LENBUDTXT) :: text1id2 ! package/model - character(len=LENBUDTXT) :: text2id2 ! to package/model - character(len=LENBUDTXT), dimension(:), pointer :: auxtxt => null() ! name of auxiliary variables - integer(I4B) :: maxlist ! allocated size of arrays - integer(I4B) :: naux ! number of auxiliary variables - integer(I4B) :: nlist ! size of arrays for this period - logical :: olconv1 = .false. ! convert id1 to user node upon output - logical :: olconv2 = .false. ! convert id2 to user node upon output - logical :: ordered_id1 ! the id1 array is ordered sequentially - integer(I4B), dimension(:), pointer :: id1 => null() ! first id (maxlist) - integer(I4B), dimension(:), pointer :: id2 => null() ! second id (maxlist) - real(DP), dimension(:), pointer :: flow => null() ! point this to simvals or simtomvr (maxlist) - real(DP), dimension(:, :), pointer :: auxvar => null() ! auxiliary variables (naux, maxlist) - integer(I4B) :: icounter ! counter variable - - contains - - procedure :: initialize - procedure :: allocate_arrays - procedure :: reset - procedure :: update_term - procedure :: accumulate_flow - procedure :: save_flows - procedure :: get_nlist - procedure :: get_flowtype - procedure :: get_flow - procedure :: get_id1 - procedure :: get_id2 - procedure :: read_flows - procedure :: fill_from_bfr - procedure :: deallocate_arrays - - end type BudgetTermType - - contains - - subroutine initialize(this, flowtype, text1id1, text2id1, & - text1id2, text2id2, maxlist, olconv1, olconv2, & - naux, auxtxt, ordered_id1) -! ****************************************************************************** -! initialize -- initialize the budget term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(BudgetTermType) :: this - character(len=LENBUDTXT), intent(in) :: flowtype - character(len=LENBUDTXT), intent(in) :: text1id1 - character(len=LENBUDTXT), intent(in) :: text2id1 - character(len=LENBUDTXT), intent(in) :: text1id2 - character(len=LENBUDTXT), intent(in) :: text2id2 - integer(I4B), intent(in) :: maxlist - logical, intent(in) :: olconv1 - logical, intent(in) :: olconv2 - integer(I4B), intent(in) :: naux - character(len=LENBUDTXT), dimension(:), intent(in), optional :: auxtxt - logical, intent(in), optional :: ordered_id1 - ! -- local -! ------------------------------------------------------------------------------ - this%flowtype = flowtype - this%text1id1 = text1id1 - this%text2id1 = text2id1 - this%text1id2 = text1id2 - this%text2id2 = text2id2 - this%maxlist = maxlist - this%olconv1 = olconv1 - this%olconv2 = olconv2 - this%naux = naux - this%nlist = 0 - call this%allocate_arrays() - if (present(auxtxt)) this%auxtxt(:) = auxtxt(1:naux) - this%ordered_id1 = .true. - if (present(ordered_id1)) this%ordered_id1 = ordered_id1 - end subroutine initialize - - subroutine allocate_arrays(this) -! ****************************************************************************** -! allocate_arrays -- allocate budget term arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(BudgetTermType) :: this -! ------------------------------------------------------------------------------ - allocate(this%id1(this%maxlist)) - allocate(this%id2(this%maxlist)) - allocate(this%flow(this%maxlist)) - allocate(this%auxvar(this%naux, this%maxlist)) - allocate(this%auxtxt(this%naux)) - end subroutine allocate_arrays - - subroutine deallocate_arrays(this) -! ****************************************************************************** -! deallocate_arrays -- deallocate budget term arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(BudgetTermType) :: this -! ------------------------------------------------------------------------------ - deallocate(this%id1) - deallocate(this%id2) - deallocate(this%flow) - deallocate(this%auxvar) - deallocate(this%auxtxt) - end subroutine deallocate_arrays - - subroutine reset(this, nlist) -! ****************************************************************************** -! reset -- reset the budget term and counter so terms can be updated -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(BudgetTermType) :: this - integer(I4B), intent(in) :: nlist -! ------------------------------------------------------------------------------ - this%nlist = nlist - this%icounter = 1 - end subroutine reset - - subroutine update_term(this, id1, id2, flow, auxvar) -! ****************************************************************************** -! update_term -- replace the terms in position this%icounter -! for id1, id2, flow, and aux -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(BudgetTermType) :: this - integer(I4B), intent(in) :: id1 - integer(I4B), intent(in) :: id2 - real(DP), intent(in) :: flow - real(DP), dimension(:), intent(in), optional :: auxvar -! ------------------------------------------------------------------------------ - this%id1(this%icounter) = id1 - this%id2(this%icounter) = id2 - this%flow(this%icounter) = flow - if (present(auxvar)) this%auxvar(:, this%icounter) = auxvar(1:this%naux) - this%icounter = this%icounter + 1 - end subroutine update_term - - subroutine accumulate_flow(this, ratin, ratout) -! ****************************************************************************** -! accumulate_flow -- calculate ratin and ratout for all the flow terms -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(BudgetTermType) :: this - real(DP), intent(inout) :: ratin - real(DP), intent(inout) :: ratout - ! -- local - integer(I4B) :: i - real(DP) :: q -! ------------------------------------------------------------------------------ - ratin = DZERO - ratout = DZERO - do i = 1, this%nlist - q = this%flow(i) - if (q < DZERO) then - ratout = ratout - q - else - ratin = ratin + q - end if - end do - end subroutine accumulate_flow - - subroutine save_flows(this, dis, ibinun, kstp, kper, delt, pertim, totim, & - iout) -! ****************************************************************************** -! save_flows -- write flows to a binary file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(BudgetTermType) :: this - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: ibinun - integer(I4B), intent(in) :: kstp - integer(I4B), intent(in) :: kper - real(DP), intent(in) :: delt - real(DP), intent(in) :: pertim - real(DP), intent(in) :: totim - integer(I4B), intent(in) :: iout - ! -- local - integer(I4B) :: i - integer(I4B) :: n1 - integer(I4B) :: n2 - real(DP) :: q -! ------------------------------------------------------------------------------ - call ubdsv06(kstp, kper, this%flowtype, & - this%text1id1, this%text2id1, & - this%text1id2, this%text2id2, & - ibinun, this%naux, this%auxtxt, & - this%nlist, 1, 1, this%nlist, & - iout, delt, pertim, totim) - do i = 1, this%nlist - q = this%flow(i) - n1 = this%id1(i) - n2 = this%id2(i) - call dis%record_mf6_list_entry(ibinun, n1, n2, q, & - this%naux, this%auxvar(:, i), & - olconv=this%olconv1, & - olconv2=this%olconv2) - end do - end subroutine save_flows - - function get_nlist(this) result(nlist) -! ****************************************************************************** -! get_nlist -- get the number of entries for the stress period -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - integer(I4B) :: nlist - ! -- dummy - class(BudgetTermType) :: this -! ------------------------------------------------------------------------------ - nlist = this%nlist - ! - ! -- return - return - end function get_nlist - - function get_flowtype(this) result(flowtype) -! ****************************************************************************** -! get_flowtype -- get the flowtype for the budget term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - character(len=LENBUDTXT) :: flowtype - ! -- dummy - class(BudgetTermType) :: this -! ------------------------------------------------------------------------------ - flowtype = this%flowtype - ! - ! -- return - return - end function get_flowtype - - function get_id1(this, icount) result(id1) -! ****************************************************************************** -! get_id1 -- get id1(icount) for the budget term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - integer(I4B) :: id1 - ! -- dummy - class(BudgetTermType) :: this - integer(I4B), intent(in) :: icount -! ------------------------------------------------------------------------------ - id1 = this%id1(icount) - ! - ! -- return - return - end function get_id1 - - function get_id2(this, icount) result(id2) -! ****************************************************************************** -! get_id2 -- get id2(icount) for the budget term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - integer(I4B) :: id2 - ! -- dummy - class(BudgetTermType) :: this - integer(I4B), intent(in) :: icount -! ------------------------------------------------------------------------------ - id2 = this%id2(icount) - ! - ! -- return - return - end function get_id2 - - function get_flow(this, icount) result(flow) -! ****************************************************************************** -! get_flow -- get flow(icount) for the budget term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - real(DP) :: flow - ! -- dummy - class(BudgetTermType) :: this - integer(I4B), intent(in) :: icount -! ------------------------------------------------------------------------------ - flow = this%flow(icount) - ! - ! -- return - return - end function get_flow - - subroutine read_flows(this, dis, ibinun, kstp, kper, delt, pertim, totim) -! ****************************************************************************** -! read_flows -- read flows from a binary file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(BudgetTermType) :: this - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: ibinun - integer(I4B), intent(inout) :: kstp - integer(I4B), intent(inout) :: kper - real(DP), intent(inout) :: delt - real(DP), intent(inout) :: pertim - real(DP), intent(inout) :: totim - ! -- local - integer(I4B) :: idum1, idum2, imeth - integer(I4B) :: i, j - integer(I4B) :: n1 - integer(I4B) :: n2 - real(DP) :: q -! ------------------------------------------------------------------------------ - read(ibinun) kstp, kper, this%flowtype, this%nlist, idum1, idum2 - read(ibinun) imeth, delt, pertim, totim - read(ibinun) this%text1id1 - read(ibinun) this%text2id1 - read(ibinun) this%text1id2 - read(ibinun) this%text2id2 - read(ibinun) this%naux - this%naux = this%naux - 1 - if (.not. associated(this%auxtxt)) then - allocate(this%auxtxt(this%naux)) - else - if (size(this%auxtxt) /= this%naux) then - deallocate(this%auxtxt) - allocate(this%auxtxt(this%naux)) - end if - end if - if (this%naux > 0) read(ibinun) (this%auxtxt(j), j = 1, this%naux) - read(ibinun) this%nlist - if (.not. associated(this%id1)) then - this%maxlist = this%nlist - allocate(this%id1(this%maxlist)) - allocate(this%id2(this%maxlist)) - allocate(this%flow(this%maxlist)) - allocate(this%auxvar(this%naux, this%maxlist)) - else - if (this%nlist > this%maxlist) then - this%maxlist = this%nlist - deallocate(this%id1) - deallocate(this%id2) - deallocate(this%flow) - deallocate(this%auxvar) - allocate(this%id1(this%maxlist)) - allocate(this%id2(this%maxlist)) - allocate(this%flow(this%maxlist)) - allocate(this%auxvar(this%naux, this%maxlist)) - end if - end if - do i = 1, this%nlist - read(ibinun) n1 - read(ibinun) n2 - read(ibinun) q - read(ibinun) (this%auxvar(j, i), j = 1, this%naux) - if (this%olconv1) n1 = dis%get_nodenumber(n1, 0) - if (this%olconv2) n2 = dis%get_nodenumber(n2, 0) - this%id1(i) = n1 - this%id2(i) = n2 - this%flow(i) = q - end do - end subroutine read_flows - - subroutine fill_from_bfr(this, bfr, dis) -! ****************************************************************************** -! fill_from_bfr -- copy the flow from the binary file reader into this budterm -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use BudgetFileReaderModule, only: BudgetFileReaderType - ! -- dummy - class(BudgetTermType) :: this - type(BudgetFileReaderType) :: bfr - class(DisBaseType), intent(in) :: dis - ! -- local - integer(I4B) :: i - integer(I4B) :: n1 - integer(I4B) :: n2 - real(DP) :: q -! ------------------------------------------------------------------------------ - this%flowtype = bfr%budtxt - this%text1id1 = bfr%srcmodelname - this%text2id1 = bfr%srcpackagename - this%text1id2 = bfr%dstmodelname - this%text2id2 = bfr%dstpackagename - this%naux = bfr%naux - if (.not. associated(this%auxtxt)) then - allocate(this%auxtxt(this%naux)) - else - if (size(this%auxtxt) /= this%naux) then - deallocate(this%auxtxt) - allocate(this%auxtxt(this%naux)) - end if - end if - if (this%naux > 0) this%auxtxt(:) = bfr%auxtxt(:) - this%nlist = bfr%nlist - if (.not. associated(this%id1)) then - this%maxlist = this%nlist - allocate(this%id1(this%maxlist)) - allocate(this%id2(this%maxlist)) - allocate(this%flow(this%maxlist)) - allocate(this%auxvar(this%naux, this%maxlist)) - else - if (this%nlist > this%maxlist) then - this%maxlist = this%nlist - deallocate(this%id1) - deallocate(this%id2) - deallocate(this%flow) - deallocate(this%auxvar) - allocate(this%id1(this%maxlist)) - allocate(this%id2(this%maxlist)) - allocate(this%flow(this%maxlist)) - allocate(this%auxvar(this%naux, this%maxlist)) - end if - end if - do i = 1, this%nlist - n1 = bfr%nodesrc(i) - n2 = bfr%nodedst(i) - q = bfr%flow(i) - this%auxvar(:, i) = bfr%auxvar(:, i) - if (this%olconv1) n1 = dis%get_nodenumber(n1, 0) - if (this%olconv2) n2 = dis%get_nodenumber(n2, 0) - this%id1(i) = n1 - this%id2(i) = n2 - this%flow(i) = q - end do - end subroutine fill_from_bfr - +! A budget term is the information needed to describe flow. +! The budget object contains an array of budget terms. +! For an advanced package. The budget object describes all of +! the flows. +module BudgetTermModule + + use KindModule, only: I4B, DP + use ConstantsModule, only: LENBUDTXT, DZERO + use BaseDisModule, only: DisBaseType + use InputOutputModule, only: ubdsv06 + + implicit none + + public :: BudgetTermType + + type :: BudgetTermType + + character(len=LENBUDTXT) :: flowtype ! type of flow (WEL, DRN, ...) + character(len=LENBUDTXT) :: text1id1 ! model + character(len=LENBUDTXT) :: text2id1 ! to model + character(len=LENBUDTXT) :: text1id2 ! package/model + character(len=LENBUDTXT) :: text2id2 ! to package/model + character(len=LENBUDTXT), dimension(:), pointer :: auxtxt => null() ! name of auxiliary variables + integer(I4B) :: maxlist ! allocated size of arrays + integer(I4B) :: naux ! number of auxiliary variables + integer(I4B) :: nlist ! size of arrays for this period + logical :: olconv1 = .false. ! convert id1 to user node upon output + logical :: olconv2 = .false. ! convert id2 to user node upon output + logical :: ordered_id1 ! the id1 array is ordered sequentially + integer(I4B), dimension(:), pointer :: id1 => null() ! first id (maxlist) + integer(I4B), dimension(:), pointer :: id2 => null() ! second id (maxlist) + real(DP), dimension(:), pointer :: flow => null() ! point this to simvals or simtomvr (maxlist) + real(DP), dimension(:, :), pointer :: auxvar => null() ! auxiliary variables (naux, maxlist) + integer(I4B) :: icounter ! counter variable + + contains + + procedure :: initialize + procedure :: allocate_arrays + procedure :: reset + procedure :: update_term + procedure :: accumulate_flow + procedure :: save_flows + procedure :: get_nlist + procedure :: get_flowtype + procedure :: get_flow + procedure :: get_id1 + procedure :: get_id2 + procedure :: read_flows + procedure :: fill_from_bfr + procedure :: deallocate_arrays + + end type BudgetTermType + + contains + + subroutine initialize(this, flowtype, text1id1, text2id1, & + text1id2, text2id2, maxlist, olconv1, olconv2, & + naux, auxtxt, ordered_id1) +! ****************************************************************************** +! initialize -- initialize the budget term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(BudgetTermType) :: this + character(len=LENBUDTXT), intent(in) :: flowtype + character(len=LENBUDTXT), intent(in) :: text1id1 + character(len=LENBUDTXT), intent(in) :: text2id1 + character(len=LENBUDTXT), intent(in) :: text1id2 + character(len=LENBUDTXT), intent(in) :: text2id2 + integer(I4B), intent(in) :: maxlist + logical, intent(in) :: olconv1 + logical, intent(in) :: olconv2 + integer(I4B), intent(in) :: naux + character(len=LENBUDTXT), dimension(:), intent(in), optional :: auxtxt + logical, intent(in), optional :: ordered_id1 + ! -- local +! ------------------------------------------------------------------------------ + this%flowtype = flowtype + this%text1id1 = text1id1 + this%text2id1 = text2id1 + this%text1id2 = text1id2 + this%text2id2 = text2id2 + this%maxlist = maxlist + this%olconv1 = olconv1 + this%olconv2 = olconv2 + this%naux = naux + this%nlist = 0 + call this%allocate_arrays() + if (present(auxtxt)) this%auxtxt(:) = auxtxt(1:naux) + this%ordered_id1 = .true. + if (present(ordered_id1)) this%ordered_id1 = ordered_id1 + end subroutine initialize + + subroutine allocate_arrays(this) +! ****************************************************************************** +! allocate_arrays -- allocate budget term arrays +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(BudgetTermType) :: this +! ------------------------------------------------------------------------------ + allocate(this%id1(this%maxlist)) + allocate(this%id2(this%maxlist)) + allocate(this%flow(this%maxlist)) + allocate(this%auxvar(this%naux, this%maxlist)) + allocate(this%auxtxt(this%naux)) + end subroutine allocate_arrays + + subroutine deallocate_arrays(this) +! ****************************************************************************** +! deallocate_arrays -- deallocate budget term arrays +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(BudgetTermType) :: this +! ------------------------------------------------------------------------------ + deallocate(this%id1) + deallocate(this%id2) + deallocate(this%flow) + deallocate(this%auxvar) + deallocate(this%auxtxt) + end subroutine deallocate_arrays + + subroutine reset(this, nlist) +! ****************************************************************************** +! reset -- reset the budget term and counter so terms can be updated +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(BudgetTermType) :: this + integer(I4B), intent(in) :: nlist +! ------------------------------------------------------------------------------ + this%nlist = nlist + this%icounter = 1 + end subroutine reset + + subroutine update_term(this, id1, id2, flow, auxvar) +! ****************************************************************************** +! update_term -- replace the terms in position this%icounter +! for id1, id2, flow, and aux +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(BudgetTermType) :: this + integer(I4B), intent(in) :: id1 + integer(I4B), intent(in) :: id2 + real(DP), intent(in) :: flow + real(DP), dimension(:), intent(in), optional :: auxvar +! ------------------------------------------------------------------------------ + this%id1(this%icounter) = id1 + this%id2(this%icounter) = id2 + this%flow(this%icounter) = flow + if (present(auxvar)) this%auxvar(:, this%icounter) = auxvar(1:this%naux) + this%icounter = this%icounter + 1 + end subroutine update_term + + subroutine accumulate_flow(this, ratin, ratout) +! ****************************************************************************** +! accumulate_flow -- calculate ratin and ratout for all the flow terms +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(BudgetTermType) :: this + real(DP), intent(inout) :: ratin + real(DP), intent(inout) :: ratout + ! -- local + integer(I4B) :: i + real(DP) :: q +! ------------------------------------------------------------------------------ + ratin = DZERO + ratout = DZERO + do i = 1, this%nlist + q = this%flow(i) + if (q < DZERO) then + ratout = ratout - q + else + ratin = ratin + q + end if + end do + end subroutine accumulate_flow + + subroutine save_flows(this, dis, ibinun, kstp, kper, delt, pertim, totim, & + iout) +! ****************************************************************************** +! save_flows -- write flows to a binary file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(BudgetTermType) :: this + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: ibinun + integer(I4B), intent(in) :: kstp + integer(I4B), intent(in) :: kper + real(DP), intent(in) :: delt + real(DP), intent(in) :: pertim + real(DP), intent(in) :: totim + integer(I4B), intent(in) :: iout + ! -- local + integer(I4B) :: i + integer(I4B) :: n1 + integer(I4B) :: n2 + real(DP) :: q +! ------------------------------------------------------------------------------ + call ubdsv06(kstp, kper, this%flowtype, & + this%text1id1, this%text2id1, & + this%text1id2, this%text2id2, & + ibinun, this%naux, this%auxtxt, & + this%nlist, 1, 1, this%nlist, & + iout, delt, pertim, totim) + do i = 1, this%nlist + q = this%flow(i) + n1 = this%id1(i) + n2 = this%id2(i) + call dis%record_mf6_list_entry(ibinun, n1, n2, q, & + this%naux, this%auxvar(:, i), & + olconv=this%olconv1, & + olconv2=this%olconv2) + end do + end subroutine save_flows + + function get_nlist(this) result(nlist) +! ****************************************************************************** +! get_nlist -- get the number of entries for the stress period +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + integer(I4B) :: nlist + ! -- dummy + class(BudgetTermType) :: this +! ------------------------------------------------------------------------------ + nlist = this%nlist + ! + ! -- return + return + end function get_nlist + + function get_flowtype(this) result(flowtype) +! ****************************************************************************** +! get_flowtype -- get the flowtype for the budget term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + character(len=LENBUDTXT) :: flowtype + ! -- dummy + class(BudgetTermType) :: this +! ------------------------------------------------------------------------------ + flowtype = this%flowtype + ! + ! -- return + return + end function get_flowtype + + function get_id1(this, icount) result(id1) +! ****************************************************************************** +! get_id1 -- get id1(icount) for the budget term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + integer(I4B) :: id1 + ! -- dummy + class(BudgetTermType) :: this + integer(I4B), intent(in) :: icount +! ------------------------------------------------------------------------------ + id1 = this%id1(icount) + ! + ! -- return + return + end function get_id1 + + function get_id2(this, icount) result(id2) +! ****************************************************************************** +! get_id2 -- get id2(icount) for the budget term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + integer(I4B) :: id2 + ! -- dummy + class(BudgetTermType) :: this + integer(I4B), intent(in) :: icount +! ------------------------------------------------------------------------------ + id2 = this%id2(icount) + ! + ! -- return + return + end function get_id2 + + function get_flow(this, icount) result(flow) +! ****************************************************************************** +! get_flow -- get flow(icount) for the budget term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + real(DP) :: flow + ! -- dummy + class(BudgetTermType) :: this + integer(I4B), intent(in) :: icount +! ------------------------------------------------------------------------------ + flow = this%flow(icount) + ! + ! -- return + return + end function get_flow + + subroutine read_flows(this, dis, ibinun, kstp, kper, delt, pertim, totim) +! ****************************************************************************** +! read_flows -- read flows from a binary file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(BudgetTermType) :: this + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: ibinun + integer(I4B), intent(inout) :: kstp + integer(I4B), intent(inout) :: kper + real(DP), intent(inout) :: delt + real(DP), intent(inout) :: pertim + real(DP), intent(inout) :: totim + ! -- local + integer(I4B) :: idum1, idum2, imeth + integer(I4B) :: i, j + integer(I4B) :: n1 + integer(I4B) :: n2 + real(DP) :: q +! ------------------------------------------------------------------------------ + read(ibinun) kstp, kper, this%flowtype, this%nlist, idum1, idum2 + read(ibinun) imeth, delt, pertim, totim + read(ibinun) this%text1id1 + read(ibinun) this%text2id1 + read(ibinun) this%text1id2 + read(ibinun) this%text2id2 + read(ibinun) this%naux + this%naux = this%naux - 1 + if (.not. associated(this%auxtxt)) then + allocate(this%auxtxt(this%naux)) + else + if (size(this%auxtxt) /= this%naux) then + deallocate(this%auxtxt) + allocate(this%auxtxt(this%naux)) + end if + end if + if (this%naux > 0) read(ibinun) (this%auxtxt(j), j = 1, this%naux) + read(ibinun) this%nlist + if (.not. associated(this%id1)) then + this%maxlist = this%nlist + allocate(this%id1(this%maxlist)) + allocate(this%id2(this%maxlist)) + allocate(this%flow(this%maxlist)) + allocate(this%auxvar(this%naux, this%maxlist)) + else + if (this%nlist > this%maxlist) then + this%maxlist = this%nlist + deallocate(this%id1) + deallocate(this%id2) + deallocate(this%flow) + deallocate(this%auxvar) + allocate(this%id1(this%maxlist)) + allocate(this%id2(this%maxlist)) + allocate(this%flow(this%maxlist)) + allocate(this%auxvar(this%naux, this%maxlist)) + end if + end if + do i = 1, this%nlist + read(ibinun) n1 + read(ibinun) n2 + read(ibinun) q + read(ibinun) (this%auxvar(j, i), j = 1, this%naux) + if (this%olconv1) n1 = dis%get_nodenumber(n1, 0) + if (this%olconv2) n2 = dis%get_nodenumber(n2, 0) + this%id1(i) = n1 + this%id2(i) = n2 + this%flow(i) = q + end do + end subroutine read_flows + + subroutine fill_from_bfr(this, bfr, dis) +! ****************************************************************************** +! fill_from_bfr -- copy the flow from the binary file reader into this budterm +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use BudgetFileReaderModule, only: BudgetFileReaderType + ! -- dummy + class(BudgetTermType) :: this + type(BudgetFileReaderType) :: bfr + class(DisBaseType), intent(in) :: dis + ! -- local + integer(I4B) :: i + integer(I4B) :: n1 + integer(I4B) :: n2 + real(DP) :: q +! ------------------------------------------------------------------------------ + this%flowtype = bfr%budtxt + this%text1id1 = bfr%srcmodelname + this%text2id1 = bfr%srcpackagename + this%text1id2 = bfr%dstmodelname + this%text2id2 = bfr%dstpackagename + this%naux = bfr%naux + if (.not. associated(this%auxtxt)) then + allocate(this%auxtxt(this%naux)) + else + if (size(this%auxtxt) /= this%naux) then + deallocate(this%auxtxt) + allocate(this%auxtxt(this%naux)) + end if + end if + if (this%naux > 0) this%auxtxt(:) = bfr%auxtxt(:) + this%nlist = bfr%nlist + if (.not. associated(this%id1)) then + this%maxlist = this%nlist + allocate(this%id1(this%maxlist)) + allocate(this%id2(this%maxlist)) + allocate(this%flow(this%maxlist)) + allocate(this%auxvar(this%naux, this%maxlist)) + else + if (this%nlist > this%maxlist) then + this%maxlist = this%nlist + deallocate(this%id1) + deallocate(this%id2) + deallocate(this%flow) + deallocate(this%auxvar) + allocate(this%id1(this%maxlist)) + allocate(this%id2(this%maxlist)) + allocate(this%flow(this%maxlist)) + allocate(this%auxvar(this%naux, this%maxlist)) + end if + end if + do i = 1, this%nlist + n1 = bfr%nodesrc(i) + n2 = bfr%nodedst(i) + q = bfr%flow(i) + this%auxvar(:, i) = bfr%auxvar(:, i) + if (this%olconv1) n1 = dis%get_nodenumber(n1, 0) + if (this%olconv2) n2 = dis%get_nodenumber(n2, 0) + this%id1(i) = n1 + this%id2(i) = n2 + this%flow(i) = q + end do + end subroutine fill_from_bfr + end module BudgetTermModule \ No newline at end of file diff --git a/src/Utilities/Constants.f90 b/src/Utilities/Constants.f90 index b0747690f4e..d00f96f9f97 100644 --- a/src/Utilities/Constants.f90 +++ b/src/Utilities/Constants.f90 @@ -1,127 +1,127 @@ -module ConstantsModule - use KindModule - public - ! -- constants - integer(I4B), parameter :: IUSERFORMATSTRIP = -99 - integer(I4B), parameter :: IUSERFORMATWRAP = 99 - integer(I4B), parameter :: LENBIGLINE = 5000 - integer(I4B), parameter :: LENHUGELINE = 50000 - integer(I4B), parameter :: LENVARNAME = 16 - integer(I4B), parameter :: LENMODELNAME = 16 - integer(I4B), parameter :: LENSOLUTIONNAME = 16 - integer(I4B), parameter :: LENAUXNAME = 16 - integer(I4B), parameter :: LENBOUNDNAME = 40 - integer(I4B), parameter :: LENBUDTXT = 16 - integer(I4B), parameter :: LENPACKAGENAME = 16 - integer(I4B), parameter :: LENPACKAGETYPE = 7 - integer(I4B), parameter :: LENORIGIN = LENMODELNAME + LENPACKAGENAME + 1 - integer(I4B), parameter :: LENFTYPE = 5 - integer(I4B), parameter :: LENOBSNAME = 40 - integer(I4B), parameter :: LENOBSTYPE = 30 - integer(I4B), parameter :: LENTIMESERIESNAME = LENOBSNAME - integer(I4B), parameter :: LENTIMESERIESTEXT = 12 - integer(I4B), parameter :: LENDATETIME = 30 - integer(I4B), parameter :: LINELENGTH = 300 - integer(I4B), parameter :: LENLISTLABEL = 500 - integer(I4B), parameter :: MAXCHARLEN = 1000 - integer(I4B), parameter :: MAXOBSTYPES = 100 - integer(I4B), parameter :: NAMEDBOUNDFLAG = -9 - integer(I4B), parameter :: LENPAKLOC = 34 - integer(I4B), parameter :: IZERO = 0 - ! - ! -- file constants - integer(I4B), parameter :: IUSTART = 1000 - integer(I4B), parameter :: IULAST = 10000 - ! - ! -- memory manager constants +module ConstantsModule + use KindModule + public + ! -- constants + integer(I4B), parameter :: IUSERFORMATSTRIP = -99 + integer(I4B), parameter :: IUSERFORMATWRAP = 99 + integer(I4B), parameter :: LENBIGLINE = 5000 + integer(I4B), parameter :: LENHUGELINE = 50000 + integer(I4B), parameter :: LENVARNAME = 16 + integer(I4B), parameter :: LENMODELNAME = 16 + integer(I4B), parameter :: LENSOLUTIONNAME = 16 + integer(I4B), parameter :: LENAUXNAME = 16 + integer(I4B), parameter :: LENBOUNDNAME = 40 + integer(I4B), parameter :: LENBUDTXT = 16 + integer(I4B), parameter :: LENPACKAGENAME = 16 + integer(I4B), parameter :: LENPACKAGETYPE = 7 + integer(I4B), parameter :: LENORIGIN = LENMODELNAME + LENPACKAGENAME + 1 + integer(I4B), parameter :: LENFTYPE = 5 + integer(I4B), parameter :: LENOBSNAME = 40 + integer(I4B), parameter :: LENOBSTYPE = 30 + integer(I4B), parameter :: LENTIMESERIESNAME = LENOBSNAME + integer(I4B), parameter :: LENTIMESERIESTEXT = 12 + integer(I4B), parameter :: LENDATETIME = 30 + integer(I4B), parameter :: LINELENGTH = 300 + integer(I4B), parameter :: LENLISTLABEL = 500 + integer(I4B), parameter :: MAXCHARLEN = 1000 + integer(I4B), parameter :: MAXOBSTYPES = 100 + integer(I4B), parameter :: NAMEDBOUNDFLAG = -9 + integer(I4B), parameter :: LENPAKLOC = 34 + integer(I4B), parameter :: IZERO = 0 + ! + ! -- file constants + integer(I4B), parameter :: IUSTART = 1000 + integer(I4B), parameter :: IULAST = 10000 + ! + ! -- memory manager constants integer(I4B), public, parameter :: MAXMEMRANK = 3 - integer(I4B), public, parameter :: LENMEMTYPE = 50 - ! - ! -- real constants - real(DP), parameter :: DZERO = 0.0_DP - real(DP), parameter :: DONETHIRD = 1.0_DP / 3.0_DP - real(DP), parameter :: DHALF = 0.5_DP - real(DP), parameter :: DQUARTER = 0.25_DP - real(DP), parameter :: DP6 = 0.6_DP - real(DP), parameter :: DTWOTHIRDS = 2.0_DP / 3.0_DP - real(DP), parameter :: DP7 = 0.7_DP - real(DP), parameter :: DP9 = 0.9_DP - real(DP), parameter :: DP99 = 0.99_DP - real(DP), parameter :: DP999 = 0.999_DP - - real(DP), parameter :: DONE = 1.0_DP - real(DP), parameter :: D1P1 = 1.1_DP - real(DP), parameter :: DFIVETHIRDS = 5.0_DP / 3.0_DP - real(DP), parameter :: DTWO = 2.0_DP - real(DP), parameter :: DTHREE = 3.0_DP - real(DP), parameter :: DFOUR = 4.0_DP - real(DP), parameter :: DSIX = 6.0_DP - real(DP), parameter :: DEIGHT = 8.0_DP - real(DP), parameter :: DTEN = 1.0e1_DP - real(DP), parameter :: DHUNDRED = 1.0e2_DP - - real(DP), parameter :: DEP6 = 1.0e6_DP - real(DP), parameter :: DEP20 = 1.0e20_DP - - real(DP), parameter :: DHNOFLO = 1.e30_DP - real(DP), parameter :: DHDRY = -1.e30_DP - real(DP), parameter :: DNODATA = 3.0e30_DP - - real(DP), parameter :: DEM1 = 1.0e-1_DP - real(DP), parameter :: D5EM2 = 5.0e-2_DP - real(DP), parameter :: DEM2 = 1.0e-2_DP - real(DP), parameter :: DEM3 = 1.0e-3_DP - real(DP), parameter :: DEM4 = 1.0e-4_DP - real(DP), parameter :: DEM5 = 1.0e-5_DP - real(DP), parameter :: DEM6 = 1.0e-6_DP - real(DP), parameter :: DEM7 = 1.0e-7_DP - real(DP), parameter :: DEM8 = 1.0e-8_DP - real(DP), parameter :: DEM9 = 1.0e-9_DP - real(DP), parameter :: DEM10 = 1.0e-10_DP - real(DP), parameter :: DEM12 = 1.0e-12_DP - real(DP), parameter :: DEM14 = 1.0e-14_DP - real(DP), parameter :: DEM15 = 1.0e-15_DP - real(DP), parameter :: DEM20 = 1.0e-20_DP - real(DP), parameter :: DEM30 = 1.0e-30_DP - - real(DP), parameter :: DPREC = EPSILON(1.0_DP) - real(DP), parameter :: DSAME = DHUNDRED * DPREC - - real(DP), parameter :: DLNLOW = 0.995_DP - real(DP), parameter :: DLNHIGH = 1.005_DP - - real(DP), parameter :: DPI = DFOUR * ATAN(DONE) - real(DP), parameter :: DTWOPI = DTWO * DFOUR * ATAN(DONE) - real(DP), parameter :: DPIO180 = datan(DONE)/4.5d1 - - real(DP), parameter :: DGRAVITY = 9.80665_DP - real(DP), parameter :: DCD = 0.61_DP - - character(len=10), dimension(3, 3), parameter :: cidxnames = reshape ( & - [ ' NODE', ' ', ' ', & - ' LAYER', ' CELL2D', ' ', & - ' LAYER', ' ROW', ' COL'], [3,3]) - - ! -- Enumerators used with TimeSeriesType - ENUM, BIND(C) - ! Sets UNDEFINED=0, STEPWISE=1, LINEAR=2, LINEAREND=3 - ENUMERATOR :: UNDEFINED, STEPWISE, LINEAR, LINEAREND - END ENUM - - ! -- enumerators used with table objects - ENUM, BIND(C) - ! Sets TABLEFT=0, TABCENTER=1, TABRIGHT=2 - ENUMERATOR :: TABLEFT, TABCENTER, TABRIGHT - END ENUM - - ENUM, BIND(C) - ! Sets TABSTRING=0, TABUCSTRING=1, TABINTEGER=2, TABREAL=3 - ENUMERATOR :: TABSTRING, TABUCSTRING, TABINTEGER, TABREAL - END ENUM - - ENUM, BIND(C) - ! Sets VSUMMARY=0, VALL=1, VDEBUG=2 - ENUMERATOR :: VSUMMARY, VALL, VDEBUG - END ENUM - -end module ConstantsModule + integer(I4B), public, parameter :: LENMEMTYPE = 50 + ! + ! -- real constants + real(DP), parameter :: DZERO = 0.0_DP + real(DP), parameter :: DONETHIRD = 1.0_DP / 3.0_DP + real(DP), parameter :: DHALF = 0.5_DP + real(DP), parameter :: DQUARTER = 0.25_DP + real(DP), parameter :: DP6 = 0.6_DP + real(DP), parameter :: DTWOTHIRDS = 2.0_DP / 3.0_DP + real(DP), parameter :: DP7 = 0.7_DP + real(DP), parameter :: DP9 = 0.9_DP + real(DP), parameter :: DP99 = 0.99_DP + real(DP), parameter :: DP999 = 0.999_DP + + real(DP), parameter :: DONE = 1.0_DP + real(DP), parameter :: D1P1 = 1.1_DP + real(DP), parameter :: DFIVETHIRDS = 5.0_DP / 3.0_DP + real(DP), parameter :: DTWO = 2.0_DP + real(DP), parameter :: DTHREE = 3.0_DP + real(DP), parameter :: DFOUR = 4.0_DP + real(DP), parameter :: DSIX = 6.0_DP + real(DP), parameter :: DEIGHT = 8.0_DP + real(DP), parameter :: DTEN = 1.0e1_DP + real(DP), parameter :: DHUNDRED = 1.0e2_DP + + real(DP), parameter :: DEP6 = 1.0e6_DP + real(DP), parameter :: DEP20 = 1.0e20_DP + + real(DP), parameter :: DHNOFLO = 1.e30_DP + real(DP), parameter :: DHDRY = -1.e30_DP + real(DP), parameter :: DNODATA = 3.0e30_DP + + real(DP), parameter :: DEM1 = 1.0e-1_DP + real(DP), parameter :: D5EM2 = 5.0e-2_DP + real(DP), parameter :: DEM2 = 1.0e-2_DP + real(DP), parameter :: DEM3 = 1.0e-3_DP + real(DP), parameter :: DEM4 = 1.0e-4_DP + real(DP), parameter :: DEM5 = 1.0e-5_DP + real(DP), parameter :: DEM6 = 1.0e-6_DP + real(DP), parameter :: DEM7 = 1.0e-7_DP + real(DP), parameter :: DEM8 = 1.0e-8_DP + real(DP), parameter :: DEM9 = 1.0e-9_DP + real(DP), parameter :: DEM10 = 1.0e-10_DP + real(DP), parameter :: DEM12 = 1.0e-12_DP + real(DP), parameter :: DEM14 = 1.0e-14_DP + real(DP), parameter :: DEM15 = 1.0e-15_DP + real(DP), parameter :: DEM20 = 1.0e-20_DP + real(DP), parameter :: DEM30 = 1.0e-30_DP + + real(DP), parameter :: DPREC = EPSILON(1.0_DP) + real(DP), parameter :: DSAME = DHUNDRED * DPREC + + real(DP), parameter :: DLNLOW = 0.995_DP + real(DP), parameter :: DLNHIGH = 1.005_DP + + real(DP), parameter :: DPI = DFOUR * ATAN(DONE) + real(DP), parameter :: DTWOPI = DTWO * DFOUR * ATAN(DONE) + real(DP), parameter :: DPIO180 = datan(DONE)/4.5d1 + + real(DP), parameter :: DGRAVITY = 9.80665_DP + real(DP), parameter :: DCD = 0.61_DP + + character(len=10), dimension(3, 3), parameter :: cidxnames = reshape ( & + [ ' NODE', ' ', ' ', & + ' LAYER', ' CELL2D', ' ', & + ' LAYER', ' ROW', ' COL'], [3,3]) + + ! -- Enumerators used with TimeSeriesType + ENUM, BIND(C) + ! Sets UNDEFINED=0, STEPWISE=1, LINEAR=2, LINEAREND=3 + ENUMERATOR :: UNDEFINED, STEPWISE, LINEAR, LINEAREND + END ENUM + + ! -- enumerators used with table objects + ENUM, BIND(C) + ! Sets TABLEFT=0, TABCENTER=1, TABRIGHT=2 + ENUMERATOR :: TABLEFT, TABCENTER, TABRIGHT + END ENUM + + ENUM, BIND(C) + ! Sets TABSTRING=0, TABUCSTRING=1, TABINTEGER=2, TABREAL=3 + ENUMERATOR :: TABSTRING, TABUCSTRING, TABINTEGER, TABREAL + END ENUM + + ENUM, BIND(C) + ! Sets VSUMMARY=0, VALL=1, VDEBUG=2 + ENUMERATOR :: VSUMMARY, VALL, VDEBUG + END ENUM + +end module ConstantsModule diff --git a/src/Utilities/DeferredStringObject.f90 b/src/Utilities/DeferredStringObject.f90 index 7bb83eb6b15..6889c6d77d9 100644 --- a/src/Utilities/DeferredStringObject.f90 +++ b/src/Utilities/DeferredStringObject.f90 @@ -1,10 +1,10 @@ -module DeferredStringModule - implicit none - - public :: deferred_string_type - - type deferred_string_type - character(len=:), allocatable :: string - end type deferred_string_type - -end module DeferredStringModule +module DeferredStringModule + implicit none + + public :: deferred_string_type + + type deferred_string_type + character(len=:), allocatable :: string + end type deferred_string_type + +end module DeferredStringModule diff --git a/src/Utilities/InputOutput.f90 b/src/Utilities/InputOutput.f90 index 5dd6afa0349..cce5b5e738f 100644 --- a/src/Utilities/InputOutput.f90 +++ b/src/Utilities/InputOutput.f90 @@ -1,2216 +1,2216 @@ -! -- MODFLOW 6 utility routines. -! -module InputOutputModule - - use KindModule, only: DP, I4B - use SimVariablesModule, only: iunext - use SimModule, only: store_error, ustop, store_error_unit, & - store_error_filename - use ConstantsModule, only: IUSTART, IULAST, & - LINELENGTH, LENBIGLINE, LENBOUNDNAME, & - NAMEDBOUNDFLAG, MAXCHARLEN, & - TABLEFT, TABCENTER, TABRIGHT, & - TABSTRING, TABUCSTRING, TABINTEGER, TABREAL, & - DZERO - use GenericUtilitiesModule, only: IS_SAME, sim_message - private - public :: GetUnit, u8rdcom, uget_block, & - uterminate_block, UPCASE, URWORD, ULSTLB, UBDSV4, & - ubdsv06, UBDSVB, UCOLNO, ULAPRW, & - ULASAV, ubdsv1, ubdsvc, ubdsvd, UWWORD, & - same_word, get_node, get_ijk, unitinquire, & - ParseLine, ulaprufw, openfile, & - linear_interpolate, lowcase, & - read_line, uget_any_block, & - GetFileFromPath, extract_idnum_or_bndname, urdaux, & - get_jk, uget_block_line, print_format, BuildFixedFormat, & - BuildFloatFormat, BuildIntFormat, fseek_stream, & - get_nwords - - contains - - subroutine openfile(iu, iout, fname, ftype, fmtarg_opt, accarg_opt, & - filstat_opt) -! ****************************************************************************** -! openfile -- Open a file using the specified arguments. -! -! iu is the unit number -! iout is the output unit number to write a message (iout=0 does not print) -! fname is the name of the file -! ftype is the type of the file (e.g. WEL) -! fmtarg_opt is the format, default is 'formatted' -! accarg_opt is the access, default is 'sequential' -! filstat_opt is the file status, default is 'old'. Use 'REPLACE' for an -! output file. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use OpenSpecModule, only: action - implicit none - ! -- dummy - integer(I4B), intent(inout) :: iu - integer(I4B), intent(in) :: iout - character(len=*), intent(in) :: fname - character(len=*), intent(in) :: ftype - character(len=*), intent(in), optional :: fmtarg_opt - character(len=*), intent(in), optional :: accarg_opt - character(len=*), intent(in), optional :: filstat_opt - ! -- local - character(len=20) :: fmtarg - character(len=20) :: accarg - character(len=20) :: filstat - character(len=20) :: filact - integer(I4B) :: iflen - integer(I4B) :: ivar - integer(I4B) :: iuop - character(len=LINELENGTH) :: errmsg - ! -- formats -50 FORMAT(1X,/1X,'OPENED ',A,/ & - 1X,'FILE TYPE:',A,' UNIT ',I4,3X,'STATUS:',A,/ & - 1X,'FORMAT:',A,3X,'ACCESS:',A/ & - 1X,'ACTION:',A/) -2011 FORMAT('*** ERROR OPENING FILE "',A,'" ON UNIT ',I0) -2017 format('*** FILE ALREADY OPEN ON UNIT: ',I0) -2012 format(' SPECIFIED FILE STATUS: ',A) -2013 format(' SPECIFIED FILE FORMAT: ',A) -2014 format(' SPECIFIED FILE ACCESS: ',A) -2015 format(' SPECIFIED FILE ACTION: ',A) -2016 format(' IOSTAT ERROR NUMBER: ',I0) -2018 format(' -- STOP EXECUTION (openfile)') -! ------------------------------------------------------------------------------ - ! - ! -- Default is to read an existing text file - fmtarg = 'FORMATTED' - accarg = 'SEQUENTIAL' - filstat = 'OLD' - ! - ! -- Override defaults - if(present(fmtarg_opt)) then - fmtarg = fmtarg_opt - call upcase(fmtarg) - endif - if(present(accarg_opt)) then - accarg = accarg_opt - call upcase(accarg) - endif - if(present(filstat_opt)) then - filstat = filstat_opt - call upcase(filstat) - endif - if(filstat == 'OLD') then - filact = action(1) - else - filact = action(2) - endif - ! - ! -- size of fname - iflen = len_trim(fname) - ! - ! -- Get a free unit number - if(iu <= 0) then - call freeunitnumber(iu) - endif - ! - ! -- Check to see if file is already open, if not then open the file - inquire(file=fname(1:iflen), number=iuop) - if(iuop > 0) then - ivar = -1 - else - open(unit=iu, file=fname(1:iflen), form=fmtarg, access=accarg, & - status=filstat, action=filact, iostat=ivar) - endif - ! - ! -- Check for an error - if(ivar /= 0) then - write(errmsg,2011) fname(1:iflen), iu - call store_error(errmsg) - if(iuop > 0) then - write(errmsg, 2017) iuop - call store_error(errmsg) - endif - write(errmsg,2012) filstat - call store_error(errmsg) - write(errmsg,2013) fmtarg - call store_error(errmsg) - write(errmsg,2014) accarg - call store_error(errmsg) - write(errmsg,2015) filact - call store_error(errmsg) - write(errmsg,2016) ivar - call store_error(errmsg) - write(errmsg,2018) - call store_error(errmsg) - call ustop() - endif - ! - ! -- Write a message - if(iout > 0) then - write(iout, 50) fname(1:iflen), & - ftype, iu, filstat, & - fmtarg, accarg, & - filact - endif - ! - ! -- return - return - end subroutine openfile - - subroutine freeunitnumber(iu) -! ****************************************************************************** -! Assign a free unopened unit number to the iu dummy argument. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - implicit none - ! -- dummy - integer(I4B),intent(inout) :: iu - ! -- local - integer(I4B) :: i - logical :: opened -! ------------------------------------------------------------------------------ - ! - do i = iunext, iulast - inquire(unit=i, opened=opened) - if(.not. opened) exit - enddo - iu = i - iunext = iu + 1 - ! - ! -- return - return - end subroutine freeunitnumber - - function getunit() -! ****************************************************************************** -! Get a free unit number that hasn't been used yet. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - implicit none - ! -- return - integer(I4B) :: getunit - ! -- local - integer(I4B) :: iunit -! ------------------------------------------------------------------------------ - ! - call freeunitnumber(iunit) - getunit = iunit - ! - ! -- Return - return - end function getunit - - subroutine u8rdcom(iin, iout, line, ierr) -! ****************************************************************************** -! Read until non-comment line found and then return line -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use, intrinsic :: iso_fortran_env, only: IOSTAT_END - implicit none - ! -- dummy - integer(I4B), intent(in) :: iin - integer(I4B), intent(in) :: iout - character (len=*), intent(inout) :: line - integer(I4B), intent(out) :: ierr - ! -- local definitions - character (len=2), parameter :: comment = '//' - character(len=LINELENGTH) :: errmsg - character(len=1), parameter :: tab = CHAR(9) - logical :: iscomment - integer(I4B) :: i, l -! ------------------------------------------------------------------------------ - !code - ! - !readerrmsg = '' - line = comment - pcomments: do - read (iin,'(a)', iostat=ierr) line - !read (iin,'(a)', iostat=ierr, iomsg=readerrmsg) line - if (ierr == IOSTAT_END) then - ! -- End of file reached. - ! -- Backspace is needed for gfortran. - backspace(iin) - line = ' ' - exit pcomments - elseif (ierr /= 0) then - ! -- Other error...report it - call store_error('******Error in u8rdcom.') - write(errmsg, *) 'Could not read from unit: ',iin - call store_error(errmsg) - !write(errmsg,*)'Error reported as: ',trim(readerrmsg) - !call store_error(errmsg) - call unitinquire(iin) - call ustop() - endif - if (len_trim(line).lt.1) then - line = comment - cycle - end if - ! - ! Ensure that any initial tab characters are treated as spaces - cleartabs: do - line = trim(adjustl(line)) - iscomment = .false. - select case (line(1:1)) - case ('#') - iscomment = .true. - exit cleartabs - case ('!') - iscomment = .true. - exit cleartabs - case (tab) - line(1:1) = ' ' - cycle cleartabs - case default - if (line(1:2).eq.comment) iscomment = .true. - if (len_trim(line) < 1) iscomment = .true. - exit cleartabs - end select - end do cleartabs - ! - if (.not.iscomment) then - exit pcomments - else - if (iout > 0) then - !find the last non-blank character. - l=len(line) - do i = l, 1, -1 - if(line(i:i).ne.' ') then - exit - end if - end do - !print the line up to the last non-blank character. - write(iout,'(1x,a)') line(1:i) - end if - end if - end do pcomments - return - end subroutine u8rdcom - - subroutine uget_block_line(iu, iuext, iout, line, lloc, istart, istop) -! ****************************************************************************** -! Read and return line read from an external file or from within a block. -! The line is read from an external file if iu is not equal to iuext -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - integer(I4B), intent(in) :: iu - integer(I4B), intent(in) :: iuext - integer(I4B), intent(in) :: iout - character (len=*), intent(inout) :: line - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - ! -- local definitions - integer(I4B) :: ierr - integer(I4B) :: ival - real(DP) :: rval -! ------------------------------------------------------------------------------ - lloc = 1 - call u8rdcom(iuext, iout, line, ierr) - call urword(line, lloc, istart, istop, 1, ival, rval, iout, iuext) - ! -- determine if an empty string is returned - ! condition occurs if the end of the file has been read - if (len_trim(line) < 1) then - ! -- if external file, read line from package unit (iu) - if (iuext /= iu) then - lloc = 1 - call u8rdcom(iu, iout, line, ierr) - call urword(line, lloc, istart, istop, 1, ival, rval, iout, iu) - end if - end if - return - end subroutine uget_block_line - - - subroutine uget_block(iin, iout, ctag, ierr, isfound, lloc, line, iuext, & - blockRequired, supportopenclose) -! ****************************************************************************** -! Read until the ctag block is found. Return isfound with true, if found. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - integer(I4B), intent(in) :: iin - integer(I4B), intent(in) :: iout - character (len=*), intent(in) :: ctag - integer(I4B), intent(out) :: ierr - logical, intent(inout) :: isfound - integer(I4B), intent(inout) :: lloc - character (len=*), intent(inout) :: line - integer(I4B), intent(inout) :: iuext - logical, optional, intent(in) :: blockRequired - logical, optional, intent(in) :: supportopenclose - ! -- local - integer(I4B) :: istart - integer(I4B) :: istop - integer(I4B) :: ival - integer(I4B) :: lloc2 - real(DP) :: rval - character(len=LINELENGTH) :: fname, line2 - character(len=MAXCHARLEN) :: ermsg - logical :: supportoc, blockRequiredLocal -! ------------------------------------------------------------------------------ - !code - if (present(blockRequired)) then - blockRequiredLocal = blockRequired - else - blockRequiredLocal = .true. - endif - supportoc = .false. - if (present(supportopenclose)) then - supportoc = supportopenclose - endif - iuext = iin - isfound = .false. - mainloop: do - lloc = 1 - call u8rdcom(iin, iout, line, ierr) - if (ierr < 0) exit - call urword(line, lloc, istart, istop, 1, ival, rval, iin, iout) - if (line(istart:istop) == 'BEGIN') then - call urword(line, lloc, istart, istop, 1, ival, rval, iin, iout) - if (line(istart:istop) == ctag) then - isfound = .true. - if (supportoc) then - ! Look for OPEN/CLOSE on 1st line after line starting with BEGIN - call u8rdcom(iin,iout,line2,ierr) - if (ierr < 0) exit - lloc2 = 1 - call urword(line2, lloc2, istart, istop, 1, ival, rval, iin, iout) - if (line2(istart:istop) == 'OPEN/CLOSE') then - ! -- Get filename and preserve case - call urword(line2, lloc2, istart, istop, 0, ival, rval, iin, iout) - fname = line2(istart:istop) - ! If line contains '(BINARY)' or 'SFAC', handle this block elsewhere - chk: do - call urword(line2, lloc2, istart, istop, 1, ival, rval, iin, iout) - if (line2(istart:istop) == '') exit chk - if (line2(istart:istop) == '(BINARY)' .or. & - line2(istart:istop) == 'SFAC') then - backspace(iin) - exit mainloop - end if - end do chk - iuext = GetUnit() - call openfile(iuext,iout,fname,'OPEN/CLOSE') - else - backspace(iin) - end if - end if - else - if (blockRequiredLocal) then - ermsg = 'Error: Required block "' // trim(ctag) // & - '" not found. Found block "' // line(istart:istop) // & - '" instead.' - call store_error(ermsg) - call store_error_unit(iuext) - call ustop() - else - backspace(iin) - endif - end if - exit mainloop - else if (line(istart:istop) == 'END') then - call urword(line, lloc, istart, istop, 1, ival, rval, iin, iout) - if (line(istart:istop) == ctag) then - ermsg = 'Error: Looking for BEGIN ' // trim(ctag) // & - ' but found END ' // line(istart:istop) // & - ' instead.' - call store_error(ermsg) - call store_error_unit(iuext) - call ustop() - endif - end if - end do mainloop - return - end subroutine uget_block - - subroutine uget_any_block(iin,iout,isfound,lloc,line,ctagfound,iuext) -! ****************************************************************************** -! Read until any block is found. If found, return isfound as true and -! return block name in ctagfound. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - integer(I4B), intent(in) :: iin - integer(I4B), intent(in) :: iout - logical, intent(inout) :: isfound - integer(I4B), intent(inout) :: lloc - character (len=*), intent(inout) :: line - character(len=*), intent(out) :: ctagfound - integer(I4B), intent(inout) :: iuext - ! -- local - integer(I4B) :: ierr, istart, istop - integer(I4B) :: ival, lloc2 - real(DP) :: rval - character(len=100) :: ermsg - character(len=LINELENGTH) :: line2, fname -! ------------------------------------------------------------------------------ - !code - isfound = .false. - ctagfound = '' - iuext = iin - do - lloc = 1 - call u8rdcom(iin,iout,line,ierr) - if (ierr < 0) exit - call urword(line, lloc, istart, istop, 1, ival, rval, iin, iout) - if (line(istart:istop) == 'BEGIN') then - call urword(line, lloc, istart, istop, 1, ival, rval, iin, iout) - if (line(istart:istop) /= '') then - isfound = .true. - ctagfound = line(istart:istop) - call u8rdcom(iin,iout,line2,ierr) - if (ierr < 0) exit - lloc2 = 1 - call urword(line2,lloc2,istart,istop,1,ival,rval,iout,iin) - if (line2(istart:istop) == 'OPEN/CLOSE') then - iuext = GetUnit() - call urword(line2,lloc2,istart,istop,0,ival,rval,iout,iin) - fname = line2(istart:istop) - call openfile(iuext,iout,fname,'OPEN/CLOSE') - else - backspace(iin) - endif - else - ermsg = 'Block name missing in file.' - call store_error(ermsg) - call store_error_unit(iin) - call ustop() - end if - exit - end if - end do - return - end subroutine uget_any_block - - subroutine uterminate_block(iin,iout,key,ctag,lloc,line,ierr,iuext) -! ****************************************************************************** -! Possible abnormal block termination. Terminate if 'begin' found or if -! 'end' encountered with incorrect tag. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - integer(I4B), intent(in) :: iin - integer(I4B), intent(in) :: iout - character (len=*), intent(in) :: key - character (len=*), intent(in) :: ctag - integer(I4B), intent(inout) :: lloc - character (len=*), intent(inout) :: line - integer(I4B), intent(inout) :: ierr - integer(I4B), intent(inout) :: iuext - ! -- local - character(len=LENBIGLINE) :: ermsg - integer(I4B) :: istart - integer(I4B) :: istop - integer(I4B) :: ival - real(DP) :: rval - ! -- format -1 format('ERROR. "',A,'" DETECTED WITHOUT "',A,'". ','"END',1X,A, & - '" MUST BE USED TO END ',A,'.') -2 format('ERROR. "',A,'" DETECTED BEFORE "END',1X,A,'". ','"END',1X,A, & - '" MUST BE USED TO END ',A,'.') -! ------------------------------------------------------------------------------ - !code - ierr = 1 - select case(key) - case ('END') - call urword(line, lloc, istart, istop, 1, ival, rval, iout, iin) - if (line(istart:istop).ne.ctag) then - write(ermsg, 1) trim(key), trim(ctag), trim(ctag), trim(ctag) - call store_error(ermsg) - call store_error_unit(iin) - call ustop() - else - ierr = 0 - if (iuext /= iin) then - ! close external file - close(iuext) - iuext = iin - endif - end if - case ('BEGIN') - write(ermsg, 2) trim(key), trim(ctag), trim(ctag), trim(ctag) - call store_error(ermsg) - call store_error_unit(iin) - call ustop() - end select - return - end subroutine uterminate_block - - SUBROUTINE UPCASE(WORD) -!C ****************************************************************** -!C CONVERT A CHARACTER STRING TO ALL UPPER CASE -!C ****************************************************************** -!C SPECIFICATIONS: -!C ------------------------------------------------------------------ - CHARACTER WORD*(*) -!C -!C1------Compute the difference between lowercase and uppercase. - L = LEN(WORD) - IDIFF=ICHAR('a')-ICHAR('A') -!C -!C2------Loop through the string and convert any lowercase characters. - DO 10 K=1,L - IF(WORD(K:K).GE.'a' .AND. WORD(K:K).LE.'z') & - & WORD(K:K)=CHAR(ICHAR(WORD(K:K))-IDIFF) -10 CONTINUE -!C -!C3------return. - RETURN - END SUBROUTINE upcase - - subroutine lowcase(word) -! ****************************************************************** -! Convert a character string to all lower case -! ****************************************************************** -! specifications: -! ------------------------------------------------------------------ - implicit none - ! -- dummy - character(len=*) :: word - ! -- local - integer(I4B) :: idiff, k, l -! -!------compute the difference between lowercase and uppercase. - l = len(word) - idiff=ichar('a')-ichar('A') -! -!------loop through the string and convert any uppercase characters. - do k=1,l - if(word(k:k).ge.'A' .and. word(k:k).le.'Z') then - word(k:k)=char(ichar(word(k:k))+idiff) - endif - enddo -! -!------return. - return - end subroutine lowcase - - subroutine UWWORD(LINE,ICOL,ILEN,NCODE,C,N,R,FMT,ALIGNMENT,SEP) - implicit none - ! -- dummy - character (len=*), intent(inout) :: LINE - integer(I4B), intent(inout) :: ICOL - integer(I4B), intent(in) :: ILEN - integer(I4B), intent(in) :: NCODE - character (len=*), intent(in) :: C - integer(I4B), intent(in) :: N - real(DP), intent(in) :: R - character (len=*), optional, intent(in) :: FMT - integer(I4B), optional, intent(in) :: ALIGNMENT - character (len=*), optional, intent(in) :: SEP - ! -- local - character (len=16) :: cfmt - character (len=16) :: cffmt - character (len=ILEN) :: cval - integer(I4B) :: ialign - integer(I4B) :: i - integer(I4B) :: ispace - integer(I4B) :: istop - integer(I4B) :: ipad - integer(I4B) :: ireal - ! -- code - ! - ! -- initialize locals - ipad = 0 - ireal = 0 - ! - ! -- process dummy variables - if (present(FMT)) then - CFMT = FMT - else - select case(NCODE) - case(TABSTRING, TABUCSTRING) - write(cfmt, '(A,I0,A)') '(A', ILEN, ')' - case(TABINTEGER) - write(cfmt, '(A,I0,A)') '(I', ILEN, ')' - case(TABREAL) - ireal = 1 - i = ILEN - 7 - write(cfmt, '(A,I0,A,I0,A)') '(1PG', ILEN, '.', i, ')' - if (R >= DZERO) then - ipad = 1 - end if - end select - end if - write(cffmt, '(A,I0,A)') '(A', ILEN, ')' - - if (present(ALIGNMENT)) then - ialign = ALIGNMENT - else - ialign = TABRIGHT - end if - ! - ! -- - if (NCODE == TABSTRING .or. NCODE == TABUCSTRING) then - cval = C - if (NCODE == TABUCSTRING) then - call UPCASE(cval) - end if - else if (NCODE == TABINTEGER) then - write(cval, cfmt) N - else if (NCODE == TABREAL) then - write(cval, cfmt) R - end if - ! - ! -- apply alignment to cval - if (len_trim(adjustl(cval)) > ILEN) then - cval = adjustl(cval) - else - cval = trim(adjustl(cval)) - end if - if (ialign == TABCENTER) then - i = len_trim(cval) - ispace = (ILEN - i) / 2 - if (ireal > 0) then - if (ipad > 0) then - cval = ' ' //trim(adjustl(cval)) - else - cval = trim(adjustl(cval)) - end if - else - cval = repeat(' ', ispace) // trim(cval) - end if - else if (ialign == TABLEFT) then - cval = trim(adjustl(cval)) - if (ipad > 0) then - cval = ' ' //trim(adjustl(cval)) - end if - else - cval = adjustr(cval) - end if - if (NCODE == TABUCSTRING) then - call UPCASE(cval) - end if - ! - ! -- increment istop to the end of the column - istop = ICOL + ILEN - 1 - ! - ! -- write final string to line - write(LINE(ICOL:istop), cffmt) cval - - ICOL = istop + 1 - - if (present(SEP)) then - i = len(SEP) - istop = ICOL + i - write(LINE(ICOL:istop), '(A)') SEP - ICOL = istop - end if - -! -!------return. - return - end subroutine UWWORD - - SUBROUTINE URWORD(LINE,ICOL,ISTART,ISTOP,NCODE,N,R,IOUT,IN) -!C ****************************************************************** -!C ROUTINE TO EXTRACT A WORD FROM A LINE OF TEXT, AND OPTIONALLY -!C CONVERT THE WORD TO A NUMBER. -!C ISTART AND ISTOP WILL BE RETURNED WITH THE STARTING AND -!C ENDING CHARACTER POSITIONS OF THE WORD. -!C THE LAST CHARACTER IN THE LINE IS SET TO BLANK SO THAT IF ANY -!C PROBLEMS OCCUR WITH FINDING A WORD, ISTART AND ISTOP WILL -!C POINT TO THIS BLANK CHARACTER. THUS, A WORD WILL ALWAYS BE -!C RETURNED UNLESS THERE IS A NUMERIC CONVERSION ERROR. BE SURE -!C THAT THE LAST CHARACTER IN LINE IS NOT AN IMPORTANT CHARACTER -!C BECAUSE IT WILL ALWAYS BE SET TO BLANK. -!C A WORD STARTS WITH THE FIRST CHARACTER THAT IS NOT A SPACE OR -!C COMMA, AND ENDS WHEN A SUBSEQUENT CHARACTER THAT IS A SPACE -!C OR COMMA. NOTE THAT THESE PARSING RULES DO NOT TREAT TWO -!C COMMAS SEPARATED BY ONE OR MORE SPACES AS A NULL WORD. -!C FOR A WORD THAT BEGINS WITH "'", THE WORD STARTS WITH THE -!C CHARACTER AFTER THE QUOTE AND ENDS WITH THE CHARACTER -!C PRECEDING A SUBSEQUENT QUOTE. THUS, A QUOTED WORD CAN -!C INCLUDE SPACES AND COMMAS. THE QUOTED WORD CANNOT CONTAIN -!C A QUOTE CHARACTER. -!C IF NCODE IS 1, THE WORD IS CONVERTED TO UPPER CASE. -!C IF NCODE IS 2, THE WORD IS CONVERTED TO AN INTEGER. -!C IF NCODE IS 3, THE WORD IS CONVERTED TO A REAL NUMBER. -!C NUMBER CONVERSION ERROR IS WRITTEN TO UNIT IOUT IF IOUT IS -!C POSITIVE; ERROR IS WRITTEN TO DEFAULT OUTPUT IF IOUT IS 0; -!C NO ERROR MESSAGE IS WRITTEN IF IOUT IS NEGATIVE. -!C ****************************************************************** -!C -!C SPECIFICATIONS: -!C ------------------------------------------------------------------ - integer(I4B), intent(inout) :: n - real(DP),intent(inout) :: r - CHARACTER(len=*) LINE - CHARACTER(len=20) STRING - CHARACTER(len=30) RW - CHARACTER(len=1) TAB - character(len=200) :: msg - character(len=LINELENGTH) :: msg_line -!C ------------------------------------------------------------------ - TAB=CHAR(9) -!C -!C1------Set last char in LINE to blank and set ISTART and ISTOP to point -!C1------to this blank as a default situation when no word is found. If -!C1------starting location in LINE is out of bounds, do not look for a -!C1------word. - LINLEN=LEN(LINE) - LINE(LINLEN:LINLEN)=' ' - ISTART=LINLEN - ISTOP=LINLEN - LINLEN=LINLEN-1 - IF(ICOL.LT.1 .OR. ICOL.GT.LINLEN) GO TO 100 -!C -!C2------Find start of word, which is indicated by first character that -!C2------is not a blank, a comma, or a tab. - DO 10 I=ICOL,LINLEN - IF(LINE(I:I).NE.' ' .AND. LINE(I:I).NE.',' & - & .AND. LINE(I:I).NE.TAB) GO TO 20 -10 CONTINUE - ICOL=LINLEN+1 - GO TO 100 -!C -!C3------Found start of word. Look for end. -!C3A-----When word is quoted, only a quote can terminate it. -20 IF(LINE(I:I).EQ.'''') THEN - I=I+1 - IF(I.LE.LINLEN) THEN - DO 25 J=I,LINLEN - IF(LINE(J:J).EQ.'''') GO TO 40 -25 CONTINUE - END IF -!C -!C3B-----When word is not quoted, space, comma, or tab will terminate. - ELSE - DO 30 J=I,LINLEN - IF(LINE(J:J).EQ.' ' .OR. LINE(J:J).EQ.',' & - & .OR. LINE(J:J).EQ.TAB) GO TO 40 -30 CONTINUE - END IF -!C -!C3C-----End of line without finding end of word; set end of word to -!C3C-----end of line. - J=LINLEN+1 -!C -!C4------Found end of word; set J to point to last character in WORD and -!C-------set ICOL to point to location for scanning for another word. -40 ICOL=J+1 - J=J-1 - IF(J.LT.I) GO TO 100 - ISTART=I - ISTOP=J -!C -!C5------Convert word to upper case and RETURN if NCODE is 1. - IF(NCODE.EQ.1) THEN - IDIFF=ICHAR('a')-ICHAR('A') - DO 50 K=ISTART,ISTOP - IF(LINE(K:K).GE.'a' .AND. LINE(K:K).LE.'z') & - & LINE(K:K)=CHAR(ICHAR(LINE(K:K))-IDIFF) -50 CONTINUE - RETURN - END IF -!C -!C6------Convert word to a number if requested. -100 IF(NCODE.EQ.2 .OR. NCODE.EQ.3) THEN - RW=' ' - L=30-ISTOP+ISTART - IF(L.LT.1) GO TO 200 - RW(L:30)=LINE(ISTART:ISTOP) - IF(NCODE.EQ.2) READ(RW,'(I30)',ERR=200) N - IF(NCODE.EQ.3) READ(RW,'(F30.0)',ERR=200) R - END IF - RETURN -!C -!C7------Number conversion error. -200 IF(NCODE.EQ.3) THEN - STRING= 'A REAL NUMBER' - L=13 - ELSE - STRING= 'AN INTEGER' - L=10 - END IF -!C -!C7A-----If output unit is negative, set last character of string to 'E'. - IF(IOUT.LT.0) THEN - N=0 - R=0. - LINE(LINLEN+1:LINLEN+1)='E' - RETURN -!C -!C7B-----If output unit is positive; write a message to output unit. - ELSE IF(IOUT.GT.0) THEN - IF(IN.GT.0) THEN - write(msg_line,201) IN,LINE(ISTART:ISTOP),STRING(1:L) - ELSE - WRITE(msg_line,202) LINE(ISTART:ISTOP),STRING(1:L) - END IF - call sim_message(msg_line, iunit=IOUT, skipbefore=1) - call sim_message(LINE, iunit=IOUT, fmt='(1x,a)') -201 FORMAT(1X,'FILE UNIT ',I4,' : ERROR CONVERTING "',A, & - & '" TO ',A,' IN LINE:') -202 FORMAT(1X,'KEYBOARD INPUT : ERROR CONVERTING "',A, & - '" TO ',A,' IN LINE:') -!C -!C7C-----If output unit is 0; write a message to default output. - ELSE - IF(IN.GT.0) THEN - write(msg_line,201) IN,LINE(ISTART:ISTOP),STRING(1:L) - ELSE - WRITE(msg_line,202) LINE(ISTART:ISTOP),STRING(1:L) - END IF - call sim_message(msg_line, iunit=IOUT, skipbefore=1) - call sim_message(LINE, iunit=IOUT, fmt='(1x,a)') - END IF -!C -!C7D-----STOP after storing error message. - call lowcase(string) - if (in > 0) then - write(msg,205) in,line(istart:istop),trim(string) - else - write(msg,207) line(istart:istop),trim(string) - endif -205 format('File unit ',I0,': Error converting "',A, & - & '" to ',A,' in following line:') -207 format('Keyboard input: Error converting "',A, & - & '" to ',A,' in following line:') - call store_error(msg) - call store_error(trim(line)) - call store_error_unit(in) - call ustop() - ! - END SUBROUTINE URWORD - - SUBROUTINE ULSTLB(IOUT,LABEL,CAUX,NCAUX,NAUX) -!C ****************************************************************** -!C PRINT A LABEL FOR A LIST -!C ****************************************************************** -!C -!C SPECIFICATIONS: -!C ------------------------------------------------------------------ - CHARACTER(len=*) LABEL - CHARACTER(len=16) CAUX(NCAUX) - CHARACTER(len=400) BUF - CHARACTER(len=1) DASH(400) - DATA DASH/400*'-'/ -!C ------------------------------------------------------------------ -!C -!C1------Construct the complete label in BUF. Start with BUF=LABEL. - BUF=LABEL -!C -!C2------Add auxiliary data names if there are any. - NBUF=LEN(LABEL)+9 - IF(NAUX.GT.0) THEN - DO 10 I=1,NAUX - N1=NBUF+1 - NBUF=NBUF+16 - BUF(N1:NBUF)=CAUX(I) -10 CONTINUE - END IF -!C -!C3------Write the label. - WRITE(IOUT,103) BUF(1:NBUF) - 103 FORMAT(1X,A) -!C -!C4------Add a line of dashes. - WRITE(IOUT,104) (DASH(J),J=1,NBUF) - 104 FORMAT(1X,400A) -!C -!C5------Return. - RETURN - END SUBROUTINE ULSTLB -! - - SUBROUTINE UBDSV4(KSTP,KPER,TEXT,NAUX,AUXTXT,IBDCHN, & - & NCOL,NROW,NLAY,NLIST,IOUT,DELT,PERTIM,TOTIM) -!C ****************************************************************** -!C WRITE HEADER RECORDS FOR CELL-BY-CELL FLOW TERMS FOR ONE COMPONENT -!C OF FLOW PLUS AUXILIARY DATA USING A LIST STRUCTURE. EACH ITEM IN -!C THE LIST IS WRITTEN BY MODULE UBDSVB -!C ****************************************************************** -!C -!C SPECIFICATIONS: -!C ------------------------------------------------------------------ - CHARACTER(len=16) :: TEXT - character(len=16), dimension(:) :: AUXTXT - real(DP),intent(in) :: delt,pertim,totim - character(len=*), parameter :: fmt = & - "(1X,'UBDSV4 SAVING ',A16,' ON UNIT',I7,' AT TIME STEP',I7,"// & - "', STRESS PERIOD',I7)" -!C ------------------------------------------------------------------ -!C -!C1------WRITE UNFORMATTED RECORDS IDENTIFYING DATA. - IF(IOUT.GT.0) WRITE(IOUT,fmt) TEXT,IBDCHN,KSTP,KPER - WRITE(IBDCHN) KSTP,KPER,TEXT,NCOL,NROW,-NLAY - WRITE(IBDCHN) 5,DELT,PERTIM,TOTIM - WRITE(IBDCHN) NAUX+1 - IF(NAUX.GT.0) WRITE(IBDCHN) (AUXTXT(N),N=1,NAUX) - WRITE(IBDCHN) NLIST -!C -!C2------RETURN - RETURN - END SUBROUTINE UBDSV4 - - SUBROUTINE UBDSVB(IBDCHN,ICRL,Q,VAL,NVL,NAUX,LAUX) -!C ****************************************************************** -!C WRITE ONE VALUE OF CELL-BY-CELL FLOW PLUS AUXILIARY DATA USING -!C A LIST STRUCTURE. -!C ****************************************************************** -!C -!C SPECIFICATIONS: -!C ------------------------------------------------------------------ - real(DP), DIMENSION(nvl) :: VAL - real(DP) :: q -!C ------------------------------------------------------------------ -!C -!C1------WRITE CELL NUMBER AND FLOW RATE - IF(NAUX.GT.0) THEN - N2=LAUX+NAUX-1 - WRITE(IBDCHN) ICRL,Q,(VAL(N),N=LAUX,N2) - ELSE - WRITE(IBDCHN) ICRL,Q - END IF -!C -!C2------RETURN - RETURN - END SUBROUTINE UBDSVB - - SUBROUTINE UCOLNO(NLBL1,NLBL2,NSPACE,NCPL,NDIG,IOUT) -!C ****************************************************************** -!C OUTPUT COLUMN NUMBERS ABOVE A MATRIX PRINTOUT -!C NLBL1 IS THE START COLUMN LABEL (NUMBER) -!C NLBL2 IS THE STOP COLUMN LABEL (NUMBER) -!C NSPACE IS NUMBER OF BLANK SPACES TO LEAVE AT START OF LINE -!C NCPL IS NUMBER OF COLUMN NUMBERS PER LINE -!C NDIG IS NUMBER OF CHARACTERS IN EACH COLUMN FIELD -!C IOUT IS OUTPUT CHANNEL -!C ****************************************************************** -!C -!C SPECIFICATIONS: -!C ------------------------------------------------------------------ - CHARACTER(len=1) DOT,SPACE,DG,BF - DIMENSION BF(1000),DG(10) -!C - DATA DG(1),DG(2),DG(3),DG(4),DG(5),DG(6),DG(7),DG(8),DG(9),DG(10)/ & - & '0','1','2','3','4','5','6','7','8','9'/ - DATA DOT,SPACE/'.',' '/ -!C ------------------------------------------------------------------ -!C -!C1------CALCULATE # OF COLUMNS TO BE PRINTED (NLBL), WIDTH -!C1------OF A LINE (NTOT), NUMBER OF LINES (NWRAP). - if (iout<=0) return - WRITE(IOUT,1) - 1 FORMAT(1X) - NLBL=NLBL2-NLBL1+1 - N=NLBL - IF(NLBL.GT.NCPL) N=NCPL - NTOT=NSPACE+N*NDIG - IF(NTOT.GT.1000) GO TO 50 - NWRAP=(NLBL-1)/NCPL + 1 - J1=NLBL1-NCPL - J2=NLBL1-1 -!C -!C2------BUILD AND PRINT EACH LINE - DO 40 N=1,NWRAP -!C -!C3------CLEAR THE BUFFER (BF). - DO 20 I=1,1000 - BF(I)=SPACE - 20 CONTINUE - NBF=NSPACE -!C -!C4------DETERMINE FIRST (J1) AND LAST (J2) COLUMN # FOR THIS LINE. - J1=J1+NCPL - J2=J2+NCPL - IF(J2.GT.NLBL2) J2=NLBL2 -!C -!C5------LOAD THE COLUMN #'S INTO THE BUFFER. - DO 30 J=J1,J2 - NBF=NBF+NDIG - I2=J/10 - I1=J-I2*10+1 - BF(NBF)=DG(I1) - IF(I2.EQ.0) GO TO 30 - I3=I2/10 - I2=I2-I3*10+1 - BF(NBF-1)=DG(I2) - IF(I3.EQ.0) GO TO 30 - I4=I3/10 - I3=I3-I4*10+1 - BF(NBF-2)=DG(I3) - IF(I4.EQ.0) GO TO 30 - IF(I4.GT.9) THEN -!C5A-----If more than 4 digits, use "X" for 4th digit. - BF(NBF-3)='X' - ELSE - BF(NBF-3)=DG(I4+1) - END IF - 30 CONTINUE -!C -!C6------PRINT THE CONTENTS OF THE BUFFER (I.E. PRINT THE LINE). - WRITE(IOUT,31) (BF(I),I=1,NBF) - 31 FORMAT(1X,1000A1) -!C - 40 CONTINUE -!C -!C7------PRINT A LINE OF DOTS (FOR AESTHETIC PURPOSES ONLY). - 50 NTOT=NTOT - IF(NTOT.GT.1000) NTOT=1000 - WRITE(IOUT,51) (DOT,I=1,NTOT) - 51 FORMAT(1X,1000A1) -!C -!C8------RETURN - RETURN - END SUBROUTINE UCOLNO - - SUBROUTINE ULAPRW(BUF,TEXT,KSTP,KPER,NCOL,NROW,ILAY,IPRN,IOUT) -!C ****************************************************************** -!C PRINT 1 LAYER ARRAY -!C ****************************************************************** -!C -!C SPECIFICATIONS: -!C ------------------------------------------------------------------ - CHARACTER(len=16) TEXT - real(DP),dimension(ncol,nrow) :: buf -!C ------------------------------------------------------------------ -!C - if (iout<=0) return -!C1------PRINT A HEADER DEPENDING ON ILAY - IF(ILAY.GT.0) THEN - WRITE(IOUT,1) TEXT,ILAY,KSTP,KPER - 1 FORMAT('1',/2X,A,' IN LAYER ',I3,' AT END OF TIME STEP ',I3, & - & ' IN STRESS PERIOD ',I4/2X,75('-')) - ELSE IF(ILAY.LT.0) THEN - WRITE(IOUT,2) TEXT,KSTP,KPER - 2 FORMAT('1',/1X,A,' FOR CROSS SECTION AT END OF TIME STEP',I3, & - & ' IN STRESS PERIOD ',I4/1X,79('-')) - END IF -!C -!C2------MAKE SURE THE FORMAT CODE (IP OR IPRN) IS -!C2------BETWEEN 1 AND 21. - IP=IPRN - IF(IP.LT.1 .OR. IP.GT.21) IP=12 -!C -!C3------CALL THE UTILITY MODULE UCOLNO TO PRINT COLUMN NUMBERS. - IF(IP.EQ.1) CALL UCOLNO(1,NCOL,0,11,11,IOUT) - IF(IP.EQ.2) CALL UCOLNO(1,NCOL,0,9,14,IOUT) - IF(IP.GE.3 .AND. IP.LE.6) CALL UCOLNO(1,NCOL,3,15,8,IOUT) - IF(IP.GE.7 .AND. IP.LE.11) CALL UCOLNO(1,NCOL,3,20,6,IOUT) - IF(IP.EQ.12) CALL UCOLNO(1,NCOL,0,10,12,IOUT) - IF(IP.GE.13 .AND. IP.LE.18) CALL UCOLNO(1,NCOL,3,10,7,IOUT) - IF(IP.EQ.19) CALL UCOLNO(1,NCOL,0,5,13,IOUT) - IF(IP.EQ.20) CALL UCOLNO(1,NCOL,0,6,12,IOUT) - IF(IP.EQ.21) CALL UCOLNO(1,NCOL,0,7,10,IOUT) -!C -!C4------LOOP THROUGH THE ROWS PRINTING EACH ONE IN ITS ENTIRETY. - DO I=1,NROW - SELECT CASE(IP) - - CASE(1) -!C------------ FORMAT 11G10.3 - WRITE(IOUT,11) I,(BUF(J,I),J=1,NCOL) -11 FORMAT(1X,I3,2X,1PG10.3,10(1X,G10.3):/(5X,11(1X,G10.3))) - - CASE(2) -!C------------ FORMAT 9G13.6 - WRITE(IOUT,21) I,(BUF(J,I),J=1,NCOL) -21 FORMAT(1X,I3,2X,1PG13.6,8(1X,G13.6):/(5X,9(1X,G13.6))) - - CASE(3) -!C------------ FORMAT 15F7.1 - WRITE(IOUT,31) I,(BUF(J,I),J=1,NCOL) -31 FORMAT(1X,I3,1X,15(1X,F7.1):/(5X,15(1X,F7.1))) - - CASE(4) -!C------------ FORMAT 15F7.2 - WRITE(IOUT,41) I,(BUF(J,I),J=1,NCOL) -41 FORMAT(1X,I3,1X,15(1X,F7.2):/(5X,15(1X,F7.2))) - - CASE(5) -!C------------ FORMAT 15F7.3 - WRITE(IOUT,51) I,(BUF(J,I),J=1,NCOL) -51 FORMAT(1X,I3,1X,15(1X,F7.3):/(5X,15(1X,F7.3))) - - CASE(6) -!C------------ FORMAT 15F7.4 - WRITE(IOUT,61) I,(BUF(J,I),J=1,NCOL) -61 FORMAT(1X,I3,1X,15(1X,F7.4):/(5X,15(1X,F7.4))) - - CASE(7) -!C------------ FORMAT 20F5.0 - WRITE(IOUT,71) I,(BUF(J,I),J=1,NCOL) -71 FORMAT(1X,I3,1X,20(1X,F5.0):/(5X,20(1X,F5.0))) - - CASE(8) -!C------------ FORMAT 20F5.1 - WRITE(IOUT,81) I,(BUF(J,I),J=1,NCOL) -81 FORMAT(1X,I3,1X,20(1X,F5.1):/(5X,20(1X,F5.1))) - - CASE(9) -!C------------ FORMAT 20F5.2 - WRITE(IOUT,91) I,(BUF(J,I),J=1,NCOL) -91 FORMAT(1X,I3,1X,20(1X,F5.2):/(5X,20(1X,F5.2))) - - CASE(10) -!C------------ FORMAT 20F5.3 - WRITE(IOUT,101) I,(BUF(J,I),J=1,NCOL) -101 FORMAT(1X,I3,1X,20(1X,F5.3):/(5X,20(1X,F5.3))) - - CASE(11) -!C------------ FORMAT 20F5.4 - WRITE(IOUT,111) I,(BUF(J,I),J=1,NCOL) -111 FORMAT(1X,I3,1X,20(1X,F5.4):/(5X,20(1X,F5.4))) - - CASE(12) -!C------------ FORMAT 10G11.4 - WRITE(IOUT,121) I,(BUF(J,I),J=1,NCOL) -121 FORMAT(1X,I3,2X,1PG11.4,9(1X,G11.4):/(5X,10(1X,G11.4))) - - CASE(13) -!C------------ FORMAT 10F6.0 - WRITE(IOUT,131) I,(BUF(J,I),J=1,NCOL) -131 FORMAT(1X,I3,1X,10(1X,F6.0):/(5X,10(1X,F6.0))) - - CASE(14) -!C------------ FORMAT 10F6.1 - WRITE(IOUT,141) I,(BUF(J,I),J=1,NCOL) -141 FORMAT(1X,I3,1X,10(1X,F6.1):/(5X,10(1X,F6.1))) - - CASE(15) -!C------------ FORMAT 10F6.2 - WRITE(IOUT,151) I,(BUF(J,I),J=1,NCOL) -151 FORMAT(1X,I3,1X,10(1X,F6.2):/(5X,10(1X,F6.2))) - - CASE(16) -!C------------ FORMAT 10F6.3 - WRITE(IOUT,161) I,(BUF(J,I),J=1,NCOL) -161 FORMAT(1X,I3,1X,10(1X,F6.3):/(5X,10(1X,F6.3))) - - CASE(17) -!C------------ FORMAT 10F6.4 - WRITE(IOUT,171) I,(BUF(J,I),J=1,NCOL) -171 FORMAT(1X,I3,1X,10(1X,F6.4):/(5X,10(1X,F6.4))) - - CASE(18) -!C------------ FORMAT 10F6.5 - WRITE(IOUT,181) I,(BUF(J,I),J=1,NCOL) -181 FORMAT(1X,I3,1X,10(1X,F6.5):/(5X,10(1X,F6.5))) - - CASE(19) -!C------------FORMAT 5G12.5 - WRITE(IOUT,191) I,(BUF(J,I),J=1,NCOL) -191 FORMAT(1X,I3,2X,1PG12.5,4(1X,G12.5):/(5X,5(1X,G12.5))) - - CASE(20) -!C------------FORMAT 6G11.4 - WRITE(IOUT,201) I,(BUF(J,I),J=1,NCOL) -201 FORMAT(1X,I3,2X,1PG11.4,5(1X,G11.4):/(5X,6(1X,G11.4))) - - CASE(21) -!C------------FORMAT 7G9.2 - WRITE(IOUT,211) I,(BUF(J,I),J=1,NCOL) -211 FORMAT(1X,I3,2X,1PG9.2,6(1X,G9.2):/(5X,7(1X,G9.2))) - - END SELECT - END DO - - RETURN - END SUBROUTINE ULAPRW - - SUBROUTINE ULASAV(BUF,TEXT,KSTP,KPER,PERTIM,TOTIM,NCOL, & - & NROW,ILAY,ICHN) -!C ****************************************************************** -!C SAVE 1 LAYER ARRAY ON DISK -!C ****************************************************************** -!C -!C SPECIFICATIONS: -!C ------------------------------------------------------------------ - CHARACTER(len=16) TEXT - real(DP),dimension(ncol,nrow) :: buf - real(DP) :: pertim,totim -!C ------------------------------------------------------------------ -!C -!C1------WRITE AN UNFORMATTED RECORD CONTAINING IDENTIFYING -!C1------INFORMATION. - WRITE(ICHN) KSTP,KPER,PERTIM,TOTIM,TEXT,NCOL,NROW,ILAY -!C -!C2------WRITE AN UNFORMATTED RECORD CONTAINING ARRAY VALUES -!C2------THE ARRAY IS DIMENSIONED (NCOL,NROW) - WRITE(ICHN) ((BUF(IC,IR),IC=1,NCOL),IR=1,NROW) -!C -!C3------RETURN - RETURN - END SUBROUTINE ULASAV - - subroutine ubdsv1(kstp, kper, text, ibdchn, buff, ncol, nrow, nlay, iout, & - delt, pertim, totim) -! ****************************************************************************** -! Record cell-by-cell flow terms for one component of flow as a 3-D array with -! extra record to indicate delt, pertim, and totim -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - integer(I4B), intent(in) :: kstp - integer(I4B), intent(in) :: kper - character(len=*), intent(in) :: text - integer(I4B), intent(in) :: ibdchn - real(DP), dimension(:), intent(in) :: buff - integer(I4B), intent(in) :: ncol - integer(I4B), intent(in) :: nrow - integer(I4B), intent(in) :: nlay - integer(I4B), intent(in) :: iout - real(DP), intent(in) :: delt - real(DP), intent(in) :: pertim - real(DP), intent(in) :: totim - ! -- format - character(len=*), parameter :: fmt = & - "(1X,'UBDSV1 SAVING ',A16,' ON UNIT',I7,' AT TIME STEP',I7,"// & - "', STRESS PERIOD',I7)" -! ------------------------------------------------------------------------------ - ! - ! -- Write records - if(iout > 0) write(iout, fmt) text, ibdchn, kstp, kper - write(ibdchn) kstp,kper,text,ncol,nrow,-nlay - write(ibdchn) 1,delt,pertim,totim - write(ibdchn) buff - ! - ! -- return - return - end subroutine ubdsv1 - - subroutine ubdsv06(kstp,kper,text, & - modelnam1,paknam1,modelnam2,paknam2, & - ibdchn,naux,auxtxt, & - ncol,nrow,nlay,nlist,iout,delt,pertim,totim) -! ****************************************************************** -! write header records for cell-by-cell flow terms for one component -! of flow. each item in the list is written by module ubdsvc -! ****************************************************************** -! -! specifications: -! ------------------------------------------------------------------ - implicit none - integer(I4B), intent(in) :: kstp - integer(I4B), intent(in) :: kper - character(len=*), intent(in) :: text - character(len=*), intent(in) :: modelnam1 - character(len=*), intent(in) :: paknam1 - character(len=*), intent(in) :: modelnam2 - character(len=*), intent(in) :: paknam2 - integer(I4B), intent(in) :: naux - character(len=16), dimension(:), intent(in) :: auxtxt - integer(I4B), intent(in) :: ibdchn - integer(I4B), intent(in) :: ncol - integer(I4B), intent(in) :: nrow - integer(I4B), intent(in) :: nlay - integer(I4B), intent(in) :: nlist - integer(I4B), intent(in) :: iout - real(DP), intent(in) :: delt - real(DP), intent(in) :: pertim - real(DP), intent(in) :: totim - ! -- local - integer(I4B) :: n - ! -- format - character(len=*), parameter :: fmt = & - "(1X,'UBDSV06 SAVING ',A16,' IN MODEL ',A16,' PACKAGE ',A16,"//& - "'CONNECTED TO MODEL ',A16,' PACKAGE ',A16,"// & - "' ON UNIT',I7,' AT TIME STEP',I7,', STRESS PERIOD',I7)" -! ------------------------------------------------------------------ -! -! write unformatted records identifying data. - if (iout > 0) write(iout,fmt) text, modelnam1, paknam1, & - modelnam2, paknam2, & - ibdchn, kstp, kper - write(ibdchn) kstp,kper,text,ncol,nrow,-nlay - write(ibdchn) 6,delt,pertim,totim - write(ibdchn) modelnam1 - write(ibdchn) paknam1 - write(ibdchn) modelnam2 - write(ibdchn) paknam2 - write(ibdchn) naux+1 - if (naux > 0) write(ibdchn) (auxtxt(n),n=1,naux) - write(ibdchn) nlist - ! - ! -- return - return - end subroutine ubdsv06 - - subroutine ubdsvc(ibdchn, n, q, naux, aux) -! ****************************************************************************** -! Write one value of cell-by-cell flow using a list structure. From node (n) -! and to node (n2) are written to the file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - integer(I4B), intent(in) :: ibdchn - integer(I4B), intent(in) :: n - real(DP), intent(in) :: q - integer(I4B), intent(in) :: naux - real(DP), dimension(naux), intent(in) :: aux - ! -- local - integer(I4B) :: nn -! ------------------------------------------------------------------------------ - ! - ! -- Write record - if (naux > 0) then - write(ibdchn) n,q,(aux(nn),nn=1,naux) - else - write(ibdchn) n,q - end if - ! - ! -- return - return - end subroutine ubdsvc - - subroutine ubdsvd(ibdchn, n, n2, q, naux, aux) -! ****************************************************************************** -! Write one value of cell-by-cell flow using a list structure. From node (n) -! and to node (n2) are written to the file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - integer(I4B), intent(in) :: ibdchn - integer(I4B), intent(in) :: n - integer(I4B), intent(in) :: n2 - real(DP), intent(in) :: q - integer(I4B), intent(in) :: naux - real(DP), dimension(naux), intent(in) :: aux - ! -- local - integer(I4B) :: nn -! ------------------------------------------------------------------------------ - ! - ! -- Write record - if (naux > 0) then - write(ibdchn) n,n2,q,(aux(nn),nn=1,naux) - else - write(ibdchn) n,n2,q - end if - ! - ! -- return - return - end subroutine ubdsvd - - logical function same_word(word1, word2) - ! Perform a case-insensitive comparison of two words - implicit none - ! -- dummy variables - character(len=*), intent(in) :: word1, word2 - ! -- local - character(len=200) :: upword1, upword2 - ! - upword1 = word1 - call upcase(upword1) - upword2 = word2 - call upcase(upword2) - same_word = (upword1==upword2) - return - end function same_word - - function get_node(ilay, irow, icol, nlay, nrow, ncol) - ! Return node number, given layer, row, and column indices - ! for a structured grid. If any argument is invalid, - ! return -1. - implicit none - ! -- return - integer(I4B) :: get_node - ! -- dummy - integer(I4B), intent(in) :: ilay, irow, icol, nlay, nrow, ncol - ! - if (nlay>0 .and. nrow>0 .and. ncol>0) then - if (ilay>0 .and. ilay<=nlay) then - if (irow>0 .and. irow<=nrow) then - if (icol>0 .and. icol<=ncol) then - get_node = icol + ncol*(irow-1) + (ilay-1)*nrow*ncol - return - endif - endif - endif - endif - get_node = -1 - return - end function get_node - - subroutine get_ijk(nodenumber, nrow, ncol, nlay, irow, icol, ilay) - ! Calculate irow, icol, and ilay from the nodenumber and grid - ! dimensions. If nodenumber is invalid, set irow, icol, and - ! ilay to -1 - implicit none - ! -- dummy - integer(I4B), intent(in) :: nodenumber - integer(I4B), intent(in) :: nrow - integer(I4B), intent(in) :: ncol - integer(I4B), intent(in) :: nlay - integer(I4B), intent(out) :: irow - integer(I4B), intent(out) :: icol - integer(I4B), intent(out) :: ilay - ! -- local - integer(I4B) :: nodes - integer(I4B) :: ij - ! - nodes = nlay * nrow * ncol - if(nodenumber < 1 .or. nodenumber > nodes) then - irow = -1 - icol = -1 - ilay = -1 - else - ilay = (nodenumber - 1) / (ncol * nrow) + 1 - ij = nodenumber - (ilay - 1) * ncol * nrow - irow = (ij - 1) / ncol + 1 - icol = ij - (irow - 1) * ncol - endif - ! - return - end subroutine get_ijk - - subroutine get_jk(nodenumber, ncpl, nlay, icpl, ilay) - ! Calculate icpl, and ilay from the nodenumber and grid - ! dimensions. If nodenumber is invalid, set irow, icol, and - ! ilay to -1 - implicit none - ! -- dummy - integer(I4B), intent(in) :: nodenumber - integer(I4B), intent(in) :: ncpl - integer(I4B), intent(in) :: nlay - integer(I4B), intent(out) :: icpl - integer(I4B), intent(out) :: ilay - ! -- local - integer(I4B) :: nodes - ! - nodes = ncpl * nlay - if(nodenumber < 1 .or. nodenumber > nodes) then - icpl = -1 - ilay = -1 - else - ilay = (nodenumber - 1) / ncpl + 1 - icpl = nodenumber - (ilay - 1) * ncpl - endif - ! - return - end subroutine get_jk - - subroutine unitinquire(iu) - ! -- dummy - integer(I4B) :: iu - ! -- local - character(len=LINELENGTH) :: line - character(len=100) :: fname, ac, act, fm, frm, seq, unf - ! -- format - character(len=*), parameter :: fmta = & - &"('unit:',i4,' name:',a,' access:',a,' action:',a)" - character(len=*), parameter :: fmtb = & - &"(' formatted:',a,' sequential:',a,' unformatted:',a,' form:',a)" - ! -- code - ! - ! -- set strings using inquire statement - inquire(unit=iu, name=fname, access=ac, action=act, formatted=fm, & - sequential=seq, unformatted=unf, form=frm) - ! - ! -- write the results of the inquire statement - write(line,fmta) iu, trim(fname), trim(ac), trim(act) - call sim_message(line) - write(line,fmtb) trim(fm), trim(seq), trim(unf), trim(frm) - call sim_message(line) - ! - ! -- return - return - end subroutine unitinquire - - subroutine ParseLine(line, nwords, words, inunit, filename) - ! Parse a line into words. Blanks and commas are recognized as - ! delimiters. Multiple blanks between words is OK, but multiple - ! commas between words is treated as an error. Quotation marks - ! are not recognized as delimiters. - use ConstantsModule, only: LINELENGTH - implicit none - ! -- dummy - character(len=*), intent(in) :: line - integer(I4B), intent(inout) :: nwords - character(len=*), allocatable, dimension(:), intent(inout) :: words - integer(I4B), intent(in), optional :: inunit - character(len=*), intent(in), optional :: filename - ! -- local - integer(I4B) :: i, idum, istart, istop, linelen, lloc - real(DP) :: rdum - ! - nwords = 0 - if (allocated(words)) then - deallocate(words) - endif - linelen = len(line) - ! - ! -- get the number of words in a line and allocate words array - nwords = get_nwords(line) - allocate(words(nwords)) - ! - ! -- Populate words array and return - lloc = 1 - do i = 1, nwords - call URWORD(line, lloc, istart, istop, 0, idum, rdum, 0, 0) - words(i) = line(istart:istop) - end do - ! - ! -- return - return - end subroutine ParseLine - - subroutine ulaprufw(ncol, nrow, kstp, kper, ilay, iout, buf, text, userfmt, & - nvalues, nwidth, editdesc) - ! ************************************************************************** - ! Print 1 layer array with user formatting in wrap format - ! ************************************************************************** - ! - ! Specifications: - ! -------------------------------------------------------------------------- - implicit none - ! -- dummy - integer(I4B), intent(in) :: ncol, nrow, kstp, kper, ilay, iout - real(DP),dimension(ncol,nrow), intent(in) :: buf - character(len=*), intent(in) :: text - character(len=*), intent(in) :: userfmt - integer(I4B), intent(in) :: nvalues, nwidth - character(len=1), intent(in) :: editdesc - ! -- local - integer(I4B) :: i, j, nspaces - ! formats - 1 format('1',/2X,A,' IN LAYER ',I3,' AT END OF TIME STEP ',I3, & - ' IN STRESS PERIOD ',I4/2X,75('-')) - 2 format('1',/1X,A,' FOR CROSS SECTION AT END OF TIME STEP',I3, & - ' IN STRESS PERIOD ',I4/1X,79('-')) - ! ------------------------------------------------------------------ - ! - if (iout<=0) return - ! -- Print a header depending on ILAY - if (ilay > 0) then - write(iout,1) trim(text), ilay, kstp, kper - else if(ilay < 0) then - write(iout,2) trim(text), kstp, kper - end if - ! - ! -- Print column numbers. - nspaces = 0 - if (editdesc == 'F') nspaces = 3 - call ucolno(1, ncol, nspaces, nvalues, nwidth+1, iout) - ! - ! -- Loop through the rows, printing each one in its entirety. - do i=1,nrow - write(iout,userfmt) i,(buf(j,i),j=1,ncol) - enddo - ! - return - end subroutine ulaprufw - - function linear_interpolate(t0, t1, y0, y1, t) result(y) - implicit none - ! -- dummy - real(DP), intent(in) :: t, t0, t1, y0, y1 - real(DP) :: y - ! -- local - real(DP) :: delt, dely, slope - character(len=100) :: msg - ! - ! -- don't get bitten by rounding errors or divide-by-zero - if (IS_SAME(t0, t1) .or. IS_SAME(t, t1)) then - y = y1 - elseif (t == t0) then - y = y0 - elseif ((t0 < t .and. t < t1) .or. (t1 < t .and. t < t0)) then - ! -- perform linear interpolation - delt = t1 - t0 - dely = y1 - y0 - slope = dely / delt - y = y0 + slope * (t - t0) - else - ! -- t is outside range t0 to t1 - msg = 'Error: in linear_interpolate, t is outside range t0 to t1' - call store_error(msg) - call ustop() - endif - ! - return - end function linear_interpolate - - function read_line(iu, eof) result (astring) - ! This function reads a line of arbitrary length and returns - ! it. The returned string can be stored in a deferred-length - ! character variable, for example: - ! - ! integer(I4B) :: iu - ! character(len=:), allocatable :: my_string - ! logical :: eof - ! iu = 8 - ! open(iu,file='my_file') - ! my_string = read_line(iu, eof) - ! - implicit none - ! -- dummy - integer(I4B), intent(in) :: iu - logical, intent(out) :: eof - character(len=:), allocatable :: astring - ! -- local - integer(I4B) :: isize, istat - character(len=256) :: buffer - character(len=1000) :: ermsg, fname - character(len=7) :: fmtd - logical :: lop - ! -- format -20 format('Error in read_line: File ',i0,' is not open.') -30 format('Error in read_line: Attempting to read text ' // & - 'from unformatted file: "',a,'"') -40 format('Error reading from file "',a,'" opened on unit ',i0, & - ' in read_line.') - ! - astring = '' - eof = .false. - do - read(iu, '(a)', advance='NO', iostat=istat, size=isize, end=99) buffer - if (istat > 0) then - ! Determine error if possible, report it, and stop. - if (iu <= 0) then - ermsg = 'Programming error in call to read_line: ' // & - 'Attempt to read from unit number <= 0' - else - inquire(unit=iu,opened=lop,name=fname,formatted=fmtd) - if (.not. lop) then - write(ermsg,20) iu - elseif (fmtd == 'NO' .or. fmtd == 'UNKNOWN') then - write(ermsg, 30) trim(fname) - else - write(ermsg,40) trim(fname), iu - endif - endif - call store_error(ermsg) - call store_error_unit(iu) - call ustop() - endif - astring = astring // buffer(:isize) - ! An end-of-record condition stops the loop. - if (istat < 0) then - return - endif - enddo - ! - return -99 continue - ! An end-of-file condition returns an empty string. - eof = .true. - return - ! - end function read_line - - subroutine GetFileFromPath(pathname, filename) - implicit none - ! -- dummy - character(len=*), intent(in) :: pathname - character(len=*), intent(out) :: filename - ! -- local - integer(I4B) :: i, istart, istop, lenpath - character(len=1) :: fs = '/' - character(len=1) :: bs = '\' - ! - filename = '' - lenpath = len_trim(pathname) - istart = 1 - istop = lenpath - loop: do i=lenpath,1,-1 - if (pathname(i:i) == fs .or. pathname(i:i) == bs) then - if (i == istop) then - istop = istop - 1 - else - istart = i + 1 - exit loop - endif - endif - enddo loop - if (istop >= istart) then - filename = pathname(istart:istop) - endif - ! - return - end subroutine GetFileFromPath - - subroutine extract_idnum_or_bndname(line, icol, istart, istop, idnum, bndname) - ! Starting at position icol, define string as line(istart:istop). - ! If string can be interpreted as an integer(I4B), return integer in idnum argument. - ! If token is not an integer(I4B), assume it is a boundary name, return NAMEDBOUNDFLAG - ! in idnum, convert string to uppercase and return it in bndname. - implicit none - ! -- dummy - character(len=*), intent(inout) :: line - integer(I4B), intent(inout) :: icol, istart, istop - integer(I4B), intent(out) :: idnum - character(len=LENBOUNDNAME), intent(out) :: bndname - ! -- local - integer(I4B) :: istat, ndum, ncode=0 - real(DP) :: rdum - ! - call urword(line, icol, istart, istop, ncode, ndum, rdum, 0, 0) - read(line(istart:istop),*,iostat=istat) ndum - if (istat == 0) then - idnum = ndum - bndname = '' - else - idnum = NAMEDBOUNDFLAG - bndname = line(istart:istop) - call upcase(bndname) - endif - ! - return - end subroutine extract_idnum_or_bndname - - subroutine urdaux(naux, inunit, iout, lloc, istart, istop, auxname, line, & - text) -! ****************************************************************************** -! Read auxiliary variables from an input line -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ArrayHandlersModule, only: ExpandArray - use ConstantsModule, only: LENAUXNAME - ! -- implicit - implicit none - ! -- dummy - integer(I4B), intent(inout) :: naux - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - character(len=LENAUXNAME), allocatable, dimension(:), intent(inout) :: auxname - character(len=*), intent(inout) :: line - character(len=*), intent(in) :: text - ! -- local - integer(I4B) :: n, linelen - real(DP) :: rval - character(len=LINELENGTH) :: errmsg -! ------------------------------------------------------------------------------ - linelen = len(line) - if(naux > 0) then - write(errmsg,'(a)') '****ERROR. AUXILIARY VARIABLES ' // & - 'ALREADY SPECIFIED. AUXILIARY VARIABLES MUST BE SPECIFIED '// & - 'ON ONE LINE IN THE OPTIONS BLOCK.' - call store_error(errmsg) - call store_error_unit(inunit) - call ustop() - endif - auxloop: do - call urword(line, lloc, istart, istop, 1, n, rval, iout, inunit) - if(lloc >= linelen) exit auxloop - naux = naux + 1 - call ExpandArray(auxname) - auxname(naux) = line(istart:istop) - if(iout > 0) then - write(iout, "(4X,'AUXILIARY ',a,' VARIABLE: ',A)") & - trim(adjustl(text)), auxname(naux) - endif - enddo auxloop - - end subroutine urdaux - - subroutine print_format(linein, cdatafmp, editdesc, nvaluesp, nwidthp, inunit) -! ****************************************************************************** -! print_format -- define the print or save format -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ -! Define cdatafmp as a Fortran output format based on user input. Also define -! nvalues, nwidth, and editdesc. -! -! Syntax for linein: -! COLUMNS nval WIDTH nwid [DIGITS ndig [options]] -! -! Where: -! nval = Number of values per line. -! nwid = Number of character places to be used for each value. -! ndig = Number of digits to the right of the decimal point (required -! for real array). -! options are: -! editoption: One of [EXPONENTIAL, FIXED, GENERAL, SCIENTIFIC] -! A default value should be passed in for editdesc as G, I, E, F, or S. -! If I is passed in, then the fortran format will be for an integer variable. -! ------------------------------------------------------------------------------ - ! -- dummy - character(len=*), intent(in) :: linein - character(len=*), intent(inout) :: cdatafmp - character(len=*), intent(inout) :: editdesc - integer(I4B), intent(inout) :: nvaluesp - integer(I4B), intent(inout) :: nwidthp - integer(I4B), intent(in) :: inunit - ! -- local - character(len=len(linein)) :: line - character(len=20), dimension(:), allocatable :: words - character(len=100) :: ermsg - integer(I4B) :: ndigits=0, nwords=0 - integer(I4B) :: i, ierr - logical :: isint -! ------------------------------------------------------------------------------ - ! - ! -- Parse line and initialize values - line(:) = linein(:) - call ParseLine(line, nwords, words, inunit) - ierr = 0 - i = 0 - isint = .false. - if(editdesc == 'I') isint = .true. - ! - ! -- Check array name - if (nwords < 1) then - ermsg = 'Could not build PRINT_FORMAT from line' // trim(line) - call store_error(trim(ermsg)) - ermsg = 'Syntax is: COLUMNS WIDTH DIGITS & - & ' - call store_error(trim(ermsg)) - call store_error_unit(inunit) - call ustop() - endif - ! - ermsg = 'Error setting PRINT_FORMAT. Syntax is incorrect in line:' - if (nwords >= 4) then - if (.not. same_word(words(1), 'COLUMNS')) ierr = 1 - if (.not. same_word(words(3), 'WIDTH')) ierr = 1 - ! -- Read nvalues and nwidth - if (ierr == 0) then - read(words(2), *, iostat=ierr) nvaluesp - endif - if (ierr == 0) then - read(words(4), *, iostat=ierr) nwidthp - endif - else - ierr = 1 - endif - if (ierr /= 0) then - call store_error(ermsg) - call store_error(line) - ermsg = 'Syntax is: COLUMNS WIDTH & - &DIGITS ' - call store_error(trim(ermsg)) - call store_error_unit(inunit) - call ustop() - endif - i = 4 - ! - if (.not. isint) then - ! -- Check for DIGITS specification - if (nwords >= 5) then - if (.not. same_word(words(5), 'DIGITS')) ierr = 1 - ! -- Read ndigits - read(words(6), *, iostat=ierr) ndigits - else - ierr = 1 - endif - i = i + 2 - endif - ! - ! -- Check for EXPONENTIAL | FIXED | GENERAL | SCIENTIFIC option. - ! -- Check for LABEL, WRAP, and STRIP options. - do - i = i + 1 - if (i <= nwords) then - call upcase(words(i)) - select case (words(i)) - case ('EXPONENTIAL') - editdesc = 'E' - if (isint) ierr = 1 - case ('FIXED') - editdesc = 'F' - if (isint) ierr = 1 - case ('GENERAL') - editdesc = 'G' - if (isint) ierr = 1 - case ('SCIENTIFIC') - editdesc = 'S' - if (isint) ierr = 1 - case default - ermsg = 'Error in format specification. Unrecognized option: ' // words(i) - call store_error(ermsg) - ermsg = 'Valid values are EXPONENTIAL, FIXED, GENERAL, or SCIENTIFIC.' - call store_error(ermsg) - call store_error_unit(inunit) - call ustop() - end select - else - exit - endif - enddo - if (ierr /= 0) then - call store_error(ermsg) - call store_error(line) - call store_error_unit(inunit) - call ustop() - endif - ! - ! -- Build the output format. - select case (editdesc) - case ('I') - call BuildIntFormat(nvaluesp, nwidthp, cdatafmp) - case ('F') - call BuildFixedFormat(nvaluesp, nwidthp, ndigits, cdatafmp) - case ('E', 'G', 'S') - call BuildFloatFormat(nvaluesp, nwidthp, ndigits, editdesc, cdatafmp) - end select - ! - return - end subroutine print_format - - subroutine BuildFixedFormat(nvalsp, nwidp, ndig, outfmt, prowcolnum) - ! Build a fixed format for printing or saving a real array - implicit none - ! -- dummy - integer(I4B), intent(in) :: nvalsp, nwidp, ndig - character(len=*), intent(inout) :: outfmt - logical, intent(in), optional :: prowcolnum ! default true - ! -- local - character(len=8) :: cvalues, cwidth, cdigits - character(len=60) :: ufmt - logical :: prowcolnumlocal - ! formats - 10 format(i8) - ! - if (present(prowcolnum)) then - prowcolnumlocal = prowcolnum - else - prowcolnumlocal = .true. - endif - ! - ! -- Convert integers to characters and left-adjust - write(cdigits,10) ndig - cdigits = adjustl(cdigits) - ! - ! -- Build format for printing to the list file in wrap format - write(cvalues,10) nvalsp - cvalues = adjustl(cvalues) - write(cwidth,10) nwidp - cwidth = adjustl(cwidth) - if (prowcolnumlocal) then - ufmt = '(1x,i3,1x,' - else - ufmt = '(5x,' - endif - ufmt = trim(ufmt) // cvalues - ufmt = trim(ufmt) // '(1x,f' - ufmt = trim(ufmt) // cwidth - ufmt = trim(ufmt) // '.' - ufmt = trim(ufmt) // cdigits - ufmt = trim(ufmt) // '):/(5x,' - ufmt = trim(ufmt) // cvalues - ufmt = trim(ufmt) // '(1x,f' - ufmt = trim(ufmt) // cwidth - ufmt = trim(ufmt) // '.' - ufmt = trim(ufmt) // cdigits - ufmt = trim(ufmt) // ')))' - outfmt = ufmt - ! - return - end subroutine BuildFixedFormat - - subroutine BuildFloatFormat(nvalsp, nwidp, ndig, editdesc, outfmt, prowcolnum) - ! Build a floating-point format for printing or saving a real array - implicit none - ! -- dummy - integer(I4B), intent(in) :: nvalsp, nwidp, ndig - character(len=*), intent(in) :: editdesc - character(len=*), intent(inout) :: outfmt - logical, intent(in), optional :: prowcolnum ! default true - ! -- local - character(len=8) :: cvalues, cwidth, cdigits - character(len=60) :: ufmt - logical :: prowcolnumlocal - ! formats - 10 format(i8) - ! - if (present(prowcolnum)) then - prowcolnumlocal = prowcolnum - else - prowcolnumlocal = .true. - endif - ! - ! -- Build the format - write(cdigits,10) ndig - cdigits = adjustl(cdigits) - ! -- Convert integers to characters and left-adjust - write(cwidth,10) nwidp - cwidth = adjustl(cwidth) - ! -- Build format for printing to the list file - write(cvalues, 10) (nvalsp - 1) - cvalues = adjustl(cvalues) - if (prowcolnumlocal) then - ufmt = '(1x,i3,2x,1p,' // editdesc - else - ufmt = '(6x,1p,' // editdesc - endif - ufmt = trim(ufmt) // cwidth - ufmt = trim(ufmt) // '.' - ufmt = trim(ufmt) // cdigits - if (nvalsp>1) then - ufmt = trim(ufmt) // ',' - ufmt = trim(ufmt) // cvalues - ufmt = trim(ufmt) // '(1x,' - ufmt = trim(ufmt) // editdesc - ufmt = trim(ufmt) // cwidth - ufmt = trim(ufmt) // '.' - ufmt = trim(ufmt) // cdigits - ufmt = trim(ufmt) // ')' - endif - ufmt = trim(ufmt) // ':/(5x,' - write(cvalues, 10) nvalsp - cvalues = adjustl(cvalues) - ufmt = trim(ufmt) // cvalues - ufmt = trim(ufmt) // '(1x,' - ufmt = trim(ufmt) // editdesc - ufmt = trim(ufmt) // cwidth - ufmt = trim(ufmt) // '.' - ufmt = trim(ufmt) // cdigits - ufmt = trim(ufmt) // ')))' - outfmt = ufmt - ! - return - end subroutine BuildFloatFormat - - subroutine BuildIntFormat(nvalsp, nwidp, outfmt, prowcolnum) - ! Build a format for printing or saving an integer array - implicit none - ! -- dummy - integer(I4B), intent(in) :: nvalsp, nwidp - character(len=*), intent(inout) :: outfmt - logical, intent(in), optional :: prowcolnum ! default true - ! -- local - character(len=8) :: cvalues, cwidth - character(len=60) :: ufmt - logical :: prowcolnumlocal - ! formats - 10 format(i8) - ! - if (present(prowcolnum)) then - prowcolnumlocal = prowcolnum - else - prowcolnumlocal = .true. - endif - ! - ! -- Build format for printing to the list file in wrap format - write(cvalues,10)nvalsp - cvalues = adjustl(cvalues) - write(cwidth,10)nwidp - cwidth = adjustl(cwidth) - if (prowcolnumlocal) then - ufmt = '(1x,i3,1x,' - else - ufmt = '(5x,' - endif - ufmt = trim(ufmt) // cvalues - ufmt = trim(ufmt) // '(1x,i' - ufmt = trim(ufmt) // cwidth - ufmt = trim(ufmt) // '):/(5x,' - ufmt = trim(ufmt) // cvalues - ufmt = trim(ufmt) // '(1x,i' - ufmt = trim(ufmt) // cwidth - ufmt = trim(ufmt) // ')))' - outfmt = ufmt - ! - return - end subroutine BuildIntFormat - - - function get_nwords(line) -! ****************************************************************************** -! get_nwords -- return number of words in a string -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return variable - integer(I4B) :: get_nwords - ! -- dummy - character(len=*), intent(in) :: line - ! -- local - integer(I4B) :: linelen - integer(I4B) :: lloc - integer(I4B) :: istart - integer(I4B) :: istop - integer(I4B) :: idum - real(DP) :: rdum - ! - ! -- initialize variables - get_nwords = 0 - linelen = len(line) - ! - ! -- Count words in line and allocate words array - lloc = 1 - do - call URWORD(line, lloc, istart, istop, 0, idum, rdum, 0, 0) - if (istart == linelen) exit - get_nwords = get_nwords + 1 - end do - ! - ! -- return - return - end function get_nwords - - subroutine fseek_stream(iu, offset, whence, status) -! ****************************************************************************** -! Move the file pointer. Patterned after fseek, which is not -! supported as part of the fortran standard. For this subroutine to work -! the file must have been opened with access='stream' and action='readwrite'. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - integer(I4B), intent(in) :: iu - integer(I4B), intent(in) :: offset - integer(I4B), intent(in) :: whence - integer(I4B), intent(inout) :: status - integer(I4B) :: ipos -! ------------------------------------------------------------------------------ - ! - inquire(unit=iu, size=ipos) - - select case(whence) - case(0) - ! - ! -- whence = 0, offset is relative to start of file - ipos = 0 + offset - case(1) - ! - ! -- whence = 1, offset is relative to current pointer position - inquire(unit=iu, pos=ipos) - ipos = ipos + offset - case(2) - ! - ! -- whence = 2, offset is relative to end of file - inquire(unit=iu, size=ipos) - ipos = ipos + offset - end select - ! - ! -- position the file pointer to ipos - write(iu, pos=ipos, iostat=status) - inquire(unit=iu, pos=ipos) - ! - ! -- return - return - end subroutine fseek_stream - - - -END MODULE InputOutputModule +! -- MODFLOW 6 utility routines. +! +module InputOutputModule + + use KindModule, only: DP, I4B + use SimVariablesModule, only: iunext + use SimModule, only: store_error, ustop, store_error_unit, & + store_error_filename + use ConstantsModule, only: IUSTART, IULAST, & + LINELENGTH, LENBIGLINE, LENBOUNDNAME, & + NAMEDBOUNDFLAG, MAXCHARLEN, & + TABLEFT, TABCENTER, TABRIGHT, & + TABSTRING, TABUCSTRING, TABINTEGER, TABREAL, & + DZERO + use GenericUtilitiesModule, only: IS_SAME, sim_message + private + public :: GetUnit, u8rdcom, uget_block, & + uterminate_block, UPCASE, URWORD, ULSTLB, UBDSV4, & + ubdsv06, UBDSVB, UCOLNO, ULAPRW, & + ULASAV, ubdsv1, ubdsvc, ubdsvd, UWWORD, & + same_word, get_node, get_ijk, unitinquire, & + ParseLine, ulaprufw, openfile, & + linear_interpolate, lowcase, & + read_line, uget_any_block, & + GetFileFromPath, extract_idnum_or_bndname, urdaux, & + get_jk, uget_block_line, print_format, BuildFixedFormat, & + BuildFloatFormat, BuildIntFormat, fseek_stream, & + get_nwords + + contains + + subroutine openfile(iu, iout, fname, ftype, fmtarg_opt, accarg_opt, & + filstat_opt) +! ****************************************************************************** +! openfile -- Open a file using the specified arguments. +! +! iu is the unit number +! iout is the output unit number to write a message (iout=0 does not print) +! fname is the name of the file +! ftype is the type of the file (e.g. WEL) +! fmtarg_opt is the format, default is 'formatted' +! accarg_opt is the access, default is 'sequential' +! filstat_opt is the file status, default is 'old'. Use 'REPLACE' for an +! output file. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use OpenSpecModule, only: action + implicit none + ! -- dummy + integer(I4B), intent(inout) :: iu + integer(I4B), intent(in) :: iout + character(len=*), intent(in) :: fname + character(len=*), intent(in) :: ftype + character(len=*), intent(in), optional :: fmtarg_opt + character(len=*), intent(in), optional :: accarg_opt + character(len=*), intent(in), optional :: filstat_opt + ! -- local + character(len=20) :: fmtarg + character(len=20) :: accarg + character(len=20) :: filstat + character(len=20) :: filact + integer(I4B) :: iflen + integer(I4B) :: ivar + integer(I4B) :: iuop + character(len=LINELENGTH) :: errmsg + ! -- formats +50 FORMAT(1X,/1X,'OPENED ',A,/ & + 1X,'FILE TYPE:',A,' UNIT ',I4,3X,'STATUS:',A,/ & + 1X,'FORMAT:',A,3X,'ACCESS:',A/ & + 1X,'ACTION:',A/) +2011 FORMAT('*** ERROR OPENING FILE "',A,'" ON UNIT ',I0) +2017 format('*** FILE ALREADY OPEN ON UNIT: ',I0) +2012 format(' SPECIFIED FILE STATUS: ',A) +2013 format(' SPECIFIED FILE FORMAT: ',A) +2014 format(' SPECIFIED FILE ACCESS: ',A) +2015 format(' SPECIFIED FILE ACTION: ',A) +2016 format(' IOSTAT ERROR NUMBER: ',I0) +2018 format(' -- STOP EXECUTION (openfile)') +! ------------------------------------------------------------------------------ + ! + ! -- Default is to read an existing text file + fmtarg = 'FORMATTED' + accarg = 'SEQUENTIAL' + filstat = 'OLD' + ! + ! -- Override defaults + if(present(fmtarg_opt)) then + fmtarg = fmtarg_opt + call upcase(fmtarg) + endif + if(present(accarg_opt)) then + accarg = accarg_opt + call upcase(accarg) + endif + if(present(filstat_opt)) then + filstat = filstat_opt + call upcase(filstat) + endif + if(filstat == 'OLD') then + filact = action(1) + else + filact = action(2) + endif + ! + ! -- size of fname + iflen = len_trim(fname) + ! + ! -- Get a free unit number + if(iu <= 0) then + call freeunitnumber(iu) + endif + ! + ! -- Check to see if file is already open, if not then open the file + inquire(file=fname(1:iflen), number=iuop) + if(iuop > 0) then + ivar = -1 + else + open(unit=iu, file=fname(1:iflen), form=fmtarg, access=accarg, & + status=filstat, action=filact, iostat=ivar) + endif + ! + ! -- Check for an error + if(ivar /= 0) then + write(errmsg,2011) fname(1:iflen), iu + call store_error(errmsg) + if(iuop > 0) then + write(errmsg, 2017) iuop + call store_error(errmsg) + endif + write(errmsg,2012) filstat + call store_error(errmsg) + write(errmsg,2013) fmtarg + call store_error(errmsg) + write(errmsg,2014) accarg + call store_error(errmsg) + write(errmsg,2015) filact + call store_error(errmsg) + write(errmsg,2016) ivar + call store_error(errmsg) + write(errmsg,2018) + call store_error(errmsg) + call ustop() + endif + ! + ! -- Write a message + if(iout > 0) then + write(iout, 50) fname(1:iflen), & + ftype, iu, filstat, & + fmtarg, accarg, & + filact + endif + ! + ! -- return + return + end subroutine openfile + + subroutine freeunitnumber(iu) +! ****************************************************************************** +! Assign a free unopened unit number to the iu dummy argument. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + implicit none + ! -- dummy + integer(I4B),intent(inout) :: iu + ! -- local + integer(I4B) :: i + logical :: opened +! ------------------------------------------------------------------------------ + ! + do i = iunext, iulast + inquire(unit=i, opened=opened) + if(.not. opened) exit + enddo + iu = i + iunext = iu + 1 + ! + ! -- return + return + end subroutine freeunitnumber + + function getunit() +! ****************************************************************************** +! Get a free unit number that hasn't been used yet. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + implicit none + ! -- return + integer(I4B) :: getunit + ! -- local + integer(I4B) :: iunit +! ------------------------------------------------------------------------------ + ! + call freeunitnumber(iunit) + getunit = iunit + ! + ! -- Return + return + end function getunit + + subroutine u8rdcom(iin, iout, line, ierr) +! ****************************************************************************** +! Read until non-comment line found and then return line +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use, intrinsic :: iso_fortran_env, only: IOSTAT_END + implicit none + ! -- dummy + integer(I4B), intent(in) :: iin + integer(I4B), intent(in) :: iout + character (len=*), intent(inout) :: line + integer(I4B), intent(out) :: ierr + ! -- local definitions + character (len=2), parameter :: comment = '//' + character(len=LINELENGTH) :: errmsg + character(len=1), parameter :: tab = CHAR(9) + logical :: iscomment + integer(I4B) :: i, l +! ------------------------------------------------------------------------------ + !code + ! + !readerrmsg = '' + line = comment + pcomments: do + read (iin,'(a)', iostat=ierr) line + !read (iin,'(a)', iostat=ierr, iomsg=readerrmsg) line + if (ierr == IOSTAT_END) then + ! -- End of file reached. + ! -- Backspace is needed for gfortran. + backspace(iin) + line = ' ' + exit pcomments + elseif (ierr /= 0) then + ! -- Other error...report it + call store_error('******Error in u8rdcom.') + write(errmsg, *) 'Could not read from unit: ',iin + call store_error(errmsg) + !write(errmsg,*)'Error reported as: ',trim(readerrmsg) + !call store_error(errmsg) + call unitinquire(iin) + call ustop() + endif + if (len_trim(line).lt.1) then + line = comment + cycle + end if + ! + ! Ensure that any initial tab characters are treated as spaces + cleartabs: do + line = trim(adjustl(line)) + iscomment = .false. + select case (line(1:1)) + case ('#') + iscomment = .true. + exit cleartabs + case ('!') + iscomment = .true. + exit cleartabs + case (tab) + line(1:1) = ' ' + cycle cleartabs + case default + if (line(1:2).eq.comment) iscomment = .true. + if (len_trim(line) < 1) iscomment = .true. + exit cleartabs + end select + end do cleartabs + ! + if (.not.iscomment) then + exit pcomments + else + if (iout > 0) then + !find the last non-blank character. + l=len(line) + do i = l, 1, -1 + if(line(i:i).ne.' ') then + exit + end if + end do + !print the line up to the last non-blank character. + write(iout,'(1x,a)') line(1:i) + end if + end if + end do pcomments + return + end subroutine u8rdcom + + subroutine uget_block_line(iu, iuext, iout, line, lloc, istart, istop) +! ****************************************************************************** +! Read and return line read from an external file or from within a block. +! The line is read from an external file if iu is not equal to iuext +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + ! -- dummy + integer(I4B), intent(in) :: iu + integer(I4B), intent(in) :: iuext + integer(I4B), intent(in) :: iout + character (len=*), intent(inout) :: line + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + ! -- local definitions + integer(I4B) :: ierr + integer(I4B) :: ival + real(DP) :: rval +! ------------------------------------------------------------------------------ + lloc = 1 + call u8rdcom(iuext, iout, line, ierr) + call urword(line, lloc, istart, istop, 1, ival, rval, iout, iuext) + ! -- determine if an empty string is returned + ! condition occurs if the end of the file has been read + if (len_trim(line) < 1) then + ! -- if external file, read line from package unit (iu) + if (iuext /= iu) then + lloc = 1 + call u8rdcom(iu, iout, line, ierr) + call urword(line, lloc, istart, istop, 1, ival, rval, iout, iu) + end if + end if + return + end subroutine uget_block_line + + + subroutine uget_block(iin, iout, ctag, ierr, isfound, lloc, line, iuext, & + blockRequired, supportopenclose) +! ****************************************************************************** +! Read until the ctag block is found. Return isfound with true, if found. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + ! -- dummy + integer(I4B), intent(in) :: iin + integer(I4B), intent(in) :: iout + character (len=*), intent(in) :: ctag + integer(I4B), intent(out) :: ierr + logical, intent(inout) :: isfound + integer(I4B), intent(inout) :: lloc + character (len=*), intent(inout) :: line + integer(I4B), intent(inout) :: iuext + logical, optional, intent(in) :: blockRequired + logical, optional, intent(in) :: supportopenclose + ! -- local + integer(I4B) :: istart + integer(I4B) :: istop + integer(I4B) :: ival + integer(I4B) :: lloc2 + real(DP) :: rval + character(len=LINELENGTH) :: fname, line2 + character(len=MAXCHARLEN) :: ermsg + logical :: supportoc, blockRequiredLocal +! ------------------------------------------------------------------------------ + !code + if (present(blockRequired)) then + blockRequiredLocal = blockRequired + else + blockRequiredLocal = .true. + endif + supportoc = .false. + if (present(supportopenclose)) then + supportoc = supportopenclose + endif + iuext = iin + isfound = .false. + mainloop: do + lloc = 1 + call u8rdcom(iin, iout, line, ierr) + if (ierr < 0) exit + call urword(line, lloc, istart, istop, 1, ival, rval, iin, iout) + if (line(istart:istop) == 'BEGIN') then + call urword(line, lloc, istart, istop, 1, ival, rval, iin, iout) + if (line(istart:istop) == ctag) then + isfound = .true. + if (supportoc) then + ! Look for OPEN/CLOSE on 1st line after line starting with BEGIN + call u8rdcom(iin,iout,line2,ierr) + if (ierr < 0) exit + lloc2 = 1 + call urword(line2, lloc2, istart, istop, 1, ival, rval, iin, iout) + if (line2(istart:istop) == 'OPEN/CLOSE') then + ! -- Get filename and preserve case + call urword(line2, lloc2, istart, istop, 0, ival, rval, iin, iout) + fname = line2(istart:istop) + ! If line contains '(BINARY)' or 'SFAC', handle this block elsewhere + chk: do + call urword(line2, lloc2, istart, istop, 1, ival, rval, iin, iout) + if (line2(istart:istop) == '') exit chk + if (line2(istart:istop) == '(BINARY)' .or. & + line2(istart:istop) == 'SFAC') then + backspace(iin) + exit mainloop + end if + end do chk + iuext = GetUnit() + call openfile(iuext,iout,fname,'OPEN/CLOSE') + else + backspace(iin) + end if + end if + else + if (blockRequiredLocal) then + ermsg = 'Error: Required block "' // trim(ctag) // & + '" not found. Found block "' // line(istart:istop) // & + '" instead.' + call store_error(ermsg) + call store_error_unit(iuext) + call ustop() + else + backspace(iin) + endif + end if + exit mainloop + else if (line(istart:istop) == 'END') then + call urword(line, lloc, istart, istop, 1, ival, rval, iin, iout) + if (line(istart:istop) == ctag) then + ermsg = 'Error: Looking for BEGIN ' // trim(ctag) // & + ' but found END ' // line(istart:istop) // & + ' instead.' + call store_error(ermsg) + call store_error_unit(iuext) + call ustop() + endif + end if + end do mainloop + return + end subroutine uget_block + + subroutine uget_any_block(iin,iout,isfound,lloc,line,ctagfound,iuext) +! ****************************************************************************** +! Read until any block is found. If found, return isfound as true and +! return block name in ctagfound. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + ! -- dummy + integer(I4B), intent(in) :: iin + integer(I4B), intent(in) :: iout + logical, intent(inout) :: isfound + integer(I4B), intent(inout) :: lloc + character (len=*), intent(inout) :: line + character(len=*), intent(out) :: ctagfound + integer(I4B), intent(inout) :: iuext + ! -- local + integer(I4B) :: ierr, istart, istop + integer(I4B) :: ival, lloc2 + real(DP) :: rval + character(len=100) :: ermsg + character(len=LINELENGTH) :: line2, fname +! ------------------------------------------------------------------------------ + !code + isfound = .false. + ctagfound = '' + iuext = iin + do + lloc = 1 + call u8rdcom(iin,iout,line,ierr) + if (ierr < 0) exit + call urword(line, lloc, istart, istop, 1, ival, rval, iin, iout) + if (line(istart:istop) == 'BEGIN') then + call urword(line, lloc, istart, istop, 1, ival, rval, iin, iout) + if (line(istart:istop) /= '') then + isfound = .true. + ctagfound = line(istart:istop) + call u8rdcom(iin,iout,line2,ierr) + if (ierr < 0) exit + lloc2 = 1 + call urword(line2,lloc2,istart,istop,1,ival,rval,iout,iin) + if (line2(istart:istop) == 'OPEN/CLOSE') then + iuext = GetUnit() + call urword(line2,lloc2,istart,istop,0,ival,rval,iout,iin) + fname = line2(istart:istop) + call openfile(iuext,iout,fname,'OPEN/CLOSE') + else + backspace(iin) + endif + else + ermsg = 'Block name missing in file.' + call store_error(ermsg) + call store_error_unit(iin) + call ustop() + end if + exit + end if + end do + return + end subroutine uget_any_block + + subroutine uterminate_block(iin,iout,key,ctag,lloc,line,ierr,iuext) +! ****************************************************************************** +! Possible abnormal block termination. Terminate if 'begin' found or if +! 'end' encountered with incorrect tag. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + ! -- dummy + integer(I4B), intent(in) :: iin + integer(I4B), intent(in) :: iout + character (len=*), intent(in) :: key + character (len=*), intent(in) :: ctag + integer(I4B), intent(inout) :: lloc + character (len=*), intent(inout) :: line + integer(I4B), intent(inout) :: ierr + integer(I4B), intent(inout) :: iuext + ! -- local + character(len=LENBIGLINE) :: ermsg + integer(I4B) :: istart + integer(I4B) :: istop + integer(I4B) :: ival + real(DP) :: rval + ! -- format +1 format('ERROR. "',A,'" DETECTED WITHOUT "',A,'". ','"END',1X,A, & + '" MUST BE USED TO END ',A,'.') +2 format('ERROR. "',A,'" DETECTED BEFORE "END',1X,A,'". ','"END',1X,A, & + '" MUST BE USED TO END ',A,'.') +! ------------------------------------------------------------------------------ + !code + ierr = 1 + select case(key) + case ('END') + call urword(line, lloc, istart, istop, 1, ival, rval, iout, iin) + if (line(istart:istop).ne.ctag) then + write(ermsg, 1) trim(key), trim(ctag), trim(ctag), trim(ctag) + call store_error(ermsg) + call store_error_unit(iin) + call ustop() + else + ierr = 0 + if (iuext /= iin) then + ! close external file + close(iuext) + iuext = iin + endif + end if + case ('BEGIN') + write(ermsg, 2) trim(key), trim(ctag), trim(ctag), trim(ctag) + call store_error(ermsg) + call store_error_unit(iin) + call ustop() + end select + return + end subroutine uterminate_block + + SUBROUTINE UPCASE(WORD) +!C ****************************************************************** +!C CONVERT A CHARACTER STRING TO ALL UPPER CASE +!C ****************************************************************** +!C SPECIFICATIONS: +!C ------------------------------------------------------------------ + CHARACTER WORD*(*) +!C +!C1------Compute the difference between lowercase and uppercase. + L = LEN(WORD) + IDIFF=ICHAR('a')-ICHAR('A') +!C +!C2------Loop through the string and convert any lowercase characters. + DO 10 K=1,L + IF(WORD(K:K).GE.'a' .AND. WORD(K:K).LE.'z') & + & WORD(K:K)=CHAR(ICHAR(WORD(K:K))-IDIFF) +10 CONTINUE +!C +!C3------return. + RETURN + END SUBROUTINE upcase + + subroutine lowcase(word) +! ****************************************************************** +! Convert a character string to all lower case +! ****************************************************************** +! specifications: +! ------------------------------------------------------------------ + implicit none + ! -- dummy + character(len=*) :: word + ! -- local + integer(I4B) :: idiff, k, l +! +!------compute the difference between lowercase and uppercase. + l = len(word) + idiff=ichar('a')-ichar('A') +! +!------loop through the string and convert any uppercase characters. + do k=1,l + if(word(k:k).ge.'A' .and. word(k:k).le.'Z') then + word(k:k)=char(ichar(word(k:k))+idiff) + endif + enddo +! +!------return. + return + end subroutine lowcase + + subroutine UWWORD(LINE,ICOL,ILEN,NCODE,C,N,R,FMT,ALIGNMENT,SEP) + implicit none + ! -- dummy + character (len=*), intent(inout) :: LINE + integer(I4B), intent(inout) :: ICOL + integer(I4B), intent(in) :: ILEN + integer(I4B), intent(in) :: NCODE + character (len=*), intent(in) :: C + integer(I4B), intent(in) :: N + real(DP), intent(in) :: R + character (len=*), optional, intent(in) :: FMT + integer(I4B), optional, intent(in) :: ALIGNMENT + character (len=*), optional, intent(in) :: SEP + ! -- local + character (len=16) :: cfmt + character (len=16) :: cffmt + character (len=ILEN) :: cval + integer(I4B) :: ialign + integer(I4B) :: i + integer(I4B) :: ispace + integer(I4B) :: istop + integer(I4B) :: ipad + integer(I4B) :: ireal + ! -- code + ! + ! -- initialize locals + ipad = 0 + ireal = 0 + ! + ! -- process dummy variables + if (present(FMT)) then + CFMT = FMT + else + select case(NCODE) + case(TABSTRING, TABUCSTRING) + write(cfmt, '(A,I0,A)') '(A', ILEN, ')' + case(TABINTEGER) + write(cfmt, '(A,I0,A)') '(I', ILEN, ')' + case(TABREAL) + ireal = 1 + i = ILEN - 7 + write(cfmt, '(A,I0,A,I0,A)') '(1PG', ILEN, '.', i, ')' + if (R >= DZERO) then + ipad = 1 + end if + end select + end if + write(cffmt, '(A,I0,A)') '(A', ILEN, ')' + + if (present(ALIGNMENT)) then + ialign = ALIGNMENT + else + ialign = TABRIGHT + end if + ! + ! -- + if (NCODE == TABSTRING .or. NCODE == TABUCSTRING) then + cval = C + if (NCODE == TABUCSTRING) then + call UPCASE(cval) + end if + else if (NCODE == TABINTEGER) then + write(cval, cfmt) N + else if (NCODE == TABREAL) then + write(cval, cfmt) R + end if + ! + ! -- apply alignment to cval + if (len_trim(adjustl(cval)) > ILEN) then + cval = adjustl(cval) + else + cval = trim(adjustl(cval)) + end if + if (ialign == TABCENTER) then + i = len_trim(cval) + ispace = (ILEN - i) / 2 + if (ireal > 0) then + if (ipad > 0) then + cval = ' ' //trim(adjustl(cval)) + else + cval = trim(adjustl(cval)) + end if + else + cval = repeat(' ', ispace) // trim(cval) + end if + else if (ialign == TABLEFT) then + cval = trim(adjustl(cval)) + if (ipad > 0) then + cval = ' ' //trim(adjustl(cval)) + end if + else + cval = adjustr(cval) + end if + if (NCODE == TABUCSTRING) then + call UPCASE(cval) + end if + ! + ! -- increment istop to the end of the column + istop = ICOL + ILEN - 1 + ! + ! -- write final string to line + write(LINE(ICOL:istop), cffmt) cval + + ICOL = istop + 1 + + if (present(SEP)) then + i = len(SEP) + istop = ICOL + i + write(LINE(ICOL:istop), '(A)') SEP + ICOL = istop + end if + +! +!------return. + return + end subroutine UWWORD + + SUBROUTINE URWORD(LINE,ICOL,ISTART,ISTOP,NCODE,N,R,IOUT,IN) +!C ****************************************************************** +!C ROUTINE TO EXTRACT A WORD FROM A LINE OF TEXT, AND OPTIONALLY +!C CONVERT THE WORD TO A NUMBER. +!C ISTART AND ISTOP WILL BE RETURNED WITH THE STARTING AND +!C ENDING CHARACTER POSITIONS OF THE WORD. +!C THE LAST CHARACTER IN THE LINE IS SET TO BLANK SO THAT IF ANY +!C PROBLEMS OCCUR WITH FINDING A WORD, ISTART AND ISTOP WILL +!C POINT TO THIS BLANK CHARACTER. THUS, A WORD WILL ALWAYS BE +!C RETURNED UNLESS THERE IS A NUMERIC CONVERSION ERROR. BE SURE +!C THAT THE LAST CHARACTER IN LINE IS NOT AN IMPORTANT CHARACTER +!C BECAUSE IT WILL ALWAYS BE SET TO BLANK. +!C A WORD STARTS WITH THE FIRST CHARACTER THAT IS NOT A SPACE OR +!C COMMA, AND ENDS WHEN A SUBSEQUENT CHARACTER THAT IS A SPACE +!C OR COMMA. NOTE THAT THESE PARSING RULES DO NOT TREAT TWO +!C COMMAS SEPARATED BY ONE OR MORE SPACES AS A NULL WORD. +!C FOR A WORD THAT BEGINS WITH "'", THE WORD STARTS WITH THE +!C CHARACTER AFTER THE QUOTE AND ENDS WITH THE CHARACTER +!C PRECEDING A SUBSEQUENT QUOTE. THUS, A QUOTED WORD CAN +!C INCLUDE SPACES AND COMMAS. THE QUOTED WORD CANNOT CONTAIN +!C A QUOTE CHARACTER. +!C IF NCODE IS 1, THE WORD IS CONVERTED TO UPPER CASE. +!C IF NCODE IS 2, THE WORD IS CONVERTED TO AN INTEGER. +!C IF NCODE IS 3, THE WORD IS CONVERTED TO A REAL NUMBER. +!C NUMBER CONVERSION ERROR IS WRITTEN TO UNIT IOUT IF IOUT IS +!C POSITIVE; ERROR IS WRITTEN TO DEFAULT OUTPUT IF IOUT IS 0; +!C NO ERROR MESSAGE IS WRITTEN IF IOUT IS NEGATIVE. +!C ****************************************************************** +!C +!C SPECIFICATIONS: +!C ------------------------------------------------------------------ + integer(I4B), intent(inout) :: n + real(DP),intent(inout) :: r + CHARACTER(len=*) LINE + CHARACTER(len=20) STRING + CHARACTER(len=30) RW + CHARACTER(len=1) TAB + character(len=200) :: msg + character(len=LINELENGTH) :: msg_line +!C ------------------------------------------------------------------ + TAB=CHAR(9) +!C +!C1------Set last char in LINE to blank and set ISTART and ISTOP to point +!C1------to this blank as a default situation when no word is found. If +!C1------starting location in LINE is out of bounds, do not look for a +!C1------word. + LINLEN=LEN(LINE) + LINE(LINLEN:LINLEN)=' ' + ISTART=LINLEN + ISTOP=LINLEN + LINLEN=LINLEN-1 + IF(ICOL.LT.1 .OR. ICOL.GT.LINLEN) GO TO 100 +!C +!C2------Find start of word, which is indicated by first character that +!C2------is not a blank, a comma, or a tab. + DO 10 I=ICOL,LINLEN + IF(LINE(I:I).NE.' ' .AND. LINE(I:I).NE.',' & + & .AND. LINE(I:I).NE.TAB) GO TO 20 +10 CONTINUE + ICOL=LINLEN+1 + GO TO 100 +!C +!C3------Found start of word. Look for end. +!C3A-----When word is quoted, only a quote can terminate it. +20 IF(LINE(I:I).EQ.'''') THEN + I=I+1 + IF(I.LE.LINLEN) THEN + DO 25 J=I,LINLEN + IF(LINE(J:J).EQ.'''') GO TO 40 +25 CONTINUE + END IF +!C +!C3B-----When word is not quoted, space, comma, or tab will terminate. + ELSE + DO 30 J=I,LINLEN + IF(LINE(J:J).EQ.' ' .OR. LINE(J:J).EQ.',' & + & .OR. LINE(J:J).EQ.TAB) GO TO 40 +30 CONTINUE + END IF +!C +!C3C-----End of line without finding end of word; set end of word to +!C3C-----end of line. + J=LINLEN+1 +!C +!C4------Found end of word; set J to point to last character in WORD and +!C-------set ICOL to point to location for scanning for another word. +40 ICOL=J+1 + J=J-1 + IF(J.LT.I) GO TO 100 + ISTART=I + ISTOP=J +!C +!C5------Convert word to upper case and RETURN if NCODE is 1. + IF(NCODE.EQ.1) THEN + IDIFF=ICHAR('a')-ICHAR('A') + DO 50 K=ISTART,ISTOP + IF(LINE(K:K).GE.'a' .AND. LINE(K:K).LE.'z') & + & LINE(K:K)=CHAR(ICHAR(LINE(K:K))-IDIFF) +50 CONTINUE + RETURN + END IF +!C +!C6------Convert word to a number if requested. +100 IF(NCODE.EQ.2 .OR. NCODE.EQ.3) THEN + RW=' ' + L=30-ISTOP+ISTART + IF(L.LT.1) GO TO 200 + RW(L:30)=LINE(ISTART:ISTOP) + IF(NCODE.EQ.2) READ(RW,'(I30)',ERR=200) N + IF(NCODE.EQ.3) READ(RW,'(F30.0)',ERR=200) R + END IF + RETURN +!C +!C7------Number conversion error. +200 IF(NCODE.EQ.3) THEN + STRING= 'A REAL NUMBER' + L=13 + ELSE + STRING= 'AN INTEGER' + L=10 + END IF +!C +!C7A-----If output unit is negative, set last character of string to 'E'. + IF(IOUT.LT.0) THEN + N=0 + R=0. + LINE(LINLEN+1:LINLEN+1)='E' + RETURN +!C +!C7B-----If output unit is positive; write a message to output unit. + ELSE IF(IOUT.GT.0) THEN + IF(IN.GT.0) THEN + write(msg_line,201) IN,LINE(ISTART:ISTOP),STRING(1:L) + ELSE + WRITE(msg_line,202) LINE(ISTART:ISTOP),STRING(1:L) + END IF + call sim_message(msg_line, iunit=IOUT, skipbefore=1) + call sim_message(LINE, iunit=IOUT, fmt='(1x,a)') +201 FORMAT(1X,'FILE UNIT ',I4,' : ERROR CONVERTING "',A, & + & '" TO ',A,' IN LINE:') +202 FORMAT(1X,'KEYBOARD INPUT : ERROR CONVERTING "',A, & + '" TO ',A,' IN LINE:') +!C +!C7C-----If output unit is 0; write a message to default output. + ELSE + IF(IN.GT.0) THEN + write(msg_line,201) IN,LINE(ISTART:ISTOP),STRING(1:L) + ELSE + WRITE(msg_line,202) LINE(ISTART:ISTOP),STRING(1:L) + END IF + call sim_message(msg_line, iunit=IOUT, skipbefore=1) + call sim_message(LINE, iunit=IOUT, fmt='(1x,a)') + END IF +!C +!C7D-----STOP after storing error message. + call lowcase(string) + if (in > 0) then + write(msg,205) in,line(istart:istop),trim(string) + else + write(msg,207) line(istart:istop),trim(string) + endif +205 format('File unit ',I0,': Error converting "',A, & + & '" to ',A,' in following line:') +207 format('Keyboard input: Error converting "',A, & + & '" to ',A,' in following line:') + call store_error(msg) + call store_error(trim(line)) + call store_error_unit(in) + call ustop() + ! + END SUBROUTINE URWORD + + SUBROUTINE ULSTLB(IOUT,LABEL,CAUX,NCAUX,NAUX) +!C ****************************************************************** +!C PRINT A LABEL FOR A LIST +!C ****************************************************************** +!C +!C SPECIFICATIONS: +!C ------------------------------------------------------------------ + CHARACTER(len=*) LABEL + CHARACTER(len=16) CAUX(NCAUX) + CHARACTER(len=400) BUF + CHARACTER(len=1) DASH(400) + DATA DASH/400*'-'/ +!C ------------------------------------------------------------------ +!C +!C1------Construct the complete label in BUF. Start with BUF=LABEL. + BUF=LABEL +!C +!C2------Add auxiliary data names if there are any. + NBUF=LEN(LABEL)+9 + IF(NAUX.GT.0) THEN + DO 10 I=1,NAUX + N1=NBUF+1 + NBUF=NBUF+16 + BUF(N1:NBUF)=CAUX(I) +10 CONTINUE + END IF +!C +!C3------Write the label. + WRITE(IOUT,103) BUF(1:NBUF) + 103 FORMAT(1X,A) +!C +!C4------Add a line of dashes. + WRITE(IOUT,104) (DASH(J),J=1,NBUF) + 104 FORMAT(1X,400A) +!C +!C5------Return. + RETURN + END SUBROUTINE ULSTLB +! + + SUBROUTINE UBDSV4(KSTP,KPER,TEXT,NAUX,AUXTXT,IBDCHN, & + & NCOL,NROW,NLAY,NLIST,IOUT,DELT,PERTIM,TOTIM) +!C ****************************************************************** +!C WRITE HEADER RECORDS FOR CELL-BY-CELL FLOW TERMS FOR ONE COMPONENT +!C OF FLOW PLUS AUXILIARY DATA USING A LIST STRUCTURE. EACH ITEM IN +!C THE LIST IS WRITTEN BY MODULE UBDSVB +!C ****************************************************************** +!C +!C SPECIFICATIONS: +!C ------------------------------------------------------------------ + CHARACTER(len=16) :: TEXT + character(len=16), dimension(:) :: AUXTXT + real(DP),intent(in) :: delt,pertim,totim + character(len=*), parameter :: fmt = & + "(1X,'UBDSV4 SAVING ',A16,' ON UNIT',I7,' AT TIME STEP',I7,"// & + "', STRESS PERIOD',I7)" +!C ------------------------------------------------------------------ +!C +!C1------WRITE UNFORMATTED RECORDS IDENTIFYING DATA. + IF(IOUT.GT.0) WRITE(IOUT,fmt) TEXT,IBDCHN,KSTP,KPER + WRITE(IBDCHN) KSTP,KPER,TEXT,NCOL,NROW,-NLAY + WRITE(IBDCHN) 5,DELT,PERTIM,TOTIM + WRITE(IBDCHN) NAUX+1 + IF(NAUX.GT.0) WRITE(IBDCHN) (AUXTXT(N),N=1,NAUX) + WRITE(IBDCHN) NLIST +!C +!C2------RETURN + RETURN + END SUBROUTINE UBDSV4 + + SUBROUTINE UBDSVB(IBDCHN,ICRL,Q,VAL,NVL,NAUX,LAUX) +!C ****************************************************************** +!C WRITE ONE VALUE OF CELL-BY-CELL FLOW PLUS AUXILIARY DATA USING +!C A LIST STRUCTURE. +!C ****************************************************************** +!C +!C SPECIFICATIONS: +!C ------------------------------------------------------------------ + real(DP), DIMENSION(nvl) :: VAL + real(DP) :: q +!C ------------------------------------------------------------------ +!C +!C1------WRITE CELL NUMBER AND FLOW RATE + IF(NAUX.GT.0) THEN + N2=LAUX+NAUX-1 + WRITE(IBDCHN) ICRL,Q,(VAL(N),N=LAUX,N2) + ELSE + WRITE(IBDCHN) ICRL,Q + END IF +!C +!C2------RETURN + RETURN + END SUBROUTINE UBDSVB + + SUBROUTINE UCOLNO(NLBL1,NLBL2,NSPACE,NCPL,NDIG,IOUT) +!C ****************************************************************** +!C OUTPUT COLUMN NUMBERS ABOVE A MATRIX PRINTOUT +!C NLBL1 IS THE START COLUMN LABEL (NUMBER) +!C NLBL2 IS THE STOP COLUMN LABEL (NUMBER) +!C NSPACE IS NUMBER OF BLANK SPACES TO LEAVE AT START OF LINE +!C NCPL IS NUMBER OF COLUMN NUMBERS PER LINE +!C NDIG IS NUMBER OF CHARACTERS IN EACH COLUMN FIELD +!C IOUT IS OUTPUT CHANNEL +!C ****************************************************************** +!C +!C SPECIFICATIONS: +!C ------------------------------------------------------------------ + CHARACTER(len=1) DOT,SPACE,DG,BF + DIMENSION BF(1000),DG(10) +!C + DATA DG(1),DG(2),DG(3),DG(4),DG(5),DG(6),DG(7),DG(8),DG(9),DG(10)/ & + & '0','1','2','3','4','5','6','7','8','9'/ + DATA DOT,SPACE/'.',' '/ +!C ------------------------------------------------------------------ +!C +!C1------CALCULATE # OF COLUMNS TO BE PRINTED (NLBL), WIDTH +!C1------OF A LINE (NTOT), NUMBER OF LINES (NWRAP). + if (iout<=0) return + WRITE(IOUT,1) + 1 FORMAT(1X) + NLBL=NLBL2-NLBL1+1 + N=NLBL + IF(NLBL.GT.NCPL) N=NCPL + NTOT=NSPACE+N*NDIG + IF(NTOT.GT.1000) GO TO 50 + NWRAP=(NLBL-1)/NCPL + 1 + J1=NLBL1-NCPL + J2=NLBL1-1 +!C +!C2------BUILD AND PRINT EACH LINE + DO 40 N=1,NWRAP +!C +!C3------CLEAR THE BUFFER (BF). + DO 20 I=1,1000 + BF(I)=SPACE + 20 CONTINUE + NBF=NSPACE +!C +!C4------DETERMINE FIRST (J1) AND LAST (J2) COLUMN # FOR THIS LINE. + J1=J1+NCPL + J2=J2+NCPL + IF(J2.GT.NLBL2) J2=NLBL2 +!C +!C5------LOAD THE COLUMN #'S INTO THE BUFFER. + DO 30 J=J1,J2 + NBF=NBF+NDIG + I2=J/10 + I1=J-I2*10+1 + BF(NBF)=DG(I1) + IF(I2.EQ.0) GO TO 30 + I3=I2/10 + I2=I2-I3*10+1 + BF(NBF-1)=DG(I2) + IF(I3.EQ.0) GO TO 30 + I4=I3/10 + I3=I3-I4*10+1 + BF(NBF-2)=DG(I3) + IF(I4.EQ.0) GO TO 30 + IF(I4.GT.9) THEN +!C5A-----If more than 4 digits, use "X" for 4th digit. + BF(NBF-3)='X' + ELSE + BF(NBF-3)=DG(I4+1) + END IF + 30 CONTINUE +!C +!C6------PRINT THE CONTENTS OF THE BUFFER (I.E. PRINT THE LINE). + WRITE(IOUT,31) (BF(I),I=1,NBF) + 31 FORMAT(1X,1000A1) +!C + 40 CONTINUE +!C +!C7------PRINT A LINE OF DOTS (FOR AESTHETIC PURPOSES ONLY). + 50 NTOT=NTOT + IF(NTOT.GT.1000) NTOT=1000 + WRITE(IOUT,51) (DOT,I=1,NTOT) + 51 FORMAT(1X,1000A1) +!C +!C8------RETURN + RETURN + END SUBROUTINE UCOLNO + + SUBROUTINE ULAPRW(BUF,TEXT,KSTP,KPER,NCOL,NROW,ILAY,IPRN,IOUT) +!C ****************************************************************** +!C PRINT 1 LAYER ARRAY +!C ****************************************************************** +!C +!C SPECIFICATIONS: +!C ------------------------------------------------------------------ + CHARACTER(len=16) TEXT + real(DP),dimension(ncol,nrow) :: buf +!C ------------------------------------------------------------------ +!C + if (iout<=0) return +!C1------PRINT A HEADER DEPENDING ON ILAY + IF(ILAY.GT.0) THEN + WRITE(IOUT,1) TEXT,ILAY,KSTP,KPER + 1 FORMAT('1',/2X,A,' IN LAYER ',I3,' AT END OF TIME STEP ',I3, & + & ' IN STRESS PERIOD ',I4/2X,75('-')) + ELSE IF(ILAY.LT.0) THEN + WRITE(IOUT,2) TEXT,KSTP,KPER + 2 FORMAT('1',/1X,A,' FOR CROSS SECTION AT END OF TIME STEP',I3, & + & ' IN STRESS PERIOD ',I4/1X,79('-')) + END IF +!C +!C2------MAKE SURE THE FORMAT CODE (IP OR IPRN) IS +!C2------BETWEEN 1 AND 21. + IP=IPRN + IF(IP.LT.1 .OR. IP.GT.21) IP=12 +!C +!C3------CALL THE UTILITY MODULE UCOLNO TO PRINT COLUMN NUMBERS. + IF(IP.EQ.1) CALL UCOLNO(1,NCOL,0,11,11,IOUT) + IF(IP.EQ.2) CALL UCOLNO(1,NCOL,0,9,14,IOUT) + IF(IP.GE.3 .AND. IP.LE.6) CALL UCOLNO(1,NCOL,3,15,8,IOUT) + IF(IP.GE.7 .AND. IP.LE.11) CALL UCOLNO(1,NCOL,3,20,6,IOUT) + IF(IP.EQ.12) CALL UCOLNO(1,NCOL,0,10,12,IOUT) + IF(IP.GE.13 .AND. IP.LE.18) CALL UCOLNO(1,NCOL,3,10,7,IOUT) + IF(IP.EQ.19) CALL UCOLNO(1,NCOL,0,5,13,IOUT) + IF(IP.EQ.20) CALL UCOLNO(1,NCOL,0,6,12,IOUT) + IF(IP.EQ.21) CALL UCOLNO(1,NCOL,0,7,10,IOUT) +!C +!C4------LOOP THROUGH THE ROWS PRINTING EACH ONE IN ITS ENTIRETY. + DO I=1,NROW + SELECT CASE(IP) + + CASE(1) +!C------------ FORMAT 11G10.3 + WRITE(IOUT,11) I,(BUF(J,I),J=1,NCOL) +11 FORMAT(1X,I3,2X,1PG10.3,10(1X,G10.3):/(5X,11(1X,G10.3))) + + CASE(2) +!C------------ FORMAT 9G13.6 + WRITE(IOUT,21) I,(BUF(J,I),J=1,NCOL) +21 FORMAT(1X,I3,2X,1PG13.6,8(1X,G13.6):/(5X,9(1X,G13.6))) + + CASE(3) +!C------------ FORMAT 15F7.1 + WRITE(IOUT,31) I,(BUF(J,I),J=1,NCOL) +31 FORMAT(1X,I3,1X,15(1X,F7.1):/(5X,15(1X,F7.1))) + + CASE(4) +!C------------ FORMAT 15F7.2 + WRITE(IOUT,41) I,(BUF(J,I),J=1,NCOL) +41 FORMAT(1X,I3,1X,15(1X,F7.2):/(5X,15(1X,F7.2))) + + CASE(5) +!C------------ FORMAT 15F7.3 + WRITE(IOUT,51) I,(BUF(J,I),J=1,NCOL) +51 FORMAT(1X,I3,1X,15(1X,F7.3):/(5X,15(1X,F7.3))) + + CASE(6) +!C------------ FORMAT 15F7.4 + WRITE(IOUT,61) I,(BUF(J,I),J=1,NCOL) +61 FORMAT(1X,I3,1X,15(1X,F7.4):/(5X,15(1X,F7.4))) + + CASE(7) +!C------------ FORMAT 20F5.0 + WRITE(IOUT,71) I,(BUF(J,I),J=1,NCOL) +71 FORMAT(1X,I3,1X,20(1X,F5.0):/(5X,20(1X,F5.0))) + + CASE(8) +!C------------ FORMAT 20F5.1 + WRITE(IOUT,81) I,(BUF(J,I),J=1,NCOL) +81 FORMAT(1X,I3,1X,20(1X,F5.1):/(5X,20(1X,F5.1))) + + CASE(9) +!C------------ FORMAT 20F5.2 + WRITE(IOUT,91) I,(BUF(J,I),J=1,NCOL) +91 FORMAT(1X,I3,1X,20(1X,F5.2):/(5X,20(1X,F5.2))) + + CASE(10) +!C------------ FORMAT 20F5.3 + WRITE(IOUT,101) I,(BUF(J,I),J=1,NCOL) +101 FORMAT(1X,I3,1X,20(1X,F5.3):/(5X,20(1X,F5.3))) + + CASE(11) +!C------------ FORMAT 20F5.4 + WRITE(IOUT,111) I,(BUF(J,I),J=1,NCOL) +111 FORMAT(1X,I3,1X,20(1X,F5.4):/(5X,20(1X,F5.4))) + + CASE(12) +!C------------ FORMAT 10G11.4 + WRITE(IOUT,121) I,(BUF(J,I),J=1,NCOL) +121 FORMAT(1X,I3,2X,1PG11.4,9(1X,G11.4):/(5X,10(1X,G11.4))) + + CASE(13) +!C------------ FORMAT 10F6.0 + WRITE(IOUT,131) I,(BUF(J,I),J=1,NCOL) +131 FORMAT(1X,I3,1X,10(1X,F6.0):/(5X,10(1X,F6.0))) + + CASE(14) +!C------------ FORMAT 10F6.1 + WRITE(IOUT,141) I,(BUF(J,I),J=1,NCOL) +141 FORMAT(1X,I3,1X,10(1X,F6.1):/(5X,10(1X,F6.1))) + + CASE(15) +!C------------ FORMAT 10F6.2 + WRITE(IOUT,151) I,(BUF(J,I),J=1,NCOL) +151 FORMAT(1X,I3,1X,10(1X,F6.2):/(5X,10(1X,F6.2))) + + CASE(16) +!C------------ FORMAT 10F6.3 + WRITE(IOUT,161) I,(BUF(J,I),J=1,NCOL) +161 FORMAT(1X,I3,1X,10(1X,F6.3):/(5X,10(1X,F6.3))) + + CASE(17) +!C------------ FORMAT 10F6.4 + WRITE(IOUT,171) I,(BUF(J,I),J=1,NCOL) +171 FORMAT(1X,I3,1X,10(1X,F6.4):/(5X,10(1X,F6.4))) + + CASE(18) +!C------------ FORMAT 10F6.5 + WRITE(IOUT,181) I,(BUF(J,I),J=1,NCOL) +181 FORMAT(1X,I3,1X,10(1X,F6.5):/(5X,10(1X,F6.5))) + + CASE(19) +!C------------FORMAT 5G12.5 + WRITE(IOUT,191) I,(BUF(J,I),J=1,NCOL) +191 FORMAT(1X,I3,2X,1PG12.5,4(1X,G12.5):/(5X,5(1X,G12.5))) + + CASE(20) +!C------------FORMAT 6G11.4 + WRITE(IOUT,201) I,(BUF(J,I),J=1,NCOL) +201 FORMAT(1X,I3,2X,1PG11.4,5(1X,G11.4):/(5X,6(1X,G11.4))) + + CASE(21) +!C------------FORMAT 7G9.2 + WRITE(IOUT,211) I,(BUF(J,I),J=1,NCOL) +211 FORMAT(1X,I3,2X,1PG9.2,6(1X,G9.2):/(5X,7(1X,G9.2))) + + END SELECT + END DO + + RETURN + END SUBROUTINE ULAPRW + + SUBROUTINE ULASAV(BUF,TEXT,KSTP,KPER,PERTIM,TOTIM,NCOL, & + & NROW,ILAY,ICHN) +!C ****************************************************************** +!C SAVE 1 LAYER ARRAY ON DISK +!C ****************************************************************** +!C +!C SPECIFICATIONS: +!C ------------------------------------------------------------------ + CHARACTER(len=16) TEXT + real(DP),dimension(ncol,nrow) :: buf + real(DP) :: pertim,totim +!C ------------------------------------------------------------------ +!C +!C1------WRITE AN UNFORMATTED RECORD CONTAINING IDENTIFYING +!C1------INFORMATION. + WRITE(ICHN) KSTP,KPER,PERTIM,TOTIM,TEXT,NCOL,NROW,ILAY +!C +!C2------WRITE AN UNFORMATTED RECORD CONTAINING ARRAY VALUES +!C2------THE ARRAY IS DIMENSIONED (NCOL,NROW) + WRITE(ICHN) ((BUF(IC,IR),IC=1,NCOL),IR=1,NROW) +!C +!C3------RETURN + RETURN + END SUBROUTINE ULASAV + + subroutine ubdsv1(kstp, kper, text, ibdchn, buff, ncol, nrow, nlay, iout, & + delt, pertim, totim) +! ****************************************************************************** +! Record cell-by-cell flow terms for one component of flow as a 3-D array with +! extra record to indicate delt, pertim, and totim +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + integer(I4B), intent(in) :: kstp + integer(I4B), intent(in) :: kper + character(len=*), intent(in) :: text + integer(I4B), intent(in) :: ibdchn + real(DP), dimension(:), intent(in) :: buff + integer(I4B), intent(in) :: ncol + integer(I4B), intent(in) :: nrow + integer(I4B), intent(in) :: nlay + integer(I4B), intent(in) :: iout + real(DP), intent(in) :: delt + real(DP), intent(in) :: pertim + real(DP), intent(in) :: totim + ! -- format + character(len=*), parameter :: fmt = & + "(1X,'UBDSV1 SAVING ',A16,' ON UNIT',I7,' AT TIME STEP',I7,"// & + "', STRESS PERIOD',I7)" +! ------------------------------------------------------------------------------ + ! + ! -- Write records + if(iout > 0) write(iout, fmt) text, ibdchn, kstp, kper + write(ibdchn) kstp,kper,text,ncol,nrow,-nlay + write(ibdchn) 1,delt,pertim,totim + write(ibdchn) buff + ! + ! -- return + return + end subroutine ubdsv1 + + subroutine ubdsv06(kstp,kper,text, & + modelnam1,paknam1,modelnam2,paknam2, & + ibdchn,naux,auxtxt, & + ncol,nrow,nlay,nlist,iout,delt,pertim,totim) +! ****************************************************************** +! write header records for cell-by-cell flow terms for one component +! of flow. each item in the list is written by module ubdsvc +! ****************************************************************** +! +! specifications: +! ------------------------------------------------------------------ + implicit none + integer(I4B), intent(in) :: kstp + integer(I4B), intent(in) :: kper + character(len=*), intent(in) :: text + character(len=*), intent(in) :: modelnam1 + character(len=*), intent(in) :: paknam1 + character(len=*), intent(in) :: modelnam2 + character(len=*), intent(in) :: paknam2 + integer(I4B), intent(in) :: naux + character(len=16), dimension(:), intent(in) :: auxtxt + integer(I4B), intent(in) :: ibdchn + integer(I4B), intent(in) :: ncol + integer(I4B), intent(in) :: nrow + integer(I4B), intent(in) :: nlay + integer(I4B), intent(in) :: nlist + integer(I4B), intent(in) :: iout + real(DP), intent(in) :: delt + real(DP), intent(in) :: pertim + real(DP), intent(in) :: totim + ! -- local + integer(I4B) :: n + ! -- format + character(len=*), parameter :: fmt = & + "(1X,'UBDSV06 SAVING ',A16,' IN MODEL ',A16,' PACKAGE ',A16,"//& + "'CONNECTED TO MODEL ',A16,' PACKAGE ',A16,"// & + "' ON UNIT',I7,' AT TIME STEP',I7,', STRESS PERIOD',I7)" +! ------------------------------------------------------------------ +! +! write unformatted records identifying data. + if (iout > 0) write(iout,fmt) text, modelnam1, paknam1, & + modelnam2, paknam2, & + ibdchn, kstp, kper + write(ibdchn) kstp,kper,text,ncol,nrow,-nlay + write(ibdchn) 6,delt,pertim,totim + write(ibdchn) modelnam1 + write(ibdchn) paknam1 + write(ibdchn) modelnam2 + write(ibdchn) paknam2 + write(ibdchn) naux+1 + if (naux > 0) write(ibdchn) (auxtxt(n),n=1,naux) + write(ibdchn) nlist + ! + ! -- return + return + end subroutine ubdsv06 + + subroutine ubdsvc(ibdchn, n, q, naux, aux) +! ****************************************************************************** +! Write one value of cell-by-cell flow using a list structure. From node (n) +! and to node (n2) are written to the file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + integer(I4B), intent(in) :: ibdchn + integer(I4B), intent(in) :: n + real(DP), intent(in) :: q + integer(I4B), intent(in) :: naux + real(DP), dimension(naux), intent(in) :: aux + ! -- local + integer(I4B) :: nn +! ------------------------------------------------------------------------------ + ! + ! -- Write record + if (naux > 0) then + write(ibdchn) n,q,(aux(nn),nn=1,naux) + else + write(ibdchn) n,q + end if + ! + ! -- return + return + end subroutine ubdsvc + + subroutine ubdsvd(ibdchn, n, n2, q, naux, aux) +! ****************************************************************************** +! Write one value of cell-by-cell flow using a list structure. From node (n) +! and to node (n2) are written to the file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + integer(I4B), intent(in) :: ibdchn + integer(I4B), intent(in) :: n + integer(I4B), intent(in) :: n2 + real(DP), intent(in) :: q + integer(I4B), intent(in) :: naux + real(DP), dimension(naux), intent(in) :: aux + ! -- local + integer(I4B) :: nn +! ------------------------------------------------------------------------------ + ! + ! -- Write record + if (naux > 0) then + write(ibdchn) n,n2,q,(aux(nn),nn=1,naux) + else + write(ibdchn) n,n2,q + end if + ! + ! -- return + return + end subroutine ubdsvd + + logical function same_word(word1, word2) + ! Perform a case-insensitive comparison of two words + implicit none + ! -- dummy variables + character(len=*), intent(in) :: word1, word2 + ! -- local + character(len=200) :: upword1, upword2 + ! + upword1 = word1 + call upcase(upword1) + upword2 = word2 + call upcase(upword2) + same_word = (upword1==upword2) + return + end function same_word + + function get_node(ilay, irow, icol, nlay, nrow, ncol) + ! Return node number, given layer, row, and column indices + ! for a structured grid. If any argument is invalid, + ! return -1. + implicit none + ! -- return + integer(I4B) :: get_node + ! -- dummy + integer(I4B), intent(in) :: ilay, irow, icol, nlay, nrow, ncol + ! + if (nlay>0 .and. nrow>0 .and. ncol>0) then + if (ilay>0 .and. ilay<=nlay) then + if (irow>0 .and. irow<=nrow) then + if (icol>0 .and. icol<=ncol) then + get_node = icol + ncol*(irow-1) + (ilay-1)*nrow*ncol + return + endif + endif + endif + endif + get_node = -1 + return + end function get_node + + subroutine get_ijk(nodenumber, nrow, ncol, nlay, irow, icol, ilay) + ! Calculate irow, icol, and ilay from the nodenumber and grid + ! dimensions. If nodenumber is invalid, set irow, icol, and + ! ilay to -1 + implicit none + ! -- dummy + integer(I4B), intent(in) :: nodenumber + integer(I4B), intent(in) :: nrow + integer(I4B), intent(in) :: ncol + integer(I4B), intent(in) :: nlay + integer(I4B), intent(out) :: irow + integer(I4B), intent(out) :: icol + integer(I4B), intent(out) :: ilay + ! -- local + integer(I4B) :: nodes + integer(I4B) :: ij + ! + nodes = nlay * nrow * ncol + if(nodenumber < 1 .or. nodenumber > nodes) then + irow = -1 + icol = -1 + ilay = -1 + else + ilay = (nodenumber - 1) / (ncol * nrow) + 1 + ij = nodenumber - (ilay - 1) * ncol * nrow + irow = (ij - 1) / ncol + 1 + icol = ij - (irow - 1) * ncol + endif + ! + return + end subroutine get_ijk + + subroutine get_jk(nodenumber, ncpl, nlay, icpl, ilay) + ! Calculate icpl, and ilay from the nodenumber and grid + ! dimensions. If nodenumber is invalid, set irow, icol, and + ! ilay to -1 + implicit none + ! -- dummy + integer(I4B), intent(in) :: nodenumber + integer(I4B), intent(in) :: ncpl + integer(I4B), intent(in) :: nlay + integer(I4B), intent(out) :: icpl + integer(I4B), intent(out) :: ilay + ! -- local + integer(I4B) :: nodes + ! + nodes = ncpl * nlay + if(nodenumber < 1 .or. nodenumber > nodes) then + icpl = -1 + ilay = -1 + else + ilay = (nodenumber - 1) / ncpl + 1 + icpl = nodenumber - (ilay - 1) * ncpl + endif + ! + return + end subroutine get_jk + + subroutine unitinquire(iu) + ! -- dummy + integer(I4B) :: iu + ! -- local + character(len=LINELENGTH) :: line + character(len=100) :: fname, ac, act, fm, frm, seq, unf + ! -- format + character(len=*), parameter :: fmta = & + &"('unit:',i4,' name:',a,' access:',a,' action:',a)" + character(len=*), parameter :: fmtb = & + &"(' formatted:',a,' sequential:',a,' unformatted:',a,' form:',a)" + ! -- code + ! + ! -- set strings using inquire statement + inquire(unit=iu, name=fname, access=ac, action=act, formatted=fm, & + sequential=seq, unformatted=unf, form=frm) + ! + ! -- write the results of the inquire statement + write(line,fmta) iu, trim(fname), trim(ac), trim(act) + call sim_message(line) + write(line,fmtb) trim(fm), trim(seq), trim(unf), trim(frm) + call sim_message(line) + ! + ! -- return + return + end subroutine unitinquire + + subroutine ParseLine(line, nwords, words, inunit, filename) + ! Parse a line into words. Blanks and commas are recognized as + ! delimiters. Multiple blanks between words is OK, but multiple + ! commas between words is treated as an error. Quotation marks + ! are not recognized as delimiters. + use ConstantsModule, only: LINELENGTH + implicit none + ! -- dummy + character(len=*), intent(in) :: line + integer(I4B), intent(inout) :: nwords + character(len=*), allocatable, dimension(:), intent(inout) :: words + integer(I4B), intent(in), optional :: inunit + character(len=*), intent(in), optional :: filename + ! -- local + integer(I4B) :: i, idum, istart, istop, linelen, lloc + real(DP) :: rdum + ! + nwords = 0 + if (allocated(words)) then + deallocate(words) + endif + linelen = len(line) + ! + ! -- get the number of words in a line and allocate words array + nwords = get_nwords(line) + allocate(words(nwords)) + ! + ! -- Populate words array and return + lloc = 1 + do i = 1, nwords + call URWORD(line, lloc, istart, istop, 0, idum, rdum, 0, 0) + words(i) = line(istart:istop) + end do + ! + ! -- return + return + end subroutine ParseLine + + subroutine ulaprufw(ncol, nrow, kstp, kper, ilay, iout, buf, text, userfmt, & + nvalues, nwidth, editdesc) + ! ************************************************************************** + ! Print 1 layer array with user formatting in wrap format + ! ************************************************************************** + ! + ! Specifications: + ! -------------------------------------------------------------------------- + implicit none + ! -- dummy + integer(I4B), intent(in) :: ncol, nrow, kstp, kper, ilay, iout + real(DP),dimension(ncol,nrow), intent(in) :: buf + character(len=*), intent(in) :: text + character(len=*), intent(in) :: userfmt + integer(I4B), intent(in) :: nvalues, nwidth + character(len=1), intent(in) :: editdesc + ! -- local + integer(I4B) :: i, j, nspaces + ! formats + 1 format('1',/2X,A,' IN LAYER ',I3,' AT END OF TIME STEP ',I3, & + ' IN STRESS PERIOD ',I4/2X,75('-')) + 2 format('1',/1X,A,' FOR CROSS SECTION AT END OF TIME STEP',I3, & + ' IN STRESS PERIOD ',I4/1X,79('-')) + ! ------------------------------------------------------------------ + ! + if (iout<=0) return + ! -- Print a header depending on ILAY + if (ilay > 0) then + write(iout,1) trim(text), ilay, kstp, kper + else if(ilay < 0) then + write(iout,2) trim(text), kstp, kper + end if + ! + ! -- Print column numbers. + nspaces = 0 + if (editdesc == 'F') nspaces = 3 + call ucolno(1, ncol, nspaces, nvalues, nwidth+1, iout) + ! + ! -- Loop through the rows, printing each one in its entirety. + do i=1,nrow + write(iout,userfmt) i,(buf(j,i),j=1,ncol) + enddo + ! + return + end subroutine ulaprufw + + function linear_interpolate(t0, t1, y0, y1, t) result(y) + implicit none + ! -- dummy + real(DP), intent(in) :: t, t0, t1, y0, y1 + real(DP) :: y + ! -- local + real(DP) :: delt, dely, slope + character(len=100) :: msg + ! + ! -- don't get bitten by rounding errors or divide-by-zero + if (IS_SAME(t0, t1) .or. IS_SAME(t, t1)) then + y = y1 + elseif (t == t0) then + y = y0 + elseif ((t0 < t .and. t < t1) .or. (t1 < t .and. t < t0)) then + ! -- perform linear interpolation + delt = t1 - t0 + dely = y1 - y0 + slope = dely / delt + y = y0 + slope * (t - t0) + else + ! -- t is outside range t0 to t1 + msg = 'Error: in linear_interpolate, t is outside range t0 to t1' + call store_error(msg) + call ustop() + endif + ! + return + end function linear_interpolate + + function read_line(iu, eof) result (astring) + ! This function reads a line of arbitrary length and returns + ! it. The returned string can be stored in a deferred-length + ! character variable, for example: + ! + ! integer(I4B) :: iu + ! character(len=:), allocatable :: my_string + ! logical :: eof + ! iu = 8 + ! open(iu,file='my_file') + ! my_string = read_line(iu, eof) + ! + implicit none + ! -- dummy + integer(I4B), intent(in) :: iu + logical, intent(out) :: eof + character(len=:), allocatable :: astring + ! -- local + integer(I4B) :: isize, istat + character(len=256) :: buffer + character(len=1000) :: ermsg, fname + character(len=7) :: fmtd + logical :: lop + ! -- format +20 format('Error in read_line: File ',i0,' is not open.') +30 format('Error in read_line: Attempting to read text ' // & + 'from unformatted file: "',a,'"') +40 format('Error reading from file "',a,'" opened on unit ',i0, & + ' in read_line.') + ! + astring = '' + eof = .false. + do + read(iu, '(a)', advance='NO', iostat=istat, size=isize, end=99) buffer + if (istat > 0) then + ! Determine error if possible, report it, and stop. + if (iu <= 0) then + ermsg = 'Programming error in call to read_line: ' // & + 'Attempt to read from unit number <= 0' + else + inquire(unit=iu,opened=lop,name=fname,formatted=fmtd) + if (.not. lop) then + write(ermsg,20) iu + elseif (fmtd == 'NO' .or. fmtd == 'UNKNOWN') then + write(ermsg, 30) trim(fname) + else + write(ermsg,40) trim(fname), iu + endif + endif + call store_error(ermsg) + call store_error_unit(iu) + call ustop() + endif + astring = astring // buffer(:isize) + ! An end-of-record condition stops the loop. + if (istat < 0) then + return + endif + enddo + ! + return +99 continue + ! An end-of-file condition returns an empty string. + eof = .true. + return + ! + end function read_line + + subroutine GetFileFromPath(pathname, filename) + implicit none + ! -- dummy + character(len=*), intent(in) :: pathname + character(len=*), intent(out) :: filename + ! -- local + integer(I4B) :: i, istart, istop, lenpath + character(len=1) :: fs = '/' + character(len=1) :: bs = '\' + ! + filename = '' + lenpath = len_trim(pathname) + istart = 1 + istop = lenpath + loop: do i=lenpath,1,-1 + if (pathname(i:i) == fs .or. pathname(i:i) == bs) then + if (i == istop) then + istop = istop - 1 + else + istart = i + 1 + exit loop + endif + endif + enddo loop + if (istop >= istart) then + filename = pathname(istart:istop) + endif + ! + return + end subroutine GetFileFromPath + + subroutine extract_idnum_or_bndname(line, icol, istart, istop, idnum, bndname) + ! Starting at position icol, define string as line(istart:istop). + ! If string can be interpreted as an integer(I4B), return integer in idnum argument. + ! If token is not an integer(I4B), assume it is a boundary name, return NAMEDBOUNDFLAG + ! in idnum, convert string to uppercase and return it in bndname. + implicit none + ! -- dummy + character(len=*), intent(inout) :: line + integer(I4B), intent(inout) :: icol, istart, istop + integer(I4B), intent(out) :: idnum + character(len=LENBOUNDNAME), intent(out) :: bndname + ! -- local + integer(I4B) :: istat, ndum, ncode=0 + real(DP) :: rdum + ! + call urword(line, icol, istart, istop, ncode, ndum, rdum, 0, 0) + read(line(istart:istop),*,iostat=istat) ndum + if (istat == 0) then + idnum = ndum + bndname = '' + else + idnum = NAMEDBOUNDFLAG + bndname = line(istart:istop) + call upcase(bndname) + endif + ! + return + end subroutine extract_idnum_or_bndname + + subroutine urdaux(naux, inunit, iout, lloc, istart, istop, auxname, line, & + text) +! ****************************************************************************** +! Read auxiliary variables from an input line +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ArrayHandlersModule, only: ExpandArray + use ConstantsModule, only: LENAUXNAME + ! -- implicit + implicit none + ! -- dummy + integer(I4B), intent(inout) :: naux + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + character(len=LENAUXNAME), allocatable, dimension(:), intent(inout) :: auxname + character(len=*), intent(inout) :: line + character(len=*), intent(in) :: text + ! -- local + integer(I4B) :: n, linelen + real(DP) :: rval + character(len=LINELENGTH) :: errmsg +! ------------------------------------------------------------------------------ + linelen = len(line) + if(naux > 0) then + write(errmsg,'(a)') '****ERROR. AUXILIARY VARIABLES ' // & + 'ALREADY SPECIFIED. AUXILIARY VARIABLES MUST BE SPECIFIED '// & + 'ON ONE LINE IN THE OPTIONS BLOCK.' + call store_error(errmsg) + call store_error_unit(inunit) + call ustop() + endif + auxloop: do + call urword(line, lloc, istart, istop, 1, n, rval, iout, inunit) + if(lloc >= linelen) exit auxloop + naux = naux + 1 + call ExpandArray(auxname) + auxname(naux) = line(istart:istop) + if(iout > 0) then + write(iout, "(4X,'AUXILIARY ',a,' VARIABLE: ',A)") & + trim(adjustl(text)), auxname(naux) + endif + enddo auxloop + + end subroutine urdaux + + subroutine print_format(linein, cdatafmp, editdesc, nvaluesp, nwidthp, inunit) +! ****************************************************************************** +! print_format -- define the print or save format +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ +! Define cdatafmp as a Fortran output format based on user input. Also define +! nvalues, nwidth, and editdesc. +! +! Syntax for linein: +! COLUMNS nval WIDTH nwid [DIGITS ndig [options]] +! +! Where: +! nval = Number of values per line. +! nwid = Number of character places to be used for each value. +! ndig = Number of digits to the right of the decimal point (required +! for real array). +! options are: +! editoption: One of [EXPONENTIAL, FIXED, GENERAL, SCIENTIFIC] +! A default value should be passed in for editdesc as G, I, E, F, or S. +! If I is passed in, then the fortran format will be for an integer variable. +! ------------------------------------------------------------------------------ + ! -- dummy + character(len=*), intent(in) :: linein + character(len=*), intent(inout) :: cdatafmp + character(len=*), intent(inout) :: editdesc + integer(I4B), intent(inout) :: nvaluesp + integer(I4B), intent(inout) :: nwidthp + integer(I4B), intent(in) :: inunit + ! -- local + character(len=len(linein)) :: line + character(len=20), dimension(:), allocatable :: words + character(len=100) :: ermsg + integer(I4B) :: ndigits=0, nwords=0 + integer(I4B) :: i, ierr + logical :: isint +! ------------------------------------------------------------------------------ + ! + ! -- Parse line and initialize values + line(:) = linein(:) + call ParseLine(line, nwords, words, inunit) + ierr = 0 + i = 0 + isint = .false. + if(editdesc == 'I') isint = .true. + ! + ! -- Check array name + if (nwords < 1) then + ermsg = 'Could not build PRINT_FORMAT from line' // trim(line) + call store_error(trim(ermsg)) + ermsg = 'Syntax is: COLUMNS WIDTH DIGITS & + & ' + call store_error(trim(ermsg)) + call store_error_unit(inunit) + call ustop() + endif + ! + ermsg = 'Error setting PRINT_FORMAT. Syntax is incorrect in line:' + if (nwords >= 4) then + if (.not. same_word(words(1), 'COLUMNS')) ierr = 1 + if (.not. same_word(words(3), 'WIDTH')) ierr = 1 + ! -- Read nvalues and nwidth + if (ierr == 0) then + read(words(2), *, iostat=ierr) nvaluesp + endif + if (ierr == 0) then + read(words(4), *, iostat=ierr) nwidthp + endif + else + ierr = 1 + endif + if (ierr /= 0) then + call store_error(ermsg) + call store_error(line) + ermsg = 'Syntax is: COLUMNS WIDTH & + &DIGITS ' + call store_error(trim(ermsg)) + call store_error_unit(inunit) + call ustop() + endif + i = 4 + ! + if (.not. isint) then + ! -- Check for DIGITS specification + if (nwords >= 5) then + if (.not. same_word(words(5), 'DIGITS')) ierr = 1 + ! -- Read ndigits + read(words(6), *, iostat=ierr) ndigits + else + ierr = 1 + endif + i = i + 2 + endif + ! + ! -- Check for EXPONENTIAL | FIXED | GENERAL | SCIENTIFIC option. + ! -- Check for LABEL, WRAP, and STRIP options. + do + i = i + 1 + if (i <= nwords) then + call upcase(words(i)) + select case (words(i)) + case ('EXPONENTIAL') + editdesc = 'E' + if (isint) ierr = 1 + case ('FIXED') + editdesc = 'F' + if (isint) ierr = 1 + case ('GENERAL') + editdesc = 'G' + if (isint) ierr = 1 + case ('SCIENTIFIC') + editdesc = 'S' + if (isint) ierr = 1 + case default + ermsg = 'Error in format specification. Unrecognized option: ' // words(i) + call store_error(ermsg) + ermsg = 'Valid values are EXPONENTIAL, FIXED, GENERAL, or SCIENTIFIC.' + call store_error(ermsg) + call store_error_unit(inunit) + call ustop() + end select + else + exit + endif + enddo + if (ierr /= 0) then + call store_error(ermsg) + call store_error(line) + call store_error_unit(inunit) + call ustop() + endif + ! + ! -- Build the output format. + select case (editdesc) + case ('I') + call BuildIntFormat(nvaluesp, nwidthp, cdatafmp) + case ('F') + call BuildFixedFormat(nvaluesp, nwidthp, ndigits, cdatafmp) + case ('E', 'G', 'S') + call BuildFloatFormat(nvaluesp, nwidthp, ndigits, editdesc, cdatafmp) + end select + ! + return + end subroutine print_format + + subroutine BuildFixedFormat(nvalsp, nwidp, ndig, outfmt, prowcolnum) + ! Build a fixed format for printing or saving a real array + implicit none + ! -- dummy + integer(I4B), intent(in) :: nvalsp, nwidp, ndig + character(len=*), intent(inout) :: outfmt + logical, intent(in), optional :: prowcolnum ! default true + ! -- local + character(len=8) :: cvalues, cwidth, cdigits + character(len=60) :: ufmt + logical :: prowcolnumlocal + ! formats + 10 format(i8) + ! + if (present(prowcolnum)) then + prowcolnumlocal = prowcolnum + else + prowcolnumlocal = .true. + endif + ! + ! -- Convert integers to characters and left-adjust + write(cdigits,10) ndig + cdigits = adjustl(cdigits) + ! + ! -- Build format for printing to the list file in wrap format + write(cvalues,10) nvalsp + cvalues = adjustl(cvalues) + write(cwidth,10) nwidp + cwidth = adjustl(cwidth) + if (prowcolnumlocal) then + ufmt = '(1x,i3,1x,' + else + ufmt = '(5x,' + endif + ufmt = trim(ufmt) // cvalues + ufmt = trim(ufmt) // '(1x,f' + ufmt = trim(ufmt) // cwidth + ufmt = trim(ufmt) // '.' + ufmt = trim(ufmt) // cdigits + ufmt = trim(ufmt) // '):/(5x,' + ufmt = trim(ufmt) // cvalues + ufmt = trim(ufmt) // '(1x,f' + ufmt = trim(ufmt) // cwidth + ufmt = trim(ufmt) // '.' + ufmt = trim(ufmt) // cdigits + ufmt = trim(ufmt) // ')))' + outfmt = ufmt + ! + return + end subroutine BuildFixedFormat + + subroutine BuildFloatFormat(nvalsp, nwidp, ndig, editdesc, outfmt, prowcolnum) + ! Build a floating-point format for printing or saving a real array + implicit none + ! -- dummy + integer(I4B), intent(in) :: nvalsp, nwidp, ndig + character(len=*), intent(in) :: editdesc + character(len=*), intent(inout) :: outfmt + logical, intent(in), optional :: prowcolnum ! default true + ! -- local + character(len=8) :: cvalues, cwidth, cdigits + character(len=60) :: ufmt + logical :: prowcolnumlocal + ! formats + 10 format(i8) + ! + if (present(prowcolnum)) then + prowcolnumlocal = prowcolnum + else + prowcolnumlocal = .true. + endif + ! + ! -- Build the format + write(cdigits,10) ndig + cdigits = adjustl(cdigits) + ! -- Convert integers to characters and left-adjust + write(cwidth,10) nwidp + cwidth = adjustl(cwidth) + ! -- Build format for printing to the list file + write(cvalues, 10) (nvalsp - 1) + cvalues = adjustl(cvalues) + if (prowcolnumlocal) then + ufmt = '(1x,i3,2x,1p,' // editdesc + else + ufmt = '(6x,1p,' // editdesc + endif + ufmt = trim(ufmt) // cwidth + ufmt = trim(ufmt) // '.' + ufmt = trim(ufmt) // cdigits + if (nvalsp>1) then + ufmt = trim(ufmt) // ',' + ufmt = trim(ufmt) // cvalues + ufmt = trim(ufmt) // '(1x,' + ufmt = trim(ufmt) // editdesc + ufmt = trim(ufmt) // cwidth + ufmt = trim(ufmt) // '.' + ufmt = trim(ufmt) // cdigits + ufmt = trim(ufmt) // ')' + endif + ufmt = trim(ufmt) // ':/(5x,' + write(cvalues, 10) nvalsp + cvalues = adjustl(cvalues) + ufmt = trim(ufmt) // cvalues + ufmt = trim(ufmt) // '(1x,' + ufmt = trim(ufmt) // editdesc + ufmt = trim(ufmt) // cwidth + ufmt = trim(ufmt) // '.' + ufmt = trim(ufmt) // cdigits + ufmt = trim(ufmt) // ')))' + outfmt = ufmt + ! + return + end subroutine BuildFloatFormat + + subroutine BuildIntFormat(nvalsp, nwidp, outfmt, prowcolnum) + ! Build a format for printing or saving an integer array + implicit none + ! -- dummy + integer(I4B), intent(in) :: nvalsp, nwidp + character(len=*), intent(inout) :: outfmt + logical, intent(in), optional :: prowcolnum ! default true + ! -- local + character(len=8) :: cvalues, cwidth + character(len=60) :: ufmt + logical :: prowcolnumlocal + ! formats + 10 format(i8) + ! + if (present(prowcolnum)) then + prowcolnumlocal = prowcolnum + else + prowcolnumlocal = .true. + endif + ! + ! -- Build format for printing to the list file in wrap format + write(cvalues,10)nvalsp + cvalues = adjustl(cvalues) + write(cwidth,10)nwidp + cwidth = adjustl(cwidth) + if (prowcolnumlocal) then + ufmt = '(1x,i3,1x,' + else + ufmt = '(5x,' + endif + ufmt = trim(ufmt) // cvalues + ufmt = trim(ufmt) // '(1x,i' + ufmt = trim(ufmt) // cwidth + ufmt = trim(ufmt) // '):/(5x,' + ufmt = trim(ufmt) // cvalues + ufmt = trim(ufmt) // '(1x,i' + ufmt = trim(ufmt) // cwidth + ufmt = trim(ufmt) // ')))' + outfmt = ufmt + ! + return + end subroutine BuildIntFormat + + + function get_nwords(line) +! ****************************************************************************** +! get_nwords -- return number of words in a string +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return variable + integer(I4B) :: get_nwords + ! -- dummy + character(len=*), intent(in) :: line + ! -- local + integer(I4B) :: linelen + integer(I4B) :: lloc + integer(I4B) :: istart + integer(I4B) :: istop + integer(I4B) :: idum + real(DP) :: rdum + ! + ! -- initialize variables + get_nwords = 0 + linelen = len(line) + ! + ! -- Count words in line and allocate words array + lloc = 1 + do + call URWORD(line, lloc, istart, istop, 0, idum, rdum, 0, 0) + if (istart == linelen) exit + get_nwords = get_nwords + 1 + end do + ! + ! -- return + return + end function get_nwords + + subroutine fseek_stream(iu, offset, whence, status) +! ****************************************************************************** +! Move the file pointer. Patterned after fseek, which is not +! supported as part of the fortran standard. For this subroutine to work +! the file must have been opened with access='stream' and action='readwrite'. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + integer(I4B), intent(in) :: iu + integer(I4B), intent(in) :: offset + integer(I4B), intent(in) :: whence + integer(I4B), intent(inout) :: status + integer(I4B) :: ipos +! ------------------------------------------------------------------------------ + ! + inquire(unit=iu, size=ipos) + + select case(whence) + case(0) + ! + ! -- whence = 0, offset is relative to start of file + ipos = 0 + offset + case(1) + ! + ! -- whence = 1, offset is relative to current pointer position + inquire(unit=iu, pos=ipos) + ipos = ipos + offset + case(2) + ! + ! -- whence = 2, offset is relative to end of file + inquire(unit=iu, size=ipos) + ipos = ipos + offset + end select + ! + ! -- position the file pointer to ipos + write(iu, pos=ipos, iostat=status) + inquire(unit=iu, pos=ipos) + ! + ! -- return + return + end subroutine fseek_stream + + + +END MODULE InputOutputModule diff --git a/src/Utilities/Iunit.f90 b/src/Utilities/Iunit.f90 index eaf6088fc38..a4cd159434d 100644 --- a/src/Utilities/Iunit.f90 +++ b/src/Utilities/Iunit.f90 @@ -1,172 +1,172 @@ -! -- Module to manage unit numbers. Allows for multiple unit numbers -! -- assigned to a single package type, as shown below. -! -- row(i) cunit(i) iunit(i)%nval iunit(i)%iunit iunit(i)%ipos -! -- 1 BCF6 1 (1000) (1) -! -- 2 WEL 3 (1001,1003,1005) (2,5,7) -! -- 3 GHB 1 (1002) (4) -! -- 4 EVT 2 (1004,1006) (6,10) -! -- 5 RIV 0 () () -! -- ... - -module IunitModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH, LENFTYPE - use SimModule, only: store_error, count_errors, ustop, store_error_filename - implicit none - private - public :: IunitType - - type :: IunitRowType - integer(I4B) :: nval = 0 - integer(I4B), allocatable, dimension(:) :: iunit ! unit numbers for this row - integer(I4B), allocatable, dimension(:) :: ipos ! position in the input files character array - end type IunitRowType - - type :: IunitType - integer(I4B) :: niunit = 0 - character(len=LENFTYPE), allocatable, dimension(:) :: cunit - type(IunitRowType), allocatable, dimension(:) :: iunit - contains - procedure :: init - procedure :: addfile - procedure :: getunitnumber - end type IunitType - - contains - - subroutine init(this, niunit, cunit) -! ****************************************************************************** -! init -- allocate the cunit and iunit entries of this object, and copy -! cunit into the object. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(IunitType), intent(inout) :: this - integer(I4B), intent(in) :: niunit - character(len=*), dimension(niunit), intent(in) :: cunit - ! -- local - integer(I4B) :: i -! ------------------------------------------------------------------------------ - ! - allocate(this%cunit(niunit)) - allocate(this%iunit(niunit)) - this%niunit = niunit - do i=1,niunit - this%cunit(i)=cunit(i) - enddo - ! - ! -- Return - return - end subroutine init - - subroutine addfile(this, ftyp, iunit, ipos, namefilename) -! ****************************************************************************** -! addfile -- add an ftyp and unit number. Find the row for the ftyp and -! store another iunit value. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(IunitType), intent(inout) :: this - character(len=*), intent(in) :: ftyp - integer(I4B), intent(in) :: iunit - integer(I4B), intent(in) :: ipos - character(len=*), intent(in) :: namefilename - ! -- local - character(len=LINELENGTH) :: errmsg - integer(I4B), allocatable, dimension(:) :: itemp - integer(I4B) :: i, irow -! ------------------------------------------------------------------------------ - ! - ! -- Find the row containing ftyp - irow = 0 - do i = 1, this%niunit - if(this%cunit(i) == ftyp) then - irow = i - exit - endif - enddo - if(irow == 0) then - write(errmsg, '(a,a)') 'Package type not supported: ', ftyp - call store_error(errmsg) - call store_error_filename(namefilename) - call ustop() - endif - ! - ! -- Store the iunit number for this ftyp - if(this%iunit(irow)%nval == 0) then - allocate(this%iunit(irow)%iunit(1)) - allocate(this%iunit(irow)%ipos(1)) - this%iunit(irow)%nval=1 - else - ! - ! -- increase size of iunit - allocate(itemp(this%iunit(irow)%nval)) - itemp(:) = this%iunit(irow)%iunit(:) - deallocate(this%iunit(irow)%iunit) - this%iunit(irow)%nval = this%iunit(irow)%nval + 1 - allocate(this%iunit(irow)%iunit(this%iunit(irow)%nval)) - this%iunit(irow)%iunit(1:this%iunit(irow)%nval - 1) = itemp(:) - ! - ! -- increase size of ipos - itemp(:) = this%iunit(irow)%ipos(:) - deallocate(this%iunit(irow)%ipos) - allocate(this%iunit(irow)%ipos(this%iunit(irow)%nval)) - this%iunit(irow)%ipos(1:this%iunit(irow)%nval - 1) = itemp(:) - ! - ! -- cleanup temp - deallocate(itemp) - endif - this%iunit(irow)%iunit(this%iunit(irow)%nval) = iunit - this%iunit(irow)%ipos(this%iunit(irow)%nval) = ipos - ! - ! -- Return - return - end subroutine - - subroutine getunitnumber(this, ftyp, iunit, iremove) -! ****************************************************************************** -! Get the last unit number for type ftyp or return 0 for iunit. If iremove -! is 1, then remove this unit number. Similar to a list.pop(). -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(IunitType), intent(inout) :: this - character(len=*), intent(in) :: ftyp - integer(I4B), intent(inout) :: iunit - integer(I4B), intent(in) :: iremove - integer(I4B) :: i, irow, nval -! ------------------------------------------------------------------------------ - ! - ! -- Find the row - irow = 0 - do i = 1, this%niunit - if(this%cunit(i) == ftyp) then - irow = i - exit - endif - enddo - ! - ! -- Find the unit number. - iunit = 0 - if(irow > 0) then - nval = this%iunit(irow)%nval - if(nval > 0) then - iunit = this%iunit(irow)%iunit(nval) - if(iremove > 0) then - this%iunit(irow)%iunit(nval) = 0 - this%iunit(irow)%nval = nval - 1 - endif - else - iunit = 0 - endif - endif - end subroutine getunitnumber - -end module IunitModule +! -- Module to manage unit numbers. Allows for multiple unit numbers +! -- assigned to a single package type, as shown below. +! -- row(i) cunit(i) iunit(i)%nval iunit(i)%iunit iunit(i)%ipos +! -- 1 BCF6 1 (1000) (1) +! -- 2 WEL 3 (1001,1003,1005) (2,5,7) +! -- 3 GHB 1 (1002) (4) +! -- 4 EVT 2 (1004,1006) (6,10) +! -- 5 RIV 0 () () +! -- ... + +module IunitModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: LINELENGTH, LENFTYPE + use SimModule, only: store_error, count_errors, ustop, store_error_filename + implicit none + private + public :: IunitType + + type :: IunitRowType + integer(I4B) :: nval = 0 + integer(I4B), allocatable, dimension(:) :: iunit ! unit numbers for this row + integer(I4B), allocatable, dimension(:) :: ipos ! position in the input files character array + end type IunitRowType + + type :: IunitType + integer(I4B) :: niunit = 0 + character(len=LENFTYPE), allocatable, dimension(:) :: cunit + type(IunitRowType), allocatable, dimension(:) :: iunit + contains + procedure :: init + procedure :: addfile + procedure :: getunitnumber + end type IunitType + + contains + + subroutine init(this, niunit, cunit) +! ****************************************************************************** +! init -- allocate the cunit and iunit entries of this object, and copy +! cunit into the object. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(IunitType), intent(inout) :: this + integer(I4B), intent(in) :: niunit + character(len=*), dimension(niunit), intent(in) :: cunit + ! -- local + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + allocate(this%cunit(niunit)) + allocate(this%iunit(niunit)) + this%niunit = niunit + do i=1,niunit + this%cunit(i)=cunit(i) + enddo + ! + ! -- Return + return + end subroutine init + + subroutine addfile(this, ftyp, iunit, ipos, namefilename) +! ****************************************************************************** +! addfile -- add an ftyp and unit number. Find the row for the ftyp and +! store another iunit value. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(IunitType), intent(inout) :: this + character(len=*), intent(in) :: ftyp + integer(I4B), intent(in) :: iunit + integer(I4B), intent(in) :: ipos + character(len=*), intent(in) :: namefilename + ! -- local + character(len=LINELENGTH) :: errmsg + integer(I4B), allocatable, dimension(:) :: itemp + integer(I4B) :: i, irow +! ------------------------------------------------------------------------------ + ! + ! -- Find the row containing ftyp + irow = 0 + do i = 1, this%niunit + if(this%cunit(i) == ftyp) then + irow = i + exit + endif + enddo + if(irow == 0) then + write(errmsg, '(a,a)') 'Package type not supported: ', ftyp + call store_error(errmsg) + call store_error_filename(namefilename) + call ustop() + endif + ! + ! -- Store the iunit number for this ftyp + if(this%iunit(irow)%nval == 0) then + allocate(this%iunit(irow)%iunit(1)) + allocate(this%iunit(irow)%ipos(1)) + this%iunit(irow)%nval=1 + else + ! + ! -- increase size of iunit + allocate(itemp(this%iunit(irow)%nval)) + itemp(:) = this%iunit(irow)%iunit(:) + deallocate(this%iunit(irow)%iunit) + this%iunit(irow)%nval = this%iunit(irow)%nval + 1 + allocate(this%iunit(irow)%iunit(this%iunit(irow)%nval)) + this%iunit(irow)%iunit(1:this%iunit(irow)%nval - 1) = itemp(:) + ! + ! -- increase size of ipos + itemp(:) = this%iunit(irow)%ipos(:) + deallocate(this%iunit(irow)%ipos) + allocate(this%iunit(irow)%ipos(this%iunit(irow)%nval)) + this%iunit(irow)%ipos(1:this%iunit(irow)%nval - 1) = itemp(:) + ! + ! -- cleanup temp + deallocate(itemp) + endif + this%iunit(irow)%iunit(this%iunit(irow)%nval) = iunit + this%iunit(irow)%ipos(this%iunit(irow)%nval) = ipos + ! + ! -- Return + return + end subroutine + + subroutine getunitnumber(this, ftyp, iunit, iremove) +! ****************************************************************************** +! Get the last unit number for type ftyp or return 0 for iunit. If iremove +! is 1, then remove this unit number. Similar to a list.pop(). +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(IunitType), intent(inout) :: this + character(len=*), intent(in) :: ftyp + integer(I4B), intent(inout) :: iunit + integer(I4B), intent(in) :: iremove + integer(I4B) :: i, irow, nval +! ------------------------------------------------------------------------------ + ! + ! -- Find the row + irow = 0 + do i = 1, this%niunit + if(this%cunit(i) == ftyp) then + irow = i + exit + endif + enddo + ! + ! -- Find the unit number. + iunit = 0 + if(irow > 0) then + nval = this%iunit(irow)%nval + if(nval > 0) then + iunit = this%iunit(irow)%iunit(nval) + if(iremove > 0) then + this%iunit(irow)%iunit(nval) = 0 + this%iunit(irow)%nval = nval - 1 + endif + else + iunit = 0 + endif + endif + end subroutine getunitnumber + +end module IunitModule diff --git a/src/Utilities/List.f90 b/src/Utilities/List.f90 index f2d1f77852e..961b934155c 100644 --- a/src/Utilities/List.f90 +++ b/src/Utilities/List.f90 @@ -1,8 +1,8 @@ module ListModule ! -- ListType implements a generic list. - use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH - use GenericUtilitiesModule, only: sim_message, stop_with_error + use KindModule, only: DP, I4B + use ConstantsModule, only: LINELENGTH + use GenericUtilitiesModule, only: sim_message, stop_with_error private public :: ListType, ListNodeType @@ -208,11 +208,11 @@ end function GetPreviousItem subroutine InsertAfter(this, objptr, indx) implicit none ! -- dummy - class(ListType), intent(inout) :: this + class(ListType), intent(inout) :: this class(*), pointer, intent(inout) :: objptr integer(I4B), intent(in) :: indx - ! -- local - character(len=LINELENGTH) :: line + ! -- local + character(len=LINELENGTH) :: line integer(I4B) :: numnodes type(ListNodeType), pointer :: precedingNode => null() type(ListNodeType), pointer :: followingNode => null() @@ -233,7 +233,7 @@ subroutine InsertAfter(this, objptr, indx) followingNode%prevNode => newNode this%nodeCount = this%nodeCount + 1 else - write(line,'(a)') 'Programming error in ListType%insert_after' + write(line,'(a)') 'Programming error in ListType%insert_after' call sim_message(line) call stop_with_error(1) endif diff --git a/src/Utilities/ListReader.f90 b/src/Utilities/ListReader.f90 index 777e845ebda..c8b80426d7b 100644 --- a/src/Utilities/ListReader.f90 +++ b/src/Utilities/ListReader.f90 @@ -1,773 +1,773 @@ -! -- Generic List Reader Module -module ListReaderModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, LENTIMESERIESNAME, & - LENLISTLABEL, DONE - use SimModule, only: store_error_unit - implicit none - private - public ListReaderType - - type :: ListReaderType - integer(I4B) :: in = 0 ! unit number of file containing control record - integer(I4B) :: inlist = 0 ! unit number of file from which list will be read - integer(I4B) :: iout = 0 ! unit number to output messages - integer(I4B) :: inamedbound = 0 ! flag indicating boundary names are to be read - integer(I4B) :: ierr = 0 ! error flag - integer(I4B) :: nlist = 0 ! number of entries in list. -1 indicates number will be automatically determined - integer(I4B) :: ibinary = 0 ! flag indicating to read binary list - integer(I4B) :: istart = 0 ! string starting location - integer(I4B) :: istop = 0 ! string ending location - integer(I4B) :: lloc = 0 ! entry number in line - integer(I4B) :: iclose = 0 ! flag indicating whether or not to close file - integer(I4B) :: ndim = 0 ! number of dimensions in model - integer(I4B) :: ntxtrlist = 0 ! number of text entries found in rlist - integer(I4B) :: ntxtauxvar = 0 ! number of text entries found in auxvar - character(len=LENLISTLABEL) :: label = '' ! label for printing list - character(len=LINELENGTH) :: line = '' ! line string for reading file - integer(I4B), dimension(:), pointer, contiguous :: mshape => null() ! pointer to model shape - integer(I4B), dimension(:), pointer, contiguous :: nodelist => null() ! pointer to nodelist - real(DP), dimension(:, :), pointer, contiguous :: rlist => null() ! pointer to rlist - real(DP), dimension(:, :), pointer, contiguous :: auxvar => null() ! pointer to auxvar - character(len=16), dimension(:), pointer :: auxname => null() ! pointer to aux names - character(len=LENBOUNDNAME), dimension(:), pointer, & - contiguous :: boundname => null() ! pointer to boundname - integer(I4B), dimension(:), allocatable :: idxtxtrow ! row locations of text in rlist - integer(I4B), dimension(:), allocatable :: idxtxtcol ! col locations of text in rlist - integer(I4B), dimension(:), allocatable :: idxtxtauxrow ! row locations of text in auxvar - integer(I4B), dimension(:), allocatable :: idxtxtauxcol ! col locations of text in auxvar - character(len=LENTIMESERIESNAME), dimension(:), allocatable :: txtrlist ! text found in rlist - character(len=LENTIMESERIESNAME), dimension(:), allocatable :: txtauxvar ! text found in auxvar - contains - procedure :: read_list - procedure :: write_list - procedure, private :: read_control_record - procedure, private :: read_data - procedure, private :: set_openclose - procedure, private :: read_ascii - procedure, private :: read_binary - end type ListReaderType - - contains - - subroutine read_list(this, in, iout, nlist, inamedbound, mshape, nodelist, & - rlist, auxvar, auxname, boundname, label) -! ****************************************************************************** -! init -- Initialize the reader -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LENBOUNDNAME - ! -- dummy - class(ListReaderType) :: this - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout - integer(I4B), intent(inout) :: nlist - integer(I4B), intent(in) :: inamedbound - integer(I4B), dimension(:), intent(in), contiguous, pointer :: mshape - integer(I4B), dimension(:), intent(inout), contiguous, pointer :: nodelist - real(DP), dimension(:, :), intent(inout), contiguous, pointer :: rlist - real(DP), dimension(:, :), intent(inout), contiguous, pointer :: auxvar - character(len=16), dimension(:), intent(inout), target :: auxname - character(len=LENBOUNDNAME), dimension(:), pointer, contiguous, intent(inout) :: boundname - character(len=500), intent(in) :: label - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- Copy variables - this%in = in - this%iout = iout - this%nlist = nlist - this%inamedbound = inamedbound - this%ndim = size(mshape) - this%label = label - ! - ! -- Set pointers - this%mshape => mshape - this%nodelist => nodelist - this%rlist => rlist - this%auxvar => auxvar - this%auxname => auxname - this%boundname => boundname - ! - ! -- Allocate arrays for storing text and text locations - if(.not. allocated(this%idxtxtrow)) allocate(this%idxtxtrow(0)) - if(.not. allocated(this%idxtxtcol)) allocate(this%idxtxtcol(0)) - if(.not. allocated(this%idxtxtauxrow)) allocate(this%idxtxtauxrow(0)) - if(.not. allocated(this%idxtxtauxcol)) allocate(this%idxtxtauxcol(0)) - if(.not. allocated(this%txtrlist)) allocate(this%txtrlist(0)) - if(.not. allocated(this%txtauxvar)) allocate(this%txtauxvar(0)) - ! - ! -- Read control record - call this%read_control_record() - ! - ! -- Read data - call this%read_data() - ! - ! -- Set nlist for return - nlist = this%nlist - ! - ! -- return - return - end subroutine read_list - - subroutine read_control_record(this) -! ****************************************************************************** -! read_control_record -- Check for a control record, and parse if found -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: u8rdcom, urword - ! -- dummy - class(ListReaderType) :: this - ! -- local - integer(I4B) :: idum - real(DP) :: r - ! -- formats - character(len=*), parameter :: fmtlsf = & - "(1X,'LIST SCALING FACTOR=',1PG12.5)" -! ------------------------------------------------------------------------------ - ! - ! -- Set default values, which may be changed by control record - this%inlist = this%in - this%iclose = 0 - this%ibinary = 0 - ! - ! -- Read to the first non-commented line - call u8rdcom(this%in, this%iout, this%line, this%ierr) - this%lloc = 1 - call urword(this%line, this%lloc, this%istart, this%istop, 1, idum, r, & - this%iout, this%in) - ! - ! -- Parse record - select case(this%line(this%istart:this%istop)) - case('OPEN/CLOSE') - call this%set_openclose() - end select - ! - ! -- return - return - end subroutine read_control_record - - subroutine set_openclose(this) -! ****************************************************************************** -! set_openclose -- set up for open/close file -! -! OPEN/CLOSE fname [(BINARY)] -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: u8rdcom, urword, openfile - use OpenSpecModule, only: form, access - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error - ! -- dummy - class(ListReaderType) :: this - ! -- local - integer(I4B) :: idum, itmp - real(DP) :: r - logical :: exists - integer(I4B) :: nunopn = 99 - character(len=LINELENGTH) :: fname - character(len=LINELENGTH) :: errmsg - ! -- formats - character(len=*), parameter :: fmtocne = & - "('Specified OPEN/CLOSE file ',(A),' does not exist')" - character(len=*), parameter :: fmtobf = & - "(1X,/1X,'OPENING BINARY FILE ON UNIT ',I0,':',/1X,A)" - character(len=*), parameter :: fmtobfnlist = & - "(1X, 'TO READ ', I0, ' RECORDS.')" - character(len=*), parameter :: fmtofnlist = & - "(1x,'TO READ ', I0, ' RECORDS.')" - character(len=*), parameter :: fmtof = & - "(1X,/1X,'OPENING FILE ON UNIT ',I0,':',/1X,A)" -! ------------------------------------------------------------------------------ - ! - ! -- get filename - call urword(this%line, this%lloc, this%istart, this%istop, 0, idum, r, & - this%iout, this%in) - fname = this%line(this%istart:this%istop) - ! - ! -- check to see if file OPEN/CLOSE file exists - inquire(file=fname, exist=exists) - if (.not. exists) then - write(errmsg, fmtocne) this%line(this%istart:this%istop) - call store_error(errmsg) - call store_error('Specified OPEN/CLOSE file does not exist') - call store_error_unit(this%in) - call ustop() - endif - ! - ! -- Check for (BINARY) keyword - call urword(this%line, this%lloc, this%istart, this%istop, 1, idum, r, & - this%iout, this%in) - if(this%line(this%istart:this%istop) == '(BINARY)') this%ibinary = 1 - ! - ! -- Open the file depending on ibinary flag - this%inlist = nunopn - if(this%ibinary == 1) then - itmp = this%iout - if(this%iout > 0) then - itmp = 0 - write(this%iout, fmtobf) this%inlist, trim(adjustl(fname)) - if(this%nlist > 0) write(this%iout, fmtobfnlist) this%nlist - endif - call openfile(this%inlist, itmp, fname, 'OPEN/CLOSE', fmtarg_opt=form, & - accarg_opt=access) - else - itmp = this%iout - if(this%iout > 0) then - itmp = 0 - write(this%iout, fmtof) this%inlist, trim(adjustl(fname)) - if(this%nlist > 0) write(this%iout, fmtofnlist) this%nlist - endif - call openfile(this%inlist, itmp, fname, 'OPEN/CLOSE') - end if - ! - ! -- Set iclose to 1 because it is open/close, to indicate that the - ! file needs to be closed after the list is read - this%iclose = 1 - ! - ! -- Read the first line from inlist to be consistent with how the list is - ! read when it is included in the package input file - if(this%ibinary /= 1) call u8rdcom(this%inlist, this%iout, this%line, & - this%ierr) - ! - ! -- return - return - end subroutine set_openclose - - subroutine read_data(this) -! ****************************************************************************** -! read_data -- read the data -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(ListReaderType) :: this - ! -- local - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- Read the list - if(this%ibinary == 1) then - call this%read_binary() - else - call this%read_ascii() - endif - ! - ! -- if open/close, then close file - if(this%iclose == 1) then - close(this%inlist) - endif - ! -- return - return - end subroutine read_data - - subroutine read_binary(this) -! ****************************************************************************** -! read_binary -- read the data from a binary file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH, LENBIGLINE - use InputOutputModule, only: get_node - use SimModule, only: ustop, store_error - ! -- dummy - class(ListReaderType) :: this - ! -- local - integer(I4B) :: mxlist, ldim, naux, nod, ii, jj - character(len=LINELENGTH) :: fname - character(len=LENBIGLINE) :: errmsg - integer(I4B), dimension(:), allocatable :: cellid - ! -- formats - character(len=*), parameter :: fmtmxlsterronly = & - "('ERROR READING LIST FROM FILE: '," // & - "a,' ON UNIT: ',I0," // & - "' THE NUMBER OF RECORDS ENCOUNTERED EXCEEDS THE MAXIMUM NUMBER " // & - "OF RECORDS. TRY INCREASING MAXBOUND FOR THIS LIST." // & - " NUMBER OF RECORDS: ',I0,' MAXBOUND: ',I0)" - character(len=*), parameter :: fmtlsterronly = & - "('ERROR READING LIST FROM FILE: '," // & - "1x,a,1x,' ON UNIT: ',I0)" -! ------------------------------------------------------------------------------ - ! - ! -- determine array sizes - mxlist = size(this%rlist, 2) - ldim = size(this%rlist, 1) - naux = size(this%auxvar, 1) - ! - ! -- Allocate arrays - allocate(cellid(this%ndim)) - ! - ii = 1 - readloop: do - ! - ! -- read layer, row, col, or cell number - read(this%inlist, iostat=this%ierr) cellid - - ! -- If not end of record, then store nodenumber, else - ! calculate lstend and nlist, and exit readloop - select case(this%ierr) - case(0) - ! - ! -- Check range - if(ii > mxlist) then - inquire(unit=this%inlist, name=fname) - write(errmsg, fmtmxlsterronly) fname, this%inlist, ii, mxlist - call store_error(errmsg) - call ustop() - endif - ! - ! -- Store node number and read the remainder of the record - if(this%ndim == 1) then - nod = cellid(1) - elseif(this%ndim == 2) then - nod = get_node(cellid(1), 1, cellid(2), & - this%mshape(1), 1, this%mshape(2)) - else - nod = get_node(cellid(1), cellid(2), cellid(3), & - this%mshape(1), this%mshape(2), this%mshape(3)) - endif - this%nodelist(ii) = nod - read(this%inlist, iostat=this%ierr) (this%rlist(jj,ii),jj=1,ldim), & - (this%auxvar(ii,jj),jj=1,naux) - if(this%ierr /= 0) then - inquire(unit=this%inlist, name=fname) - write(errmsg, fmtlsterronly) trim(adjustl(fname)), this%inlist - call store_error(errmsg) - call ustop() - endif - ! - case(:-1) - ! - ! -- End of record was encountered - this%nlist = ii - 1 - exit readloop - ! - case(1:) - ! - ! -- Error - inquire(unit=this%inlist, name=fname) - write(errmsg, fmtlsterronly) trim(adjustl(fname)), this%inlist - call store_error(errmsg) - call ustop() - ! - end select - ! - ! -- If nlist is known, then exit when nlist values have been read - if(this%nlist > 0) then - if(ii == this%nlist) exit readloop - endif - ! - ! -- increment ii - ii = ii + 1 - ! - enddo readloop - ! - ! -- return - return - end subroutine read_binary - - subroutine read_ascii(this) -! ****************************************************************************** -! read_ascii -- read the data from an ascii file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LENBOUNDNAME, LINELENGTH, DZERO - use InputOutputModule, only: u8rdcom, urword, get_node - use SimModule, only: ustop, store_error, count_errors - use ArrayHandlersModule, only: ExpandArray - ! -- dummy - class(ListReaderType) :: this - ! -- local - integer(I4B) :: mxlist, ldim, naux - integer(I4B) :: ii, jj, idum, nod, istat, increment - real(DP) :: r - integer(I4B), dimension(:), allocatable :: cellid - character(len=LINELENGTH) :: fname - character(len=LINELENGTH) :: errmsg - ! -- formats - character(len=*), parameter :: fmtmxlsterronly = & - "('***ERROR READING LIST. & - &THE NUMBER OF RECORDS ENCOUNTERED EXCEEDS THE MAXIMUM NUMBER " // & - "OF RECORDS. TRY INCREASING MAXBOUND FOR THIS LIST." // & - " NUMBER OF RECORDS: ',I0,' MAXBOUND: ',I0)" -! ------------------------------------------------------------------------------ - ! - ! -- determine array sizes - mxlist = size(this%rlist, 2) - ldim = size(this%rlist, 1) - naux = size(this%auxvar, 1) - this%ntxtrlist = 0 - this%ntxtauxvar = 0 - ! - ! -- Allocate arrays - allocate(cellid(this%ndim)) - ! - ii = 1 - readloop: do - ! - ! -- First line was already read, so don't read again - if(ii /= 1) call u8rdcom(this%inlist, 0, this%line, this%ierr) - ! - ! -- If this is an unknown-length list, then check for END. - ! If found, then backspace, set nlist, and exit readloop. - if(this%nlist < 0) then - this%lloc = 1 - call urword(this%line, this%lloc, this%istart, this%istop, 1, idum, r, & - this%iout, this%inlist) - if(this%line(this%istart:this%istop) == 'END' .or. this%ierr < 0) then - ! If ierr < 0, backspace was already performed in u8rdcom, so only - ! need to backspace if END was found. - if (this%ierr == 0) then - backspace(this%inlist) - endif - this%nlist = ii - 1 - exit readloop - endif - endif - ! - ! -- Check range - if(ii > mxlist) then - inquire(unit=this%inlist, name=fname) - write(errmsg, fmtmxlsterronly) ii, mxlist - call store_error(errmsg) - errmsg = 'Error occurred reading line: ' // trim(this%line) - call store_error(errmsg) - call store_error_unit(this%inlist) - call ustop() - endif - ! - ! -- Read layer, row, column or cell number and assign to nodelist - this%lloc = 1 - if(this%ndim == 3) then - ! - ! -- Grid is structured; read layer, row, column - call urword(this%line, this%lloc, this%istart, this%istop, 2, & - cellid(1), r, this%iout, this%inlist) - call urword(this%line, this%lloc, this%istart, this%istop, 2, & - cellid(2), r, this%iout, this%inlist) - call urword(this%line, this%lloc, this%istart, this%istop, 2, & - cellid(3), r, this%iout, this%inlist) - ! - ! -- Check for illegal grid location - if(cellid(1) < 1 .or. cellid(1) > this%mshape(1)) then - write(errmsg, *) ' Layer number in list is outside of the grid', & - cellid(1) - call store_error(errmsg) - end if - if(cellid(2) < 1 .or. cellid(2) > this%mshape(2)) then - write(errmsg, *) ' Row number in list is outside of the grid', & - cellid(2) - call store_error(errmsg) - end if - if(cellid(3) < 1 .or. cellid(3) > this%mshape(3)) then - write(errmsg, *) ' Column number in list is outside of the grid', & - cellid(3) - call store_error(errmsg) - end if - ! - ! -- Calculate nodenumber and put in nodelist - nod = get_node(cellid(1), cellid(2), cellid(3), & - this%mshape(1), this%mshape(2), this%mshape(3)) - elseif(this%ndim == 2) then - ! - ! -- Grid is disv - call urword(this%line, this%lloc, this%istart, this%istop, 2, & - cellid(1), r, this%iout, this%inlist) - call urword(this%line, this%lloc, this%istart, this%istop, 2, & - cellid(2), r, this%iout, this%inlist) - ! - ! -- Check for illegal grid location - if(cellid(1) < 1 .or. cellid(1) > this%mshape(1)) then - write(errmsg, *) ' Layer number in list is outside of the grid', & - cellid(1) - call store_error(errmsg) - end if - if(cellid(2) < 1 .or. cellid(2) > this%mshape(2)) then - write(errmsg, *) ' Cell2d number in list is outside of the grid', & - cellid(2) - call store_error(errmsg) - end if - ! - ! -- Calculate nodenumber and put in nodelist - nod = get_node(cellid(1), 1, cellid(2), & - this%mshape(1), 1, this%mshape(2)) - else - ! - ! -- Grid is unstructured; read layer and celld2d number - call urword(this%line, this%lloc, this%istart, this%istop, 2, nod, r, & - this%iout, this%inlist) - if(nod < 1 .or. nod > this%mshape(1)) then - write(errmsg, *) ' Node number in list is outside of the grid', nod - call store_error(errmsg) - end if - ! - endif - ! - ! -- Assign nod to nodelist - this%nodelist(ii) = nod - ! - ! -- Read rlist - do jj = 1, ldim - call urword(this%line, this%lloc, this%istart, this%istop, 0, idum, & - r, this%iout, this%inlist) - read(this%line(this%istart:this%istop), *, iostat=istat) r - ! - ! -- If a double precision value, then store in rlist, otherwise store - ! the text name and location - if (istat == 0) then - this%rlist(jj, ii) = r - else - this%rlist(jj, ii) = DZERO - this%ntxtrlist = this%ntxtrlist + 1 - if(this%ntxtrlist > size(this%txtrlist)) then - increment = size(this%txtrlist) * 0.2 - increment = max(100, increment) - call ExpandArray(this%txtrlist, increment) - call ExpandArray(this%idxtxtrow, increment) - call ExpandArray(this%idxtxtcol, increment) - endif - this%txtrlist(this%ntxtrlist) = this%line(this%istart:this%istop) - this%idxtxtrow(this%ntxtrlist) = ii - this%idxtxtcol(this%ntxtrlist) = jj - endif - ! - enddo - ! - ! -- Read auxvar - do jj = 1, naux - call urword(this%line, this%lloc, this%istart, this%istop, 0, idum, & - r, this%iout, this%inlist) - read(this%line(this%istart:this%istop), *, iostat=istat) r - ! - ! -- If a double precision value, then store in auxvar, otherwise store - ! the text name and location - if (istat == 0) then - this%auxvar(jj, ii) = r - else - this%auxvar(jj, ii) = DZERO - this%ntxtauxvar = this%ntxtauxvar + 1 - if(this%ntxtauxvar > size(this%txtauxvar)) then - increment = size(this%txtauxvar) * 0.2 - increment = max(100, increment) - call ExpandArray(this%txtauxvar, increment) - call ExpandArray(this%idxtxtauxrow, increment) - call ExpandArray(this%idxtxtauxcol, increment) - endif - this%txtauxvar(this%ntxtauxvar) = this%line(this%istart:this%istop) - this%idxtxtauxrow(this%ntxtauxvar) = ii - this%idxtxtauxcol(this%ntxtauxvar) = jj - endif - ! - enddo - ! - ! -- Read the boundary names (only supported for ascii input) - if (this%inamedbound > 0) then - call urword(this%line, this%lloc, this%istart, this%istop, 1, idum, r, & - this%iout, this%inlist) - this%boundname(ii) = this%line(this%istart:this%istop) - endif - ! - ! -- If nlist is known, then exit when nlist values have been read - if(this%nlist > 0) then - if(ii == this%nlist) exit readloop - endif - ! - ! -- increment ii row counter - ii = ii + 1 - ! - enddo readloop - ! - ! -- Stop if errors were detected - if(count_errors() > 0) then - call store_error_unit(this%inlist) - call ustop() - endif - ! - ! -- return - return - end subroutine read_ascii - - subroutine write_list(this) -! ****************************************************************************** -! write_list -- Write input data to a list -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, & - TABLEFT, TABCENTER - use InputOutputModule, only: ulstlb, get_ijk - use TableModule, only: TableType, table_cr - ! -- dummy - class(ListReaderType) :: this - ! -- local - character(len=10) :: cpos - character(len=LINELENGTH) :: tag - character(len=LINELENGTH), allocatable, dimension(:) :: words - integer(I4B) :: ntabrows - integer(I4B) :: ntabcols - integer(I4B) :: ipos - integer(I4B) :: ii, jj, i, j, k, nod - integer(I4B) :: ldim - integer(I4B) :: naux - type(TableType), pointer :: inputtab => null() - ! -- formats - character(len=LINELENGTH) :: fmtlstbn -! ------------------------------------------------------------------------------ - ! - ! -- Determine sizes - ldim = size(this%rlist, 1) - naux = size(this%auxvar, 1) - ! - ! -- dimension table - ntabrows = this%nlist - ! - ! -- start building format statement to parse this%label, which - ! contains the column headers (except for boundname and auxnames) - ipos = index(this%label, 'NO.') - if (ipos /= 0) then - write(cpos,'(i10)') ipos + 3 - fmtlstbn = '(a' // trim(adjustl(cpos)) - else - fmtlstbn = '(a7' - end if - ! -- sequence number, layer, row, and column. - if(size(this%mshape) == 3) then - ntabcols = 4 - fmtlstbn = trim(fmtlstbn) // ',a7,a7,a7' - ! - ! -- sequence number, layer, and cell2d. - else if(size(this%mshape) == 2) then - ntabcols = 3 - fmtlstbn = trim(fmtlstbn) // ',a7,a7' - ! - ! -- sequence number and node. - else - ntabcols = 2 - fmtlstbn = trim(fmtlstbn) // ',a7' - end if - ! - ! -- Add fields for non-optional real values - ntabcols = ntabcols + ldim - do i = 1, ldim - fmtlstbn = trim(fmtlstbn) // ',a16' - end do - ! - ! -- Add field for boundary name - if (this%inamedbound == 1) then - ntabcols = ntabcols + 1 - fmtlstbn = trim(fmtlstbn) // ',a16' - end if - ! - ! -- Add fields for auxiliary variables - ntabcols = ntabcols + naux - do i = 1, naux - fmtlstbn = trim(fmtlstbn) // ',a16' - end do - fmtlstbn = trim(fmtlstbn) // ')' - ! - ! -- allocate words - allocate(words(ntabcols)) - ! - ! -- parse this%label into words - read(this%label, fmtlstbn) (words(i), i=1, ntabcols) - ! - ! -- initialize the input table object - call table_cr(inputtab, ' ', ' ') - call inputtab%table_df(ntabrows, ntabcols, this%iout) - ! - ! -- add the columns - ipos = 1 - call inputtab%initialize_column(words(ipos), 10, alignment=TABCENTER) - ! - ! -- discretization - do i = 1, size(this%mshape) - ipos = ipos + 1 - call inputtab%initialize_column(words(ipos), 7, alignment=TABCENTER) - end do - ! - ! -- non-optional variables - do i = 1, ldim - ipos = ipos + 1 - call inputtab%initialize_column(words(ipos), 16, alignment=TABCENTER) - end do - ! - ! -- boundname - if (this%inamedbound == 1) then - ipos = ipos + 1 - tag = 'BOUNDNAME' - call inputtab%initialize_column(tag, LENBOUNDNAME, alignment=TABLEFT) - end if - ! - ! -- aux variables - do i = 1, naux - call inputtab%initialize_column(this%auxname(i), 16, alignment=TABCENTER) - end do - ! - ! -- Write the table - do ii = 1, this%nlist - call inputtab%add_term(ii) - ! - ! -- discretization - if (size(this%mshape) == 3) then - nod = this%nodelist(ii) - call get_ijk(nod, this%mshape(2), this%mshape(3), this%mshape(1), & - i, j, k) - call inputtab%add_term(k) - call inputtab%add_term(i) - call inputtab%add_term(j) - else if (size(this%mshape) == 2) then - nod = this%nodelist(ii) - call get_ijk(nod, 1, this%mshape(2), this%mshape(1), i, j, k) - call inputtab%add_term(k) - call inputtab%add_term(j) - else - nod = this%nodelist(ii) - call inputtab%add_term(nod) - end if - ! - ! -- non-optional variables - do jj = 1, ldim - call inputtab%add_term(this%rlist(jj,ii)) - end do - ! - ! -- boundname - if (this%inamedbound == 1) then - call inputtab%add_term(this%boundname(ii)) - end if - ! - ! -- aux variables - do jj = 1, naux - call inputtab%add_term(this%auxvar(jj,ii)) - end do - end do - ! - ! -- deallocate the local variables - call inputtab%table_da() - deallocate(inputtab) - nullify(inputtab) - deallocate(words) - ! - ! -- return - return - end subroutine write_list - -end module ListReaderModule +! -- Generic List Reader Module +module ListReaderModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, LENTIMESERIESNAME, & + LENLISTLABEL, DONE + use SimModule, only: store_error_unit + implicit none + private + public ListReaderType + + type :: ListReaderType + integer(I4B) :: in = 0 ! unit number of file containing control record + integer(I4B) :: inlist = 0 ! unit number of file from which list will be read + integer(I4B) :: iout = 0 ! unit number to output messages + integer(I4B) :: inamedbound = 0 ! flag indicating boundary names are to be read + integer(I4B) :: ierr = 0 ! error flag + integer(I4B) :: nlist = 0 ! number of entries in list. -1 indicates number will be automatically determined + integer(I4B) :: ibinary = 0 ! flag indicating to read binary list + integer(I4B) :: istart = 0 ! string starting location + integer(I4B) :: istop = 0 ! string ending location + integer(I4B) :: lloc = 0 ! entry number in line + integer(I4B) :: iclose = 0 ! flag indicating whether or not to close file + integer(I4B) :: ndim = 0 ! number of dimensions in model + integer(I4B) :: ntxtrlist = 0 ! number of text entries found in rlist + integer(I4B) :: ntxtauxvar = 0 ! number of text entries found in auxvar + character(len=LENLISTLABEL) :: label = '' ! label for printing list + character(len=LINELENGTH) :: line = '' ! line string for reading file + integer(I4B), dimension(:), pointer, contiguous :: mshape => null() ! pointer to model shape + integer(I4B), dimension(:), pointer, contiguous :: nodelist => null() ! pointer to nodelist + real(DP), dimension(:, :), pointer, contiguous :: rlist => null() ! pointer to rlist + real(DP), dimension(:, :), pointer, contiguous :: auxvar => null() ! pointer to auxvar + character(len=16), dimension(:), pointer :: auxname => null() ! pointer to aux names + character(len=LENBOUNDNAME), dimension(:), pointer, & + contiguous :: boundname => null() ! pointer to boundname + integer(I4B), dimension(:), allocatable :: idxtxtrow ! row locations of text in rlist + integer(I4B), dimension(:), allocatable :: idxtxtcol ! col locations of text in rlist + integer(I4B), dimension(:), allocatable :: idxtxtauxrow ! row locations of text in auxvar + integer(I4B), dimension(:), allocatable :: idxtxtauxcol ! col locations of text in auxvar + character(len=LENTIMESERIESNAME), dimension(:), allocatable :: txtrlist ! text found in rlist + character(len=LENTIMESERIESNAME), dimension(:), allocatable :: txtauxvar ! text found in auxvar + contains + procedure :: read_list + procedure :: write_list + procedure, private :: read_control_record + procedure, private :: read_data + procedure, private :: set_openclose + procedure, private :: read_ascii + procedure, private :: read_binary + end type ListReaderType + + contains + + subroutine read_list(this, in, iout, nlist, inamedbound, mshape, nodelist, & + rlist, auxvar, auxname, boundname, label) +! ****************************************************************************** +! init -- Initialize the reader +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LENBOUNDNAME + ! -- dummy + class(ListReaderType) :: this + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout + integer(I4B), intent(inout) :: nlist + integer(I4B), intent(in) :: inamedbound + integer(I4B), dimension(:), intent(in), contiguous, pointer :: mshape + integer(I4B), dimension(:), intent(inout), contiguous, pointer :: nodelist + real(DP), dimension(:, :), intent(inout), contiguous, pointer :: rlist + real(DP), dimension(:, :), intent(inout), contiguous, pointer :: auxvar + character(len=16), dimension(:), intent(inout), target :: auxname + character(len=LENBOUNDNAME), dimension(:), pointer, contiguous, intent(inout) :: boundname + character(len=500), intent(in) :: label + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Copy variables + this%in = in + this%iout = iout + this%nlist = nlist + this%inamedbound = inamedbound + this%ndim = size(mshape) + this%label = label + ! + ! -- Set pointers + this%mshape => mshape + this%nodelist => nodelist + this%rlist => rlist + this%auxvar => auxvar + this%auxname => auxname + this%boundname => boundname + ! + ! -- Allocate arrays for storing text and text locations + if(.not. allocated(this%idxtxtrow)) allocate(this%idxtxtrow(0)) + if(.not. allocated(this%idxtxtcol)) allocate(this%idxtxtcol(0)) + if(.not. allocated(this%idxtxtauxrow)) allocate(this%idxtxtauxrow(0)) + if(.not. allocated(this%idxtxtauxcol)) allocate(this%idxtxtauxcol(0)) + if(.not. allocated(this%txtrlist)) allocate(this%txtrlist(0)) + if(.not. allocated(this%txtauxvar)) allocate(this%txtauxvar(0)) + ! + ! -- Read control record + call this%read_control_record() + ! + ! -- Read data + call this%read_data() + ! + ! -- Set nlist for return + nlist = this%nlist + ! + ! -- return + return + end subroutine read_list + + subroutine read_control_record(this) +! ****************************************************************************** +! read_control_record -- Check for a control record, and parse if found +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: u8rdcom, urword + ! -- dummy + class(ListReaderType) :: this + ! -- local + integer(I4B) :: idum + real(DP) :: r + ! -- formats + character(len=*), parameter :: fmtlsf = & + "(1X,'LIST SCALING FACTOR=',1PG12.5)" +! ------------------------------------------------------------------------------ + ! + ! -- Set default values, which may be changed by control record + this%inlist = this%in + this%iclose = 0 + this%ibinary = 0 + ! + ! -- Read to the first non-commented line + call u8rdcom(this%in, this%iout, this%line, this%ierr) + this%lloc = 1 + call urword(this%line, this%lloc, this%istart, this%istop, 1, idum, r, & + this%iout, this%in) + ! + ! -- Parse record + select case(this%line(this%istart:this%istop)) + case('OPEN/CLOSE') + call this%set_openclose() + end select + ! + ! -- return + return + end subroutine read_control_record + + subroutine set_openclose(this) +! ****************************************************************************** +! set_openclose -- set up for open/close file +! +! OPEN/CLOSE fname [(BINARY)] +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: u8rdcom, urword, openfile + use OpenSpecModule, only: form, access + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error + ! -- dummy + class(ListReaderType) :: this + ! -- local + integer(I4B) :: idum, itmp + real(DP) :: r + logical :: exists + integer(I4B) :: nunopn = 99 + character(len=LINELENGTH) :: fname + character(len=LINELENGTH) :: errmsg + ! -- formats + character(len=*), parameter :: fmtocne = & + "('Specified OPEN/CLOSE file ',(A),' does not exist')" + character(len=*), parameter :: fmtobf = & + "(1X,/1X,'OPENING BINARY FILE ON UNIT ',I0,':',/1X,A)" + character(len=*), parameter :: fmtobfnlist = & + "(1X, 'TO READ ', I0, ' RECORDS.')" + character(len=*), parameter :: fmtofnlist = & + "(1x,'TO READ ', I0, ' RECORDS.')" + character(len=*), parameter :: fmtof = & + "(1X,/1X,'OPENING FILE ON UNIT ',I0,':',/1X,A)" +! ------------------------------------------------------------------------------ + ! + ! -- get filename + call urword(this%line, this%lloc, this%istart, this%istop, 0, idum, r, & + this%iout, this%in) + fname = this%line(this%istart:this%istop) + ! + ! -- check to see if file OPEN/CLOSE file exists + inquire(file=fname, exist=exists) + if (.not. exists) then + write(errmsg, fmtocne) this%line(this%istart:this%istop) + call store_error(errmsg) + call store_error('Specified OPEN/CLOSE file does not exist') + call store_error_unit(this%in) + call ustop() + endif + ! + ! -- Check for (BINARY) keyword + call urword(this%line, this%lloc, this%istart, this%istop, 1, idum, r, & + this%iout, this%in) + if(this%line(this%istart:this%istop) == '(BINARY)') this%ibinary = 1 + ! + ! -- Open the file depending on ibinary flag + this%inlist = nunopn + if(this%ibinary == 1) then + itmp = this%iout + if(this%iout > 0) then + itmp = 0 + write(this%iout, fmtobf) this%inlist, trim(adjustl(fname)) + if(this%nlist > 0) write(this%iout, fmtobfnlist) this%nlist + endif + call openfile(this%inlist, itmp, fname, 'OPEN/CLOSE', fmtarg_opt=form, & + accarg_opt=access) + else + itmp = this%iout + if(this%iout > 0) then + itmp = 0 + write(this%iout, fmtof) this%inlist, trim(adjustl(fname)) + if(this%nlist > 0) write(this%iout, fmtofnlist) this%nlist + endif + call openfile(this%inlist, itmp, fname, 'OPEN/CLOSE') + end if + ! + ! -- Set iclose to 1 because it is open/close, to indicate that the + ! file needs to be closed after the list is read + this%iclose = 1 + ! + ! -- Read the first line from inlist to be consistent with how the list is + ! read when it is included in the package input file + if(this%ibinary /= 1) call u8rdcom(this%inlist, this%iout, this%line, & + this%ierr) + ! + ! -- return + return + end subroutine set_openclose + + subroutine read_data(this) +! ****************************************************************************** +! read_data -- read the data +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(ListReaderType) :: this + ! -- local + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- Read the list + if(this%ibinary == 1) then + call this%read_binary() + else + call this%read_ascii() + endif + ! + ! -- if open/close, then close file + if(this%iclose == 1) then + close(this%inlist) + endif + ! -- return + return + end subroutine read_data + + subroutine read_binary(this) +! ****************************************************************************** +! read_binary -- read the data from a binary file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH, LENBIGLINE + use InputOutputModule, only: get_node + use SimModule, only: ustop, store_error + ! -- dummy + class(ListReaderType) :: this + ! -- local + integer(I4B) :: mxlist, ldim, naux, nod, ii, jj + character(len=LINELENGTH) :: fname + character(len=LENBIGLINE) :: errmsg + integer(I4B), dimension(:), allocatable :: cellid + ! -- formats + character(len=*), parameter :: fmtmxlsterronly = & + "('ERROR READING LIST FROM FILE: '," // & + "a,' ON UNIT: ',I0," // & + "' THE NUMBER OF RECORDS ENCOUNTERED EXCEEDS THE MAXIMUM NUMBER " // & + "OF RECORDS. TRY INCREASING MAXBOUND FOR THIS LIST." // & + " NUMBER OF RECORDS: ',I0,' MAXBOUND: ',I0)" + character(len=*), parameter :: fmtlsterronly = & + "('ERROR READING LIST FROM FILE: '," // & + "1x,a,1x,' ON UNIT: ',I0)" +! ------------------------------------------------------------------------------ + ! + ! -- determine array sizes + mxlist = size(this%rlist, 2) + ldim = size(this%rlist, 1) + naux = size(this%auxvar, 1) + ! + ! -- Allocate arrays + allocate(cellid(this%ndim)) + ! + ii = 1 + readloop: do + ! + ! -- read layer, row, col, or cell number + read(this%inlist, iostat=this%ierr) cellid + + ! -- If not end of record, then store nodenumber, else + ! calculate lstend and nlist, and exit readloop + select case(this%ierr) + case(0) + ! + ! -- Check range + if(ii > mxlist) then + inquire(unit=this%inlist, name=fname) + write(errmsg, fmtmxlsterronly) fname, this%inlist, ii, mxlist + call store_error(errmsg) + call ustop() + endif + ! + ! -- Store node number and read the remainder of the record + if(this%ndim == 1) then + nod = cellid(1) + elseif(this%ndim == 2) then + nod = get_node(cellid(1), 1, cellid(2), & + this%mshape(1), 1, this%mshape(2)) + else + nod = get_node(cellid(1), cellid(2), cellid(3), & + this%mshape(1), this%mshape(2), this%mshape(3)) + endif + this%nodelist(ii) = nod + read(this%inlist, iostat=this%ierr) (this%rlist(jj,ii),jj=1,ldim), & + (this%auxvar(ii,jj),jj=1,naux) + if(this%ierr /= 0) then + inquire(unit=this%inlist, name=fname) + write(errmsg, fmtlsterronly) trim(adjustl(fname)), this%inlist + call store_error(errmsg) + call ustop() + endif + ! + case(:-1) + ! + ! -- End of record was encountered + this%nlist = ii - 1 + exit readloop + ! + case(1:) + ! + ! -- Error + inquire(unit=this%inlist, name=fname) + write(errmsg, fmtlsterronly) trim(adjustl(fname)), this%inlist + call store_error(errmsg) + call ustop() + ! + end select + ! + ! -- If nlist is known, then exit when nlist values have been read + if(this%nlist > 0) then + if(ii == this%nlist) exit readloop + endif + ! + ! -- increment ii + ii = ii + 1 + ! + enddo readloop + ! + ! -- return + return + end subroutine read_binary + + subroutine read_ascii(this) +! ****************************************************************************** +! read_ascii -- read the data from an ascii file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LENBOUNDNAME, LINELENGTH, DZERO + use InputOutputModule, only: u8rdcom, urword, get_node + use SimModule, only: ustop, store_error, count_errors + use ArrayHandlersModule, only: ExpandArray + ! -- dummy + class(ListReaderType) :: this + ! -- local + integer(I4B) :: mxlist, ldim, naux + integer(I4B) :: ii, jj, idum, nod, istat, increment + real(DP) :: r + integer(I4B), dimension(:), allocatable :: cellid + character(len=LINELENGTH) :: fname + character(len=LINELENGTH) :: errmsg + ! -- formats + character(len=*), parameter :: fmtmxlsterronly = & + "('***ERROR READING LIST. & + &THE NUMBER OF RECORDS ENCOUNTERED EXCEEDS THE MAXIMUM NUMBER " // & + "OF RECORDS. TRY INCREASING MAXBOUND FOR THIS LIST." // & + " NUMBER OF RECORDS: ',I0,' MAXBOUND: ',I0)" +! ------------------------------------------------------------------------------ + ! + ! -- determine array sizes + mxlist = size(this%rlist, 2) + ldim = size(this%rlist, 1) + naux = size(this%auxvar, 1) + this%ntxtrlist = 0 + this%ntxtauxvar = 0 + ! + ! -- Allocate arrays + allocate(cellid(this%ndim)) + ! + ii = 1 + readloop: do + ! + ! -- First line was already read, so don't read again + if(ii /= 1) call u8rdcom(this%inlist, 0, this%line, this%ierr) + ! + ! -- If this is an unknown-length list, then check for END. + ! If found, then backspace, set nlist, and exit readloop. + if(this%nlist < 0) then + this%lloc = 1 + call urword(this%line, this%lloc, this%istart, this%istop, 1, idum, r, & + this%iout, this%inlist) + if(this%line(this%istart:this%istop) == 'END' .or. this%ierr < 0) then + ! If ierr < 0, backspace was already performed in u8rdcom, so only + ! need to backspace if END was found. + if (this%ierr == 0) then + backspace(this%inlist) + endif + this%nlist = ii - 1 + exit readloop + endif + endif + ! + ! -- Check range + if(ii > mxlist) then + inquire(unit=this%inlist, name=fname) + write(errmsg, fmtmxlsterronly) ii, mxlist + call store_error(errmsg) + errmsg = 'Error occurred reading line: ' // trim(this%line) + call store_error(errmsg) + call store_error_unit(this%inlist) + call ustop() + endif + ! + ! -- Read layer, row, column or cell number and assign to nodelist + this%lloc = 1 + if(this%ndim == 3) then + ! + ! -- Grid is structured; read layer, row, column + call urword(this%line, this%lloc, this%istart, this%istop, 2, & + cellid(1), r, this%iout, this%inlist) + call urword(this%line, this%lloc, this%istart, this%istop, 2, & + cellid(2), r, this%iout, this%inlist) + call urword(this%line, this%lloc, this%istart, this%istop, 2, & + cellid(3), r, this%iout, this%inlist) + ! + ! -- Check for illegal grid location + if(cellid(1) < 1 .or. cellid(1) > this%mshape(1)) then + write(errmsg, *) ' Layer number in list is outside of the grid', & + cellid(1) + call store_error(errmsg) + end if + if(cellid(2) < 1 .or. cellid(2) > this%mshape(2)) then + write(errmsg, *) ' Row number in list is outside of the grid', & + cellid(2) + call store_error(errmsg) + end if + if(cellid(3) < 1 .or. cellid(3) > this%mshape(3)) then + write(errmsg, *) ' Column number in list is outside of the grid', & + cellid(3) + call store_error(errmsg) + end if + ! + ! -- Calculate nodenumber and put in nodelist + nod = get_node(cellid(1), cellid(2), cellid(3), & + this%mshape(1), this%mshape(2), this%mshape(3)) + elseif(this%ndim == 2) then + ! + ! -- Grid is disv + call urword(this%line, this%lloc, this%istart, this%istop, 2, & + cellid(1), r, this%iout, this%inlist) + call urword(this%line, this%lloc, this%istart, this%istop, 2, & + cellid(2), r, this%iout, this%inlist) + ! + ! -- Check for illegal grid location + if(cellid(1) < 1 .or. cellid(1) > this%mshape(1)) then + write(errmsg, *) ' Layer number in list is outside of the grid', & + cellid(1) + call store_error(errmsg) + end if + if(cellid(2) < 1 .or. cellid(2) > this%mshape(2)) then + write(errmsg, *) ' Cell2d number in list is outside of the grid', & + cellid(2) + call store_error(errmsg) + end if + ! + ! -- Calculate nodenumber and put in nodelist + nod = get_node(cellid(1), 1, cellid(2), & + this%mshape(1), 1, this%mshape(2)) + else + ! + ! -- Grid is unstructured; read layer and celld2d number + call urword(this%line, this%lloc, this%istart, this%istop, 2, nod, r, & + this%iout, this%inlist) + if(nod < 1 .or. nod > this%mshape(1)) then + write(errmsg, *) ' Node number in list is outside of the grid', nod + call store_error(errmsg) + end if + ! + endif + ! + ! -- Assign nod to nodelist + this%nodelist(ii) = nod + ! + ! -- Read rlist + do jj = 1, ldim + call urword(this%line, this%lloc, this%istart, this%istop, 0, idum, & + r, this%iout, this%inlist) + read(this%line(this%istart:this%istop), *, iostat=istat) r + ! + ! -- If a double precision value, then store in rlist, otherwise store + ! the text name and location + if (istat == 0) then + this%rlist(jj, ii) = r + else + this%rlist(jj, ii) = DZERO + this%ntxtrlist = this%ntxtrlist + 1 + if(this%ntxtrlist > size(this%txtrlist)) then + increment = size(this%txtrlist) * 0.2 + increment = max(100, increment) + call ExpandArray(this%txtrlist, increment) + call ExpandArray(this%idxtxtrow, increment) + call ExpandArray(this%idxtxtcol, increment) + endif + this%txtrlist(this%ntxtrlist) = this%line(this%istart:this%istop) + this%idxtxtrow(this%ntxtrlist) = ii + this%idxtxtcol(this%ntxtrlist) = jj + endif + ! + enddo + ! + ! -- Read auxvar + do jj = 1, naux + call urword(this%line, this%lloc, this%istart, this%istop, 0, idum, & + r, this%iout, this%inlist) + read(this%line(this%istart:this%istop), *, iostat=istat) r + ! + ! -- If a double precision value, then store in auxvar, otherwise store + ! the text name and location + if (istat == 0) then + this%auxvar(jj, ii) = r + else + this%auxvar(jj, ii) = DZERO + this%ntxtauxvar = this%ntxtauxvar + 1 + if(this%ntxtauxvar > size(this%txtauxvar)) then + increment = size(this%txtauxvar) * 0.2 + increment = max(100, increment) + call ExpandArray(this%txtauxvar, increment) + call ExpandArray(this%idxtxtauxrow, increment) + call ExpandArray(this%idxtxtauxcol, increment) + endif + this%txtauxvar(this%ntxtauxvar) = this%line(this%istart:this%istop) + this%idxtxtauxrow(this%ntxtauxvar) = ii + this%idxtxtauxcol(this%ntxtauxvar) = jj + endif + ! + enddo + ! + ! -- Read the boundary names (only supported for ascii input) + if (this%inamedbound > 0) then + call urword(this%line, this%lloc, this%istart, this%istop, 1, idum, r, & + this%iout, this%inlist) + this%boundname(ii) = this%line(this%istart:this%istop) + endif + ! + ! -- If nlist is known, then exit when nlist values have been read + if(this%nlist > 0) then + if(ii == this%nlist) exit readloop + endif + ! + ! -- increment ii row counter + ii = ii + 1 + ! + enddo readloop + ! + ! -- Stop if errors were detected + if(count_errors() > 0) then + call store_error_unit(this%inlist) + call ustop() + endif + ! + ! -- return + return + end subroutine read_ascii + + subroutine write_list(this) +! ****************************************************************************** +! write_list -- Write input data to a list +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, & + TABLEFT, TABCENTER + use InputOutputModule, only: ulstlb, get_ijk + use TableModule, only: TableType, table_cr + ! -- dummy + class(ListReaderType) :: this + ! -- local + character(len=10) :: cpos + character(len=LINELENGTH) :: tag + character(len=LINELENGTH), allocatable, dimension(:) :: words + integer(I4B) :: ntabrows + integer(I4B) :: ntabcols + integer(I4B) :: ipos + integer(I4B) :: ii, jj, i, j, k, nod + integer(I4B) :: ldim + integer(I4B) :: naux + type(TableType), pointer :: inputtab => null() + ! -- formats + character(len=LINELENGTH) :: fmtlstbn +! ------------------------------------------------------------------------------ + ! + ! -- Determine sizes + ldim = size(this%rlist, 1) + naux = size(this%auxvar, 1) + ! + ! -- dimension table + ntabrows = this%nlist + ! + ! -- start building format statement to parse this%label, which + ! contains the column headers (except for boundname and auxnames) + ipos = index(this%label, 'NO.') + if (ipos /= 0) then + write(cpos,'(i10)') ipos + 3 + fmtlstbn = '(a' // trim(adjustl(cpos)) + else + fmtlstbn = '(a7' + end if + ! -- sequence number, layer, row, and column. + if(size(this%mshape) == 3) then + ntabcols = 4 + fmtlstbn = trim(fmtlstbn) // ',a7,a7,a7' + ! + ! -- sequence number, layer, and cell2d. + else if(size(this%mshape) == 2) then + ntabcols = 3 + fmtlstbn = trim(fmtlstbn) // ',a7,a7' + ! + ! -- sequence number and node. + else + ntabcols = 2 + fmtlstbn = trim(fmtlstbn) // ',a7' + end if + ! + ! -- Add fields for non-optional real values + ntabcols = ntabcols + ldim + do i = 1, ldim + fmtlstbn = trim(fmtlstbn) // ',a16' + end do + ! + ! -- Add field for boundary name + if (this%inamedbound == 1) then + ntabcols = ntabcols + 1 + fmtlstbn = trim(fmtlstbn) // ',a16' + end if + ! + ! -- Add fields for auxiliary variables + ntabcols = ntabcols + naux + do i = 1, naux + fmtlstbn = trim(fmtlstbn) // ',a16' + end do + fmtlstbn = trim(fmtlstbn) // ')' + ! + ! -- allocate words + allocate(words(ntabcols)) + ! + ! -- parse this%label into words + read(this%label, fmtlstbn) (words(i), i=1, ntabcols) + ! + ! -- initialize the input table object + call table_cr(inputtab, ' ', ' ') + call inputtab%table_df(ntabrows, ntabcols, this%iout) + ! + ! -- add the columns + ipos = 1 + call inputtab%initialize_column(words(ipos), 10, alignment=TABCENTER) + ! + ! -- discretization + do i = 1, size(this%mshape) + ipos = ipos + 1 + call inputtab%initialize_column(words(ipos), 7, alignment=TABCENTER) + end do + ! + ! -- non-optional variables + do i = 1, ldim + ipos = ipos + 1 + call inputtab%initialize_column(words(ipos), 16, alignment=TABCENTER) + end do + ! + ! -- boundname + if (this%inamedbound == 1) then + ipos = ipos + 1 + tag = 'BOUNDNAME' + call inputtab%initialize_column(tag, LENBOUNDNAME, alignment=TABLEFT) + end if + ! + ! -- aux variables + do i = 1, naux + call inputtab%initialize_column(this%auxname(i), 16, alignment=TABCENTER) + end do + ! + ! -- Write the table + do ii = 1, this%nlist + call inputtab%add_term(ii) + ! + ! -- discretization + if (size(this%mshape) == 3) then + nod = this%nodelist(ii) + call get_ijk(nod, this%mshape(2), this%mshape(3), this%mshape(1), & + i, j, k) + call inputtab%add_term(k) + call inputtab%add_term(i) + call inputtab%add_term(j) + else if (size(this%mshape) == 2) then + nod = this%nodelist(ii) + call get_ijk(nod, 1, this%mshape(2), this%mshape(1), i, j, k) + call inputtab%add_term(k) + call inputtab%add_term(j) + else + nod = this%nodelist(ii) + call inputtab%add_term(nod) + end if + ! + ! -- non-optional variables + do jj = 1, ldim + call inputtab%add_term(this%rlist(jj,ii)) + end do + ! + ! -- boundname + if (this%inamedbound == 1) then + call inputtab%add_term(this%boundname(ii)) + end if + ! + ! -- aux variables + do jj = 1, naux + call inputtab%add_term(this%auxvar(jj,ii)) + end do + end do + ! + ! -- deallocate the local variables + call inputtab%table_da() + deallocate(inputtab) + nullify(inputtab) + deallocate(words) + ! + ! -- return + return + end subroutine write_list + +end module ListReaderModule diff --git a/src/Utilities/Memory/Memory.f90 b/src/Utilities/Memory/Memory.f90 index 7007643e720..16c67b79fad 100644 --- a/src/Utilities/Memory/Memory.f90 +++ b/src/Utilities/Memory/Memory.f90 @@ -1,7 +1,7 @@ module MemoryTypeModule use KindModule, only: DP, I4B - use ConstantsModule, only: LENORIGIN, LENTIMESERIESNAME, LENVARNAME, & + use ConstantsModule, only: LENORIGIN, LENTIMESERIESNAME, LENVARNAME, & MAXMEMRANK, LENMEMTYPE implicit none private @@ -18,7 +18,7 @@ module MemoryTypeModule character(len=LENMEMTYPE) :: memtype !type (INTEGER or DOUBLE) integer(I4B) :: id !id, not used integer(I4B) :: nrealloc = 0 !number of times reallocated - integer(I4B) :: isize !size of the array + integer(I4B) :: isize !size of the array logical :: master = .true. !master copy, others point to this one logical, pointer :: logicalsclr => null() !pointer to the logical integer(I4B), pointer :: intsclr => null() !pointer to the integer @@ -32,7 +32,7 @@ module MemoryTypeModule type (MemoryTSType), dimension(:), pointer, contiguous :: ats1d => null() !pointer to a time series array contains procedure :: table_entry - procedure :: mt_associated + procedure :: mt_associated end type contains @@ -40,13 +40,13 @@ module MemoryTypeModule subroutine table_entry(this, msg) class(MemoryType) :: this character(len=*), intent(inout) :: msg - character(len=*), parameter :: & + character(len=*), parameter :: & fmt = "(1x, a40, a20, a20, i10, i10, a10, a2)" character(len=1) :: cptr character(len=1) :: dastr ! - ! -- Create the msg table entry - cptr = '' + ! -- Create the msg table entry + cptr = '' if (.not. this%master) cptr = 'T' dastr = '' if (this%mt_associated() .and. this%isize > 0) dastr='*' diff --git a/src/Utilities/Memory/MemoryList.f90 b/src/Utilities/Memory/MemoryList.f90 index a790f1b5a97..cb82fef1f5a 100644 --- a/src/Utilities/Memory/MemoryList.f90 +++ b/src/Utilities/Memory/MemoryList.f90 @@ -1,52 +1,52 @@ -module MemoryListModule - use KindModule, only: DP, I4B - use MemoryTypeModule, only: MemoryType - use ListModule, only: ListType - private - public :: MemoryListType - - type :: MemoryListType - type(ListType), private :: list - contains - procedure :: add - procedure :: get - procedure :: count - procedure :: clear - end type MemoryListType - - contains - - subroutine add(this, mt) - class(MemoryListType) :: this - type(MemoryType), pointer :: mt - class(*), pointer :: obj - obj => mt - call this%list%add(obj) - end subroutine add - - function get(this, ipos) result(res) - class(MemoryListType) :: this - integer(I4B), intent(in) :: ipos - type(MemoryType), pointer :: res - class(*), pointer :: obj - obj => this%list%getitem(ipos) - select type (obj) - type is (MemoryType) - res => obj - end select - return - end function get - - function count(this) result(nval) - class(MemoryListType) :: this - integer(I4B) :: nval - nval = this%list%count() - return - end function count - - subroutine clear(this) - class(MemoryListType) :: this - call this%list%Clear() - end subroutine clear - +module MemoryListModule + use KindModule, only: DP, I4B + use MemoryTypeModule, only: MemoryType + use ListModule, only: ListType + private + public :: MemoryListType + + type :: MemoryListType + type(ListType), private :: list + contains + procedure :: add + procedure :: get + procedure :: count + procedure :: clear + end type MemoryListType + + contains + + subroutine add(this, mt) + class(MemoryListType) :: this + type(MemoryType), pointer :: mt + class(*), pointer :: obj + obj => mt + call this%list%add(obj) + end subroutine add + + function get(this, ipos) result(res) + class(MemoryListType) :: this + integer(I4B), intent(in) :: ipos + type(MemoryType), pointer :: res + class(*), pointer :: obj + obj => this%list%getitem(ipos) + select type (obj) + type is (MemoryType) + res => obj + end select + return + end function get + + function count(this) result(nval) + class(MemoryListType) :: this + integer(I4B) :: nval + nval = this%list%count() + return + end function count + + subroutine clear(this) + class(MemoryListType) :: this + call this%list%Clear() + end subroutine clear + end module MemoryListModule \ No newline at end of file diff --git a/src/Utilities/Memory/MemoryManager.f90 b/src/Utilities/Memory/MemoryManager.f90 index 8550ae26114..203accc6391 100644 --- a/src/Utilities/Memory/MemoryManager.f90 +++ b/src/Utilities/Memory/MemoryManager.f90 @@ -1,31 +1,31 @@ module MemoryManagerModule use KindModule, only: DP, I4B, I8B - use ConstantsModule, only: DZERO, LENORIGIN, LENVARNAME, LINELENGTH, & - LENMEMTYPE + use ConstantsModule, only: DZERO, LENORIGIN, LENVARNAME, LINELENGTH, & + LENMEMTYPE use SimModule, only: store_error, ustop use MemoryTypeModule, only: MemoryTSType, MemoryType - use MemoryListModule, only: MemoryListType + use MemoryListModule, only: MemoryListType implicit none private public :: mem_allocate public :: mem_reallocate public :: mem_setptr - public :: mem_copyptr + public :: mem_copyptr public :: mem_reassignptr public :: mem_deallocate - public :: mem_usage - public :: mem_da - public :: mem_set_print_option - + public :: mem_usage + public :: mem_da + public :: mem_set_print_option + public :: get_mem_type - public :: get_mem_rank - public :: get_mem_size - public :: get_mem_shape - public :: get_isize + public :: get_mem_rank + public :: get_mem_size + public :: get_mem_shape + public :: get_isize public :: copy_dbl1d - + type(MemoryListType) :: memorylist integer(I8B) :: nvalues_alogical = 0 integer(I8B) :: nvalues_achr = 0 @@ -36,9 +36,9 @@ module MemoryManagerModule interface mem_allocate module procedure allocate_logical, & - allocate_int, allocate_int1d, allocate_int2d, & + allocate_int, allocate_int1d, allocate_int2d, & allocate_int3d, & - allocate_dbl, allocate_dbl1d, allocate_dbl2d, & + allocate_dbl, allocate_dbl1d, allocate_dbl2d, & allocate_dbl3d, & allocate_ts1d end interface mem_allocate @@ -66,44 +66,44 @@ module MemoryManagerModule interface mem_deallocate module procedure deallocate_logical, & - deallocate_int, deallocate_int1d, deallocate_int2d, & + deallocate_int, deallocate_int1d, deallocate_int2d, & deallocate_int3d, & - deallocate_dbl, deallocate_dbl1d, deallocate_dbl2d, & + deallocate_dbl, deallocate_dbl1d, deallocate_dbl2d, & deallocate_dbl3d, & deallocate_ts1d end interface mem_deallocate - contains - - subroutine get_mem_type(name, origin, var_type) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: origin - character(len=LENMEMTYPE), intent(out) :: var_type - ! local - type(MemoryType), pointer :: mt - logical :: found - - mt => null() - var_type = 'UNKNOWN' - call get_from_memorylist(name, origin, mt, found) - if (found) then - var_type = mt%memtype - end if - - end subroutine get_mem_type - - subroutine get_mem_rank(name, origin, rank) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: origin - integer(I4B), intent(out) :: rank - ! local - type(MemoryType), pointer :: mt - logical :: found - - mt => null() - rank = -1 - call get_from_memorylist(name, origin, mt, found) - if (found) then + contains + + subroutine get_mem_type(name, origin, var_type) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: origin + character(len=LENMEMTYPE), intent(out) :: var_type + ! local + type(MemoryType), pointer :: mt + logical :: found + + mt => null() + var_type = 'UNKNOWN' + call get_from_memorylist(name, origin, mt, found) + if (found) then + var_type = mt%memtype + end if + + end subroutine get_mem_type + + subroutine get_mem_rank(name, origin, rank) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: origin + integer(I4B), intent(out) :: rank + ! local + type(MemoryType), pointer :: mt + logical :: found + + mt => null() + rank = -1 + call get_from_memorylist(name, origin, mt, found) + if (found) then if(associated(mt%logicalsclr)) rank = 0 if(associated(mt%intsclr)) rank = 0 if(associated(mt%dblsclr)) rank = 0 @@ -113,45 +113,45 @@ subroutine get_mem_rank(name, origin, rank) if(associated(mt%adbl1d)) rank = 1 if(associated(mt%adbl2d)) rank = 2 if(associated(mt%adbl3d)) rank = 3 - if(associated(mt%ats1d)) rank = 1 - end if - - end subroutine get_mem_rank - - subroutine get_mem_size(name, origin, size) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: origin - integer(I4B), intent(out) :: size - ! local - type(MemoryType), pointer :: mt - logical :: found - - mt => null() - call get_from_memorylist(name, origin, mt, found) - - size = -1 - if (found) then - select case(mt%memtype(1:index(mt%memtype,' '))) - case ('INTEGER') - size = 4 - case ('DOUBLE') - size = 8 - end select - end if - - end subroutine get_mem_size - - subroutine get_mem_shape(name, origin, mem_shape) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: origin - integer(I4B), dimension(:), intent(out) :: mem_shape - ! local - type(MemoryType), pointer :: mt - logical :: found - - mt => null() - call get_from_memorylist(name, origin, mt, found) - if (found) then + if(associated(mt%ats1d)) rank = 1 + end if + + end subroutine get_mem_rank + + subroutine get_mem_size(name, origin, size) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: origin + integer(I4B), intent(out) :: size + ! local + type(MemoryType), pointer :: mt + logical :: found + + mt => null() + call get_from_memorylist(name, origin, mt, found) + + size = -1 + if (found) then + select case(mt%memtype(1:index(mt%memtype,' '))) + case ('INTEGER') + size = 4 + case ('DOUBLE') + size = 8 + end select + end if + + end subroutine get_mem_size + + subroutine get_mem_shape(name, origin, mem_shape) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: origin + integer(I4B), dimension(:), intent(out) :: mem_shape + ! local + type(MemoryType), pointer :: mt + logical :: found + + mt => null() + call get_from_memorylist(name, origin, mt, found) + if (found) then if(associated(mt%logicalsclr)) mem_shape = shape(mt%logicalsclr) if(associated(mt%intsclr)) mem_shape = shape(mt%logicalsclr) if(associated(mt%dblsclr)) mem_shape = shape(mt%dblsclr) @@ -160,42 +160,42 @@ subroutine get_mem_shape(name, origin, mem_shape) if(associated(mt%aint3d)) mem_shape = shape(mt%aint3d) if(associated(mt%adbl1d)) mem_shape = shape(mt%adbl1d) if(associated(mt%adbl2d)) mem_shape = shape(mt%adbl2d) - if(associated(mt%adbl3d)) mem_shape = shape(mt%adbl3d) - if(associated(mt%ats1d)) mem_shape = shape(mt%ats1d) - else - ! to communicate failure - mem_shape(1) = -1 - end if - - end subroutine get_mem_shape - - subroutine get_isize(name, origin, isize) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: origin - integer(I4B), intent(out) :: isize - ! local - type(MemoryType), pointer :: mt - logical :: found - - mt => null() - call get_from_memorylist(name, origin, mt, found) - if (found) then - isize = mt%isize - else - isize = -1 - end if - end subroutine get_isize - - subroutine get_from_memorylist(name, origin, mt, found, check) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: origin + if(associated(mt%adbl3d)) mem_shape = shape(mt%adbl3d) + if(associated(mt%ats1d)) mem_shape = shape(mt%ats1d) + else + ! to communicate failure + mem_shape(1) = -1 + end if + + end subroutine get_mem_shape + + subroutine get_isize(name, origin, isize) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: origin + integer(I4B), intent(out) :: isize + ! local + type(MemoryType), pointer :: mt + logical :: found + + mt => null() + call get_from_memorylist(name, origin, mt, found) + if (found) then + isize = mt%isize + else + isize = -1 + end if + end subroutine get_isize + + subroutine get_from_memorylist(name, origin, mt, found, check) + character(len=*), intent(in) :: name + character(len=*), intent(in) :: origin type(MemoryType), pointer, intent(out) :: mt - logical,intent(out) :: found - logical, intent(in), optional :: check - integer(I4B) :: ipos - logical check_opt - character(len=LINELENGTH) :: ermsg - mt => null() + logical,intent(out) :: found + logical, intent(in), optional :: check + integer(I4B) :: ipos + logical check_opt + character(len=LINELENGTH) :: ermsg + mt => null() found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) @@ -203,19 +203,19 @@ subroutine get_from_memorylist(name, origin, mt, found, check) found = .true. exit endif - enddo - check_opt = .true. - if (present(check)) check_opt = check - if (check_opt) then - if (.not. found) then - ermsg = 'Programming error in memory manager. Variable ' // name // & - ' in origin ' // origin // & - ' cannot be assigned because it does not exist in memory manager. ' - call store_error(ermsg) - call ustop() - endif + enddo + check_opt = .true. + if (present(check)) check_opt = check + if (check_opt) then + if (.not. found) then + ermsg = 'Programming error in memory manager. Variable ' // name // & + ' in origin ' // origin // & + ' cannot be assigned because it does not exist in memory manager. ' + call store_error(ermsg) + call ustop() + endif end if - return + return end subroutine get_from_memorylist subroutine allocate_error(varname, origin, istat, errmsg, isize) @@ -225,7 +225,7 @@ subroutine allocate_error(varname, origin, istat, errmsg, isize) integer(I4B), intent(in) :: istat character(len=*), intent(in) :: errmsg integer(I4B), intent(in) :: isize - character(len=20) :: cint + character(len=20) :: cint call store_error('Error trying to allocate memory.') call store_error(' Origin: ' // origin) call store_error(' Variable name: ' // varname) @@ -236,18 +236,18 @@ subroutine allocate_error(varname, origin, istat, errmsg, isize) write(cint, '(i0)') istat call store_error(' Status code: ' // cint) call ustop() - end subroutine allocate_error - - subroutine check_varname(name) - character(len=*), intent(in) :: name + end subroutine allocate_error + + subroutine check_varname(name) + character(len=*), intent(in) :: name character(len=LINELENGTH) :: ermsg - if(len(name) > LENVARNAME) then - write(ermsg, '(*(G0))') & - 'Programming error in Memory Manager. Variable ', name, ' must be ', & - LENVARNAME, ' characters or less.' - call store_error(ermsg) - call ustop() - endif + if(len(name) > LENVARNAME) then + write(ermsg, '(*(G0))') & + 'Programming error in Memory Manager. Variable ', name, ' must be ', & + LENVARNAME, ' characters or less.' + call store_error(ermsg) + call ustop() + endif end subroutine check_varname subroutine allocate_logical(logicalsclr, name, origin) @@ -274,7 +274,7 @@ subroutine allocate_int(intsclr, name, origin) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin integer(I4B) :: istat - type(MemoryType), pointer :: mt + type(MemoryType), pointer :: mt character(len=100) :: ermsg call check_varname(name) allocate(intsclr, stat=istat, errmsg=ermsg) @@ -295,7 +295,7 @@ subroutine allocate_int1d(aint, isize, name, origin) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin integer(I4B) :: istat - type(MemoryType), pointer :: mt + type(MemoryType), pointer :: mt character(len=100) :: ermsg call check_varname(name) allocate(aint(isize), stat=istat, errmsg=ermsg) @@ -318,7 +318,7 @@ subroutine allocate_int2d(aint, ncol, nrow, name, origin) character(len=*), intent(in) :: origin integer(I4B) :: istat integer(I4B) :: isize - type(MemoryType), pointer :: mt + type(MemoryType), pointer :: mt character(len=100) :: ermsg call check_varname(name) isize = ncol * nrow @@ -332,7 +332,7 @@ subroutine allocate_int2d(aint, ncol, nrow, name, origin) mt%origin = origin write(mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow call memorylist%add(mt) - end subroutine allocate_int2d + end subroutine allocate_int2d subroutine allocate_int3d(aint, ncol, nrow, nlay, name, origin) integer(I4B), dimension(:, :, :), pointer, contiguous, intent(inout) :: aint @@ -343,7 +343,7 @@ subroutine allocate_int3d(aint, ncol, nrow, nlay, name, origin) character(len=*), intent(in) :: origin integer(I4B) :: istat integer(I4B) :: isize - type(MemoryType), pointer :: mt + type(MemoryType), pointer :: mt character(len=100) :: ermsg call check_varname(name) isize = ncol * nrow * nlay @@ -355,7 +355,7 @@ subroutine allocate_int3d(aint, ncol, nrow, nlay, name, origin) mt%isize = isize mt%name = name mt%origin = origin - write(mt%memtype, "(a,' (',i0,',',i0,',',i0,')')") 'INTEGER', ncol, & + write(mt%memtype, "(a,' (',i0,',',i0,',',i0,')')") 'INTEGER', ncol, & nrow, nlay call memorylist%add(mt) end subroutine allocate_int3d @@ -365,7 +365,7 @@ subroutine allocate_dbl(dblsclr, name, origin) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin integer(I4B) :: istat - type(MemoryType), pointer :: mt + type(MemoryType), pointer :: mt character(len=100) :: ermsg call check_varname(name) allocate(dblsclr, stat=istat, errmsg=ermsg) @@ -386,7 +386,7 @@ subroutine allocate_dbl1d(adbl, isize, name, origin) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin integer(I4B) :: istat - type(MemoryType), pointer :: mt + type(MemoryType), pointer :: mt character(len=100) :: ermsg call check_varname(name) allocate(adbl(isize), stat=istat, errmsg=ermsg) @@ -409,7 +409,7 @@ subroutine allocate_dbl2d(adbl, ncol, nrow, name, origin) character(len=*), intent(in) :: origin integer(I4B) :: istat integer(I4B) :: isize - type(MemoryType), pointer :: mt + type(MemoryType), pointer :: mt character(len=100) :: ermsg call check_varname(name) isize = ncol * nrow @@ -434,7 +434,7 @@ subroutine allocate_dbl3d(adbl, ncol, nrow, nlay, name, origin) character(len=*), intent(in) :: origin integer(I4B) :: istat integer(I4B) :: isize - type(MemoryType), pointer :: mt + type(MemoryType), pointer :: mt character(len=100) :: ermsg call check_varname(name) isize = ncol * nrow * nlay @@ -446,7 +446,7 @@ subroutine allocate_dbl3d(adbl, ncol, nrow, nlay, name, origin) mt%isize = isize mt%name = name mt%origin = origin - write(mt%memtype, "(a,' (',i0,',',i0,',',i0,')')") 'DOUBLE', ncol, & + write(mt%memtype, "(a,' (',i0,',',i0,',',i0,')')") 'DOUBLE', ncol, & nrow, nlay call memorylist%add(mt) end subroutine allocate_dbl3d @@ -458,7 +458,7 @@ subroutine allocate_ts1d(ats, isize, name, origin) character(len=*), intent(in) :: origin integer(I4B) :: istat integer(I4B) :: i - type(MemoryType), pointer :: mt + type(MemoryType), pointer :: mt character(len=100) :: ermsg call check_varname(name) allocate(ats(isize), stat=istat, errmsg=ermsg) @@ -488,16 +488,16 @@ subroutine reallocate_int1d(aint, isize, name, origin) character(len=*), intent(in) :: origin integer(I4B) :: istat type(MemoryType), pointer :: mt - integer(I4B) :: i, isizeold + integer(I4B) :: i, isizeold integer(I4B) :: ifill character(len=100) :: ermsg logical :: found ! - ! -- Find and assign mt + ! -- Find and assign mt call get_from_memorylist(name, origin, mt, found) ! ! -- Allocate aint and then refill - isizeold = size(mt%aint1d) + isizeold = size(mt%aint1d) ifill = min(isizeold, isize) allocate(aint(isize), stat=istat, errmsg=ermsg) if(istat /= 0) call allocate_error(name, origin, istat, ermsg, isize) @@ -509,7 +509,7 @@ subroutine reallocate_int1d(aint, isize, name, origin) deallocate(mt%aint1d) mt%aint1d => aint mt%isize = isize - mt%nrealloc = mt%nrealloc + 1 + mt%nrealloc = mt%nrealloc + 1 mt%master = .true. nvalues_aint = nvalues_aint + isize - isizeold ! @@ -530,7 +530,7 @@ subroutine reallocate_int2d(aint, ncol, nrow, name, origin) character(len=100) :: ermsg logical :: found ! - ! -- Find and assign mt + ! -- Find and assign mt call get_from_memorylist(name, origin, mt, found) ! ! -- Allocate aint and then refill @@ -565,16 +565,16 @@ subroutine reallocate_dbl1d(adbl, isize, name, origin) character(len=*), intent(in) :: origin integer(I4B) :: istat type(MemoryType), pointer :: mt - integer(I4B) :: i, isizeold + integer(I4B) :: i, isizeold integer(I4B) :: ifill character(len=100) :: ermsg logical :: found ! - ! -- Find and assign mt + ! -- Find and assign mt call get_from_memorylist(name, origin, mt, found) ! ! -- Allocate adbl and then refill - isizeold = size(mt%adbl1d) + isizeold = size(mt%adbl1d) ifill = min(isizeold, isize) allocate(adbl(isize), stat=istat, errmsg=ermsg) if(istat /= 0) call allocate_error(name, origin, istat, ermsg, isize) @@ -586,7 +586,7 @@ subroutine reallocate_dbl1d(adbl, isize, name, origin) deallocate(mt%adbl1d) mt%adbl1d => adbl mt%isize = isize - mt%nrealloc = mt%nrealloc + 1 + mt%nrealloc = mt%nrealloc + 1 mt%master = .true. nvalues_adbl = nvalues_adbl + isize - isizeold write(mt%memtype, "(a,' (',i0,')')") 'DOUBLE', isize @@ -608,7 +608,7 @@ subroutine reallocate_dbl2d(adbl, ncol, nrow, name, origin) character(len=100) :: ermsg logical :: found ! - ! -- Find and assign mt + ! -- Find and assign mt call get_from_memorylist(name, origin, mt, found) ! ! -- Allocate adbl and then refill @@ -641,8 +641,8 @@ subroutine setptr_logical(logicalsclr, name, origin) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin type(MemoryType), pointer :: mt - logical :: found - call get_from_memorylist(name, origin, mt, found) + logical :: found + call get_from_memorylist(name, origin, mt, found) logicalsclr => mt%logicalsclr end subroutine setptr_logical @@ -651,8 +651,8 @@ subroutine setptr_int(intsclr, name, origin) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin type(MemoryType), pointer :: mt - logical :: found - call get_from_memorylist(name, origin, mt, found) + logical :: found + call get_from_memorylist(name, origin, mt, found) intsclr => mt%intsclr end subroutine setptr_int @@ -661,8 +661,8 @@ subroutine setptr_int1d(aint, name, origin) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin type(MemoryType), pointer :: mt - logical :: found - call get_from_memorylist(name, origin, mt, found) + logical :: found + call get_from_memorylist(name, origin, mt, found) aint => mt%aint1d end subroutine setptr_int1d @@ -671,8 +671,8 @@ subroutine setptr_int2d(aint, name, origin) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin type(MemoryType), pointer :: mt - logical :: found - call get_from_memorylist(name, origin, mt, found) + logical :: found + call get_from_memorylist(name, origin, mt, found) aint => mt%aint2d end subroutine setptr_int2d @@ -681,8 +681,8 @@ subroutine setptr_dbl(dblsclr, name, origin) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin type(MemoryType), pointer :: mt - logical :: found - call get_from_memorylist(name, origin, mt, found) + logical :: found + call get_from_memorylist(name, origin, mt, found) dblsclr => mt%dblsclr end subroutine setptr_dbl @@ -691,8 +691,8 @@ subroutine setptr_dbl1d(adbl, name, origin) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin type(MemoryType), pointer :: mt - logical :: found - call get_from_memorylist(name, origin, mt, found) + logical :: found + call get_from_memorylist(name, origin, mt, found) adbl => mt%adbl1d end subroutine setptr_dbl1d @@ -701,8 +701,8 @@ subroutine setptr_dbl2d(adbl, name, origin) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin type(MemoryType), pointer :: mt - logical :: found - call get_from_memorylist(name, origin, mt, found) + logical :: found + call get_from_memorylist(name, origin, mt, found) adbl => mt%adbl2d end subroutine setptr_dbl2d @@ -713,8 +713,8 @@ subroutine copyptr_int1d(aint, name, origin, origin2) character(len=*), intent(in), optional :: origin2 type(MemoryType), pointer :: mt integer(I4B) :: n - logical :: found - call get_from_memorylist(name, origin, mt, found) + logical :: found + call get_from_memorylist(name, origin, mt, found) aint => null() ! -- check the copy into the memory manager if (present(origin2)) then @@ -736,8 +736,8 @@ subroutine copyptr_int2d(aint, name, origin, origin2) type(MemoryType), pointer :: mt integer(I4B) :: i, j integer(I4B) :: ncol, nrow - logical :: found - call get_from_memorylist(name, origin, mt, found) + logical :: found + call get_from_memorylist(name, origin, mt, found) aint => null() ncol = size(mt%aint2d, dim=1) nrow = size(mt%aint2d, dim=2) @@ -762,8 +762,8 @@ subroutine copyptr_dbl1d(adbl, name, origin, origin2) character(len=*), intent(in), optional :: origin2 type(MemoryType), pointer :: mt integer(I4B) :: n - logical :: found - call get_from_memorylist(name, origin, mt, found) + logical :: found + call get_from_memorylist(name, origin, mt, found) adbl => null() ! -- check the copy into the memory manager if (present(origin2)) then @@ -785,8 +785,8 @@ subroutine copyptr_dbl2d(adbl, name, origin, origin2) type(MemoryType), pointer :: mt integer(I4B) :: i, j integer(I4B) :: ncol, nrow - logical :: found - call get_from_memorylist(name, origin, mt, found) + logical :: found + call get_from_memorylist(name, origin, mt, found) adbl => null() ncol = size(mt%adbl2d, dim=1) nrow = size(mt%adbl2d, dim=2) @@ -803,21 +803,21 @@ subroutine copyptr_dbl2d(adbl, name, origin, origin2) end do end do end subroutine copyptr_dbl2d - + subroutine copy_dbl1d(adbl, name, origin) real(DP), dimension(:), intent(inout) :: adbl character(len=*), intent(in) :: name character(len=*), intent(in) :: origin type(MemoryType), pointer :: mt integer(I4B) :: n - logical :: found - + logical :: found + call get_from_memorylist(name, origin, mt, found) do n = 1, size(mt%adbl1d) adbl(n) = mt%adbl1d(n) - end do + end do - end subroutine copy_dbl1d + end subroutine copy_dbl1d subroutine reassignptr_int1d(aint1d, name, origin, name2, origin2) integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint1d @@ -827,17 +827,17 @@ subroutine reassignptr_int1d(aint1d, name, origin, name2, origin2) character(len=*), intent(in) :: origin2 type(MemoryType), pointer :: mt, mt2 logical :: found - call get_from_memorylist(name, origin, mt, found) + call get_from_memorylist(name, origin, mt, found) call get_from_memorylist(name2, origin2, mt2, found) - if (size(aint1d) > 0) then - nvalues_aint = nvalues_aint - size(aint1d) - deallocate(aint1d) - end if - aint1d => mt2%aint1d - mt%aint1d => aint1d - mt%isize = size(aint1d) - write(mt%memtype, "(a,' (',i0,')')") 'INTEGER', mt%isize - mt%master = .false. + if (size(aint1d) > 0) then + nvalues_aint = nvalues_aint - size(aint1d) + deallocate(aint1d) + end if + aint1d => mt2%aint1d + mt%aint1d => aint1d + mt%isize = size(aint1d) + write(mt%memtype, "(a,' (',i0,')')") 'INTEGER', mt%isize + mt%master = .false. return end subroutine reassignptr_int1d @@ -846,23 +846,23 @@ subroutine reassignptr_int2d(aint2d, name, origin, name2, origin2) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin character(len=*), intent(in) :: name2 - character(len=*), intent(in) :: origin2 + character(len=*), intent(in) :: origin2 integer(I4B) :: ncol, nrow type(MemoryType), pointer :: mt, mt2 logical :: found - call get_from_memorylist(name, origin, mt, found) + call get_from_memorylist(name, origin, mt, found) call get_from_memorylist(name2, origin2, mt2, found) - if (size(aint2d) > 0) then - nvalues_aint = nvalues_aint - size(aint2d) - deallocate(aint2d) - end if - aint2d => mt2%aint2d - mt%aint2d => aint2d - mt%isize = size(aint2d) + if (size(aint2d) > 0) then + nvalues_aint = nvalues_aint - size(aint2d) + deallocate(aint2d) + end if + aint2d => mt2%aint2d + mt%aint2d => aint2d + mt%isize = size(aint2d) ncol = size(aint2d, dim=1) nrow = size(aint2d, dim=2) - write(mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow - mt%master = .false. + write(mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow + mt%master = .false. return end subroutine reassignptr_int2d @@ -874,17 +874,17 @@ subroutine reassignptr_dbl1d(adbl1d, name, origin, name2, origin2) character(len=*), intent(in) :: origin2 type(MemoryType), pointer :: mt, mt2 logical :: found - call get_from_memorylist(name, origin, mt, found) + call get_from_memorylist(name, origin, mt, found) call get_from_memorylist(name2, origin2, mt2, found) - if (size(adbl1d) > 0) then - nvalues_adbl = nvalues_adbl - size(adbl1d) - deallocate(adbl1d) - end if - adbl1d => mt2%adbl1d - mt%adbl1d => adbl1d - mt%isize = size(adbl1d) - write(mt%memtype, "(a,' (',i0,')')") 'DOUBLE', mt%isize - mt%master = .false. + if (size(adbl1d) > 0) then + nvalues_adbl = nvalues_adbl - size(adbl1d) + deallocate(adbl1d) + end if + adbl1d => mt2%adbl1d + mt%adbl1d => adbl1d + mt%isize = size(adbl1d) + write(mt%memtype, "(a,' (',i0,')')") 'DOUBLE', mt%isize + mt%master = .false. return end subroutine reassignptr_dbl1d @@ -893,49 +893,49 @@ subroutine reassignptr_dbl2d(adbl2d, name, origin, name2, origin2) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin character(len=*), intent(in) :: name2 - character(len=*), intent(in) :: origin2 + character(len=*), intent(in) :: origin2 integer(I4B) :: ncol, nrow type(MemoryType), pointer :: mt, mt2 logical :: found - call get_from_memorylist(name, origin, mt, found) + call get_from_memorylist(name, origin, mt, found) call get_from_memorylist(name2, origin2, mt2, found) - if (size(adbl2d) > 0) then - nvalues_adbl = nvalues_adbl - size(adbl2d) - deallocate(adbl2d) - end if - adbl2d => mt2%adbl2d - mt%adbl2d => adbl2d - mt%isize = size(adbl2d) + if (size(adbl2d) > 0) then + nvalues_adbl = nvalues_adbl - size(adbl2d) + deallocate(adbl2d) + end if + adbl2d => mt2%adbl2d + mt%adbl2d => adbl2d + mt%isize = size(adbl2d) ncol = size(adbl2d, dim=1) nrow = size(adbl2d, dim=2) - write(mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow - mt%master = .false. + write(mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow + mt%master = .false. return end subroutine reassignptr_dbl2d subroutine deallocate_logical(logicalsclr) logical, pointer, intent(inout) :: logicalsclr class(MemoryType), pointer :: mt - integer(I4B) :: ipos - logical :: found + integer(I4B) :: ipos + logical :: found found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%logicalsclr, logicalsclr)) then - nullify(mt%logicalsclr) - found = .true. - exit + if(associated(mt%logicalsclr, logicalsclr)) then + nullify(mt%logicalsclr) + found = .true. + exit endif - enddo - if (.not. found) then - call store_error('programming error in deallocate_logical') - call ustop() + enddo + if (.not. found) then + call store_error('programming error in deallocate_logical') + call ustop() else - if (mt%master) then - deallocate(logicalsclr) - else - nullify(logicalsclr) - end if + if (mt%master) then + deallocate(logicalsclr) + else + nullify(logicalsclr) + end if endif end subroutine deallocate_logical @@ -943,25 +943,25 @@ subroutine deallocate_int(intsclr) integer(I4B), pointer, intent(inout) :: intsclr class(MemoryType), pointer :: mt integer(I4B) :: ipos - logical :: found + logical :: found found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%intsclr, intsclr)) then - nullify(mt%intsclr) - found = .true. - exit + if(associated(mt%intsclr, intsclr)) then + nullify(mt%intsclr) + found = .true. + exit endif - enddo - if (.not. found) then - call store_error('programming error in deallocate_int') - call ustop() + enddo + if (.not. found) then + call store_error('programming error in deallocate_int') + call ustop() else - if (mt%master) then - deallocate(intsclr) - else - nullify(intsclr) - end if + if (mt%master) then + deallocate(intsclr) + else + nullify(intsclr) + end if endif end subroutine deallocate_int @@ -969,25 +969,25 @@ subroutine deallocate_dbl(dblsclr) real(DP), pointer, intent(inout) :: dblsclr class(MemoryType), pointer :: mt integer(I4B) :: ipos - logical :: found + logical :: found found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%dblsclr, dblsclr)) then - nullify(mt%dblsclr) - found = .true. - exit + if(associated(mt%dblsclr, dblsclr)) then + nullify(mt%dblsclr) + found = .true. + exit endif enddo - if (.not. found) then - call store_error('programming error in deallocate_dbl') - call ustop() + if (.not. found) then + call store_error('programming error in deallocate_dbl') + call ustop() else - if (mt%master) then - deallocate(dblsclr) - else - nullify (dblsclr) - end if + if (mt%master) then + deallocate(dblsclr) + else + nullify (dblsclr) + end if endif end subroutine deallocate_dbl @@ -996,31 +996,31 @@ subroutine deallocate_int1d(aint1d, name, origin) character(len=*), optional :: name character(len=*), optional :: origin type(MemoryType), pointer :: mt - integer(I4B) :: ipos - logical :: found - if (present(name) .and. present(origin)) then - call get_from_memorylist(name, origin, mt, found) - nullify(mt%aint1d) - else + integer(I4B) :: ipos + logical :: found + if (present(name) .and. present(origin)) then + call get_from_memorylist(name, origin, mt, found) + nullify(mt%aint1d) + else found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%aint1d, aint1d)) then - nullify(mt%aint1d) - found = .true. - exit + if(associated(mt%aint1d, aint1d)) then + nullify(mt%aint1d) + found = .true. + exit endif - enddo + enddo end if - if (.not. found .and. size(aint1d) > 0 ) then - call store_error('programming error in deallocate_int1d') - call ustop() + if (.not. found .and. size(aint1d) > 0 ) then + call store_error('programming error in deallocate_int1d') + call ustop() else - if (mt%master) then - deallocate(aint1d) - else - nullify(aint1d) - end if + if (mt%master) then + deallocate(aint1d) + else + nullify(aint1d) + end if endif end subroutine deallocate_int1d @@ -1030,30 +1030,30 @@ subroutine deallocate_int2d(aint2d, name, origin) character(len=*), optional :: origin type(MemoryType), pointer :: mt integer(I4B) :: ipos - logical :: found - if (present(name) .and. present(origin)) then - call get_from_memorylist(name, origin, mt, found) - nullify(mt%aint2d) - else + logical :: found + if (present(name) .and. present(origin)) then + call get_from_memorylist(name, origin, mt, found) + nullify(mt%aint2d) + else found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%aint2d, aint2d)) then - nullify(mt%aint2d) - found = .true. - exit + if(associated(mt%aint2d, aint2d)) then + nullify(mt%aint2d) + found = .true. + exit endif - enddo + enddo end if - if (.not. found .and. size(aint2d) > 0 ) then - call store_error('programming error in deallocate_int2d') - call ustop() + if (.not. found .and. size(aint2d) > 0 ) then + call store_error('programming error in deallocate_int2d') + call ustop() else - if (mt%master) then - deallocate(aint2d) - else - nullify(aint2d) - end if + if (mt%master) then + deallocate(aint2d) + else + nullify(aint2d) + end if endif end subroutine deallocate_int2d @@ -1063,129 +1063,129 @@ subroutine deallocate_int3d(aint3d, name, origin) character(len=*), optional :: origin type(MemoryType), pointer :: mt integer(I4B) :: ipos - logical :: found - if (present(name) .and. present(origin)) then - call get_from_memorylist(name, origin, mt, found) - nullify(mt%aint3d) - else + logical :: found + if (present(name) .and. present(origin)) then + call get_from_memorylist(name, origin, mt, found) + nullify(mt%aint3d) + else found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%aint3d, aint3d)) then - nullify(mt%aint3d) - found = .true. - exit + if(associated(mt%aint3d, aint3d)) then + nullify(mt%aint3d) + found = .true. + exit endif - enddo + enddo end if - if (.not. found .and. size(aint3d) > 0 ) then - call store_error('programming error in deallocate_int3d') - call ustop() + if (.not. found .and. size(aint3d) > 0 ) then + call store_error('programming error in deallocate_int3d') + call ustop() else - if (mt%master) then - deallocate(aint3d) - else - nullify(aint3d) - end if + if (mt%master) then + deallocate(aint3d) + else + nullify(aint3d) + end if endif end subroutine deallocate_int3d - subroutine deallocate_dbl1d(adbl1d, name, origin) - real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl1d + subroutine deallocate_dbl1d(adbl1d, name, origin) + real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl1d character(len=*), optional :: name character(len=*), optional :: origin - type(MemoryType), pointer :: mt - integer(I4B) :: ipos - logical :: found - if (present(name) .and. present(origin)) then - call get_from_memorylist(name, origin, mt, found) - nullify(mt%adbl1d) - else - found = .false. - do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - if(associated(mt%adbl1d, adbl1d)) then - nullify(mt%adbl1d) - found = .true. - exit - endif - enddo - end if - if (.not. found .and. size(adbl1d) > 0 ) then - call store_error('programming error in deallocate_dbl1d') - call ustop() - else - if (mt%master) then - deallocate(adbl1d) - else - nullify(adbl1d) - end if - endif - end subroutine deallocate_dbl1d - + type(MemoryType), pointer :: mt + integer(I4B) :: ipos + logical :: found + if (present(name) .and. present(origin)) then + call get_from_memorylist(name, origin, mt, found) + nullify(mt%adbl1d) + else + found = .false. + do ipos = 1, memorylist%count() + mt => memorylist%Get(ipos) + if(associated(mt%adbl1d, adbl1d)) then + nullify(mt%adbl1d) + found = .true. + exit + endif + enddo + end if + if (.not. found .and. size(adbl1d) > 0 ) then + call store_error('programming error in deallocate_dbl1d') + call ustop() + else + if (mt%master) then + deallocate(adbl1d) + else + nullify(adbl1d) + end if + endif + end subroutine deallocate_dbl1d + subroutine deallocate_dbl2d(adbl2d, name, origin) real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl2d character(len=*), optional :: name character(len=*), optional :: origin type(MemoryType), pointer :: mt integer(I4B) :: ipos - logical :: found - if (present(name) .and. present(origin)) then - call get_from_memorylist(name, origin, mt, found) - nullify(mt%adbl2d) - else + logical :: found + if (present(name) .and. present(origin)) then + call get_from_memorylist(name, origin, mt, found) + nullify(mt%adbl2d) + else found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%adbl2d, adbl2d)) then - nullify(mt%adbl2d) - found = .true. - exit + if(associated(mt%adbl2d, adbl2d)) then + nullify(mt%adbl2d) + found = .true. + exit endif - enddo + enddo end if - if (.not. found .and. size(adbl2d) > 0 ) then - call store_error('programming error in deallocate_dbl2d') - call ustop() + if (.not. found .and. size(adbl2d) > 0 ) then + call store_error('programming error in deallocate_dbl2d') + call ustop() else - if (mt%master) then - deallocate(adbl2d) - else - nullify(adbl2d) - end if + if (mt%master) then + deallocate(adbl2d) + else + nullify(adbl2d) + end if endif end subroutine deallocate_dbl2d - + subroutine deallocate_dbl3d(adbl3d, name, origin) real(DP), dimension(:, :, :), pointer, contiguous, intent(inout) :: adbl3d character(len=*), optional :: name character(len=*), optional :: origin type(MemoryType), pointer :: mt integer(I4B) :: ipos - logical :: found - if (present(name) .and. present(origin)) then - call get_from_memorylist(name, origin, mt, found) - nullify(mt%adbl3d) - else + logical :: found + if (present(name) .and. present(origin)) then + call get_from_memorylist(name, origin, mt, found) + nullify(mt%adbl3d) + else found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%adbl3d, adbl3d)) then - nullify(mt%adbl3d) - found = .true. - exit + if(associated(mt%adbl3d, adbl3d)) then + nullify(mt%adbl3d) + found = .true. + exit endif - enddo + enddo end if - if (.not. found .and. size(adbl3d) > 0 ) then - call store_error('programming error in deallocate_dbl3d') - call ustop() + if (.not. found .and. size(adbl3d) > 0 ) then + call store_error('programming error in deallocate_dbl3d') + call ustop() else - if (mt%master) then - deallocate(adbl3d) - else - nullify(adbl3d) - end if + if (mt%master) then + deallocate(adbl3d) + else + nullify(adbl3d) + end if endif end subroutine deallocate_dbl3d @@ -1193,58 +1193,58 @@ subroutine deallocate_ts1d(ats1d) type (MemoryTSType), dimension(:), pointer, contiguous, intent(inout) :: ats1d class(MemoryType), pointer :: mt integer(I4B) :: ipos - integer(I4B) :: i - logical :: found + integer(I4B) :: i + logical :: found found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) if (associated(mt%ats1d, ats1d)) then - nullify(mt%ats1d) - found = .true. - exit + nullify(mt%ats1d) + found = .true. + exit end if end do - if (.not. found .and. size(ats1d) > 0 ) then - call store_error('programming error in deallocate_ts1d') - call ustop() - else - do i = 1, size(ats1d) - deallocate(ats1d(i)%name) - deallocate(ats1d(i)%value) + if (.not. found .and. size(ats1d) > 0 ) then + call store_error('programming error in deallocate_ts1d') + call ustop() + else + do i = 1, size(ats1d) + deallocate(ats1d(i)%name) + deallocate(ats1d(i)%value) enddo - if (mt%master) then - deallocate(ats1d) - else - nullify(ats1d) - end if - endif + if (mt%master) then + deallocate(ats1d) + else + nullify(ats1d) + end if + endif return end subroutine deallocate_ts1d - subroutine mem_set_print_option(iout, keyword, errmsg) - integer(I4B), intent(in) :: iout - character(len=*), intent(in) :: keyword - character(len=*), intent(inout) :: errmsg - select case (keyword) - case ('NONE') - iprmem = 0 - write(iout, '(4x, a)') & - 'LIMITED MEMORY INFORMATION WILL BE WRITTEN.' - case ('SUMMARY') - iprmem = 1 - write(iout, '(4x, a)') & - 'A SUMMARY OF SIMULATION MEMORY INFORMATION WILL BE WRITTEN.' - case ('ALL') - iprmem = 2 - write(iout, '(4x, a)') & - 'ALL SIMULATION MEMORY INFORMATION WILL BE WRITTEN.' - case default - write(errmsg,'(4x,a,a)') & - 'UNKNOWN MEMORY PRINT OPTION: ', trim(keyword) - end select - return - end subroutine mem_set_print_option - + subroutine mem_set_print_option(iout, keyword, errmsg) + integer(I4B), intent(in) :: iout + character(len=*), intent(in) :: keyword + character(len=*), intent(inout) :: errmsg + select case (keyword) + case ('NONE') + iprmem = 0 + write(iout, '(4x, a)') & + 'LIMITED MEMORY INFORMATION WILL BE WRITTEN.' + case ('SUMMARY') + iprmem = 1 + write(iout, '(4x, a)') & + 'A SUMMARY OF SIMULATION MEMORY INFORMATION WILL BE WRITTEN.' + case ('ALL') + iprmem = 2 + write(iout, '(4x, a)') & + 'ALL SIMULATION MEMORY INFORMATION WILL BE WRITTEN.' + case default + write(errmsg,'(4x,a,a)') & + 'UNKNOWN MEMORY PRINT OPTION: ', trim(keyword) + end select + return + end subroutine mem_set_print_option + subroutine mem_usage(iout) integer(I4B), intent(in) :: iout class(MemoryType), pointer :: mt @@ -1253,111 +1253,111 @@ subroutine mem_usage(iout) character(len=*), parameter :: fmttitle = "(/, 1x, a)" character(len=*), parameter :: fmtheader = & "(1x, a40, a20, a20, a10, a10, a10, /, 1x, 110('-'))" - character(len=200) :: msg + character(len=200) :: msg character(len=LENORIGIN), allocatable, dimension(:) :: cunique real(DP) :: bytesmb - integer(I4B) :: ipos - integer(I4B) :: icomp, ilen - integer(I8B) :: nint, nreal - ! - ! -- Write info to simulation list file - write(iout, fmttitle) 'INFORMATION ON VARIABLES STORED IN THE MEMORY MANAGER' - ! - ! -- Write summary table for simulatation components - if (iprmem == 1) then - ! - ! -- Find unique names of simulation componenets - call mem_unique_origins(cunique) - write(iout, '(*(G0))') ' COMPONENT ', & - ' NINTS ', & - ' NREAL ', & - ' MBYTES ' - write(iout, "(56('-'))") - do icomp = 1, size(cunique) - nint = 0 - nreal = 0 - bytesmb = DZERO - ilen = len_trim(cunique(icomp)) + integer(I4B) :: ipos + integer(I4B) :: icomp, ilen + integer(I8B) :: nint, nreal + ! + ! -- Write info to simulation list file + write(iout, fmttitle) 'INFORMATION ON VARIABLES STORED IN THE MEMORY MANAGER' + ! + ! -- Write summary table for simulatation components + if (iprmem == 1) then + ! + ! -- Find unique names of simulation componenets + call mem_unique_origins(cunique) + write(iout, '(*(G0))') ' COMPONENT ', & + ' NINTS ', & + ' NREAL ', & + ' MBYTES ' + write(iout, "(56('-'))") + do icomp = 1, size(cunique) + nint = 0 + nreal = 0 + bytesmb = DZERO + ilen = len_trim(cunique(icomp)) do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - if (cunique(icomp) /= mt%origin(1:ilen)) cycle - if (.not. mt%master) cycle - if (mt%memtype(1:7) == 'INTEGER') nint = nint + mt%isize - if (mt%memtype(1:6) == 'DOUBLE') nreal = nreal + mt%isize - enddo - bytesmb = (nint * I4B + nreal * DP) / 1000000.d0 - write(iout, '(a20, i10, i10, 1pg16.2)') cunique(icomp), nint, nreal, bytesmb - enddo + mt => memorylist%Get(ipos) + if (cunique(icomp) /= mt%origin(1:ilen)) cycle + if (.not. mt%master) cycle + if (mt%memtype(1:7) == 'INTEGER') nint = nint + mt%isize + if (mt%memtype(1:6) == 'DOUBLE') nreal = nreal + mt%isize + enddo + bytesmb = (nint * I4B + nreal * DP) / 1000000.d0 + write(iout, '(a20, i10, i10, 1pg16.2)') cunique(icomp), nint, nreal, bytesmb + enddo endif - ! - ! -- Write table with all variables for iprmem == 2 + ! + ! -- Write table with all variables for iprmem == 2 if (iprmem == 2) then write(iout, *) write(iout, fmtheader) ' ORIGIN ', & ' NAME ', & ' TYPE ', & ' SIZE ', & - ' NREALLOC ', & + ' NREALLOC ', & ' POINTER ' do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) call mt%table_entry(msg) write(iout, '(a)') msg - enddo - endif - ! + enddo + endif + ! ! -- Calculate and write total memory allocation - bytesmb = (nvalues_aint * I4B + & - nvalues_adbl * DP + & + bytesmb = (nvalues_aint * I4B + & + nvalues_adbl * DP + & nvalues_ats * DP) / 1000000.d0 write(iout, *) write(iout, fmt) 'Number of allocated integer variables: ', nvalues_aint write(iout, fmt) 'Number of allocated real variables: ', nvalues_adbl + nvalues_ats write(iout, fmtd) 'Allocated memory in megabytes: ', bytesmb write(iout, *) - end subroutine mem_usage - - subroutine mem_da() - use SimModule, only: store_error, ustop, count_errors - use VersionModule, only: IDEVELOPMODE - class(MemoryType), pointer :: mt - integer(I4B) :: ipos + end subroutine mem_usage + + subroutine mem_da() + use SimModule, only: store_error, ustop, count_errors + use VersionModule, only: IDEVELOPMODE + class(MemoryType), pointer :: mt + integer(I4B) :: ipos character(len=LINELENGTH) :: errmsg do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - if (IDEVELOPMODE == 1) then - if (mt%mt_associated() .and. mt%isize > 0) then - errmsg = trim(adjustl(mt%origin)) // ' ' // & - trim(adjustl(mt%name)) // ' not deallocated' - call store_error(trim(errmsg)) - end if - end if + mt => memorylist%Get(ipos) + if (IDEVELOPMODE == 1) then + if (mt%mt_associated() .and. mt%isize > 0) then + errmsg = trim(adjustl(mt%origin)) // ' ' // & + trim(adjustl(mt%name)) // ' not deallocated' + call store_error(trim(errmsg)) + end if + end if deallocate(mt) - enddo - call memorylist%clear() - if (count_errors() > 0) call ustop() - end subroutine mem_da - - subroutine mem_unique_origins(cunique) - use ArrayHandlersModule, only: ExpandArray, ifind - use InputOutputModule, only: ParseLine - character(len=LENORIGIN), allocatable, dimension(:), intent(inout) :: cunique - class(MemoryType), pointer :: mt - integer(I4B) :: ipos - integer(I4B) :: ipa - integer(I4B) :: nwords - character(len=LENORIGIN), allocatable, dimension(:) :: words - allocate(cunique(0)) + enddo + call memorylist%clear() + if (count_errors() > 0) call ustop() + end subroutine mem_da + + subroutine mem_unique_origins(cunique) + use ArrayHandlersModule, only: ExpandArray, ifind + use InputOutputModule, only: ParseLine + character(len=LENORIGIN), allocatable, dimension(:), intent(inout) :: cunique + class(MemoryType), pointer :: mt + integer(I4B) :: ipos + integer(I4B) :: ipa + integer(I4B) :: nwords + character(len=LENORIGIN), allocatable, dimension(:) :: words + allocate(cunique(0)) do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - call ParseLine(mt%origin, nwords, words) - ipa = ifind(cunique, words(1)) - if(ipa < 1) then - call ExpandArray(cunique, 1) - cunique(size(cunique)) = words(1) - endif + mt => memorylist%Get(ipos) + call ParseLine(mt%origin, nwords, words) + ipa = ifind(cunique, words(1)) + if(ipa < 1) then + call ExpandArray(cunique, 1) + cunique(size(cunique)) = words(1) + endif enddo - return + return end subroutine mem_unique_origins end module MemoryManagerModule diff --git a/src/Utilities/NameFile.f90 b/src/Utilities/NameFile.f90 index 2ced0808dcf..370f9d4511b 100644 --- a/src/Utilities/NameFile.f90 +++ b/src/Utilities/NameFile.f90 @@ -1,384 +1,384 @@ -module NameFileModule - - use KindModule, only: DP, I4B - use InputOutputModule, only: ParseLine, openfile, getunit - use ConstantsModule, only: LINELENGTH, LENPACKAGENAME - use ArrayHandlersModule, only: ExpandArray, remove_character - use IunitModule, only: IunitType - use BlockParserModule, only: BlockParserType - implicit none - private - public :: NameFileType - - type :: NameFileType - character(len=LINELENGTH) :: filename - logical :: opened_listfile = .false. - character(len=LINELENGTH), dimension(:), allocatable :: opts - character(len=LINELENGTH), dimension(:), allocatable :: input_files - type(IunitType) :: iunit_obj - type(BlockParserType) :: parser - contains - procedure :: init => namefile_init - procedure :: add_cunit => namefile_add_cunit - procedure :: openlistfile => namefile_openlistfile - procedure :: openfiles => namefile_openfiles - procedure :: get_unitnumber => namefile_get_unitnumber - procedure :: get_nval_for_row => namefile_get_nval_for_row - procedure :: get_unitnumber_rowcol => namefile_get_unitnumber_rowcol - procedure :: get_pakname => namefile_get_pakname - end type NameFileType - - contains - - subroutine namefile_init(this, filename, iout) -! ****************************************************************************** -! namefile_init -- initialize the namefile object using the filename. if iout -! is non-zero, then the block information will be written to iout. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: store_error, ustop - ! -- dummy - class(NameFileType) :: this - character(len=*), intent(in) :: filename - integer(I4B), intent(in) :: iout - ! -- local - character(len=LINELENGTH) :: errmsg, line - integer(I4B) :: i, ierr, inunit, n - logical :: isFound, endOfBlock - ! -- formats - character(len=*), parameter :: fmtfname = & - "(1x, 'NON-COMMENTED ENTRIES FOUND IN ', /, & - &4X, 'BLOCK: ', a, /, & - &4X, 'FILE: ', a)" - character(len=*), parameter :: fmtbeg = "(/, 1x, A)" - character(len=*), parameter :: fmtline = "(2x, a)" - character(len=*), parameter :: fmtend = "(1x, A, /)" -! ------------------------------------------------------------------------------ - ! - ! -- Store filename and initialize variables - this%filename = filename - allocate(this%opts(0)) - allocate(this%input_files(0)) - ! - ! -- Open the name file and initialize the block parser - inunit = getunit() - call openfile(inunit, iout, filename, 'NAM', filstat_opt='OLD') - call this%parser%Initialize(inunit, iout) - ! - ! -- Read and set the options - call this%parser%GetBlock('OPTIONS', isFound, ierr, & - supportOpenClose=.true., blockRequired=.false.) - if(isFound) then - ! - ! -- Populate this%opts - n = 0 - getopts: do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit getopts - call this%parser%GetCurrentLine(line) - call ExpandArray(this%opts) - n = n + 1 - this%opts(n) = adjustl(line) - enddo getopts - ! - if(iout > 0) then - write(iout, fmtfname) 'OPTIONS', trim(adjustl(filename)) - write(iout, fmtbeg) 'BEGIN OPTIONS' - do i = 1, n - write(iout, fmtline) trim(adjustl(this%opts(i))) - enddo - write(iout, fmtend) 'END OPTIONS' - endif - else - if(iout > 0) then - write(iout, '(/, A, /)') 'NO VALID OPTIONS BLOCK DETECTED' - endif - endif - ! - ! -- Read and set the input_files - call this%parser%GetBlock('PACKAGES', isFound, ierr, & - supportOpenClose=.true.) - if(isFound) then - ! - ! -- Populate this%input_files - n = 0 - getpaks: do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit getpaks - call this%parser%GetCurrentLine(line) - call ExpandArray(this%input_files) - n = n + 1 - this%input_files(n) = adjustl(line) - enddo getpaks - ! - ! -- Write to list file - if(iout > 0) then - write(iout, fmtfname) 'PACKAGES', trim(adjustl(filename)) - write(iout, fmtbeg) 'BEGIN PACKAGES' - do i = 1, n - write(iout, fmtline) trim(adjustl(this%input_files(i))) - enddo - write(iout, fmtend) 'END PACKAGES' - endif - else - ! - ! -- Package block not found. Terminate with error. - write(errmsg, '(a, a)') 'Error reading PACKAGES from file: ', & - trim(adjustl(filename)) - call store_error(errmsg) - call ustop() - endif - ! - ! -- return - return - end subroutine namefile_init - - subroutine namefile_add_cunit(this, niunit, cunit) -! ****************************************************************************** -! namefile_add_cunit -- attach the cunit array to the iunit object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(NameFileType) :: this - integer(I4B), intent(in) :: niunit - character(len=*), dimension(niunit), intent(in) :: cunit -! ------------------------------------------------------------------------------ - ! - call this%iunit_obj%init(niunit, cunit) - ! - ! -- return - return - end subroutine namefile_add_cunit - - subroutine namefile_openlistfile(this, iout) -! ****************************************************************************** -! namefile_openlistfile -- Open the list file and set iout. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: store_error, ustop - use InputOutputModule, only: getunit, upcase - ! -- dummy - class(NameFileType) :: this - integer(I4B), intent(inout) :: iout - ! -- local - logical :: found - character(len=LINELENGTH) :: fname - integer(I4B) :: i, istart, istop - integer(I4B) :: nwords - integer(I4B) :: ipos - character(len=LINELENGTH), allocatable, dimension(:) :: words - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- Go through the options and see if LIST was specified - found = .false. - ipos = 0 - findloop: do i = 1, size(this%opts) - call ParseLine(this%opts(i), nwords, words) - call upcase(words(1)) - if(words(1) == 'LIST') then - fname = words(2) - ipos = i - found = .true. - exit findloop - endif - enddo findloop - ! - ! -- remove list file from options list - if (ipos > 0) then - call remove_character(this%opts, ipos) - end if - ! - ! -- If LIST was not found, then set name of list file by replacing the - ! namefile extension with '.lst' If no extension then add to end - ! of namefile name. - if (.not. found) then - fname = ' ' - istart = 0 - istop = len_trim(this%filename) - do i = istop, 1, -1 - if (this%filename(i:i) == '.') then - istart = i - exit - endif - enddo - if (istart == 0) istart = istop + 1 - fname = this%filename(1:istart) - istop = istart + 3 - fname(istart:istop) = '.lst' - endif - ! - ! -- Open the list file - iout = getunit() - call openfile(iout, 0, trim(fname), 'LIST', filstat_opt='REPLACE') - this%opened_listfile = .true. - ! - ! -- return - return - end subroutine namefile_openlistfile - - subroutine namefile_openfiles(this, iout) -! ****************************************************************************** -! namefile_openfiles -- Open the files. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: store_error, ustop - use InputOutputModule, only: getunit, upcase - ! -- dummy - class(NameFileType) :: this - integer(I4B), intent(in) :: iout - ! -- local - character(len=20) :: ftype, accarg, fmtarg, filstat - integer(I4B) :: i, inunit, nwords - character(len=LINELENGTH), allocatable, dimension(:) :: words - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- Open the input_files - do i = 1, size(this%input_files) - ! - ! -- Parse the line and set defaults - call ParseLine(this%input_files(i), nwords, words) - call upcase(words(1)) - ftype = words(1)(1:20) - accarg = 'SEQUENTIAL' - fmtarg = 'FORMATTED' - filstat = 'OLD' - ! - ! -- Get a free unit number and assign it to the file - inunit = getunit() - call this%iunit_obj%addfile(ftype, inunit, i, this%filename) - ! - ! -- Open the file - call openfile(inunit, iout, trim(adjustl(words(2))), & - ftype, fmtarg, accarg, filstat) - enddo - ! - ! -- return - return - end subroutine namefile_openfiles - - subroutine namefile_get_unitnumber(this, ftype, inunit, iremove) -! ****************************************************************************** -! namefile_get_unitnumber -- Assign the unit number for the ftype to inunit. -! If iremove > 0, then remove this file from iunit_obj. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - class(NameFileType) :: this - character(len=*), intent(in) :: ftype - integer(I4B), intent(inout) :: inunit - integer(I4B), intent(in) :: iremove -! ------------------------------------------------------------------------------ - ! - call this%iunit_obj%getunitnumber(ftype, inunit, iremove) - ! - ! -- return - return - end subroutine namefile_get_unitnumber - - function namefile_get_nval_for_row(this, irow) result(nval) -! ****************************************************************************** -! namefile_get_nval_for_row -- Get the number of entries for the cunit type in -! row irow. For example, return the number of well packages that were -! read from the name file. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - integer(I4B) :: nval - class(NameFileType) :: this - integer(I4B), intent(in) :: irow -! ------------------------------------------------------------------------------ - ! - nval = this%iunit_obj%iunit(irow)%nval - ! - ! -- return - return - end function namefile_get_nval_for_row - - function namefile_get_unitnumber_rowcol(this, irow, jcol) & - result(iu) -! ****************************************************************************** -! namefile_get_unitnumber_rowcol -- Get the unit number for entries in -! cunit(irow) and columns (icol). For example, return the unit number for -! the first, second, or third well package. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - integer(I4B) :: iu - class(NameFileType) :: this - integer(I4B), intent(in) :: irow - integer(I4B), intent(in) :: jcol -! ------------------------------------------------------------------------------ - ! - iu = this%iunit_obj%iunit(irow)%iunit(jcol) - ! - ! -- return - return - end function namefile_get_unitnumber_rowcol - - subroutine namefile_get_pakname(this, irow, jcol, pakname) -! ****************************************************************************** -! namefile_get_pakname -- Assign the unit number for the ftype to inunit. -! If iremove > 0, then remove this file from iunit_obj. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: store_error, ustop - use InputOutputModule, only: upcase - ! -- dummy - class(NameFileType) :: this - integer(I4B), intent(in) :: irow - integer(I4B), intent(in) :: jcol - character(len=*), intent(inout) :: pakname - ! -- local - integer(I4B) :: ilen, ipos, nwords - character(len=LINELENGTH) :: errmsg - character(len=LINELENGTH), allocatable, dimension(:) :: words -! ------------------------------------------------------------------------------ - ! - ipos = this%iunit_obj%iunit(irow)%ipos(jcol) - call ParseLine(this%input_files(ipos), nwords, words, & - filename=this%filename) - pakname = '' - if (nwords > 2) then - ilen = len(trim(adjustl(words(3)))) - if(ilen > LENPACKAGENAME) then - write(errmsg, "(a, i0, a)") & - 'ERROR. PACKAGENAME MUST NOT BE GREATER THAN ', & - LENPACKAGENAME, ' CHARACTERS.' - call store_error(errmsg) - call store_error(trim(this%input_files(ipos))) - write(errmsg, '(a, a)') 'Error in PACKAGES block in file: ', & - trim(adjustl(this%filename)) - call store_error(errmsg) - call ustop() - endif - pakname = trim(adjustl(words(3))) - call upcase(pakname) - endif - ! - ! -- return - return - end subroutine namefile_get_pakname - - -end module NameFileModule +module NameFileModule + + use KindModule, only: DP, I4B + use InputOutputModule, only: ParseLine, openfile, getunit + use ConstantsModule, only: LINELENGTH, LENPACKAGENAME + use ArrayHandlersModule, only: ExpandArray, remove_character + use IunitModule, only: IunitType + use BlockParserModule, only: BlockParserType + implicit none + private + public :: NameFileType + + type :: NameFileType + character(len=LINELENGTH) :: filename + logical :: opened_listfile = .false. + character(len=LINELENGTH), dimension(:), allocatable :: opts + character(len=LINELENGTH), dimension(:), allocatable :: input_files + type(IunitType) :: iunit_obj + type(BlockParserType) :: parser + contains + procedure :: init => namefile_init + procedure :: add_cunit => namefile_add_cunit + procedure :: openlistfile => namefile_openlistfile + procedure :: openfiles => namefile_openfiles + procedure :: get_unitnumber => namefile_get_unitnumber + procedure :: get_nval_for_row => namefile_get_nval_for_row + procedure :: get_unitnumber_rowcol => namefile_get_unitnumber_rowcol + procedure :: get_pakname => namefile_get_pakname + end type NameFileType + + contains + + subroutine namefile_init(this, filename, iout) +! ****************************************************************************** +! namefile_init -- initialize the namefile object using the filename. if iout +! is non-zero, then the block information will be written to iout. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: store_error, ustop + ! -- dummy + class(NameFileType) :: this + character(len=*), intent(in) :: filename + integer(I4B), intent(in) :: iout + ! -- local + character(len=LINELENGTH) :: errmsg, line + integer(I4B) :: i, ierr, inunit, n + logical :: isFound, endOfBlock + ! -- formats + character(len=*), parameter :: fmtfname = & + "(1x, 'NON-COMMENTED ENTRIES FOUND IN ', /, & + &4X, 'BLOCK: ', a, /, & + &4X, 'FILE: ', a)" + character(len=*), parameter :: fmtbeg = "(/, 1x, A)" + character(len=*), parameter :: fmtline = "(2x, a)" + character(len=*), parameter :: fmtend = "(1x, A, /)" +! ------------------------------------------------------------------------------ + ! + ! -- Store filename and initialize variables + this%filename = filename + allocate(this%opts(0)) + allocate(this%input_files(0)) + ! + ! -- Open the name file and initialize the block parser + inunit = getunit() + call openfile(inunit, iout, filename, 'NAM', filstat_opt='OLD') + call this%parser%Initialize(inunit, iout) + ! + ! -- Read and set the options + call this%parser%GetBlock('OPTIONS', isFound, ierr, & + supportOpenClose=.true., blockRequired=.false.) + if(isFound) then + ! + ! -- Populate this%opts + n = 0 + getopts: do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit getopts + call this%parser%GetCurrentLine(line) + call ExpandArray(this%opts) + n = n + 1 + this%opts(n) = adjustl(line) + enddo getopts + ! + if(iout > 0) then + write(iout, fmtfname) 'OPTIONS', trim(adjustl(filename)) + write(iout, fmtbeg) 'BEGIN OPTIONS' + do i = 1, n + write(iout, fmtline) trim(adjustl(this%opts(i))) + enddo + write(iout, fmtend) 'END OPTIONS' + endif + else + if(iout > 0) then + write(iout, '(/, A, /)') 'NO VALID OPTIONS BLOCK DETECTED' + endif + endif + ! + ! -- Read and set the input_files + call this%parser%GetBlock('PACKAGES', isFound, ierr, & + supportOpenClose=.true.) + if(isFound) then + ! + ! -- Populate this%input_files + n = 0 + getpaks: do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit getpaks + call this%parser%GetCurrentLine(line) + call ExpandArray(this%input_files) + n = n + 1 + this%input_files(n) = adjustl(line) + enddo getpaks + ! + ! -- Write to list file + if(iout > 0) then + write(iout, fmtfname) 'PACKAGES', trim(adjustl(filename)) + write(iout, fmtbeg) 'BEGIN PACKAGES' + do i = 1, n + write(iout, fmtline) trim(adjustl(this%input_files(i))) + enddo + write(iout, fmtend) 'END PACKAGES' + endif + else + ! + ! -- Package block not found. Terminate with error. + write(errmsg, '(a, a)') 'Error reading PACKAGES from file: ', & + trim(adjustl(filename)) + call store_error(errmsg) + call ustop() + endif + ! + ! -- return + return + end subroutine namefile_init + + subroutine namefile_add_cunit(this, niunit, cunit) +! ****************************************************************************** +! namefile_add_cunit -- attach the cunit array to the iunit object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(NameFileType) :: this + integer(I4B), intent(in) :: niunit + character(len=*), dimension(niunit), intent(in) :: cunit +! ------------------------------------------------------------------------------ + ! + call this%iunit_obj%init(niunit, cunit) + ! + ! -- return + return + end subroutine namefile_add_cunit + + subroutine namefile_openlistfile(this, iout) +! ****************************************************************************** +! namefile_openlistfile -- Open the list file and set iout. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: store_error, ustop + use InputOutputModule, only: getunit, upcase + ! -- dummy + class(NameFileType) :: this + integer(I4B), intent(inout) :: iout + ! -- local + logical :: found + character(len=LINELENGTH) :: fname + integer(I4B) :: i, istart, istop + integer(I4B) :: nwords + integer(I4B) :: ipos + character(len=LINELENGTH), allocatable, dimension(:) :: words + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- Go through the options and see if LIST was specified + found = .false. + ipos = 0 + findloop: do i = 1, size(this%opts) + call ParseLine(this%opts(i), nwords, words) + call upcase(words(1)) + if(words(1) == 'LIST') then + fname = words(2) + ipos = i + found = .true. + exit findloop + endif + enddo findloop + ! + ! -- remove list file from options list + if (ipos > 0) then + call remove_character(this%opts, ipos) + end if + ! + ! -- If LIST was not found, then set name of list file by replacing the + ! namefile extension with '.lst' If no extension then add to end + ! of namefile name. + if (.not. found) then + fname = ' ' + istart = 0 + istop = len_trim(this%filename) + do i = istop, 1, -1 + if (this%filename(i:i) == '.') then + istart = i + exit + endif + enddo + if (istart == 0) istart = istop + 1 + fname = this%filename(1:istart) + istop = istart + 3 + fname(istart:istop) = '.lst' + endif + ! + ! -- Open the list file + iout = getunit() + call openfile(iout, 0, trim(fname), 'LIST', filstat_opt='REPLACE') + this%opened_listfile = .true. + ! + ! -- return + return + end subroutine namefile_openlistfile + + subroutine namefile_openfiles(this, iout) +! ****************************************************************************** +! namefile_openfiles -- Open the files. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: store_error, ustop + use InputOutputModule, only: getunit, upcase + ! -- dummy + class(NameFileType) :: this + integer(I4B), intent(in) :: iout + ! -- local + character(len=20) :: ftype, accarg, fmtarg, filstat + integer(I4B) :: i, inunit, nwords + character(len=LINELENGTH), allocatable, dimension(:) :: words + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- Open the input_files + do i = 1, size(this%input_files) + ! + ! -- Parse the line and set defaults + call ParseLine(this%input_files(i), nwords, words) + call upcase(words(1)) + ftype = words(1)(1:20) + accarg = 'SEQUENTIAL' + fmtarg = 'FORMATTED' + filstat = 'OLD' + ! + ! -- Get a free unit number and assign it to the file + inunit = getunit() + call this%iunit_obj%addfile(ftype, inunit, i, this%filename) + ! + ! -- Open the file + call openfile(inunit, iout, trim(adjustl(words(2))), & + ftype, fmtarg, accarg, filstat) + enddo + ! + ! -- return + return + end subroutine namefile_openfiles + + subroutine namefile_get_unitnumber(this, ftype, inunit, iremove) +! ****************************************************************************** +! namefile_get_unitnumber -- Assign the unit number for the ftype to inunit. +! If iremove > 0, then remove this file from iunit_obj. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(NameFileType) :: this + character(len=*), intent(in) :: ftype + integer(I4B), intent(inout) :: inunit + integer(I4B), intent(in) :: iremove +! ------------------------------------------------------------------------------ + ! + call this%iunit_obj%getunitnumber(ftype, inunit, iremove) + ! + ! -- return + return + end subroutine namefile_get_unitnumber + + function namefile_get_nval_for_row(this, irow) result(nval) +! ****************************************************************************** +! namefile_get_nval_for_row -- Get the number of entries for the cunit type in +! row irow. For example, return the number of well packages that were +! read from the name file. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + integer(I4B) :: nval + class(NameFileType) :: this + integer(I4B), intent(in) :: irow +! ------------------------------------------------------------------------------ + ! + nval = this%iunit_obj%iunit(irow)%nval + ! + ! -- return + return + end function namefile_get_nval_for_row + + function namefile_get_unitnumber_rowcol(this, irow, jcol) & + result(iu) +! ****************************************************************************** +! namefile_get_unitnumber_rowcol -- Get the unit number for entries in +! cunit(irow) and columns (icol). For example, return the unit number for +! the first, second, or third well package. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + integer(I4B) :: iu + class(NameFileType) :: this + integer(I4B), intent(in) :: irow + integer(I4B), intent(in) :: jcol +! ------------------------------------------------------------------------------ + ! + iu = this%iunit_obj%iunit(irow)%iunit(jcol) + ! + ! -- return + return + end function namefile_get_unitnumber_rowcol + + subroutine namefile_get_pakname(this, irow, jcol, pakname) +! ****************************************************************************** +! namefile_get_pakname -- Assign the unit number for the ftype to inunit. +! If iremove > 0, then remove this file from iunit_obj. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: store_error, ustop + use InputOutputModule, only: upcase + ! -- dummy + class(NameFileType) :: this + integer(I4B), intent(in) :: irow + integer(I4B), intent(in) :: jcol + character(len=*), intent(inout) :: pakname + ! -- local + integer(I4B) :: ilen, ipos, nwords + character(len=LINELENGTH) :: errmsg + character(len=LINELENGTH), allocatable, dimension(:) :: words +! ------------------------------------------------------------------------------ + ! + ipos = this%iunit_obj%iunit(irow)%ipos(jcol) + call ParseLine(this%input_files(ipos), nwords, words, & + filename=this%filename) + pakname = '' + if (nwords > 2) then + ilen = len(trim(adjustl(words(3)))) + if(ilen > LENPACKAGENAME) then + write(errmsg, "(a, i0, a)") & + 'ERROR. PACKAGENAME MUST NOT BE GREATER THAN ', & + LENPACKAGENAME, ' CHARACTERS.' + call store_error(errmsg) + call store_error(trim(this%input_files(ipos))) + write(errmsg, '(a, a)') 'Error in PACKAGES block in file: ', & + trim(adjustl(this%filename)) + call store_error(errmsg) + call ustop() + endif + pakname = trim(adjustl(words(3))) + call upcase(pakname) + endif + ! + ! -- return + return + end subroutine namefile_get_pakname + + +end module NameFileModule diff --git a/src/Utilities/Observation/Obs3.f90 b/src/Utilities/Observation/Obs3.f90 index ee666ecb107..55edc48b638 100644 --- a/src/Utilities/Observation/Obs3.f90 +++ b/src/Utilities/Observation/Obs3.f90 @@ -1,1214 +1,1214 @@ -! This module defines type ObsType, which is the highest-level -! derived type for implementing observations. All objects derived from -! NumericalModelType or BndType already contain an ObsType member. -! -! Examples: -! NumericalModelType.obs -! BndType.obs -! -! Similarly, an ObsType member could be added to, say, -! NumericalExchangeType or any other type that has DF, AR, RP, AD, BD, and OT -! routines. -! -! ------------------------------------------------------------------------------ -! IMPLEMENTATION OF OBSERVATIONS IN A MODEL OR PACKAGE -! -! For simple boundary packages like RIV and DRN, only steps 1-6 are -! needed. For models and advanced packages like MAW and SFR, additional -! steps are needed. -! -! 1. (package only) Override BndType.bnd_obs_supported to return true. -! bnd_obs_supported is called from various places in code. -! -! 2. (optional) Write a subroutine that implements abstract interface -! ObserveModule.ProcessIdSub. (Not needed if IDstring, which identifies -! location in model to be observed, is either a single node number or -! a single {lay, row, col} set of indices). -! -! Examples: -! gwf_process_head_drawdown_obs_id, gwf_process_intercell_obs_id -! -! A package can allow IDstring to be a boundary name. -! Example: ObsModule.DefaultObsIdProcessor -! -! 3. Override BndType.bnd_df_obs() to define string(s) to be -! recognized as observation type(s) and (optional) assign ProcessIdPtr -! (not needed if IDstring is either a node number or a {lay, row, col} -! set of indices). -! -! Examples: gwf_df_obs, drn_df_obs -! -! When boundary names are allowed and developer wants simulated value -! to be cumulative (flow, for example) if user specifies multiple -! boundaries with the same BOUNDNAME, in bnd_df_obs call to -! ObsPackage.StoreObsType, provide cumulative argument as true. -! Otherwise, simulated values are not cumulative. -! -! 4. In DF routine: Call bnd_df_obs -! -! 5. In AR routine: Call ObsType.obs_ar. This reads the OBS input -! file. -! Example (gwf_ar): call this%obs%obs_ar() -! Example (lak_ar): call this%obs%obs_ar() -! -! 6. Override BndType.bnd_rp_obs for any package that needs to -! check user input or process observation input in any special way. -! If no special processing is needed, BndType.bnd_rp_obs can -! be used. This routine also expands the ObserveType%indxbnds array for -! each observation in a package. ObserveType%indxbnds is used to sum -! simulated values from multiple boundaries when BOUNDNAMES is used. -! Equivalent routine may or may not be needed for model observations. -! If needed, call it from bottom of RP routine. -! -! Examples: -! BndType.bnd_rp_obs, which is called from gwf_rp -! -! 7. In AD routine: Call ObsType.obs_ad -! Example: gwf_ad -! -! 8. Write a *_bd_obs routine. This is the routine that actually -! calculates the simulated value for each observation type supported -! by the model/package. Call *_bd_obs from the bottom of the -! _bd routine. -! *_bd_obs needs to: -! Call ObsType.obs_bd_clear -! For each observation: -! Calculate the simulated value -! Call ObsType.SaveOneSimval -! Examples: gwf_bd_obs, maw_bd_obs, lak_bd_obs -! -! 9. In BD routine: -! Call BndType.bnd_bd_obs -! Examples: BndType.bnd_bd calls bnd_bd_obs -! GwfModelType.gwf_bd calls gwf_bd_obs -! MawType.maw_bd calls maw_bd_obs -! LakType.lak_bd calls lak_bd_obs -! -! 10. Ensure that ObsType.obs_ot is called. For packages, obs_ot is called -! from the model _ot procedure. The model _ot procedure should also call -! obs_ot for its own observations. Do not call obs_ot from a package _ot -! procedure because the package _ot procedure may not be called, depending -! on Output Control settings (ibudfl). -! -! Note: BndType.bnd_ot_obs calls: -! ObsType.obs_ot -! -! Note: ObsType.obs_ot calls: -! store_all_simvals -! write_continuous_simvals -! obsOutputList.WriteOutputLines -! -! BINARY OUTPUT: -! -! When observation-output files are written, the user has the option to have -! output written to a binary file. Binary obs output files start with a -! 100-byte header structured as follows: -! -! bytes 1-4 (ascii): Observation type contained in file; options are: -! "sngl" -- Single observations -! "cont" -- Continuous observations -! byte 5: blank -! bytes 6-11 (ascii): Precision of all floating-point values; options are: -! "single" -- Single precision -! "double" -- Double precision -! bytes 12-15 (ascii): LENOBSNAME (integer; length of observation names, -! in bytes) -! bytes 16-100: blank -! -! IN A FILE OF CONTINUOUS OBSERVATIONS: -! -! The 100-byte header is followed by: -! NOBS (4-byte integer) -- Number of observations. -! NOBS repetitions of OBSNAME (ascii, LENOBSNAME bytes each). -! Any number of repetitions of: -! TIME SIMVAL-1 SIMVAL-2 ... SIMVAL-NOBS (floating point) -! -!------------------------------------------------------------------------------- -module ObsModule - - use KindModule, only: DP, I4B - use ArrayHandlersModule, only: ExpandArray - use BaseDisModule, only: DisBaseType - use BlockParserModule, only: BlockParserType - use ConstantsModule, only: LENBIGLINE, LENFTYPE, LENOBSNAME, & - LENOBSTYPE, LENPACKAGENAME, LENBOUNDNAME, & - LINELENGTH, NAMEDBOUNDFLAG, MAXCHARLEN, & - MAXOBSTYPES, LENHUGELINE, DNODATA, & - TABLEFT - use TableModule, only: TableType, table_cr - use InputOutputModule, only: UPCASE, openfile, GetUnit, GetFileFromPath - use ListModule, only: ListType - use ObsContainerModule, only: ObsContainerType - use ObserveModule, only: ConstructObservation, ObsDataType, & - ObserveType, GetObsFromList, & - AddObsToList - use ObsOutputListModule, only: ObsOutputListType - use ObsOutputModule, only: ObsOutputType - use ObsUtilityModule, only: write_fmtd_cont, write_unfmtd_cont - use OpenSpecModule, only: ACCESS, FORM - use SimModule, only: count_errors, store_error, store_error_unit, & - ustop - use StringListModule, only: AddStringToList, GetStringFromList - use TdisModule, only: totim - - implicit none - - private - public :: ObsType, DefaultObsIdProcessor, obs_cr - - type :: ObsType - ! -- Public members - integer(I4B), public :: iout = 0 - integer(I4B), public :: npakobs = 0 - integer(I4B), pointer, public :: inUnitObs => null() - character(len=LINELENGTH), pointer, public :: inputFilename => null() - character(len=2*LENPACKAGENAME+4), public :: pkgName = '' - character(len=LENFTYPE), public :: filtyp = '' - logical, pointer, public :: active => null() - type(ObsContainerType), dimension(:), pointer, public :: pakobs => null() - type(ObsDataType), dimension(:), pointer, public :: obsData => null() - ! -- Private members - integer(I4B), private :: iprecision = 2 ! 2=double; 1=single - integer(I4B), private :: idigits = 5 - character(len=LINELENGTH), private :: outputFilename = '' - character(len=LINELENGTH), private :: blockTypeFound = '' - character(len=20), private:: obsfmtcont = '' - logical, private :: echo = .false. - logical, private :: more - type(ListType), private :: obsList - type(ObsOutputListType), pointer, private :: obsOutputList => null() - class(DisBaseType), pointer, private :: dis => null() - type(BlockParserType), private :: parser - ! - ! -- table object - type(TableType), pointer :: obstab => null() - contains - ! -- Public procedures - procedure, public :: obs_df - procedure, public :: obs_ar - procedure, public :: obs_ad - procedure, public :: obs_bd_clear - procedure, public :: obs_ot - procedure, public :: obs_da - procedure, public :: SaveOneSimval - procedure, public :: StoreObsType - procedure, public :: allocate_scalars - ! -- Private procedures - procedure, private :: build_headers - procedure, private :: define_fmts - procedure, private :: get_num - procedure, private :: get_obs - procedure, private :: get_obs_array - procedure, private :: get_obs_datum - procedure, private :: obs_ar1 - procedure, private :: obs_ar2 - procedure, private :: populate_obs_array - procedure, private :: read_observations - procedure, private :: read_obs_blocks - procedure, private :: read_obs_options - procedure, private :: write_continuous_simvals - end type ObsType - -contains - - ! Non-type-bound procedures - - subroutine obs_cr(obs, inobs) -! ****************************************************************************** -! obs_cr -- Create a new ObsType object -! Subroutine: (1) creates object -! (2) allocates pointers -! (3) initializes values -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - type(ObsType), pointer, intent(out) :: obs - integer(I4B), pointer, intent(in) :: inobs - ! - allocate(obs) - call obs%allocate_scalars() - obs%inUnitObs => inobs - ! - return - end subroutine obs_cr - - subroutine DefaultObsIdProcessor(obsrv, dis, inunitobs, iout) -! ****************************************************************************** -! DefaultObsIdProcessor -- Process IDstring provided for each observation. The -! IDstring identifies the location in the model of the node(s) or feature(s) -! where the simulated value is to be extracted and recorded. -! Subroutine: (1) interprets the IDstring -! (2) stores the location of interest in the ObserveType object that -! contains information about the observation -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - type(ObserveType), intent(inout) :: obsrv - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: inunitobs - integer(I4B), intent(in) :: iout - ! -- local - integer(I4B) :: n - integer(I4B) :: icol, istart, istop - character(len=LINELENGTH) :: ermsg, strng - logical :: flag_string - ! - ! -- Initialize variables - strng = obsrv%IDstring - icol = 1 - flag_string = .true. ! Allow strng to contain a boundary name - ! - n = dis%noder_from_string(icol, istart, istop, inunitobs, & - iout, strng, flag_string) - ! - if (n > 0) then - obsrv%NodeNumber = n - elseif (n == -2) then - ! Integer can't be read from strng; it's presumed to be a boundary - ! name (already converted to uppercase) - obsrv%FeatureName = strng(istart:istop) - ! -- Observation may require summing rates from multiple boundaries, - ! so assign NodeNumber as a value that indicates observation - ! is for a named boundary or group of boundaries. - obsrv%NodeNumber = NAMEDBOUNDFLAG - else - ermsg = 'Error reading data from ID string' - call store_error(ermsg) - call store_error_unit(inunitobs) - call ustop() - endif - ! - return - end subroutine DefaultObsIdProcessor - - ! Type-bound public procedures - - subroutine obs_df(this, iout, pkgname, filtyp, dis) -! ****************************************************************************** -! obs_df -- Define some members of an ObsType object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - class(ObsType), intent(inout) :: this - integer(I4B), intent(in) :: iout - character(len=*), intent(in) :: pkgname - character(len=*), intent(in) :: filtyp - class(DisBaseType), pointer :: dis - ! - this%iout = iout - this%pkgName = pkgname - this%filtyp = filtyp - this%dis => dis - ! - ! -- Initialize block parser - call this%parser%Initialize(this%inUnitObs, this%iout) - ! - return - end subroutine obs_df - - subroutine obs_ar(this) -! ****************************************************************************** -! obs_ar -- ObsType Allocate and Read -! Subroutine: (1) reads OPTIONS block of OBS input file -! (2) reads CONTINUOUS blocks of OBS input file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - class(ObsType) :: this - ! - call this%obs_ar1(this%pkgName) - if (this%active) then - call this%obs_ar2(this%dis) - endif - ! - return - end subroutine obs_ar - - subroutine obs_ad(this) -! ****************************************************************************** -! obs_ad -- Observation Time Step Advance -! Subroutine: (1) For each observation, resets "current" value -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - class(ObsType) :: this - ! -- local - integer(I4B) :: i, n - class(ObserveType), pointer :: obsrv => null() - ! - n = this%get_num() - do i=1,n - obsrv => this%get_obs(i) - call obsrv%ResetCurrent() - enddo - ! - return - end subroutine obs_ad - - subroutine obs_bd_clear(this) -! ************************************************************************** -! obs_bd_clear -- Clear output lines in preparation for new rows of -! continuous observations -! Subroutine: (1) Clears contents of all lineout members of obsOutputList -! at start of a new time step -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - implicit none - ! -- dummy - class(ObsType), target :: this - ! - call this%obsOutputList%ClearOutputLines() - ! - return - end subroutine obs_bd_clear - - subroutine obs_ot(this) -! ****************************************************************************** -! obs_ot -- Observation Output -! Subroutine: (1) stores each simulated value into its ObserveType object -! (2) writes each simulated value to it ObsOutputList object -! (3) writes contents of ObsOutputList to output file -! Note: This procedure should NOT be called from a package's _ot procedure -! because the package _ot procedure may not be called every time step. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - class(ObsType), intent(inout) :: this - ! - if (this%npakobs > 0) then - call this%write_continuous_simvals() - call this%obsOutputList%WriteOutputLines() - endif - ! - return - end subroutine obs_ot - - subroutine obs_da(this) -! ****************************************************************************** -! obs_da -- Observation Output -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(ObsType), intent(inout) :: this - ! -- local - integer(I4B) :: i - ! - deallocate(this%active) - deallocate(this%inputFilename) - deallocate(this%obsData) - ! - ! -- obs table object - if (associated(this%obstab)) then - call this%obstab%table_da() - deallocate(this%obstab) - nullify(this%obstab) - end if - ! - ! -- deallocate pakobs components and pakobs - if (associated(this%pakobs)) then - do i = 1, this%npakobs - if (allocated(this%pakobs(i)%obsrv%indxbnds)) then - deallocate(this%pakobs(i)%obsrv%indxbnds) - end if - ! - ! -- nullify pointer to this%pakobs(i)%obsrv - ! deallocate does not work in gfortran-8 since no - ! allocatable variables in obsrv except for indxbnds - nullify(this%pakobs(i)%obsrv) - end do - deallocate(this%pakobs) - end if - ! - ! -- deallocate obsOutputList - call this%obsOutputList%DeallocObsOutputList() - deallocate(this%obsOutputList) - ! - ! -- deallocate obslist - call this%obslist%Clear() - ! - ! -- nullify - nullify(this%inUnitObs) - ! - return - end subroutine obs_da - - subroutine SaveOneSimval(this, obsrv, simval) -! ************************************************************************** -! SaveOneSimval -! Subroutine: (1) saves or accumulates a simulated value to its ObserveType -! object -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - implicit none - ! -- dummy - class(ObsType) :: this - class(ObserveType), intent(inout) :: obsrv - real(DP), intent(in) :: simval - ! -- local - character(len=LENOBSTYPE) :: obsTypeID - type(ObsDataType), pointer :: obsDatum => null() - ! - ! -- initialize variables - obsTypeID = obsrv%ObsTypeId - obsDatum => this%get_obs_datum(obsTypeID) - ! - ! -- save current simulation time - obsrv%CurrentTimeStepEndTime = totim - ! - ! -- assign or accumulate simulated value - if (obsDatum%Cumulative .and. simval /= DNODATA) then - obsrv%CurrentTimeStepEndValue = obsrv%CurrentTimeStepEndValue + simval - else - obsrv%CurrentTimeStepEndValue = simval - endif - ! - return - end subroutine SaveOneSimval - - subroutine StoreObsType(this, obsrvType, cumulative, indx) -! ************************************************************************** -! StoreObsType -! Subroutine: (1) stores type name and related information for an -! observation type that belongs to a package or model in -! the obsData array -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - implicit none - ! -- dummy - class(ObsType), intent(inout) :: this - character(len=*), intent(in) :: obsrvType - ! cumulative: Accumulate simulated values for multiple boundaries - logical, intent(in) :: cumulative - integer(I4B), intent(out) :: indx - ! -- local - integer(I4B) :: i - character(len=LENOBSTYPE) :: obsTypeUpper - character(len=100) :: msg - ! - ! -- Ensure that obsrvType is not blank - if (obsrvType=='') then - msg = 'Programmer error: Invalid argument in store_obs_type.' - call store_error(msg) - call ustop() - endif - ! - ! -- Find first unused element - indx = -1 - do i=1,MAXOBSTYPES - if (this%obsData(i)%ObsTypeID /= '') cycle - indx = i - exit - enddo - ! - ! -- Ensure that array size is not exceeded - if (indx == -1) then - msg = 'Size of obsData array is insufficient; ' & - // 'need to increase MAXOBSTYPES.' - call store_error(msg) - call store_error_unit(this%inUnitObs) - call ustop() - endif - ! - ! -- Convert character argument to upper case - obsTypeUpper = obsrvType - call upcase(obsTypeUpper) - ! - ! -- Assign members - this%obsData(indx)%ObsTypeID = obsTypeUpper - this%obsData(indx)%Cumulative = cumulative - ! - return - end subroutine StoreObsType - - ! Type-bound private procedures - - subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -- Allocate memory for non-allocatable members -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(ObsType) :: this -! ------------------------------------------------------------------------------ - ! - allocate(this%active) - allocate(this%inputFilename) - allocate(this%obsOutputList) - allocate(this%obsData(MAXOBSTYPES)) - ! - ! -- Initialize - this%active = .false. - this%inputFilename = '' - ! - ! -- Return - return - end subroutine allocate_scalars - - subroutine obs_ar1(this, pkgname) -! ************************************************************************** -! obs_ar1 -! -- read OPTIONS block of OBS input file and define output formats. -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - implicit none - ! -- dummy - class(ObsType), intent(inout) :: this - character(len=*), intent(in) :: pkgname - ! -- formats - 10 format(/,'The observation utility is active for "',a,'"') -! ------------------------------------------------------------------------------ - ! - if (this%inUnitObs > 0) then - this%active = .true. - ! - ! -- Indicate that OBS is active - write(this%iout,10)trim(pkgname) - ! - ! -- Read Options block - call this%read_obs_options() - ! - ! -- define output formats - call this%define_fmts() - endif - ! - return - end subroutine obs_ar1 - - subroutine obs_ar2(this, dis) -! ************************************************************************** -! obs_ar2 -! -- Call procedure provided by package to interpret IDstring and -! store required data. -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - implicit none - ! -- dummy - class(ObsType), intent(inout) :: this - class(DisBaseType) :: dis - ! -- local - integer(I4B) :: i - type(ObsDataType), pointer :: obsDat => null() - character(len=LENOBSTYPE) :: obsTypeID - class(ObserveType), pointer :: obsrv => null() - ! - call this%read_observations() - ! -- allocate and populate observations array - call this%get_obs_array(this%npakobs, this%pakobs) - ! - do i=1,this%npakobs - obsrv => this%pakobs(i)%obsrv - ! -- Call IDstring processor procedure provided by package - obsTypeID = obsrv%ObsTypeId - obsDat => this%get_obs_datum(obsTypeID) - if (associated(obsDat%ProcessIdPtr)) then - call obsDat%ProcessIdPtr(obsrv, dis, & - this%inUnitObs, this%iout) - else - call DefaultObsIdProcessor(obsrv, dis, & - this%inUnitObs, this%iout) - endif - enddo - ! - if (count_errors() > 0) then - call store_error_unit(this%inunitobs) - call ustop() - end if - ! - return - end subroutine obs_ar2 - - subroutine read_obs_options(this) -! ************************************************************************** -! read_obs_options -! -- read OPTIONS block of OBS input file -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - implicit none - ! -- dummy - class(ObsType) :: this - ! -- local - integer(I4B) :: iin - integer(I4B) :: ierr - integer(I4B) :: localprecision - integer(I4B) :: localdigits - character(len=40) :: keyword - character(len=LINELENGTH) :: ermsg - character(len=LINELENGTH) :: errormessage, fname - type(ListType), pointer :: lineList => null() - logical :: continueread, found, endOfBlock - ! -- formats -10 format('No options block found in OBS input. Defaults will be used.') -40 format('Text output number of digits of precision set to: ',i2) -60 format(/,'Processing observation options:',/) - ! - localprecision = 0 - localdigits = 0 - lineList => null() - ! - ! -- Find and store file name - iin = this%inUnitObs - inquire(unit=iin, name=fname) - this%inputFilename = fname - ! - ! -- Read Options block - continueread = .false. - ierr = 0 - ! - ! -- get BEGIN line of OPTIONS block - call this%parser%GetBlock('OPTIONS', found, ierr, & - supportOpenClose=.true., blockRequired=.false.) - if (ierr /= 0) then - ! end of file - ermsg = 'End-of-file encountered while searching for' // & - ' OPTIONS in OBS ' // & - 'input file "' // trim(this%inputFilename) // '"' - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - elseif (.not. found) then - this%blockTypeFound = '' - if (this%iout>0) write(this%iout,10) - endif - ! - ! -- parse OPTIONS entries - if (found) then - write(this%iout,60) - readblockoptions: do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('DIGITS') - ! -- Specifies number of significant digits used writing simulated - ! values to a text file. Default is 5 digits. - if (localdigits==0) then - localdigits = this%parser%GetInteger() - if (localdigits < 1) then - errormessage = 'Error in OBS input: Invalid value for DIGITS option' - call store_error(errormessage) - exit readblockoptions - endif - if (localdigits < 2) localdigits = 2 - if (localdigits > 16) localdigits = 16 - write(this%iout,40)localdigits - else - errormessage = 'Error in OBS input: DIGITS has already been defined' - call store_error(errormessage) - exit readblockoptions - endif - case ('PRINT_INPUT') - this%echo = .true. - write(this%iout,'(a)')'The PRINT_INPUT option has been specified.' - case default - errormessage = 'Error in OBS input: Unrecognized option: ' // & - trim(keyword) - call store_error(errormessage) - exit readblockoptions - end select - enddo readblockoptions - endif - ! - if (count_errors()>0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - write(this%iout,'(1x)') - ! - ! -- Assign type variables - if (localprecision>0) this%iprecision = localprecision - if (localdigits>0) this%idigits = localdigits - ! - return - end subroutine read_obs_options - - subroutine define_fmts(this) -! ************************************************************************** -! define_fmts -! -- define output formats for single and continuous observations -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - implicit none - ! -- dummy - class(ObsType) :: this - ! formats - 50 format('(g',i2.2,'.',i2.2,')') - ! - write(this%obsfmtcont,50)this%idigits+7, this%idigits - return - end subroutine define_fmts - - subroutine read_observations(this) -! ************************************************************************** -! read_observations -! -- read CONTINUOUS blocks from OBS input file -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - implicit none - ! -- dummy - class(ObsType) :: this - ! -- local - ! - ! -- Read CONTINUOUS blocks and store observations - call this%read_obs_blocks(this%outputFilename) - ! - ! -- build headers - call this%build_headers() - ! - return - end subroutine read_observations - - function get_num(this) -! ************************************************************************** -! get_num -! -- Return the number of observations contained in this ObsType object -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - implicit none - ! -- return - integer(I4B) :: get_num - ! -- dummy - class(ObsType) :: this - get_num = this%obsList%Count() - return - end function get_num - - subroutine build_headers(this) -! ************************************************************************** -! build_headers -! -- Build headers for CSV-formatted and unformatted continuous-observation -! output files and write them to those files. -! Each formatted header will have the form: "time,obsname-1,obsname-2, ..." -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - use iso_fortran_env, only: int32 - implicit none - ! -- dummy - class(ObsType), target :: this - ! -- local - integer(I4B) :: i, ii, idx, indx, iu, num, nunit - integer(int32) :: nobs - character(len=LENOBSNAME), pointer :: headr => null() - character(len=LENOBSNAME) :: nam - character(len=4) :: clenobsname - type(ObserveType), pointer :: obsrv => null() - type(ObsOutputType), pointer :: obsOutput => null() - ! - ! -- - num = this%obsList%Count() - ! -- Cycle through observations to build the header(s) - if (num>0) then - do i=1,num - obsrv => this%get_obs(i) - ! -- header for file of continuous observations - indx = obsrv%indxObsOutput - obsOutput => this%obsOutputList%Get(indx) - headr => obsOutput%header - if (headr == '') then - headr = 'time' - endif - nam = obsrv%Name - call ExpandArray(obsOutput%obsnames) - idx = size(obsOutput%obsnames) - obsOutput%obsnames(idx) = nam - enddo - endif - ! - ! -- Cycle through ObsOutputList to write headers - ! to formatted and unformatted file(s). - num = this%obsOutputList%Count() - do i=1,num - obsOutput => this%obsOutputList%Get(i) - if (obsOutput%FormattedOutput) then - ! -- write header to formatted file - headr => obsOutput%header - if (headr /= '') then - nobs = obsOutput%nobs - iu = obsOutput%nunit - write(iu, '(a)', advance='NO') 'time' - do ii = 1,nobs - write(iu, '(a,a)', advance='NO') ',', trim(obsOutput%obsnames(ii)) - enddo - write(iu, '(a)', advance='YES') '' - endif - else - ! -- write header to unformatted file - ! First 11 bytes are obs type and precision - nunit = obsOutput%nunit - if (this%iprecision==1) then - ! -- single precision output - write(nunit)'cont single' - elseif (this%iprecision==2) then - ! -- double precision output - write(nunit)'cont double' - endif - ! -- write LENOBSNAME to bytes 12-15 - write(clenobsname,'(i4)')LENOBSNAME - write(nunit)clenobsname - ! -- write blanks to complete 100-byte header - do ii=16,100 - write(nunit)' ' - enddo - ! -- write NOBS - nobs = obsOutput%nobs - write(nunit)nobs - ! -- write NOBS * (LENOBSNAME-character observation name) - do ii=1,nobs - write(nunit)obsOutput%obsnames(ii) - enddo - endif - enddo - ! - return - end subroutine build_headers - - subroutine get_obs_array(this, nObs, obsArray) -! ************************************************************************** -! get_obs_array -! -- Get an array containing all observations in this ObsType object -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - implicit none - ! -- dummy - class(ObsType), intent(inout) :: this - integer(I4B), intent(out) :: nObs - type(ObsContainerType), dimension(:), pointer, intent(inout) :: obsArray - ! -- local - ! - nObs = this%get_num() - if (associated(obsArray)) deallocate(obsArray) - allocate(obsArray(nObs)) - ! - ! Get observations - if (nObs > 0) then - call this%populate_obs_array(nObs, obsArray) - endif - ! - return - end subroutine get_obs_array - - function get_obs_datum(this, obsTypeID) result(obsDatum) -! ************************************************************************** -! get_obs_datum -! -- Return an ObsDataType object for the specified observation type -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - implicit none - ! -- dummy - class(ObsType) :: this - character(len=*), intent(in) :: obsTypeID - type(ObsDataType), pointer :: obsDatum - ! -- local - integer(I4B) :: i - character( len=MAXCHARLEN) :: ermsg - ! - obsDatum => null() - do i=1,MAXOBSTYPES - if (this%obsData(i)%ObsTypeID == obsTypeID) then - obsDatum => this%obsData(I) - exit - endif - enddo - ! - if (.not. associated(obsDatum)) then - ermsg = 'Observation type not found: ' // trim(obsTypeID) - call store_error(ermsg) - call store_error_unit(this%inUnitObs) - call ustop() - endif - ! - return - end function get_obs_datum - - subroutine populate_obs_array(this, nObs, obsArray) -! ************************************************************************** -! populate_obs_array -! -- Populate obsArray with observations for specified package -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - implicit none - ! -- dummy - class(ObsType), intent(inout) :: this - integer(I4B), intent(in) :: nObs - type(ObsContainerType), dimension(nObs), intent(inout) :: obsArray - ! - ! -- local - integer(I4B) :: i, n - type(ObserveType), pointer :: obsrv => null() - ! - n = this%get_num() - do i=1,n - obsrv => this%get_obs(i) - obsArray(i)%obsrv => obsrv - enddo - ! - return - end subroutine populate_obs_array - - function get_obs(this, indx) result(obsrv) -! ************************************************************************** -! get_obs -! -- Return the specified ObserveType object from the list of observations -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - implicit none - ! -- dummy - class(ObsType) :: this - integer(I4B), intent(in) :: indx - class(ObserveType), pointer :: obsrv - ! -- local - ! - obsrv => GetObsFromList(this%obsList, indx) - ! - return - end function get_obs - - subroutine read_obs_blocks(this, fname) -! ************************************************************************** -! read_obs_blocks -! -- read CONTINUOUS blocks from the OBS input file -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - implicit none - ! -- dummy - class(ObsType), intent(inout) :: this - character(len=*), intent(inout) :: fname - ! -- local - integer(I4B) :: ierr, indexobsout, numspec - logical :: fmtd, found, endOfBlock - character(len=LENBIGLINE) :: pnamein, fnamein - character(len=LENHUGELINE) :: line - character(len=LINELENGTH) :: btagfound, ermsg, message, word - character(len=LINELENGTH) :: title - character(len=LINELENGTH) :: tag - character(len=20) :: accarg, bin, fmtarg - type(ObserveType), pointer :: obsrv => null() - type(ObsOutputType), pointer :: obsOutput => null() - integer(I4B) :: ntabrows - integer(I4B) :: ntabcols - ! -- formats - ! - ! -- initialize local variables - numspec = -1 - ermsg = '' - ! - inquire(unit=this%parser%iuactive, name=pnamein) - call GetFileFromPath(pnamein, fnamein) - ! - if (this%echo) then - ! - ! -- create the observation table - ! -- table dimensions - ntabrows = 1 - ntabcols = 5 - ! - ! -- initialize table and define columns - title = 'OBSERVATIONS READ FROM FILE "' // trim(fnamein) // '"' - call table_cr(this%obstab, fnamein, title) - call this%obstab%table_df(ntabrows, ntabcols, this%iout, & - finalize=.FALSE.) - tag = 'NAME' - call this%obstab%initialize_column(tag, LENOBSNAME, alignment=TABLEFT) - tag = 'TYPE' - call this%obstab%initialize_column(tag, LENOBSTYPE+12, alignment=TABLEFT) - tag = 'TIME' - call this%obstab%initialize_column(tag, 12, alignment=TABLEFT) - tag = 'LOCATION DATA' - call this%obstab%initialize_column(tag, LENBOUNDNAME+2, alignment=TABLEFT) - tag = 'OUTPUT FILENAME' - call this%obstab%initialize_column(tag, 80, alignment=TABLEFT) - end if - ! - found = .true. - readblocks: do - if (.not. found) exit - ! - call this%parser%GetBlock('*', found, ierr, .true., .false., btagfound) - if (.not. found) then - exit readblocks - end if - this%blockTypeFound = btagfound - ! - ! Get keyword, which should be FILEOUT - call this%parser%GetStringCaps(word) - if (word /= 'FILEOUT') then - call store_error('CONTINUOUS keyword must be followed by ' // & - '"FILEOUT" then by filename.') - cycle - end if - ! - ! -- get name of output file - call this%parser%GetString(fname) - ! Fname is the output file name defined in the BEGIN line of the block. - if (fname == '') then - message = 'Error reading OBS input file, likely due to bad' // & - ' block or missing file name.' - call store_error(message) - cycle - else if (this%obsOutputList%ContainsFile(fname)) then - ermsg = 'OBS outfile "' // trim(fname) // & - '" is provided more than once.' - call store_error(ermsg) - cycle - end if - ! - ! -- look for BINARY option - call this%parser%GetStringCaps(bin) - if (bin == 'BINARY') then - fmtarg = FORM - accarg = ACCESS - fmtd = .false. - else - fmtarg = 'FORMATTED' - accarg = 'SEQUENTIAL' - fmtd = .true. - endif - ! - ! -- open the output file - numspec = 0 - call openfile(numspec, 0, fname, 'OBS OUTPUT', fmtarg, & - accarg, 'REPLACE') - ! - ! -- add output file to list of output files and assign its - ! FormattedOutput member appropriately - call this%obsOutputList%Add(fname,numspec) - indexobsout = this%obsOutputList%Count() - obsOutput => this%obsOutputList%Get(indexobsout) - obsOutput%FormattedOutput = fmtd - ! - ! -- process lines defining observations - select case (btagfound) - case ('CONTINUOUS') - ! - ! -- construct a continuous observation from each line in the block - readblockcontinuous: do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetCurrentLine(line) - call ConstructObservation(obsrv, line, numspec, fmtd, & - indexobsout, this%obsData, & - this%parser%iuactive) - ! - ! -- increment number of observations - ! to be written to this output file. - obsOutput => this%obsOutputList%Get(indexobsout) - obsOutput%nobs = obsOutput%nobs + 1 - call AddObsToList(this%obsList, obsrv) - ! - ! -- write line to the observation table - if (this%echo) then - call obsrv%WriteTo(this%obstab, btagfound, fname) - end if - end do readblockcontinuous - case default - ermsg = 'Error: Observation block type not recognized: ' // & - trim(btagfound) - call store_error(ermsg) - end select - end do readblocks - ! - ! -- finalize the observation table - if (this%echo) then - call this%obstab%finalize_table() - end if - ! - ! -- determine if error condition occurs - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- return - return - end subroutine read_obs_blocks - - subroutine write_continuous_simvals(this) -! ************************************************************************** -! write_continuous_simvals -! Subroutine: (1) for each continuous observation, writes value to output -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- - implicit none - ! -- dummy - class(ObsType), intent(inout) :: this - ! -- local - integer(I4B) :: i, iprec, numobs - character(len=20) :: fmtc - real(DP) :: simval - class(ObserveType), pointer :: obsrv => null() - !--------------------------------------------------------------------------- - ! - ! Write simulated values for observations - iprec = this%iprecision - fmtc = this%obsfmtcont - ! -- iterate through all observations - numobs = this%obsList%Count() - do i=1,numobs - obsrv => this%get_obs(i) - ! -- continuous observation - simval = obsrv%CurrentTimeStepEndValue - if (obsrv%FormattedOutput) then - call write_fmtd_cont(fmtc, obsrv, this%obsOutputList, simval) - else - call write_unfmtd_cont(obsrv, iprec, this%obsOutputList, simval) - endif - enddo - ! - return - end subroutine write_continuous_simvals - -end module ObsModule +! This module defines type ObsType, which is the highest-level +! derived type for implementing observations. All objects derived from +! NumericalModelType or BndType already contain an ObsType member. +! +! Examples: +! NumericalModelType.obs +! BndType.obs +! +! Similarly, an ObsType member could be added to, say, +! NumericalExchangeType or any other type that has DF, AR, RP, AD, BD, and OT +! routines. +! +! ------------------------------------------------------------------------------ +! IMPLEMENTATION OF OBSERVATIONS IN A MODEL OR PACKAGE +! +! For simple boundary packages like RIV and DRN, only steps 1-6 are +! needed. For models and advanced packages like MAW and SFR, additional +! steps are needed. +! +! 1. (package only) Override BndType.bnd_obs_supported to return true. +! bnd_obs_supported is called from various places in code. +! +! 2. (optional) Write a subroutine that implements abstract interface +! ObserveModule.ProcessIdSub. (Not needed if IDstring, which identifies +! location in model to be observed, is either a single node number or +! a single {lay, row, col} set of indices). +! +! Examples: +! gwf_process_head_drawdown_obs_id, gwf_process_intercell_obs_id +! +! A package can allow IDstring to be a boundary name. +! Example: ObsModule.DefaultObsIdProcessor +! +! 3. Override BndType.bnd_df_obs() to define string(s) to be +! recognized as observation type(s) and (optional) assign ProcessIdPtr +! (not needed if IDstring is either a node number or a {lay, row, col} +! set of indices). +! +! Examples: gwf_df_obs, drn_df_obs +! +! When boundary names are allowed and developer wants simulated value +! to be cumulative (flow, for example) if user specifies multiple +! boundaries with the same BOUNDNAME, in bnd_df_obs call to +! ObsPackage.StoreObsType, provide cumulative argument as true. +! Otherwise, simulated values are not cumulative. +! +! 4. In DF routine: Call bnd_df_obs +! +! 5. In AR routine: Call ObsType.obs_ar. This reads the OBS input +! file. +! Example (gwf_ar): call this%obs%obs_ar() +! Example (lak_ar): call this%obs%obs_ar() +! +! 6. Override BndType.bnd_rp_obs for any package that needs to +! check user input or process observation input in any special way. +! If no special processing is needed, BndType.bnd_rp_obs can +! be used. This routine also expands the ObserveType%indxbnds array for +! each observation in a package. ObserveType%indxbnds is used to sum +! simulated values from multiple boundaries when BOUNDNAMES is used. +! Equivalent routine may or may not be needed for model observations. +! If needed, call it from bottom of RP routine. +! +! Examples: +! BndType.bnd_rp_obs, which is called from gwf_rp +! +! 7. In AD routine: Call ObsType.obs_ad +! Example: gwf_ad +! +! 8. Write a *_bd_obs routine. This is the routine that actually +! calculates the simulated value for each observation type supported +! by the model/package. Call *_bd_obs from the bottom of the +! _bd routine. +! *_bd_obs needs to: +! Call ObsType.obs_bd_clear +! For each observation: +! Calculate the simulated value +! Call ObsType.SaveOneSimval +! Examples: gwf_bd_obs, maw_bd_obs, lak_bd_obs +! +! 9. In BD routine: +! Call BndType.bnd_bd_obs +! Examples: BndType.bnd_bd calls bnd_bd_obs +! GwfModelType.gwf_bd calls gwf_bd_obs +! MawType.maw_bd calls maw_bd_obs +! LakType.lak_bd calls lak_bd_obs +! +! 10. Ensure that ObsType.obs_ot is called. For packages, obs_ot is called +! from the model _ot procedure. The model _ot procedure should also call +! obs_ot for its own observations. Do not call obs_ot from a package _ot +! procedure because the package _ot procedure may not be called, depending +! on Output Control settings (ibudfl). +! +! Note: BndType.bnd_ot_obs calls: +! ObsType.obs_ot +! +! Note: ObsType.obs_ot calls: +! store_all_simvals +! write_continuous_simvals +! obsOutputList.WriteOutputLines +! +! BINARY OUTPUT: +! +! When observation-output files are written, the user has the option to have +! output written to a binary file. Binary obs output files start with a +! 100-byte header structured as follows: +! +! bytes 1-4 (ascii): Observation type contained in file; options are: +! "sngl" -- Single observations +! "cont" -- Continuous observations +! byte 5: blank +! bytes 6-11 (ascii): Precision of all floating-point values; options are: +! "single" -- Single precision +! "double" -- Double precision +! bytes 12-15 (ascii): LENOBSNAME (integer; length of observation names, +! in bytes) +! bytes 16-100: blank +! +! IN A FILE OF CONTINUOUS OBSERVATIONS: +! +! The 100-byte header is followed by: +! NOBS (4-byte integer) -- Number of observations. +! NOBS repetitions of OBSNAME (ascii, LENOBSNAME bytes each). +! Any number of repetitions of: +! TIME SIMVAL-1 SIMVAL-2 ... SIMVAL-NOBS (floating point) +! +!------------------------------------------------------------------------------- +module ObsModule + + use KindModule, only: DP, I4B + use ArrayHandlersModule, only: ExpandArray + use BaseDisModule, only: DisBaseType + use BlockParserModule, only: BlockParserType + use ConstantsModule, only: LENBIGLINE, LENFTYPE, LENOBSNAME, & + LENOBSTYPE, LENPACKAGENAME, LENBOUNDNAME, & + LINELENGTH, NAMEDBOUNDFLAG, MAXCHARLEN, & + MAXOBSTYPES, LENHUGELINE, DNODATA, & + TABLEFT + use TableModule, only: TableType, table_cr + use InputOutputModule, only: UPCASE, openfile, GetUnit, GetFileFromPath + use ListModule, only: ListType + use ObsContainerModule, only: ObsContainerType + use ObserveModule, only: ConstructObservation, ObsDataType, & + ObserveType, GetObsFromList, & + AddObsToList + use ObsOutputListModule, only: ObsOutputListType + use ObsOutputModule, only: ObsOutputType + use ObsUtilityModule, only: write_fmtd_cont, write_unfmtd_cont + use OpenSpecModule, only: ACCESS, FORM + use SimModule, only: count_errors, store_error, store_error_unit, & + ustop + use StringListModule, only: AddStringToList, GetStringFromList + use TdisModule, only: totim + + implicit none + + private + public :: ObsType, DefaultObsIdProcessor, obs_cr + + type :: ObsType + ! -- Public members + integer(I4B), public :: iout = 0 + integer(I4B), public :: npakobs = 0 + integer(I4B), pointer, public :: inUnitObs => null() + character(len=LINELENGTH), pointer, public :: inputFilename => null() + character(len=2*LENPACKAGENAME+4), public :: pkgName = '' + character(len=LENFTYPE), public :: filtyp = '' + logical, pointer, public :: active => null() + type(ObsContainerType), dimension(:), pointer, public :: pakobs => null() + type(ObsDataType), dimension(:), pointer, public :: obsData => null() + ! -- Private members + integer(I4B), private :: iprecision = 2 ! 2=double; 1=single + integer(I4B), private :: idigits = 5 + character(len=LINELENGTH), private :: outputFilename = '' + character(len=LINELENGTH), private :: blockTypeFound = '' + character(len=20), private:: obsfmtcont = '' + logical, private :: echo = .false. + logical, private :: more + type(ListType), private :: obsList + type(ObsOutputListType), pointer, private :: obsOutputList => null() + class(DisBaseType), pointer, private :: dis => null() + type(BlockParserType), private :: parser + ! + ! -- table object + type(TableType), pointer :: obstab => null() + contains + ! -- Public procedures + procedure, public :: obs_df + procedure, public :: obs_ar + procedure, public :: obs_ad + procedure, public :: obs_bd_clear + procedure, public :: obs_ot + procedure, public :: obs_da + procedure, public :: SaveOneSimval + procedure, public :: StoreObsType + procedure, public :: allocate_scalars + ! -- Private procedures + procedure, private :: build_headers + procedure, private :: define_fmts + procedure, private :: get_num + procedure, private :: get_obs + procedure, private :: get_obs_array + procedure, private :: get_obs_datum + procedure, private :: obs_ar1 + procedure, private :: obs_ar2 + procedure, private :: populate_obs_array + procedure, private :: read_observations + procedure, private :: read_obs_blocks + procedure, private :: read_obs_options + procedure, private :: write_continuous_simvals + end type ObsType + +contains + + ! Non-type-bound procedures + + subroutine obs_cr(obs, inobs) +! ****************************************************************************** +! obs_cr -- Create a new ObsType object +! Subroutine: (1) creates object +! (2) allocates pointers +! (3) initializes values +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + ! -- dummy + type(ObsType), pointer, intent(out) :: obs + integer(I4B), pointer, intent(in) :: inobs + ! + allocate(obs) + call obs%allocate_scalars() + obs%inUnitObs => inobs + ! + return + end subroutine obs_cr + + subroutine DefaultObsIdProcessor(obsrv, dis, inunitobs, iout) +! ****************************************************************************** +! DefaultObsIdProcessor -- Process IDstring provided for each observation. The +! IDstring identifies the location in the model of the node(s) or feature(s) +! where the simulated value is to be extracted and recorded. +! Subroutine: (1) interprets the IDstring +! (2) stores the location of interest in the ObserveType object that +! contains information about the observation +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + ! -- dummy + type(ObserveType), intent(inout) :: obsrv + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: inunitobs + integer(I4B), intent(in) :: iout + ! -- local + integer(I4B) :: n + integer(I4B) :: icol, istart, istop + character(len=LINELENGTH) :: ermsg, strng + logical :: flag_string + ! + ! -- Initialize variables + strng = obsrv%IDstring + icol = 1 + flag_string = .true. ! Allow strng to contain a boundary name + ! + n = dis%noder_from_string(icol, istart, istop, inunitobs, & + iout, strng, flag_string) + ! + if (n > 0) then + obsrv%NodeNumber = n + elseif (n == -2) then + ! Integer can't be read from strng; it's presumed to be a boundary + ! name (already converted to uppercase) + obsrv%FeatureName = strng(istart:istop) + ! -- Observation may require summing rates from multiple boundaries, + ! so assign NodeNumber as a value that indicates observation + ! is for a named boundary or group of boundaries. + obsrv%NodeNumber = NAMEDBOUNDFLAG + else + ermsg = 'Error reading data from ID string' + call store_error(ermsg) + call store_error_unit(inunitobs) + call ustop() + endif + ! + return + end subroutine DefaultObsIdProcessor + + ! Type-bound public procedures + + subroutine obs_df(this, iout, pkgname, filtyp, dis) +! ****************************************************************************** +! obs_df -- Define some members of an ObsType object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + ! -- dummy + class(ObsType), intent(inout) :: this + integer(I4B), intent(in) :: iout + character(len=*), intent(in) :: pkgname + character(len=*), intent(in) :: filtyp + class(DisBaseType), pointer :: dis + ! + this%iout = iout + this%pkgName = pkgname + this%filtyp = filtyp + this%dis => dis + ! + ! -- Initialize block parser + call this%parser%Initialize(this%inUnitObs, this%iout) + ! + return + end subroutine obs_df + + subroutine obs_ar(this) +! ****************************************************************************** +! obs_ar -- ObsType Allocate and Read +! Subroutine: (1) reads OPTIONS block of OBS input file +! (2) reads CONTINUOUS blocks of OBS input file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + ! -- dummy + class(ObsType) :: this + ! + call this%obs_ar1(this%pkgName) + if (this%active) then + call this%obs_ar2(this%dis) + endif + ! + return + end subroutine obs_ar + + subroutine obs_ad(this) +! ****************************************************************************** +! obs_ad -- Observation Time Step Advance +! Subroutine: (1) For each observation, resets "current" value +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + ! -- dummy + class(ObsType) :: this + ! -- local + integer(I4B) :: i, n + class(ObserveType), pointer :: obsrv => null() + ! + n = this%get_num() + do i=1,n + obsrv => this%get_obs(i) + call obsrv%ResetCurrent() + enddo + ! + return + end subroutine obs_ad + + subroutine obs_bd_clear(this) +! ************************************************************************** +! obs_bd_clear -- Clear output lines in preparation for new rows of +! continuous observations +! Subroutine: (1) Clears contents of all lineout members of obsOutputList +! at start of a new time step +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + implicit none + ! -- dummy + class(ObsType), target :: this + ! + call this%obsOutputList%ClearOutputLines() + ! + return + end subroutine obs_bd_clear + + subroutine obs_ot(this) +! ****************************************************************************** +! obs_ot -- Observation Output +! Subroutine: (1) stores each simulated value into its ObserveType object +! (2) writes each simulated value to it ObsOutputList object +! (3) writes contents of ObsOutputList to output file +! Note: This procedure should NOT be called from a package's _ot procedure +! because the package _ot procedure may not be called every time step. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + implicit none + ! -- dummy + class(ObsType), intent(inout) :: this + ! + if (this%npakobs > 0) then + call this%write_continuous_simvals() + call this%obsOutputList%WriteOutputLines() + endif + ! + return + end subroutine obs_ot + + subroutine obs_da(this) +! ****************************************************************************** +! obs_da -- Observation Output +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(ObsType), intent(inout) :: this + ! -- local + integer(I4B) :: i + ! + deallocate(this%active) + deallocate(this%inputFilename) + deallocate(this%obsData) + ! + ! -- obs table object + if (associated(this%obstab)) then + call this%obstab%table_da() + deallocate(this%obstab) + nullify(this%obstab) + end if + ! + ! -- deallocate pakobs components and pakobs + if (associated(this%pakobs)) then + do i = 1, this%npakobs + if (allocated(this%pakobs(i)%obsrv%indxbnds)) then + deallocate(this%pakobs(i)%obsrv%indxbnds) + end if + ! + ! -- nullify pointer to this%pakobs(i)%obsrv + ! deallocate does not work in gfortran-8 since no + ! allocatable variables in obsrv except for indxbnds + nullify(this%pakobs(i)%obsrv) + end do + deallocate(this%pakobs) + end if + ! + ! -- deallocate obsOutputList + call this%obsOutputList%DeallocObsOutputList() + deallocate(this%obsOutputList) + ! + ! -- deallocate obslist + call this%obslist%Clear() + ! + ! -- nullify + nullify(this%inUnitObs) + ! + return + end subroutine obs_da + + subroutine SaveOneSimval(this, obsrv, simval) +! ************************************************************************** +! SaveOneSimval +! Subroutine: (1) saves or accumulates a simulated value to its ObserveType +! object +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + implicit none + ! -- dummy + class(ObsType) :: this + class(ObserveType), intent(inout) :: obsrv + real(DP), intent(in) :: simval + ! -- local + character(len=LENOBSTYPE) :: obsTypeID + type(ObsDataType), pointer :: obsDatum => null() + ! + ! -- initialize variables + obsTypeID = obsrv%ObsTypeId + obsDatum => this%get_obs_datum(obsTypeID) + ! + ! -- save current simulation time + obsrv%CurrentTimeStepEndTime = totim + ! + ! -- assign or accumulate simulated value + if (obsDatum%Cumulative .and. simval /= DNODATA) then + obsrv%CurrentTimeStepEndValue = obsrv%CurrentTimeStepEndValue + simval + else + obsrv%CurrentTimeStepEndValue = simval + endif + ! + return + end subroutine SaveOneSimval + + subroutine StoreObsType(this, obsrvType, cumulative, indx) +! ************************************************************************** +! StoreObsType +! Subroutine: (1) stores type name and related information for an +! observation type that belongs to a package or model in +! the obsData array +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + implicit none + ! -- dummy + class(ObsType), intent(inout) :: this + character(len=*), intent(in) :: obsrvType + ! cumulative: Accumulate simulated values for multiple boundaries + logical, intent(in) :: cumulative + integer(I4B), intent(out) :: indx + ! -- local + integer(I4B) :: i + character(len=LENOBSTYPE) :: obsTypeUpper + character(len=100) :: msg + ! + ! -- Ensure that obsrvType is not blank + if (obsrvType=='') then + msg = 'Programmer error: Invalid argument in store_obs_type.' + call store_error(msg) + call ustop() + endif + ! + ! -- Find first unused element + indx = -1 + do i=1,MAXOBSTYPES + if (this%obsData(i)%ObsTypeID /= '') cycle + indx = i + exit + enddo + ! + ! -- Ensure that array size is not exceeded + if (indx == -1) then + msg = 'Size of obsData array is insufficient; ' & + // 'need to increase MAXOBSTYPES.' + call store_error(msg) + call store_error_unit(this%inUnitObs) + call ustop() + endif + ! + ! -- Convert character argument to upper case + obsTypeUpper = obsrvType + call upcase(obsTypeUpper) + ! + ! -- Assign members + this%obsData(indx)%ObsTypeID = obsTypeUpper + this%obsData(indx)%Cumulative = cumulative + ! + return + end subroutine StoreObsType + + ! Type-bound private procedures + + subroutine allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars -- Allocate memory for non-allocatable members +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(ObsType) :: this +! ------------------------------------------------------------------------------ + ! + allocate(this%active) + allocate(this%inputFilename) + allocate(this%obsOutputList) + allocate(this%obsData(MAXOBSTYPES)) + ! + ! -- Initialize + this%active = .false. + this%inputFilename = '' + ! + ! -- Return + return + end subroutine allocate_scalars + + subroutine obs_ar1(this, pkgname) +! ************************************************************************** +! obs_ar1 +! -- read OPTIONS block of OBS input file and define output formats. +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + implicit none + ! -- dummy + class(ObsType), intent(inout) :: this + character(len=*), intent(in) :: pkgname + ! -- formats + 10 format(/,'The observation utility is active for "',a,'"') +! ------------------------------------------------------------------------------ + ! + if (this%inUnitObs > 0) then + this%active = .true. + ! + ! -- Indicate that OBS is active + write(this%iout,10)trim(pkgname) + ! + ! -- Read Options block + call this%read_obs_options() + ! + ! -- define output formats + call this%define_fmts() + endif + ! + return + end subroutine obs_ar1 + + subroutine obs_ar2(this, dis) +! ************************************************************************** +! obs_ar2 +! -- Call procedure provided by package to interpret IDstring and +! store required data. +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + implicit none + ! -- dummy + class(ObsType), intent(inout) :: this + class(DisBaseType) :: dis + ! -- local + integer(I4B) :: i + type(ObsDataType), pointer :: obsDat => null() + character(len=LENOBSTYPE) :: obsTypeID + class(ObserveType), pointer :: obsrv => null() + ! + call this%read_observations() + ! -- allocate and populate observations array + call this%get_obs_array(this%npakobs, this%pakobs) + ! + do i=1,this%npakobs + obsrv => this%pakobs(i)%obsrv + ! -- Call IDstring processor procedure provided by package + obsTypeID = obsrv%ObsTypeId + obsDat => this%get_obs_datum(obsTypeID) + if (associated(obsDat%ProcessIdPtr)) then + call obsDat%ProcessIdPtr(obsrv, dis, & + this%inUnitObs, this%iout) + else + call DefaultObsIdProcessor(obsrv, dis, & + this%inUnitObs, this%iout) + endif + enddo + ! + if (count_errors() > 0) then + call store_error_unit(this%inunitobs) + call ustop() + end if + ! + return + end subroutine obs_ar2 + + subroutine read_obs_options(this) +! ************************************************************************** +! read_obs_options +! -- read OPTIONS block of OBS input file +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + implicit none + ! -- dummy + class(ObsType) :: this + ! -- local + integer(I4B) :: iin + integer(I4B) :: ierr + integer(I4B) :: localprecision + integer(I4B) :: localdigits + character(len=40) :: keyword + character(len=LINELENGTH) :: ermsg + character(len=LINELENGTH) :: errormessage, fname + type(ListType), pointer :: lineList => null() + logical :: continueread, found, endOfBlock + ! -- formats +10 format('No options block found in OBS input. Defaults will be used.') +40 format('Text output number of digits of precision set to: ',i2) +60 format(/,'Processing observation options:',/) + ! + localprecision = 0 + localdigits = 0 + lineList => null() + ! + ! -- Find and store file name + iin = this%inUnitObs + inquire(unit=iin, name=fname) + this%inputFilename = fname + ! + ! -- Read Options block + continueread = .false. + ierr = 0 + ! + ! -- get BEGIN line of OPTIONS block + call this%parser%GetBlock('OPTIONS', found, ierr, & + supportOpenClose=.true., blockRequired=.false.) + if (ierr /= 0) then + ! end of file + ermsg = 'End-of-file encountered while searching for' // & + ' OPTIONS in OBS ' // & + 'input file "' // trim(this%inputFilename) // '"' + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + elseif (.not. found) then + this%blockTypeFound = '' + if (this%iout>0) write(this%iout,10) + endif + ! + ! -- parse OPTIONS entries + if (found) then + write(this%iout,60) + readblockoptions: do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('DIGITS') + ! -- Specifies number of significant digits used writing simulated + ! values to a text file. Default is 5 digits. + if (localdigits==0) then + localdigits = this%parser%GetInteger() + if (localdigits < 1) then + errormessage = 'Error in OBS input: Invalid value for DIGITS option' + call store_error(errormessage) + exit readblockoptions + endif + if (localdigits < 2) localdigits = 2 + if (localdigits > 16) localdigits = 16 + write(this%iout,40)localdigits + else + errormessage = 'Error in OBS input: DIGITS has already been defined' + call store_error(errormessage) + exit readblockoptions + endif + case ('PRINT_INPUT') + this%echo = .true. + write(this%iout,'(a)')'The PRINT_INPUT option has been specified.' + case default + errormessage = 'Error in OBS input: Unrecognized option: ' // & + trim(keyword) + call store_error(errormessage) + exit readblockoptions + end select + enddo readblockoptions + endif + ! + if (count_errors()>0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + write(this%iout,'(1x)') + ! + ! -- Assign type variables + if (localprecision>0) this%iprecision = localprecision + if (localdigits>0) this%idigits = localdigits + ! + return + end subroutine read_obs_options + + subroutine define_fmts(this) +! ************************************************************************** +! define_fmts +! -- define output formats for single and continuous observations +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + implicit none + ! -- dummy + class(ObsType) :: this + ! formats + 50 format('(g',i2.2,'.',i2.2,')') + ! + write(this%obsfmtcont,50)this%idigits+7, this%idigits + return + end subroutine define_fmts + + subroutine read_observations(this) +! ************************************************************************** +! read_observations +! -- read CONTINUOUS blocks from OBS input file +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + implicit none + ! -- dummy + class(ObsType) :: this + ! -- local + ! + ! -- Read CONTINUOUS blocks and store observations + call this%read_obs_blocks(this%outputFilename) + ! + ! -- build headers + call this%build_headers() + ! + return + end subroutine read_observations + + function get_num(this) +! ************************************************************************** +! get_num +! -- Return the number of observations contained in this ObsType object +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + implicit none + ! -- return + integer(I4B) :: get_num + ! -- dummy + class(ObsType) :: this + get_num = this%obsList%Count() + return + end function get_num + + subroutine build_headers(this) +! ************************************************************************** +! build_headers +! -- Build headers for CSV-formatted and unformatted continuous-observation +! output files and write them to those files. +! Each formatted header will have the form: "time,obsname-1,obsname-2, ..." +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + use iso_fortran_env, only: int32 + implicit none + ! -- dummy + class(ObsType), target :: this + ! -- local + integer(I4B) :: i, ii, idx, indx, iu, num, nunit + integer(int32) :: nobs + character(len=LENOBSNAME), pointer :: headr => null() + character(len=LENOBSNAME) :: nam + character(len=4) :: clenobsname + type(ObserveType), pointer :: obsrv => null() + type(ObsOutputType), pointer :: obsOutput => null() + ! + ! -- + num = this%obsList%Count() + ! -- Cycle through observations to build the header(s) + if (num>0) then + do i=1,num + obsrv => this%get_obs(i) + ! -- header for file of continuous observations + indx = obsrv%indxObsOutput + obsOutput => this%obsOutputList%Get(indx) + headr => obsOutput%header + if (headr == '') then + headr = 'time' + endif + nam = obsrv%Name + call ExpandArray(obsOutput%obsnames) + idx = size(obsOutput%obsnames) + obsOutput%obsnames(idx) = nam + enddo + endif + ! + ! -- Cycle through ObsOutputList to write headers + ! to formatted and unformatted file(s). + num = this%obsOutputList%Count() + do i=1,num + obsOutput => this%obsOutputList%Get(i) + if (obsOutput%FormattedOutput) then + ! -- write header to formatted file + headr => obsOutput%header + if (headr /= '') then + nobs = obsOutput%nobs + iu = obsOutput%nunit + write(iu, '(a)', advance='NO') 'time' + do ii = 1,nobs + write(iu, '(a,a)', advance='NO') ',', trim(obsOutput%obsnames(ii)) + enddo + write(iu, '(a)', advance='YES') '' + endif + else + ! -- write header to unformatted file + ! First 11 bytes are obs type and precision + nunit = obsOutput%nunit + if (this%iprecision==1) then + ! -- single precision output + write(nunit)'cont single' + elseif (this%iprecision==2) then + ! -- double precision output + write(nunit)'cont double' + endif + ! -- write LENOBSNAME to bytes 12-15 + write(clenobsname,'(i4)')LENOBSNAME + write(nunit)clenobsname + ! -- write blanks to complete 100-byte header + do ii=16,100 + write(nunit)' ' + enddo + ! -- write NOBS + nobs = obsOutput%nobs + write(nunit)nobs + ! -- write NOBS * (LENOBSNAME-character observation name) + do ii=1,nobs + write(nunit)obsOutput%obsnames(ii) + enddo + endif + enddo + ! + return + end subroutine build_headers + + subroutine get_obs_array(this, nObs, obsArray) +! ************************************************************************** +! get_obs_array +! -- Get an array containing all observations in this ObsType object +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + implicit none + ! -- dummy + class(ObsType), intent(inout) :: this + integer(I4B), intent(out) :: nObs + type(ObsContainerType), dimension(:), pointer, intent(inout) :: obsArray + ! -- local + ! + nObs = this%get_num() + if (associated(obsArray)) deallocate(obsArray) + allocate(obsArray(nObs)) + ! + ! Get observations + if (nObs > 0) then + call this%populate_obs_array(nObs, obsArray) + endif + ! + return + end subroutine get_obs_array + + function get_obs_datum(this, obsTypeID) result(obsDatum) +! ************************************************************************** +! get_obs_datum +! -- Return an ObsDataType object for the specified observation type +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + implicit none + ! -- dummy + class(ObsType) :: this + character(len=*), intent(in) :: obsTypeID + type(ObsDataType), pointer :: obsDatum + ! -- local + integer(I4B) :: i + character( len=MAXCHARLEN) :: ermsg + ! + obsDatum => null() + do i=1,MAXOBSTYPES + if (this%obsData(i)%ObsTypeID == obsTypeID) then + obsDatum => this%obsData(I) + exit + endif + enddo + ! + if (.not. associated(obsDatum)) then + ermsg = 'Observation type not found: ' // trim(obsTypeID) + call store_error(ermsg) + call store_error_unit(this%inUnitObs) + call ustop() + endif + ! + return + end function get_obs_datum + + subroutine populate_obs_array(this, nObs, obsArray) +! ************************************************************************** +! populate_obs_array +! -- Populate obsArray with observations for specified package +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + implicit none + ! -- dummy + class(ObsType), intent(inout) :: this + integer(I4B), intent(in) :: nObs + type(ObsContainerType), dimension(nObs), intent(inout) :: obsArray + ! + ! -- local + integer(I4B) :: i, n + type(ObserveType), pointer :: obsrv => null() + ! + n = this%get_num() + do i=1,n + obsrv => this%get_obs(i) + obsArray(i)%obsrv => obsrv + enddo + ! + return + end subroutine populate_obs_array + + function get_obs(this, indx) result(obsrv) +! ************************************************************************** +! get_obs +! -- Return the specified ObserveType object from the list of observations +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + implicit none + ! -- dummy + class(ObsType) :: this + integer(I4B), intent(in) :: indx + class(ObserveType), pointer :: obsrv + ! -- local + ! + obsrv => GetObsFromList(this%obsList, indx) + ! + return + end function get_obs + + subroutine read_obs_blocks(this, fname) +! ************************************************************************** +! read_obs_blocks +! -- read CONTINUOUS blocks from the OBS input file +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + implicit none + ! -- dummy + class(ObsType), intent(inout) :: this + character(len=*), intent(inout) :: fname + ! -- local + integer(I4B) :: ierr, indexobsout, numspec + logical :: fmtd, found, endOfBlock + character(len=LENBIGLINE) :: pnamein, fnamein + character(len=LENHUGELINE) :: line + character(len=LINELENGTH) :: btagfound, ermsg, message, word + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: tag + character(len=20) :: accarg, bin, fmtarg + type(ObserveType), pointer :: obsrv => null() + type(ObsOutputType), pointer :: obsOutput => null() + integer(I4B) :: ntabrows + integer(I4B) :: ntabcols + ! -- formats + ! + ! -- initialize local variables + numspec = -1 + ermsg = '' + ! + inquire(unit=this%parser%iuactive, name=pnamein) + call GetFileFromPath(pnamein, fnamein) + ! + if (this%echo) then + ! + ! -- create the observation table + ! -- table dimensions + ntabrows = 1 + ntabcols = 5 + ! + ! -- initialize table and define columns + title = 'OBSERVATIONS READ FROM FILE "' // trim(fnamein) // '"' + call table_cr(this%obstab, fnamein, title) + call this%obstab%table_df(ntabrows, ntabcols, this%iout, & + finalize=.FALSE.) + tag = 'NAME' + call this%obstab%initialize_column(tag, LENOBSNAME, alignment=TABLEFT) + tag = 'TYPE' + call this%obstab%initialize_column(tag, LENOBSTYPE+12, alignment=TABLEFT) + tag = 'TIME' + call this%obstab%initialize_column(tag, 12, alignment=TABLEFT) + tag = 'LOCATION DATA' + call this%obstab%initialize_column(tag, LENBOUNDNAME+2, alignment=TABLEFT) + tag = 'OUTPUT FILENAME' + call this%obstab%initialize_column(tag, 80, alignment=TABLEFT) + end if + ! + found = .true. + readblocks: do + if (.not. found) exit + ! + call this%parser%GetBlock('*', found, ierr, .true., .false., btagfound) + if (.not. found) then + exit readblocks + end if + this%blockTypeFound = btagfound + ! + ! Get keyword, which should be FILEOUT + call this%parser%GetStringCaps(word) + if (word /= 'FILEOUT') then + call store_error('CONTINUOUS keyword must be followed by ' // & + '"FILEOUT" then by filename.') + cycle + end if + ! + ! -- get name of output file + call this%parser%GetString(fname) + ! Fname is the output file name defined in the BEGIN line of the block. + if (fname == '') then + message = 'Error reading OBS input file, likely due to bad' // & + ' block or missing file name.' + call store_error(message) + cycle + else if (this%obsOutputList%ContainsFile(fname)) then + ermsg = 'OBS outfile "' // trim(fname) // & + '" is provided more than once.' + call store_error(ermsg) + cycle + end if + ! + ! -- look for BINARY option + call this%parser%GetStringCaps(bin) + if (bin == 'BINARY') then + fmtarg = FORM + accarg = ACCESS + fmtd = .false. + else + fmtarg = 'FORMATTED' + accarg = 'SEQUENTIAL' + fmtd = .true. + endif + ! + ! -- open the output file + numspec = 0 + call openfile(numspec, 0, fname, 'OBS OUTPUT', fmtarg, & + accarg, 'REPLACE') + ! + ! -- add output file to list of output files and assign its + ! FormattedOutput member appropriately + call this%obsOutputList%Add(fname,numspec) + indexobsout = this%obsOutputList%Count() + obsOutput => this%obsOutputList%Get(indexobsout) + obsOutput%FormattedOutput = fmtd + ! + ! -- process lines defining observations + select case (btagfound) + case ('CONTINUOUS') + ! + ! -- construct a continuous observation from each line in the block + readblockcontinuous: do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetCurrentLine(line) + call ConstructObservation(obsrv, line, numspec, fmtd, & + indexobsout, this%obsData, & + this%parser%iuactive) + ! + ! -- increment number of observations + ! to be written to this output file. + obsOutput => this%obsOutputList%Get(indexobsout) + obsOutput%nobs = obsOutput%nobs + 1 + call AddObsToList(this%obsList, obsrv) + ! + ! -- write line to the observation table + if (this%echo) then + call obsrv%WriteTo(this%obstab, btagfound, fname) + end if + end do readblockcontinuous + case default + ermsg = 'Error: Observation block type not recognized: ' // & + trim(btagfound) + call store_error(ermsg) + end select + end do readblocks + ! + ! -- finalize the observation table + if (this%echo) then + call this%obstab%finalize_table() + end if + ! + ! -- determine if error condition occurs + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- return + return + end subroutine read_obs_blocks + + subroutine write_continuous_simvals(this) +! ************************************************************************** +! write_continuous_simvals +! Subroutine: (1) for each continuous observation, writes value to output +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + implicit none + ! -- dummy + class(ObsType), intent(inout) :: this + ! -- local + integer(I4B) :: i, iprec, numobs + character(len=20) :: fmtc + real(DP) :: simval + class(ObserveType), pointer :: obsrv => null() + !--------------------------------------------------------------------------- + ! + ! Write simulated values for observations + iprec = this%iprecision + fmtc = this%obsfmtcont + ! -- iterate through all observations + numobs = this%obsList%Count() + do i=1,numobs + obsrv => this%get_obs(i) + ! -- continuous observation + simval = obsrv%CurrentTimeStepEndValue + if (obsrv%FormattedOutput) then + call write_fmtd_cont(fmtc, obsrv, this%obsOutputList, simval) + else + call write_unfmtd_cont(obsrv, iprec, this%obsOutputList, simval) + endif + enddo + ! + return + end subroutine write_continuous_simvals + +end module ObsModule diff --git a/src/Utilities/Observation/ObsContainer.f90 b/src/Utilities/Observation/ObsContainer.f90 index db739bde361..ee36ab30d66 100644 --- a/src/Utilities/Observation/ObsContainer.f90 +++ b/src/Utilities/Observation/ObsContainer.f90 @@ -6,7 +6,7 @@ !----------------------------------------------------------------------- module ObsContainerModule - use KindModule, only: DP, I4B + use KindModule, only: DP, I4B use ObserveModule, only: ObserveType implicit none diff --git a/src/Utilities/Observation/ObsOutput.f90 b/src/Utilities/Observation/ObsOutput.f90 index 3e84e9f79ca..86f510d2fe1 100644 --- a/src/Utilities/Observation/ObsOutput.f90 +++ b/src/Utilities/Observation/ObsOutput.f90 @@ -64,7 +64,7 @@ subroutine WriteLineout(this) implicit none ! -- dummy class(ObsOutputType), intent(inout) :: this - ! -- write a line return to end of observation output line + ! -- write a line return to end of observation output line ! for this totim write(this%nunit,'(a)', advance='YES') '' ! diff --git a/src/Utilities/Observation/ObsUtility.f90 b/src/Utilities/Observation/ObsUtility.f90 index 1f373316323..324804117d6 100644 --- a/src/Utilities/Observation/ObsUtility.f90 +++ b/src/Utilities/Observation/ObsUtility.f90 @@ -37,14 +37,14 @@ subroutine write_fmtd_cont(fmtc, obsrv, obsOutputList, value) type(ObsOutputListType), pointer, intent(inout) :: obsOutputList real(DP), intent(in) :: value ! -- local - integer(I4B) :: indx + integer(I4B) :: indx integer(I4B) :: nunit character(len=50) :: cval character(len=LENOBSNAME), pointer :: linout => null() type(ObsOutputType), pointer :: ObsOutput => null() !--------------------------------------------------------------------------- ! -- format -10 format(G20.13) +10 format(G20.13) ! -- output unit nunit = obsrv%UnitNumber ! @@ -52,8 +52,8 @@ subroutine write_fmtd_cont(fmtc, obsrv, obsOutputList, value) ObsOutput => obsOutputList%Get(indx) linout => obsOutput%lineout if (linout == '') then - write(linout,10) totim - write(cval,10) totim + write(linout,10) totim + write(cval,10) totim write(nunit, '(a)', advance='NO') trim(adjustl(cval)) endif ! -- append value to output line diff --git a/src/Utilities/Observation/Observe.f90 b/src/Utilities/Observation/Observe.f90 index ef06e8c2305..f57e2b88380 100644 --- a/src/Utilities/Observation/Observe.f90 +++ b/src/Utilities/Observation/Observe.f90 @@ -15,7 +15,7 @@ module ObserveModule use BaseDisModule, only: DisBaseType use ConstantsModule, only: LENBOUNDNAME, LENOBSNAME, LENOBSTYPE, & MAXOBSTYPES, DNODATA, DZERO - use TableModule, only: TableType + use TableModule, only: TableType use InputOutputModule, only: urword use ListModule, only: ListType use SimModule, only: store_warning, store_error, & @@ -30,7 +30,7 @@ module ObserveModule type :: ObserveType ! -- Public members - ! + ! ! -- For all observations integer(I4B), public :: NodeNumber = 0 integer(I4B), public :: UnitNumber = 0 @@ -39,35 +39,35 @@ module ObserveModule character(len=200), public :: IDstring = '' character(len=LENBOUNDNAME), public :: FeatureName = '' character(len=LENBOUNDNAME), public :: FeatureName2 = '' - ! + ! ! -- members specific to NPF intercell-flow observations integer(I4B), public :: NodeNumber2 = 0 integer(I4B), public :: JaIndex = -2 - ! + ! ! -- members that can be used as needed by packages or models integer(I4B), public :: intPak1 = 0 real(DP), public :: Obsdepth = DZERO real(DP), public :: dblPak1 = DZERO - ! + ! ! -- indxbnds is intended to hold indices of position(s) in bound ! array of boundaries included in the observation. integer(I4B), allocatable, dimension(:), public :: indxbnds - ! + ! ! -- Set FormattedOutput false if output unit is opened for unformatted i/o logical, public :: FormattedOutput = .true. logical, public :: BndFound = .false. real(DP), public :: CurrentTimeStepEndValue = DZERO real(DP), public :: CurrentTimeStepEndTime = DZERO - ! + ! ! -- Members specific to continuous observations integer(I4B), public :: indxObsOutput = -1 - ! + ! ! -- Private members type(ObsDataType), pointer, private :: obsDatum => null() contains ! -- Public procedures procedure, public :: ResetCurrent - procedure, public :: WriteTo + procedure, public :: WriteTo end type ObserveType type :: ObsDataType @@ -127,36 +127,36 @@ subroutine WriteTo(this, obstab, btagfound, fnamein) ! -------------------------------------------------------------------------- implicit none ! -- dummy - class(ObserveType), intent(inout) :: this - type(TableType), intent(inout) :: obstab - character(len=*), intent(in) :: btagfound - character(len=*), intent(in) :: fnamein - ! -- local - character(len=12) :: tag + class(ObserveType), intent(inout) :: this + type(TableType), intent(inout) :: obstab + character(len=*), intent(in) :: btagfound + character(len=*), intent(in) :: fnamein + ! -- local + character(len=12) :: tag character(len=80) :: fnameout ! -- formats - ! - ! -- write btagfound to tag - if (len_trim(btagfound) > 12) then - tag = btagfound(1:12) - else - write(tag, '(a12)') btagfound - end if - ! - ! -- write fnamein to fnameout - if (len_trim(fnamein) > 80) then - fnameout = fnamein(1:80) - else - write(fnameout, '(a80)') fnamein - end if - ! - ! -- write data to observation table - call obstab%add_term(this%Name) - call obstab%add_term(tag // trim(this%ObsTypeId)) - call obstab%add_term('ALL TIMES') - call obstab%add_term('"' // trim(this%IDstring) // '"') - call obstab%add_term(fnameout) - ! + ! + ! -- write btagfound to tag + if (len_trim(btagfound) > 12) then + tag = btagfound(1:12) + else + write(tag, '(a12)') btagfound + end if + ! + ! -- write fnamein to fnameout + if (len_trim(fnamein) > 80) then + fnameout = fnamein(1:80) + else + write(fnameout, '(a80)') fnamein + end if + ! + ! -- write data to observation table + call obstab%add_term(this%Name) + call obstab%add_term(tag // trim(this%ObsTypeId)) + call obstab%add_term('ALL TIMES') + call obstab%add_term('"' // trim(this%IDstring) // '"') + call obstab%add_term(fnameout) + ! ! -- return return end subroutine WriteTo diff --git a/src/Utilities/OpenSpec.f90 b/src/Utilities/OpenSpec.f90 index b5b06f9c89f..224b6680cc2 100644 --- a/src/Utilities/OpenSpec.f90 +++ b/src/Utilities/OpenSpec.f90 @@ -1,52 +1,52 @@ -module OpenSpecModule -! Code in this file defines values for OPEN-statement specifiers. Some -! of the values are extensions to ANSI Fortran 90 and 95. One of the -! specifiers is not included in ANSI FORTRAN 77. The included -! specifiers are ACCESS, FORM and ACTION. -! - CHARACTER(len=20) :: ACCESS,FORM,ACTION(2) -! -! -! Specifiers for OPEN statements for unformatted files, which are -! sometimes compiler specific. -! The included specifiers are ACCESS and FORM. -! -! ACCESS specifier -- -! -! Standard Fortran -- Use unless there is a reason to do otherwise. -! DATA ACCESS/'SEQUENTIAL'/ - DATA ACCESS/'STREAM'/ -! -! -! FORM specifier -- -! -! Standard Fortran, which results in vendor dependent (non-portable) -! files. Use unless there is a reason to do otherwise. - DATA FORM/'UNFORMATTED'/ -! -! Non-standard Fortran that causes code compiled by Compaq (Digital) -! Fortran on personal computers to use unstructured non-formatted -! files. This may make it possible for the non-formatted files used -! by MODFLOW to be used with programs that are compiled by other -! compilers. -! DATA FORM/'BINARY'/ -! -! -! OPEN-statement specifiers related to file-sharing. -! -! ACTION specifier -- -! -! Standard FORTRAN 77 -- Eliminate the ACTION= specifier from all -! OPEN statements in the source-code files. -! -! Standard Fortran 90 and 95 -- Use unless there is a reason to do -! otherwise. - DATA (ACTION(IACT),IACT=1,2)/'READ','READWRITE'/ -! -! Non-standard Fortran that causes code compiled by the Lahey LF90 -! compiler to create files that can be shared. For use when parallel -! processing is used or to enable an editor to view output files -! while the program is running. -! DATA (ACTION(I),I=1,2)/'READ,DENYWRITE','READWRITE,DENYNONE'/ -! +module OpenSpecModule +! Code in this file defines values for OPEN-statement specifiers. Some +! of the values are extensions to ANSI Fortran 90 and 95. One of the +! specifiers is not included in ANSI FORTRAN 77. The included +! specifiers are ACCESS, FORM and ACTION. +! + CHARACTER(len=20) :: ACCESS,FORM,ACTION(2) +! +! +! Specifiers for OPEN statements for unformatted files, which are +! sometimes compiler specific. +! The included specifiers are ACCESS and FORM. +! +! ACCESS specifier -- +! +! Standard Fortran -- Use unless there is a reason to do otherwise. +! DATA ACCESS/'SEQUENTIAL'/ + DATA ACCESS/'STREAM'/ +! +! +! FORM specifier -- +! +! Standard Fortran, which results in vendor dependent (non-portable) +! files. Use unless there is a reason to do otherwise. + DATA FORM/'UNFORMATTED'/ +! +! Non-standard Fortran that causes code compiled by Compaq (Digital) +! Fortran on personal computers to use unstructured non-formatted +! files. This may make it possible for the non-formatted files used +! by MODFLOW to be used with programs that are compiled by other +! compilers. +! DATA FORM/'BINARY'/ +! +! +! OPEN-statement specifiers related to file-sharing. +! +! ACTION specifier -- +! +! Standard FORTRAN 77 -- Eliminate the ACTION= specifier from all +! OPEN statements in the source-code files. +! +! Standard Fortran 90 and 95 -- Use unless there is a reason to do +! otherwise. + DATA (ACTION(IACT),IACT=1,2)/'READ','READWRITE'/ +! +! Non-standard Fortran that causes code compiled by the Lahey LF90 +! compiler to create files that can be shared. For use when parallel +! processing is used or to enable an editor to view output files +! while the program is running. +! DATA (ACTION(I),I=1,2)/'READ,DENYWRITE','READWRITE,DENYNONE'/ +! end module OpenSpecModule \ No newline at end of file diff --git a/src/Utilities/OutputControl/OutputControl.f90 b/src/Utilities/OutputControl/OutputControl.f90 index 3eea7f58a4e..b844e4fbf06 100644 --- a/src/Utilities/OutputControl/OutputControl.f90 +++ b/src/Utilities/OutputControl/OutputControl.f90 @@ -1,481 +1,481 @@ -module OutputControlModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LENMODELNAME, LENORIGIN - use OutputControlData, only: OutputControlDataType, ocd_cr - use BlockParserModule, only: BlockParserType - - implicit none - private - public OutputControlType, oc_cr - - type OutputControlType - character(len=LENMODELNAME), pointer :: name_model => null() !name of the model - character(len=LENORIGIN), pointer :: cid => null() !character id of this object - integer(I4B), pointer :: inunit => null() !unit number for input file - integer(I4B), pointer :: iout => null() !unit number for output file - integer(I4B), pointer :: iperoc => null() !stress period number for next output control - integer(I4B), pointer :: iocrep => null() !output control repeat flag (period 0 step 0) - type(OutputControlDataType), dimension(:), pointer, contiguous :: ocdobj => null() !output control objects - type(BlockParserType) :: parser - contains - procedure :: oc_df - procedure :: oc_rp - procedure :: oc_ot - procedure :: oc_da - procedure :: allocate_scalars - procedure :: read_options - procedure :: oc_save - procedure :: oc_print - procedure :: oc_save_unit - end type OutputControlType - - contains - - subroutine oc_cr(ocobj, name_model, inunit, iout) -! ****************************************************************************** -! oc_cr -- Create a new oc object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - type(OutputControlType), pointer :: ocobj - character(len=*), intent(in) :: name_model - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout -! ------------------------------------------------------------------------------ - ! - ! -- Create the object - allocate(ocobj) - ! - ! -- Allocate scalars - call ocobj%allocate_scalars(name_model) - ! - ! -- Save unit numbers - ocobj%inunit = inunit - ocobj%iout = iout - ! - ! -- Initialize block parser - call ocobj%parser%Initialize(inunit, iout) - ! - ! -- Return - return - end subroutine oc_cr - - subroutine oc_df(this) -! ****************************************************************************** -! oc_df -- define the Oc Object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(OutputControlType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Return - return - end subroutine oc_df - - subroutine oc_rp(this) -! ****************************************************************************** -! Read and prepare output control for this stress period -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: kper, nper - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, store_error_unit, count_errors - ! -- dummy - class(OutputControlType) :: this - ! -- local - integer(I4B) :: ierr, ival, ipos - logical :: isfound, found, endOfBlock - character(len=LINELENGTH) :: line - character(len=LINELENGTH) :: ermsg, keyword1, keyword2 - character(len=LINELENGTH) :: printsave - class(OutputControlDataType), pointer :: ocdobjptr - ! -- formats - character(len=*), parameter :: fmtboc = & - "(1X,/1X,'BEGIN READING OUTPUT CONTROL FOR STRESS PERIOD ',I0)" - character(len=*), parameter :: fmteoc = & - "(/,1X,'END READING OUTPUT CONTROL FOR STRESS PERIOD ',I0)" - character(len=*), parameter :: fmterr = & - "(' ERROR READING OUTPUT CONTROL PERIOD BLOCK: ')" - character(len=*), parameter :: fmtroc = & - "(1X,/1X,'OUTPUT CONTROL FOR STRESS PERIOD ',I0, & - &' IS REPEATED USING SETTINGS FROM A PREVIOUS STRESS PERIOD.')" - character(len=*), parameter :: fmtpererr = & - "(1x,'CURRENT STRESS PERIOD GREATER THAN PERIOD IN OUTPUT CONTROL.')" - character(len=*), parameter :: fmtpererr2 = & - "(1x,'CURRENT STRESS PERIOD: ',I0,' SPECIFIED STRESS PERIOD: ',I0)" -! ------------------------------------------------------------------------------ - ! - ! -- Read next block header if kper greater than last one read - if (this%iperoc < kper) then - ! - ! -- Get period block - call this%parser%GetBlock('PERIOD', isfound, ierr, & - supportOpenClose=.true.) - ! - ! -- If end of file, set iperoc past kper, else parse line - if (ierr < 0) then - this%iperoc = nper + 1 - write(this%iout, '(/,1x,a)') 'END OF FILE DETECTED IN OUTPUT CONTROL.' - write(this%iout, '(1x,a)') 'CURRENT OUTPUT CONTROL SETTINGS WILL BE ' - write(this%iout, '(1x,a)') 'REPEATED UNTIL THE END OF THE SIMULATION.' - else - ! - ! -- Read period number - ival = this%parser%GetInteger() - ! - ! -- Check to see if this is a valid kper - if(ival <= 0 .or. ival > nper) then - write(ermsg, '(a,i0)') 'PERIOD NOT VALID IN OUTPUT CONTROL: ', ival - call store_error(ermsg) - write(ermsg, '(a, a)') 'LINE: ', trim(adjustl(line)) - call store_error(ermsg) - endif - ! - ! -- Check to see if specified is less than kper - if(ival < kper) then - write(ermsg, fmtpererr) - call store_error(ermsg) - write(ermsg, fmtpererr2) kper, ival - call store_error(ermsg) - write(ermsg, '(a, a)') 'LINE: ', trim(adjustl(line)) - call store_error(ermsg) - endif - ! - ! -- Stop or set iperoc and continue - if(count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - this%iperoc = ival - endif - end if - ! - ! -- Read the stress period block - if (this%iperoc == kper) then - ! - ! -- Clear io flags - do ipos = 1, size(this%ocdobj) - ocdobjptr => this%ocdobj(ipos) - call ocdobjptr%psmobj%init() - enddo - ! - ! -- Output control time step matches simulation time step. - write(this%iout,fmtboc) this%iperoc - ! - ! -- loop to read records - recordloop: do - ! - ! -- Read the line - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword1) - ! - ! -- Set printsave string and then read the record type (e.g. - ! BUDGET, HEAD) - printsave = keyword1 - call this%parser%GetStringCaps(keyword2) - ! - ! -- Look through the output control data objects that are - ! available and set ocdobjptr to the correct one based on - ! cname. Set found to .false. if not a valid record type. - found = .false. - do ipos = 1, size(this%ocdobj) - ocdobjptr => this%ocdobj(ipos) - if(keyword2 == trim(ocdobjptr%cname)) then - found = .true. - exit - endif - enddo - if (.not. found) then - call this%parser%GetCurrentLine(line) - write(ermsg, fmterr) - call store_error(ermsg) - call store_error('UNRECOGNIZED KEYWORD: '//keyword2) - call store_error(trim(line)) - call this%parser%StoreErrorUnit() - call ustop() - endif - call this%parser%GetRemainingLine(line) - call ocdobjptr%psmobj%rp(trim(printsave)//' '//line, & - this%iout) - call ocdobjptr%ocd_rp_check(this%parser%iuactive) - ! - ! -- End of recordloop - enddo recordloop - write(this%iout,fmteoc) this%iperoc - else - ! - ! -- Write message that output control settings are from a previous - ! stress period. - write(this%iout, fmtroc) kper - endif - ! - ! -- return - return - end subroutine oc_rp - - subroutine oc_ot(this, ipflg) -! ****************************************************************************** -! oc_ot -- output information -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: kstp, kper, nstp - ! -- dummy - class(OutputControlType) :: this - integer(I4B), intent(inout) :: ipflg - ! -- local - integer(I4B) :: ipos - type(OutputControlDataType), pointer :: ocdobjptr -! ------------------------------------------------------------------------------ - ! - ! -- Clear printout flag(ipflg). This flag indicates that an array was - ! printed to the listing file. - ipflg = 0 - ! - do ipos = 1, size(this%ocdobj) - ocdobjptr => this%ocdobj(ipos) - call ocdobjptr%ocd_ot(ipflg, kstp, nstp(kper), this%iout) - enddo - ! - ! -- Return - return - end subroutine oc_ot - - subroutine oc_da(this) -! ****************************************************************************** -! oc_da -- deallocate variables -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(OutputControlType) :: this - ! -- local - integer(I4B) :: i -! ------------------------------------------------------------------------------ - ! - do i = 1, size(this%ocdobj) - call this%ocdobj(i)%ocd_da() - enddo - deallocate(this%ocdobj) - ! - deallocate(this%name_model) - deallocate(this%cid) - call mem_deallocate(this%inunit) - call mem_deallocate(this%iout) - call mem_deallocate(this%iperoc) - call mem_deallocate(this%iocrep) - ! - ! -- return - return - end subroutine oc_da - - subroutine allocate_scalars(this, name_model) -! ****************************************************************************** -! allocate_scalars -- Allocate scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(OutputControlType) :: this - character(len=*), intent(in) :: name_model -! ------------------------------------------------------------------------------ - ! - allocate(this%name_model) - allocate(this%cid) - this%cid = trim(adjustl(name_model)) // ' OC' - call mem_allocate(this%inunit, 'INUNIT', this%cid) - call mem_allocate(this%iout, 'IOUT', this%cid) - call mem_allocate(this%iperoc, 'IPEROC', this%cid) - call mem_allocate(this%iocrep, 'IOCREP', this%cid) - ! - this%name_model = name_model - this%inunit = 0 - this%iout = 0 - this%iperoc = 0 - this%iocrep = 0 - ! - ! -- return - return - end subroutine allocate_scalars - - subroutine read_options(this) -! ****************************************************************************** -! read_options -- read oc options block -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: ustop, store_error, store_error_unit - ! -- dummy - class(OutputControlType) :: this - ! -- local - character(len=LINELENGTH) :: line, errmsg, keyword - integer(I4B) :: ierr - integer(I4B) :: ipos - logical :: isfound, found, endOfBlock - type(OutputControlDataType), pointer :: ocdobjptr -! ------------------------------------------------------------------------------ - ! - ! -- 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 OC OPTIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - found = .false. - do ipos = 1, size(this%ocdobj) - ocdobjptr => this%ocdobj(ipos) - if(keyword == trim(ocdobjptr%cname)) then - found = .true. - exit - endif - enddo - if (.not. found) then - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN OC OPTION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - call this%parser%GetRemainingLine(line) - call ocdobjptr%set_option(line, this%parser%iuactive, this%iout) - end do - write(this%iout,'(1x,a)')'END OF OC OPTIONS' - end if - ! - ! -- return - return - end subroutine read_options - - logical function oc_save(this, cname) -! ****************************************************************************** -! oc_save -- determine if it is time to save cname -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: kstp, kper, nstp - ! -- dummy - class(OutputControlType) :: this - character(len=*), intent(in) :: cname - ! -- local - integer(I4B) :: ipos - logical :: found - class(OutputControlDataType), pointer :: ocdobjptr -! ------------------------------------------------------------------------------ - ! - oc_save = .false. - found = .false. - do ipos = 1, size(this%ocdobj) - ocdobjptr => this%ocdobj(ipos) - if(cname == trim(ocdobjptr%cname)) then - found = .true. - exit - endif - enddo - if(found) then - oc_save = ocdobjptr%psmobj%kstp_to_save(kstp, nstp(kper)) - endif - ! - ! -- Return - return - end function oc_save - - logical function oc_print(this, cname) -! ****************************************************************************** -! oc_print -- determine if it is time to print cname -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use TdisModule, only: kstp, kper, nstp - ! -- dummy - class(OutputControlType) :: this - character(len=*), intent(in) :: cname - ! -- local - integer(I4B) :: ipos - logical :: found - class(OutputControlDataType), pointer :: ocdobjptr -! ------------------------------------------------------------------------------ - ! - oc_print = .false. - found = .false. - do ipos = 1, size(this%ocdobj) - ocdobjptr => this%ocdobj(ipos) - if(cname == trim(ocdobjptr%cname)) then - found = .true. - exit - endif - enddo - if(found) then - oc_print = ocdobjptr%psmobj%kstp_to_print(kstp, nstp(kper)) - endif - ! - ! -- Return - return - end function oc_print - - function oc_save_unit(this, cname) -! ****************************************************************************** -! oc_save_unit -- determine unit number for saving -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - integer(I4B) :: oc_save_unit - ! -- dummy - class(OutputControlType) :: this - character(len=*), intent(in) :: cname - ! -- local - integer(I4B) :: ipos - logical :: found - class(OutputControlDataType), pointer :: ocdobjptr -! ------------------------------------------------------------------------------ - ! - oc_save_unit = 0 - found = .false. - do ipos = 1, size(this%ocdobj) - ocdobjptr => this%ocdobj(ipos) - if(cname == trim(ocdobjptr%cname)) then - found = .true. - exit - endif - enddo - if(found) then - oc_save_unit = ocdobjptr%idataun - endif - ! - ! -- Return - return - end function oc_save_unit - -end module OutputControlModule +module OutputControlModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: LENMODELNAME, LENORIGIN + use OutputControlData, only: OutputControlDataType, ocd_cr + use BlockParserModule, only: BlockParserType + + implicit none + private + public OutputControlType, oc_cr + + type OutputControlType + character(len=LENMODELNAME), pointer :: name_model => null() !name of the model + character(len=LENORIGIN), pointer :: cid => null() !character id of this object + integer(I4B), pointer :: inunit => null() !unit number for input file + integer(I4B), pointer :: iout => null() !unit number for output file + integer(I4B), pointer :: iperoc => null() !stress period number for next output control + integer(I4B), pointer :: iocrep => null() !output control repeat flag (period 0 step 0) + type(OutputControlDataType), dimension(:), pointer, contiguous :: ocdobj => null() !output control objects + type(BlockParserType) :: parser + contains + procedure :: oc_df + procedure :: oc_rp + procedure :: oc_ot + procedure :: oc_da + procedure :: allocate_scalars + procedure :: read_options + procedure :: oc_save + procedure :: oc_print + procedure :: oc_save_unit + end type OutputControlType + + contains + + subroutine oc_cr(ocobj, name_model, inunit, iout) +! ****************************************************************************** +! oc_cr -- Create a new oc object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + type(OutputControlType), pointer :: ocobj + character(len=*), intent(in) :: name_model + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout +! ------------------------------------------------------------------------------ + ! + ! -- Create the object + allocate(ocobj) + ! + ! -- Allocate scalars + call ocobj%allocate_scalars(name_model) + ! + ! -- Save unit numbers + ocobj%inunit = inunit + ocobj%iout = iout + ! + ! -- Initialize block parser + call ocobj%parser%Initialize(inunit, iout) + ! + ! -- Return + return + end subroutine oc_cr + + subroutine oc_df(this) +! ****************************************************************************** +! oc_df -- define the Oc Object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(OutputControlType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Return + return + end subroutine oc_df + + subroutine oc_rp(this) +! ****************************************************************************** +! Read and prepare output control for this stress period +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: kper, nper + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, store_error_unit, count_errors + ! -- dummy + class(OutputControlType) :: this + ! -- local + integer(I4B) :: ierr, ival, ipos + logical :: isfound, found, endOfBlock + character(len=LINELENGTH) :: line + character(len=LINELENGTH) :: ermsg, keyword1, keyword2 + character(len=LINELENGTH) :: printsave + class(OutputControlDataType), pointer :: ocdobjptr + ! -- formats + character(len=*), parameter :: fmtboc = & + "(1X,/1X,'BEGIN READING OUTPUT CONTROL FOR STRESS PERIOD ',I0)" + character(len=*), parameter :: fmteoc = & + "(/,1X,'END READING OUTPUT CONTROL FOR STRESS PERIOD ',I0)" + character(len=*), parameter :: fmterr = & + "(' ERROR READING OUTPUT CONTROL PERIOD BLOCK: ')" + character(len=*), parameter :: fmtroc = & + "(1X,/1X,'OUTPUT CONTROL FOR STRESS PERIOD ',I0, & + &' IS REPEATED USING SETTINGS FROM A PREVIOUS STRESS PERIOD.')" + character(len=*), parameter :: fmtpererr = & + "(1x,'CURRENT STRESS PERIOD GREATER THAN PERIOD IN OUTPUT CONTROL.')" + character(len=*), parameter :: fmtpererr2 = & + "(1x,'CURRENT STRESS PERIOD: ',I0,' SPECIFIED STRESS PERIOD: ',I0)" +! ------------------------------------------------------------------------------ + ! + ! -- Read next block header if kper greater than last one read + if (this%iperoc < kper) then + ! + ! -- Get period block + call this%parser%GetBlock('PERIOD', isfound, ierr, & + supportOpenClose=.true.) + ! + ! -- If end of file, set iperoc past kper, else parse line + if (ierr < 0) then + this%iperoc = nper + 1 + write(this%iout, '(/,1x,a)') 'END OF FILE DETECTED IN OUTPUT CONTROL.' + write(this%iout, '(1x,a)') 'CURRENT OUTPUT CONTROL SETTINGS WILL BE ' + write(this%iout, '(1x,a)') 'REPEATED UNTIL THE END OF THE SIMULATION.' + else + ! + ! -- Read period number + ival = this%parser%GetInteger() + ! + ! -- Check to see if this is a valid kper + if(ival <= 0 .or. ival > nper) then + write(ermsg, '(a,i0)') 'PERIOD NOT VALID IN OUTPUT CONTROL: ', ival + call store_error(ermsg) + write(ermsg, '(a, a)') 'LINE: ', trim(adjustl(line)) + call store_error(ermsg) + endif + ! + ! -- Check to see if specified is less than kper + if(ival < kper) then + write(ermsg, fmtpererr) + call store_error(ermsg) + write(ermsg, fmtpererr2) kper, ival + call store_error(ermsg) + write(ermsg, '(a, a)') 'LINE: ', trim(adjustl(line)) + call store_error(ermsg) + endif + ! + ! -- Stop or set iperoc and continue + if(count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + this%iperoc = ival + endif + end if + ! + ! -- Read the stress period block + if (this%iperoc == kper) then + ! + ! -- Clear io flags + do ipos = 1, size(this%ocdobj) + ocdobjptr => this%ocdobj(ipos) + call ocdobjptr%psmobj%init() + enddo + ! + ! -- Output control time step matches simulation time step. + write(this%iout,fmtboc) this%iperoc + ! + ! -- loop to read records + recordloop: do + ! + ! -- Read the line + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword1) + ! + ! -- Set printsave string and then read the record type (e.g. + ! BUDGET, HEAD) + printsave = keyword1 + call this%parser%GetStringCaps(keyword2) + ! + ! -- Look through the output control data objects that are + ! available and set ocdobjptr to the correct one based on + ! cname. Set found to .false. if not a valid record type. + found = .false. + do ipos = 1, size(this%ocdobj) + ocdobjptr => this%ocdobj(ipos) + if(keyword2 == trim(ocdobjptr%cname)) then + found = .true. + exit + endif + enddo + if (.not. found) then + call this%parser%GetCurrentLine(line) + write(ermsg, fmterr) + call store_error(ermsg) + call store_error('UNRECOGNIZED KEYWORD: '//keyword2) + call store_error(trim(line)) + call this%parser%StoreErrorUnit() + call ustop() + endif + call this%parser%GetRemainingLine(line) + call ocdobjptr%psmobj%rp(trim(printsave)//' '//line, & + this%iout) + call ocdobjptr%ocd_rp_check(this%parser%iuactive) + ! + ! -- End of recordloop + enddo recordloop + write(this%iout,fmteoc) this%iperoc + else + ! + ! -- Write message that output control settings are from a previous + ! stress period. + write(this%iout, fmtroc) kper + endif + ! + ! -- return + return + end subroutine oc_rp + + subroutine oc_ot(this, ipflg) +! ****************************************************************************** +! oc_ot -- output information +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: kstp, kper, nstp + ! -- dummy + class(OutputControlType) :: this + integer(I4B), intent(inout) :: ipflg + ! -- local + integer(I4B) :: ipos + type(OutputControlDataType), pointer :: ocdobjptr +! ------------------------------------------------------------------------------ + ! + ! -- Clear printout flag(ipflg). This flag indicates that an array was + ! printed to the listing file. + ipflg = 0 + ! + do ipos = 1, size(this%ocdobj) + ocdobjptr => this%ocdobj(ipos) + call ocdobjptr%ocd_ot(ipflg, kstp, nstp(kper), this%iout) + enddo + ! + ! -- Return + return + end subroutine oc_ot + + subroutine oc_da(this) +! ****************************************************************************** +! oc_da -- deallocate variables +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(OutputControlType) :: this + ! -- local + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + do i = 1, size(this%ocdobj) + call this%ocdobj(i)%ocd_da() + enddo + deallocate(this%ocdobj) + ! + deallocate(this%name_model) + deallocate(this%cid) + call mem_deallocate(this%inunit) + call mem_deallocate(this%iout) + call mem_deallocate(this%iperoc) + call mem_deallocate(this%iocrep) + ! + ! -- return + return + end subroutine oc_da + + subroutine allocate_scalars(this, name_model) +! ****************************************************************************** +! allocate_scalars -- Allocate scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(OutputControlType) :: this + character(len=*), intent(in) :: name_model +! ------------------------------------------------------------------------------ + ! + allocate(this%name_model) + allocate(this%cid) + this%cid = trim(adjustl(name_model)) // ' OC' + call mem_allocate(this%inunit, 'INUNIT', this%cid) + call mem_allocate(this%iout, 'IOUT', this%cid) + call mem_allocate(this%iperoc, 'IPEROC', this%cid) + call mem_allocate(this%iocrep, 'IOCREP', this%cid) + ! + this%name_model = name_model + this%inunit = 0 + this%iout = 0 + this%iperoc = 0 + this%iocrep = 0 + ! + ! -- return + return + end subroutine allocate_scalars + + subroutine read_options(this) +! ****************************************************************************** +! read_options -- read oc options block +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: ustop, store_error, store_error_unit + ! -- dummy + class(OutputControlType) :: this + ! -- local + character(len=LINELENGTH) :: line, errmsg, keyword + integer(I4B) :: ierr + integer(I4B) :: ipos + logical :: isfound, found, endOfBlock + type(OutputControlDataType), pointer :: ocdobjptr +! ------------------------------------------------------------------------------ + ! + ! -- 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 OC OPTIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + found = .false. + do ipos = 1, size(this%ocdobj) + ocdobjptr => this%ocdobj(ipos) + if(keyword == trim(ocdobjptr%cname)) then + found = .true. + exit + endif + enddo + if (.not. found) then + write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN OC OPTION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + call this%parser%GetRemainingLine(line) + call ocdobjptr%set_option(line, this%parser%iuactive, this%iout) + end do + write(this%iout,'(1x,a)')'END OF OC OPTIONS' + end if + ! + ! -- return + return + end subroutine read_options + + logical function oc_save(this, cname) +! ****************************************************************************** +! oc_save -- determine if it is time to save cname +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: kstp, kper, nstp + ! -- dummy + class(OutputControlType) :: this + character(len=*), intent(in) :: cname + ! -- local + integer(I4B) :: ipos + logical :: found + class(OutputControlDataType), pointer :: ocdobjptr +! ------------------------------------------------------------------------------ + ! + oc_save = .false. + found = .false. + do ipos = 1, size(this%ocdobj) + ocdobjptr => this%ocdobj(ipos) + if(cname == trim(ocdobjptr%cname)) then + found = .true. + exit + endif + enddo + if(found) then + oc_save = ocdobjptr%psmobj%kstp_to_save(kstp, nstp(kper)) + endif + ! + ! -- Return + return + end function oc_save + + logical function oc_print(this, cname) +! ****************************************************************************** +! oc_print -- determine if it is time to print cname +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: kstp, kper, nstp + ! -- dummy + class(OutputControlType) :: this + character(len=*), intent(in) :: cname + ! -- local + integer(I4B) :: ipos + logical :: found + class(OutputControlDataType), pointer :: ocdobjptr +! ------------------------------------------------------------------------------ + ! + oc_print = .false. + found = .false. + do ipos = 1, size(this%ocdobj) + ocdobjptr => this%ocdobj(ipos) + if(cname == trim(ocdobjptr%cname)) then + found = .true. + exit + endif + enddo + if(found) then + oc_print = ocdobjptr%psmobj%kstp_to_print(kstp, nstp(kper)) + endif + ! + ! -- Return + return + end function oc_print + + function oc_save_unit(this, cname) +! ****************************************************************************** +! oc_save_unit -- determine unit number for saving +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + integer(I4B) :: oc_save_unit + ! -- dummy + class(OutputControlType) :: this + character(len=*), intent(in) :: cname + ! -- local + integer(I4B) :: ipos + logical :: found + class(OutputControlDataType), pointer :: ocdobjptr +! ------------------------------------------------------------------------------ + ! + oc_save_unit = 0 + found = .false. + do ipos = 1, size(this%ocdobj) + ocdobjptr => this%ocdobj(ipos) + if(cname == trim(ocdobjptr%cname)) then + found = .true. + exit + endif + enddo + if(found) then + oc_save_unit = ocdobjptr%idataun + endif + ! + ! -- Return + return + end function oc_save_unit + +end module OutputControlModule diff --git a/src/Utilities/OutputControl/OutputControlData.f90 b/src/Utilities/OutputControl/OutputControlData.f90 index 121d65a2aeb..242ed1000ea 100644 --- a/src/Utilities/OutputControl/OutputControlData.f90 +++ b/src/Utilities/OutputControl/OutputControlData.f90 @@ -1,343 +1,343 @@ -module OutputControlData - - use BaseDisModule, only: DisBaseType - use InputOutputModule, only: print_format - use KindModule, only: DP, I4B - use PrintSaveManagerModule, only: PrintSaveManagerType - - implicit none - private - public OutputControlDataType, ocd_cr - - type OutputControlDataType - character(len=16), pointer :: cname => null() - character(len=60), pointer :: cdatafmp => null() - integer(I4B), pointer :: idataun => null() - character(len=1), pointer :: editdesc => null() - integer(I4B), pointer :: nvaluesp => null() - integer(I4B), pointer :: nwidthp => null() - real(DP), pointer :: dnodata => null() - integer(I4B), pointer :: inodata => null() - real(DP), dimension(:), pointer, contiguous :: dblvec => null() - integer(I4B), dimension(:), pointer, contiguous :: intvec => null() - class(DisBaseType), pointer :: dis => null() - type(PrintSaveManagerType), pointer :: psmobj => null() - contains - procedure :: allocate_scalars - procedure :: init_int - procedure :: init_dbl - procedure :: set_option - procedure :: ocd_rp_check - procedure :: ocd_ot - procedure :: ocd_da - end type OutputControlDataType - - contains - - subroutine ocd_cr(ocdobj) -! ****************************************************************************** -! ocd_cr -- Create a new ocd object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - type(OutputControlDataType), pointer :: ocdobj -! ------------------------------------------------------------------------------ - ! - ! -- Create the object - allocate(ocdobj) - ! - ! -- Allocate scalars - call ocdobj%allocate_scalars() - ! - ! -- Return - return - end subroutine ocd_cr - - subroutine ocd_rp_check(this, inunit) -! ****************************************************************************** -! ocd_rp_check -- Check to make sure settings are consistent -! ****************************************************************************** -! -! Specifications: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error, count_errors, store_error_unit, ustop - ! -- dummy - class(OutputControlDataType) :: this - integer(I4B), intent(in) :: inunit - ! -- locals - character(len=LINELENGTH) :: errmsg - ! -- formats - character(len=*), parameter :: fmtocsaveerr = & - "(1X,'REQUESTING TO SAVE ',A,' BUT ',A,' SAVE FILE NOT SPECIFIED. ', & - &A,' SAVE FILE MUST BE SPECIFIED IN OUTPUT CONTROL OPTIONS.')" -! ------------------------------------------------------------------------------ - ! - ! -- Check to make sure save file was specified - if(this%psmobj%save_detected) then - if(this%idataun == 0) then - write(errmsg, fmtocsaveerr) trim(adjustl(this%cname)), & - trim(adjustl(this%cname)), & - trim(adjustl(this%cname)) - call store_error(errmsg) - endif - endif - ! - if(count_errors() > 0) then - call store_error_unit(inunit) - call ustop() - endif - ! - ! -- return - return - end subroutine ocd_rp_check - - subroutine ocd_ot(this, ipflg, kstp, nstp, iout, iprint_opt, isav_opt) -! ****************************************************************************** -! ocd_ot -- record information -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(OutputControlDataType) :: this - integer(I4B), intent(inout) :: ipflg - integer(I4B), intent(in) :: kstp - integer(I4B), intent(in) :: nstp - integer(I4B), intent(in) :: iout - integer(I4B), optional, intent(in) :: iprint_opt - integer(I4B), optional, intent(in) :: isav_opt - ! -- local - integer(I4B) :: iprint - integer(I4B) :: idataun -! ------------------------------------------------------------------------------ - ! - ! -- initialize - iprint = 0 - ipflg = 0 - idataun = 0 - ! - ! -- Determine whether or not to print the array. The present - ! check allows a caller to override the print/save manager - if (present(iprint_opt)) then - if (iprint_opt /= 0) then - iprint = 1 - ipflg = 1 - endif - else - if(this%psmobj%kstp_to_print(kstp, nstp)) then - iprint = 1 - ipflg = 1 - endif - endif - ! - ! -- determine whether or not to save the array to a file - if (present(isav_opt)) then - if (isav_opt /= 0) then - idataun = this%idataun - endif - else - if(this%psmobj%kstp_to_save(kstp, nstp)) idataun = this%idataun - endif - ! - ! -- Record double precision array - if(associated(this%dblvec)) & - call this%dis%record_array(this%dblvec, iout, iprint, idataun, & - this%cname, this%cdatafmp, this%nvaluesp, & - this%nwidthp, this%editdesc, this%dnodata) - ! - ! -- Record integer array (not supported yet) - !if(associated(this%intvec)) & - !call this%dis%record_array(this%intvec, iout, iprint, idataun, & - ! this%cname, this%cdatafmp, this%nvaluesp, & - ! this%nwidthp, this%editdesc, this%inodata) - ! - ! -- Return - return - end subroutine ocd_ot - - subroutine ocd_da(this) -! ****************************************************************************** -! ocd_da --deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DZERO - ! -- dummy - class(OutputControlDataType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- deallocate - deallocate(this%cname) - deallocate(this%cdatafmp) - deallocate(this%idataun) - deallocate(this%editdesc) - deallocate(this%nvaluesp) - deallocate(this%nwidthp) - deallocate(this%dnodata) - deallocate(this%inodata) - deallocate(this%psmobj) - ! - ! -- return - return - end subroutine ocd_da - - subroutine init_dbl(this, cname, dblvec, dis, cdefpsm, cdeffmp, iout, & - dnodata) -! ****************************************************************************** -! init_int -- Initialize integer variable -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(OutputControlDataType) :: this - character(len=*), intent(in) :: cname - real(DP), dimension(:), pointer, contiguous, intent(in) :: dblvec - class(DisBaseType), pointer, intent(in) :: dis - character(len=*), intent(in) :: cdefpsm - character(len=*), intent(in) :: cdeffmp - integer(I4B), intent(in) :: iout - real(DP), intent(in) :: dnodata -! ------------------------------------------------------------------------------ - ! - this%cname = cname - this%dblvec => dblvec - this%dis => dis - this%dnodata = dnodata - call this%psmobj%init() - if (cdefpsm /= '') call this%psmobj%rp(cdefpsm, iout) - call print_format(cdeffmp, this%cdatafmp, & - this%editdesc, this%nvaluesp, this%nwidthp, 0) - ! - ! -- return - return - end subroutine init_dbl - - subroutine init_int(this, cname, intvec, dis, cdefpsm, cdeffmp, iout, & - inodata) -! ****************************************************************************** -! init_int -- Initialize integer variable -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(OutputControlDataType) :: this - character(len=*), intent(in) :: cname - integer(I4B), dimension(:), pointer, contiguous, intent(in) :: intvec - class(DisBaseType), pointer, intent(in) :: dis - character(len=*), intent(in) :: cdefpsm - character(len=*), intent(in) :: cdeffmp - integer(I4B), intent(in) :: iout - integer(I4B), intent(in) :: inodata -! ------------------------------------------------------------------------------ - ! - this%cname = cname - this%intvec => intvec - this%dis => dis - this%inodata = inodata - this%editdesc = 'I' - call this%psmobj%init() - if (cdefpsm /= '') call this%psmobj%rp(cdefpsm, iout) - call print_format(cdeffmp, this%cdatafmp, this%editdesc, this%nvaluesp, & - this%nwidthp, 0) - ! - ! -- return - return - end subroutine init_int - - subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -- Allocate scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: DZERO - ! -- dummy - class(OutputControlDataType) :: this -! ------------------------------------------------------------------------------ - ! - allocate(this%cname) - allocate(this%cdatafmp) - allocate(this%idataun) - allocate(this%editdesc) - allocate(this%nvaluesp) - allocate(this%nwidthp) - allocate(this%dnodata) - allocate(this%inodata) - allocate(this%psmobj) - ! - this%cname = '' - this%cdatafmp = '' - this%idataun = 0 - this%editdesc = '' - this%nvaluesp = 0 - this%nwidthp = 0 - this%dnodata = DZERO - this%inodata = 0 - ! - ! -- return - return - end subroutine allocate_scalars - - subroutine set_option(this, linein, inunit, iout) -! ****************************************************************************** -! allocate_scalars -- Allocate scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use OpenSpecModule, only: access, form - use InputOutputModule, only: urword, getunit, openfile - use SimModule, only: store_error, store_error_unit, count_errors, ustop - ! -- dummy - class(OutputControlDataType) :: this - character(len=*), intent(in) :: linein - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - ! -- local - character(len=len(linein)) :: line - integer(I4B) :: lloc, istart, istop, ival - real(DP) :: rval - ! -- format - character(len=*),parameter :: fmtocsave = & - "(4X,A,' INFORMATION WILL BE WRITTEN TO:', & - &/,6X,'UNIT NUMBER: ', I0,/,6X, 'FILE NAME: ', A)" -! ------------------------------------------------------------------------------ - ! - line(:) = linein(:) - lloc = 1 - call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) - select case(line(istart:istop)) - case('FILEOUT') - call urword(line, lloc, istart, istop, 0, ival, rval, 0, 0) - this%idataun = getunit() - write(iout, fmtocsave) trim(adjustl(this%cname)), this%idataun, & - line(istart:istop) - call openfile(this%idataun, iout, line(istart:istop), 'DATA(BINARY)', & - form, access, 'REPLACE') - case('PRINT_FORMAT') - call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) - call print_format(line(istart:), this%cdatafmp, this%editdesc, & - this%nvaluesp, this%nwidthp, inunit) - case default - call store_error('Looking for FILEOUT or PRINT_FORMAT. Found:') - call store_error(trim(adjustl(line))) - call store_error_unit(inunit) - call ustop() - end select - ! - ! -- return - return - end subroutine set_option - -end module OutputControlData +module OutputControlData + + use BaseDisModule, only: DisBaseType + use InputOutputModule, only: print_format + use KindModule, only: DP, I4B + use PrintSaveManagerModule, only: PrintSaveManagerType + + implicit none + private + public OutputControlDataType, ocd_cr + + type OutputControlDataType + character(len=16), pointer :: cname => null() + character(len=60), pointer :: cdatafmp => null() + integer(I4B), pointer :: idataun => null() + character(len=1), pointer :: editdesc => null() + integer(I4B), pointer :: nvaluesp => null() + integer(I4B), pointer :: nwidthp => null() + real(DP), pointer :: dnodata => null() + integer(I4B), pointer :: inodata => null() + real(DP), dimension(:), pointer, contiguous :: dblvec => null() + integer(I4B), dimension(:), pointer, contiguous :: intvec => null() + class(DisBaseType), pointer :: dis => null() + type(PrintSaveManagerType), pointer :: psmobj => null() + contains + procedure :: allocate_scalars + procedure :: init_int + procedure :: init_dbl + procedure :: set_option + procedure :: ocd_rp_check + procedure :: ocd_ot + procedure :: ocd_da + end type OutputControlDataType + + contains + + subroutine ocd_cr(ocdobj) +! ****************************************************************************** +! ocd_cr -- Create a new ocd object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + type(OutputControlDataType), pointer :: ocdobj +! ------------------------------------------------------------------------------ + ! + ! -- Create the object + allocate(ocdobj) + ! + ! -- Allocate scalars + call ocdobj%allocate_scalars() + ! + ! -- Return + return + end subroutine ocd_cr + + subroutine ocd_rp_check(this, inunit) +! ****************************************************************************** +! ocd_rp_check -- Check to make sure settings are consistent +! ****************************************************************************** +! +! Specifications: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error, count_errors, store_error_unit, ustop + ! -- dummy + class(OutputControlDataType) :: this + integer(I4B), intent(in) :: inunit + ! -- locals + character(len=LINELENGTH) :: errmsg + ! -- formats + character(len=*), parameter :: fmtocsaveerr = & + "(1X,'REQUESTING TO SAVE ',A,' BUT ',A,' SAVE FILE NOT SPECIFIED. ', & + &A,' SAVE FILE MUST BE SPECIFIED IN OUTPUT CONTROL OPTIONS.')" +! ------------------------------------------------------------------------------ + ! + ! -- Check to make sure save file was specified + if(this%psmobj%save_detected) then + if(this%idataun == 0) then + write(errmsg, fmtocsaveerr) trim(adjustl(this%cname)), & + trim(adjustl(this%cname)), & + trim(adjustl(this%cname)) + call store_error(errmsg) + endif + endif + ! + if(count_errors() > 0) then + call store_error_unit(inunit) + call ustop() + endif + ! + ! -- return + return + end subroutine ocd_rp_check + + subroutine ocd_ot(this, ipflg, kstp, nstp, iout, iprint_opt, isav_opt) +! ****************************************************************************** +! ocd_ot -- record information +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(OutputControlDataType) :: this + integer(I4B), intent(inout) :: ipflg + integer(I4B), intent(in) :: kstp + integer(I4B), intent(in) :: nstp + integer(I4B), intent(in) :: iout + integer(I4B), optional, intent(in) :: iprint_opt + integer(I4B), optional, intent(in) :: isav_opt + ! -- local + integer(I4B) :: iprint + integer(I4B) :: idataun +! ------------------------------------------------------------------------------ + ! + ! -- initialize + iprint = 0 + ipflg = 0 + idataun = 0 + ! + ! -- Determine whether or not to print the array. The present + ! check allows a caller to override the print/save manager + if (present(iprint_opt)) then + if (iprint_opt /= 0) then + iprint = 1 + ipflg = 1 + endif + else + if(this%psmobj%kstp_to_print(kstp, nstp)) then + iprint = 1 + ipflg = 1 + endif + endif + ! + ! -- determine whether or not to save the array to a file + if (present(isav_opt)) then + if (isav_opt /= 0) then + idataun = this%idataun + endif + else + if(this%psmobj%kstp_to_save(kstp, nstp)) idataun = this%idataun + endif + ! + ! -- Record double precision array + if(associated(this%dblvec)) & + call this%dis%record_array(this%dblvec, iout, iprint, idataun, & + this%cname, this%cdatafmp, this%nvaluesp, & + this%nwidthp, this%editdesc, this%dnodata) + ! + ! -- Record integer array (not supported yet) + !if(associated(this%intvec)) & + !call this%dis%record_array(this%intvec, iout, iprint, idataun, & + ! this%cname, this%cdatafmp, this%nvaluesp, & + ! this%nwidthp, this%editdesc, this%inodata) + ! + ! -- Return + return + end subroutine ocd_ot + + subroutine ocd_da(this) +! ****************************************************************************** +! ocd_da --deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DZERO + ! -- dummy + class(OutputControlDataType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- deallocate + deallocate(this%cname) + deallocate(this%cdatafmp) + deallocate(this%idataun) + deallocate(this%editdesc) + deallocate(this%nvaluesp) + deallocate(this%nwidthp) + deallocate(this%dnodata) + deallocate(this%inodata) + deallocate(this%psmobj) + ! + ! -- return + return + end subroutine ocd_da + + subroutine init_dbl(this, cname, dblvec, dis, cdefpsm, cdeffmp, iout, & + dnodata) +! ****************************************************************************** +! init_int -- Initialize integer variable +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(OutputControlDataType) :: this + character(len=*), intent(in) :: cname + real(DP), dimension(:), pointer, contiguous, intent(in) :: dblvec + class(DisBaseType), pointer, intent(in) :: dis + character(len=*), intent(in) :: cdefpsm + character(len=*), intent(in) :: cdeffmp + integer(I4B), intent(in) :: iout + real(DP), intent(in) :: dnodata +! ------------------------------------------------------------------------------ + ! + this%cname = cname + this%dblvec => dblvec + this%dis => dis + this%dnodata = dnodata + call this%psmobj%init() + if (cdefpsm /= '') call this%psmobj%rp(cdefpsm, iout) + call print_format(cdeffmp, this%cdatafmp, & + this%editdesc, this%nvaluesp, this%nwidthp, 0) + ! + ! -- return + return + end subroutine init_dbl + + subroutine init_int(this, cname, intvec, dis, cdefpsm, cdeffmp, iout, & + inodata) +! ****************************************************************************** +! init_int -- Initialize integer variable +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(OutputControlDataType) :: this + character(len=*), intent(in) :: cname + integer(I4B), dimension(:), pointer, contiguous, intent(in) :: intvec + class(DisBaseType), pointer, intent(in) :: dis + character(len=*), intent(in) :: cdefpsm + character(len=*), intent(in) :: cdeffmp + integer(I4B), intent(in) :: iout + integer(I4B), intent(in) :: inodata +! ------------------------------------------------------------------------------ + ! + this%cname = cname + this%intvec => intvec + this%dis => dis + this%inodata = inodata + this%editdesc = 'I' + call this%psmobj%init() + if (cdefpsm /= '') call this%psmobj%rp(cdefpsm, iout) + call print_format(cdeffmp, this%cdatafmp, this%editdesc, this%nvaluesp, & + this%nwidthp, 0) + ! + ! -- return + return + end subroutine init_int + + subroutine allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars -- Allocate scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DZERO + ! -- dummy + class(OutputControlDataType) :: this +! ------------------------------------------------------------------------------ + ! + allocate(this%cname) + allocate(this%cdatafmp) + allocate(this%idataun) + allocate(this%editdesc) + allocate(this%nvaluesp) + allocate(this%nwidthp) + allocate(this%dnodata) + allocate(this%inodata) + allocate(this%psmobj) + ! + this%cname = '' + this%cdatafmp = '' + this%idataun = 0 + this%editdesc = '' + this%nvaluesp = 0 + this%nwidthp = 0 + this%dnodata = DZERO + this%inodata = 0 + ! + ! -- return + return + end subroutine allocate_scalars + + subroutine set_option(this, linein, inunit, iout) +! ****************************************************************************** +! allocate_scalars -- Allocate scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use OpenSpecModule, only: access, form + use InputOutputModule, only: urword, getunit, openfile + use SimModule, only: store_error, store_error_unit, count_errors, ustop + ! -- dummy + class(OutputControlDataType) :: this + character(len=*), intent(in) :: linein + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + ! -- local + character(len=len(linein)) :: line + integer(I4B) :: lloc, istart, istop, ival + real(DP) :: rval + ! -- format + character(len=*),parameter :: fmtocsave = & + "(4X,A,' INFORMATION WILL BE WRITTEN TO:', & + &/,6X,'UNIT NUMBER: ', I0,/,6X, 'FILE NAME: ', A)" +! ------------------------------------------------------------------------------ + ! + line(:) = linein(:) + lloc = 1 + call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) + select case(line(istart:istop)) + case('FILEOUT') + call urword(line, lloc, istart, istop, 0, ival, rval, 0, 0) + this%idataun = getunit() + write(iout, fmtocsave) trim(adjustl(this%cname)), this%idataun, & + line(istart:istop) + call openfile(this%idataun, iout, line(istart:istop), 'DATA(BINARY)', & + form, access, 'REPLACE') + case('PRINT_FORMAT') + call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) + call print_format(line(istart:), this%cdatafmp, this%editdesc, & + this%nvaluesp, this%nwidthp, inunit) + case default + call store_error('Looking for FILEOUT or PRINT_FORMAT. Found:') + call store_error(trim(adjustl(line))) + call store_error_unit(inunit) + call ustop() + end select + ! + ! -- return + return + end subroutine set_option + +end module OutputControlData diff --git a/src/Utilities/OutputControl/PrintSaveManager.f90 b/src/Utilities/OutputControl/PrintSaveManager.f90 index f726755099c..6966c397630 100644 --- a/src/Utilities/OutputControl/PrintSaveManager.f90 +++ b/src/Utilities/OutputControl/PrintSaveManager.f90 @@ -1,282 +1,282 @@ -! This module defines the PrintSaveManagerType, which can be used -! to determine when something should be printed and/or saved. The -! object should be initiated with the following call: -! call psm_obj%init() -! -! The set method will configure the members based on the following -! keywords when set is called as follows: -! call psm_obj%set(nstp, line) -! where line may be in the following form: -! PRINT ALL -! PRINT STEPS 1 4 5 6 -! PRINT FIRST -! PRINT LAST -! PRINT FREQUENCY 4 -! SAVE ALL -! SAVE STEPS 1 4 5 6 -! SAVE FIRST -! SAVE LAST -! SAVE FREQUENCY 4 -! -! Based on the keywords, the object can be called with -! psm_obj%time_to_print(kstp, kper) -! psm_obj%time_to_save(kstp, kper) -! to return a logical flag indicating whether or not it -! it is time to print or time to save - -module PrintSaveManagerModule - - use KindModule, only: DP, I4B - use ArrayHandlersModule, only: expandarray - use SimModule, only: store_error, ustop - use InputOutputModule, only: urword - implicit none - private - public :: PrintSaveManagerType - - type :: PrintSaveManagerType - integer(I4B), allocatable, dimension(:) :: kstp_list_print - integer(I4B), allocatable, dimension(:) :: kstp_list_save - integer(I4B) :: ifreq_print - integer(I4B) :: ifreq_save - logical :: print_first - logical :: save_first - logical :: print_last - logical :: save_last - logical :: print_all - logical :: save_all - logical :: save_detected - logical :: print_detected - contains - procedure :: init - procedure :: rp - procedure :: kstp_to_print - procedure :: kstp_to_save - end type PrintSaveManagerType - - contains - - subroutine init(this) -! ****************************************************************************** -! init -! ****************************************************************************** -! -! Specifications: -! ------------------------------------------------------------------------------ - ! -- dummy - class(PrintSaveManagerType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- Initialize members to their defaults - if(allocated(this%kstp_list_print)) deallocate(this%kstp_list_print) - if(allocated(this%kstp_list_save)) deallocate(this%kstp_list_save) - allocate(this%kstp_list_print(0)) - allocate(this%kstp_list_save(0)) - this%ifreq_print = 0 - this%ifreq_save = 0 - this%save_first = .false. - this%save_last = .false. - this%save_all = .false. - this%print_first = .false. - this%print_last = .false. - this%print_all = .false. - this%save_detected = .false. - this%print_detected = .false. - ! - ! -- return - return - end subroutine init - - subroutine rp(this, linein, iout) -! ****************************************************************************** -! read and prepare -! ****************************************************************************** -! -! Specifications: -! ------------------------------------------------------------------------------ - ! -- dummy - class(PrintSaveManagerType) :: this - character(len=*), intent(in) :: linein - integer(I4B), intent(in) :: iout - ! -- local - character(len=len(linein)) :: line - logical lp, ls - integer(I4B) :: n - integer(I4B) :: lloc, istart, istop, ival - real(DP) :: rval - ! -- formats - character(len=*), parameter :: fmt_steps = & - "(6x,'THE FOLLOWING STEPS WILL BE ',A,': ',50(I0,' '))" - character(len=*), parameter :: fmt_freq = & - "(6x,'THE FOLLOWING FREQUENCY WILL BE ',A,': ',I0)" -! ------------------------------------------------------------------------------ - ! - ! -- Set the values based on line - ! -- Get keyword to use in assignment - line(:) = linein(:) - lloc = 1 - call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) - ! - ! -- set dimension for print or save - lp = .false. - ls = .false. - select case(line(istart:istop)) - case('PRINT') - lp = .true. - case('SAVE') - ls = .true. - case default - call store_error('Looking for PRINT or SAVE. Found:') - call store_error(trim(adjustl(line))) - call ustop() - end select - ! - ! -- set member variables - this%save_detected = ls - this%print_detected = lp - ! - ! -- set the steps to print or save - call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) - select case(line(istart:istop)) - case('ALL') - if(lp) then - this%print_all = .true. - if(iout > 0) write(iout,"(6x,a)") 'ALL TIME STEPS WILL BE PRINTED' - endif - if(ls) then - this%save_all = .true. - if(iout > 0) write(iout,"(6x,a)") 'ALL TIME STEPS WILL BE SAVED' - endif - case('STEPS') - listsearch: do - call urword(line, lloc, istart, istop, 2, ival, rval, -1, 0) - if(ival > 0) then - if(lp) then - n = size(this%kstp_list_print) - call expandarray(this%kstp_list_print) - this%kstp_list_print(n + 1) = ival - endif - if(ls) then - n = size(this%kstp_list_save) - call expandarray(this%kstp_list_save) - this%kstp_list_save(n + 1) = ival - endif - cycle listsearch - endif - exit listsearch - enddo listsearch - if(iout > 0) then - if(lp) write(iout, fmt_steps) 'PRINTED', this%kstp_list_print - if(ls) write(iout, fmt_steps) 'SAVED', this%kstp_list_save - endif - case('FREQUENCY') - call urword(line, lloc, istart, istop, 2, ival, rval, -1, 0) - if(lp) this%ifreq_print = ival - if(ls) this%ifreq_save = ival - if(iout > 0) then - if(lp) write(iout, fmt_freq) 'PRINTED', this%ifreq_print - if(ls) write(iout, fmt_freq) 'SAVED', this%ifreq_save - endif - case('FIRST') - if(lp) then - this%print_first = .true. - if(iout > 0) write(iout,"(6x,a)") 'THE FIRST TIME STEP WILL BE PRINTED' - endif - if(ls) then - this%save_first = .true. - if(iout > 0) write(iout,"(6x,a)") 'THE FIRST TIME STEP WILL BE SAVED' - endif - case('LAST') - if(lp) then - this%print_last = .true. - if(iout > 0) write(iout,"(6x,a)") 'THE LAST TIME STEP WILL BE PRINTED' - endif - if(ls) then - this%save_last = .true. - if(iout > 0) write(iout,"(6x,a)") 'THE LAST TIME STEP WILL BE SAVED' - endif - case default - call store_error('Looking for ALL, STEPS, FIRST, LAST, OR FREQUENCY.') - call store_error('Found: '//trim(adjustl(line))) - call ustop() - end select - ! - ! -- return - return - end subroutine rp - - logical function kstp_to_print(this, kstp, nstp) -! ****************************************************************************** -! kstp_to_print -! ****************************************************************************** -! -! Specifications: -! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - class(PrintSaveManagerType) :: this - integer(I4B), intent(in) :: kstp - integer(I4B), intent(in) :: nstp - ! -- local - integer(I4B) :: i, n -! ------------------------------------------------------------------------------ - ! - kstp_to_print = .false. - if(this%print_all) kstp_to_print = .true. - if(kstp == 1 .and. this%print_first) kstp_to_print = .true. - if(kstp == nstp .and. this%print_last) kstp_to_print = .true. - if(this%ifreq_print > 0) then - if(mod(kstp, this%ifreq_print) == 0) kstp_to_print = .true. - endif - n = size(this%kstp_list_print) - if(n > 0) then - do i = 1, n - if(kstp == this%kstp_list_print(i)) then - kstp_to_print = .true. - exit - endif - enddo - endif - ! - ! -- Return - return - end function kstp_to_print - - logical function kstp_to_save(this, kstp, nstp) -! ****************************************************************************** -! kstp_to_save -! ****************************************************************************** -! -! Specifications: -! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - class(PrintSaveManagerType) :: this - integer(I4B), intent(in) :: kstp - integer(I4B), intent(in) :: nstp - ! -- local - integer(I4B) :: i, n -! ------------------------------------------------------------------------------ - ! - kstp_to_save = .false. - if(this%save_all) kstp_to_save = .true. - if(kstp == 1 .and. this%save_first) kstp_to_save = .true. - if(kstp == nstp .and. this%save_last) kstp_to_save = .true. - if(this%ifreq_save > 0) then - if(mod(kstp, this%ifreq_save) == 0) kstp_to_save = .true. - endif - n = size(this%kstp_list_save) - if(n > 0) then - do i = 1, n - if(kstp == this%kstp_list_save(i)) then - kstp_to_save = .true. - exit - endif - enddo - endif - ! - ! -- Return - return - end function kstp_to_save - +! This module defines the PrintSaveManagerType, which can be used +! to determine when something should be printed and/or saved. The +! object should be initiated with the following call: +! call psm_obj%init() +! +! The set method will configure the members based on the following +! keywords when set is called as follows: +! call psm_obj%set(nstp, line) +! where line may be in the following form: +! PRINT ALL +! PRINT STEPS 1 4 5 6 +! PRINT FIRST +! PRINT LAST +! PRINT FREQUENCY 4 +! SAVE ALL +! SAVE STEPS 1 4 5 6 +! SAVE FIRST +! SAVE LAST +! SAVE FREQUENCY 4 +! +! Based on the keywords, the object can be called with +! psm_obj%time_to_print(kstp, kper) +! psm_obj%time_to_save(kstp, kper) +! to return a logical flag indicating whether or not it +! it is time to print or time to save + +module PrintSaveManagerModule + + use KindModule, only: DP, I4B + use ArrayHandlersModule, only: expandarray + use SimModule, only: store_error, ustop + use InputOutputModule, only: urword + implicit none + private + public :: PrintSaveManagerType + + type :: PrintSaveManagerType + integer(I4B), allocatable, dimension(:) :: kstp_list_print + integer(I4B), allocatable, dimension(:) :: kstp_list_save + integer(I4B) :: ifreq_print + integer(I4B) :: ifreq_save + logical :: print_first + logical :: save_first + logical :: print_last + logical :: save_last + logical :: print_all + logical :: save_all + logical :: save_detected + logical :: print_detected + contains + procedure :: init + procedure :: rp + procedure :: kstp_to_print + procedure :: kstp_to_save + end type PrintSaveManagerType + + contains + + subroutine init(this) +! ****************************************************************************** +! init +! ****************************************************************************** +! +! Specifications: +! ------------------------------------------------------------------------------ + ! -- dummy + class(PrintSaveManagerType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Initialize members to their defaults + if(allocated(this%kstp_list_print)) deallocate(this%kstp_list_print) + if(allocated(this%kstp_list_save)) deallocate(this%kstp_list_save) + allocate(this%kstp_list_print(0)) + allocate(this%kstp_list_save(0)) + this%ifreq_print = 0 + this%ifreq_save = 0 + this%save_first = .false. + this%save_last = .false. + this%save_all = .false. + this%print_first = .false. + this%print_last = .false. + this%print_all = .false. + this%save_detected = .false. + this%print_detected = .false. + ! + ! -- return + return + end subroutine init + + subroutine rp(this, linein, iout) +! ****************************************************************************** +! read and prepare +! ****************************************************************************** +! +! Specifications: +! ------------------------------------------------------------------------------ + ! -- dummy + class(PrintSaveManagerType) :: this + character(len=*), intent(in) :: linein + integer(I4B), intent(in) :: iout + ! -- local + character(len=len(linein)) :: line + logical lp, ls + integer(I4B) :: n + integer(I4B) :: lloc, istart, istop, ival + real(DP) :: rval + ! -- formats + character(len=*), parameter :: fmt_steps = & + "(6x,'THE FOLLOWING STEPS WILL BE ',A,': ',50(I0,' '))" + character(len=*), parameter :: fmt_freq = & + "(6x,'THE FOLLOWING FREQUENCY WILL BE ',A,': ',I0)" +! ------------------------------------------------------------------------------ + ! + ! -- Set the values based on line + ! -- Get keyword to use in assignment + line(:) = linein(:) + lloc = 1 + call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) + ! + ! -- set dimension for print or save + lp = .false. + ls = .false. + select case(line(istart:istop)) + case('PRINT') + lp = .true. + case('SAVE') + ls = .true. + case default + call store_error('Looking for PRINT or SAVE. Found:') + call store_error(trim(adjustl(line))) + call ustop() + end select + ! + ! -- set member variables + this%save_detected = ls + this%print_detected = lp + ! + ! -- set the steps to print or save + call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) + select case(line(istart:istop)) + case('ALL') + if(lp) then + this%print_all = .true. + if(iout > 0) write(iout,"(6x,a)") 'ALL TIME STEPS WILL BE PRINTED' + endif + if(ls) then + this%save_all = .true. + if(iout > 0) write(iout,"(6x,a)") 'ALL TIME STEPS WILL BE SAVED' + endif + case('STEPS') + listsearch: do + call urword(line, lloc, istart, istop, 2, ival, rval, -1, 0) + if(ival > 0) then + if(lp) then + n = size(this%kstp_list_print) + call expandarray(this%kstp_list_print) + this%kstp_list_print(n + 1) = ival + endif + if(ls) then + n = size(this%kstp_list_save) + call expandarray(this%kstp_list_save) + this%kstp_list_save(n + 1) = ival + endif + cycle listsearch + endif + exit listsearch + enddo listsearch + if(iout > 0) then + if(lp) write(iout, fmt_steps) 'PRINTED', this%kstp_list_print + if(ls) write(iout, fmt_steps) 'SAVED', this%kstp_list_save + endif + case('FREQUENCY') + call urword(line, lloc, istart, istop, 2, ival, rval, -1, 0) + if(lp) this%ifreq_print = ival + if(ls) this%ifreq_save = ival + if(iout > 0) then + if(lp) write(iout, fmt_freq) 'PRINTED', this%ifreq_print + if(ls) write(iout, fmt_freq) 'SAVED', this%ifreq_save + endif + case('FIRST') + if(lp) then + this%print_first = .true. + if(iout > 0) write(iout,"(6x,a)") 'THE FIRST TIME STEP WILL BE PRINTED' + endif + if(ls) then + this%save_first = .true. + if(iout > 0) write(iout,"(6x,a)") 'THE FIRST TIME STEP WILL BE SAVED' + endif + case('LAST') + if(lp) then + this%print_last = .true. + if(iout > 0) write(iout,"(6x,a)") 'THE LAST TIME STEP WILL BE PRINTED' + endif + if(ls) then + this%save_last = .true. + if(iout > 0) write(iout,"(6x,a)") 'THE LAST TIME STEP WILL BE SAVED' + endif + case default + call store_error('Looking for ALL, STEPS, FIRST, LAST, OR FREQUENCY.') + call store_error('Found: '//trim(adjustl(line))) + call ustop() + end select + ! + ! -- return + return + end subroutine rp + + logical function kstp_to_print(this, kstp, nstp) +! ****************************************************************************** +! kstp_to_print +! ****************************************************************************** +! +! Specifications: +! ------------------------------------------------------------------------------ + implicit none + ! -- dummy + class(PrintSaveManagerType) :: this + integer(I4B), intent(in) :: kstp + integer(I4B), intent(in) :: nstp + ! -- local + integer(I4B) :: i, n +! ------------------------------------------------------------------------------ + ! + kstp_to_print = .false. + if(this%print_all) kstp_to_print = .true. + if(kstp == 1 .and. this%print_first) kstp_to_print = .true. + if(kstp == nstp .and. this%print_last) kstp_to_print = .true. + if(this%ifreq_print > 0) then + if(mod(kstp, this%ifreq_print) == 0) kstp_to_print = .true. + endif + n = size(this%kstp_list_print) + if(n > 0) then + do i = 1, n + if(kstp == this%kstp_list_print(i)) then + kstp_to_print = .true. + exit + endif + enddo + endif + ! + ! -- Return + return + end function kstp_to_print + + logical function kstp_to_save(this, kstp, nstp) +! ****************************************************************************** +! kstp_to_save +! ****************************************************************************** +! +! Specifications: +! ------------------------------------------------------------------------------ + implicit none + ! -- dummy + class(PrintSaveManagerType) :: this + integer(I4B), intent(in) :: kstp + integer(I4B), intent(in) :: nstp + ! -- local + integer(I4B) :: i, n +! ------------------------------------------------------------------------------ + ! + kstp_to_save = .false. + if(this%save_all) kstp_to_save = .true. + if(kstp == 1 .and. this%save_first) kstp_to_save = .true. + if(kstp == nstp .and. this%save_last) kstp_to_save = .true. + if(this%ifreq_save > 0) then + if(mod(kstp, this%ifreq_save) == 0) kstp_to_save = .true. + endif + n = size(this%kstp_list_save) + if(n > 0) then + do i = 1, n + if(kstp == this%kstp_list_save(i)) then + kstp_to_save = .true. + exit + endif + enddo + endif + ! + ! -- Return + return + end function kstp_to_save + end module PrintSaveManagerModule \ No newline at end of file diff --git a/src/Utilities/Sim.f90 b/src/Utilities/Sim.f90 index 4607c684a9d..cab7172181c 100644 --- a/src/Utilities/Sim.f90 +++ b/src/Utilities/Sim.f90 @@ -1,704 +1,704 @@ -module SimModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: MAXCHARLEN, LINELENGTH, & - IUSTART, IULAST, & - VSUMMARY, VALL, VDEBUG - use SimVariablesModule, only: istdout, iout, isim_level, ireturnerr, & - iforcestop, iunext - use GenericUtilitiesModule, only: sim_message, stop_with_error - - implicit none - - private - public :: count_errors - public :: store_error - public :: ustop - public :: converge_reset - public :: converge_check - public :: final_message - public :: store_warning - public :: store_note - public :: count_warnings - public :: count_notes - public :: store_error_unit - public :: store_error_filename - public :: print_notes - public :: maxerrors - - character(len=MAXCHARLEN), allocatable, dimension(:) :: sim_errors - character(len=MAXCHARLEN), allocatable, dimension(:) :: sim_warnings - character(len=MAXCHARLEN), allocatable, dimension(:) :: sim_notes - integer(I4B) :: nerrors = 0 - integer(I4B) :: maxerrors = 1000 - integer(I4B) :: maxerrors_exceeded = 0 - integer(I4B) :: nwarnings = 0 - integer(I4B) :: nnotes = 0 - integer(I4B) :: inc_errors = 100 - integer(I4B) :: inc_warnings = 100 - integer(I4B) :: inc_notes = 100 - -contains - -function count_errors() -! ****************************************************************************** -! Return error count -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - integer(I4B) :: count_errors -! ------------------------------------------------------------------------------ - if (allocated(sim_errors)) then - count_errors = nerrors - else - count_errors = 0 - endif - return -end function count_errors - -function count_warnings() -! ****************************************************************************** -! Return warning count -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - integer(I4B) :: count_warnings -! ------------------------------------------------------------------------------ - if (allocated(sim_warnings)) then - count_warnings = nwarnings - else - count_warnings = 0 - endif - return -end function count_warnings - -function count_notes() -! ****************************************************************************** -! Return notes count -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- return - integer(I4B) :: count_notes -! ------------------------------------------------------------------------------ - if (allocated(sim_notes)) then - count_notes = nnotes - else - count_notes = 0 - endif - return -end function count_notes - -subroutine store_error(errmsg) -! ****************************************************************************** -! Store an error message for printing at end of simulation -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ArrayHandlersModule, only: ExpandArray - ! -- dummy - character(len=*), intent(in) :: errmsg - ! -- local - logical :: inc_array - integer(I4B) :: i -! ------------------------------------------------------------------------------ - ! - ! -- determine if the sim_errors should be expanded - inc_array = .TRUE. - if (allocated(sim_errors)) then - if (count_errors() < size(sim_errors)) then - inc_array = .FALSE. - end if - end if - ! - ! -- resize sim_errors - if (inc_array) then - call ExpandArray(sim_errors, increment=inc_errors) - inc_errors = inc_errors * 1.1 - end if - ! - ! -- store this error - i = count_errors() + 1 - if (i <= maxerrors) then - nerrors = i - sim_errors(i) = errmsg - else - maxerrors_exceeded = maxerrors_exceeded + 1 - end if - ! - return -end subroutine store_error - -subroutine store_error_unit(iunit) -! ****************************************************************************** -! Convert iunit to file name and indicate error reading from this file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - integer(I4B), intent(in) :: iunit - ! -- local - character(len=LINELENGTH) :: fname -! ------------------------------------------------------------------------------ - ! - inquire(unit=iunit, name=fname) - call store_error('ERROR OCCURRED WHILE READING FILE: ') - call store_error(trim(adjustl(fname))) - ! - return -end subroutine store_error_unit - -subroutine store_error_filename(filename) -! ****************************************************************************** -! Indicate error reading from this file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - character(len=*), intent(in) :: filename - ! -- local -! ------------------------------------------------------------------------------ - ! - call store_error('ERROR OCCURRED WHILE READING FILE: ') - call store_error(trim(adjustl(filename))) - ! - return -end subroutine store_error_filename - -subroutine store_warning(warnmsg) -! ****************************************************************************** -! Store a warning message for printing at end of simulation -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ArrayHandlersModule, only: ExpandArray - ! -- dummy - character(len=*), intent(in) :: warnmsg - ! -- local - logical :: inc_array - integer(I4B) :: i -! ------------------------------------------------------------------------------ - ! - inc_array = .TRUE. - if (allocated(sim_warnings)) then - if (count_warnings() < size(sim_warnings)) then - inc_array = .FALSE. - end if - end if - if (inc_array) then - call ExpandArray(sim_warnings, increment=inc_warnings) - inc_warnings = inc_warnings * 1.1 - end if - i = count_warnings() + 1 - nwarnings = i - sim_warnings(i) = warnmsg - ! - return -end subroutine store_warning - -subroutine store_note(note) -! ****************************************************************************** -! Store a note for printing at end of simulation -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ArrayHandlersModule, only: ExpandArray - ! -- dummy - character(len=*), intent(in) :: note - ! -- local - logical :: inc_array - integer(I4B) :: i -! ------------------------------------------------------------------------------ - ! - inc_array = .TRUE. - if (allocated(sim_notes)) then - if (count_notes() < size(sim_notes)) then - inc_array = .FALSE. - end if - end if - if (inc_array) then - call ExpandArray(sim_notes, increment=inc_notes) - inc_notes = inc_notes * 1.1 - end if - i = count_notes() + 1 - nnotes = i - sim_notes(i) = note - ! - return -end subroutine store_note - -logical function print_errors() -! ****************************************************************************** -! Print all error messages that have been stored -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- local - integer(I4B) :: i, isize - character(len=LINELENGTH) :: errmsg - ! -- formats - character(len=*), parameter :: stdfmt = "(/,'ERROR REPORT:',/)" -! ------------------------------------------------------------------------------ - ! - print_errors = .false. - if (allocated(sim_errors)) then - isize = count_errors() - if (isize > 0) then - print_errors = .true. - if (iout > 0) write(iout, stdfmt) - call sim_message('', fmt=stdfmt) - do i = 1, isize - call write_message(sim_errors(i)) - if (iout > 0) then - call write_message(sim_errors(i), iout) - end if - enddo - ! - ! -- write the number of errors - write(errmsg, '(i0, a)') isize, ' errors detected.' - call write_message(trim(errmsg)) - if (iout > 0) then - call write_message(trim(errmsg), iout) - end if - ! - ! -- write number of additional errors - if (maxerrors_exceeded > 0) then - write(errmsg, '(i0, a)') maxerrors_exceeded, & - ' additional errors detected but not printed.' - call write_message(trim(errmsg)) - if (iout > 0) then - call write_message(trim(errmsg), iout) - end if - end if - endif - endif - ! - return -end function print_errors - -subroutine print_warnings() -! ****************************************************************************** -! Print all warning messages that have been stored -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- local - integer(I4B) :: i, isize - ! -- formats - character(len=*), parameter :: stdfmt = "(/,'WARNINGS:',/)" -! ------------------------------------------------------------------------------ - ! - if (allocated(sim_warnings)) then - isize = count_warnings() - if (isize>0) then - if (iout>0) then - call sim_message('', fmt=stdfmt, iunit=iout) - end if - call sim_message('', fmt=stdfmt) - do i=1,isize - call write_message(sim_warnings(i)) - if (iout>0) then - call write_message(sim_warnings(i), iout) - end if - end do - end if - ! - ! -- write a blank line - if (iout>0) then - call sim_message('', iunit=iout) - end if - call sim_message('') - end if - ! - return -end subroutine print_warnings - -subroutine print_notes(numberlist) -! ****************************************************************************** -! Print all notes that have been stored -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - logical, intent(in), optional :: numberlist - ! -- local - integer(I4B) :: i, isize - character(len=MAXCHARLEN+10) :: noteplus - logical :: numlist - ! -- formats - character(len=*), parameter :: fmtnotes = "(/,'NOTES:')" - character(len=*), parameter :: fmta = "(i0,'. ',a)" - character(len=*), parameter :: fmtb = '(a)' -! ------------------------------------------------------------------------------ - ! - if (present(numberlist)) then - numlist = numberlist - else - numlist = .true. - endif - ! - if (allocated(sim_notes)) then - isize = count_notes() - if (isize>0) then - if (iout>0) then - call sim_message('', fmt=fmtnotes, iunit=iout) - end if - call sim_message('', fmt=fmtnotes) - do i=1, isize - if (numlist) then - write(noteplus,fmta) i, trim(sim_notes(i)) - else - write(noteplus,fmtb) trim(sim_notes(i)) - endif - call write_message(noteplus) - if (iout > 0) then - call write_message(noteplus, iout) - end if - enddo - endif - endif - ! - return -end subroutine print_notes - -subroutine write_message(message, iunit, error, skipbefore, skipafter) -! ****************************************************************************** -! Subroutine write_message formats and writes a message. -! -! -- Arguments are as follows: -! MESSAGE : message to be written -! IUNIT : the unit number to which the message is written -! ERROR : if true precede message with "Error" -! SKIPBEFORE : number of empty lines before message -! SKIPAFTER : number of empty lines after message -! -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - character (len=*), intent(in) :: message - integer(I4B), intent(in), optional :: iunit - logical, intent(in), optional :: error - integer(I4B), intent(in), optional :: skipbefore - integer(I4B), intent(in), optional :: skipafter - ! -- local - integer(I4B) :: jend, i, nblc, junit, leadblank - integer(I4B) :: itake, j - character(len=20) :: ablank - character(len=MAXCHARLEN) :: amessage -! ------------------------------------------------------------------------------ - ! - amessage = message - if (amessage==' ') return - if (amessage(1:1).ne.' ') amessage = ' ' // trim(amessage) - ! - ! -- initialize local variables - junit = istdout - ablank = ' ' - itake = 0 - j = 0 - ! - ! -- process optional dummy variables - if(present(iunit))then - if (iunit > 0) then - junit = iunit - end if - end if - if(present(skipbefore))then - do i = 1, skipbefore - call sim_message('', iunit=junit) - end do - endif - if(present(error))then - if(error)then - nblc=len_trim(amessage) - amessage=adjustr(amessage(1:nblc+8)) - if(nblc+8.lt.len(amessage)) amessage(nblc+9:)=' ' - amessage(1:8)=' Error: ' - end if - end if - ! - do i=1,20 - if (amessage(i:i).ne.' ') exit - end do - leadblank=i-1 - nblc=len_trim(amessage) - ! -5 continue - jend = j + 78 - itake - if (jend >= nblc) go to 100 - do i=jend,j+1,-1 - if(amessage(i:i).eq.' ') then - if(itake.eq.0) then - call sim_message(amessage(j+1:i), iunit=junit) - itake = 2 + leadblank - else - call sim_message(ablank(1:leadblank+2)//amessage(j+1:i), iunit=junit) - end if - j = i - go to 5 - end if - end do - if(itake == 0)then - call sim_message(amessage(j+1:jend), iunit=junit) - itake = 2 + leadblank - else - call sim_message(ablank(1:leadblank+2)//amessage(j+1:jend), iunit=junit) - end if - j = jend - go to 5 - ! -100 continue - jend = nblc - if (itake == 0)then - call sim_message(amessage(j+1:jend), iunit=junit) - else - call sim_message(ablank(1:leadblank+2)//amessage(j+1:jend), iunit=junit) - end if - ! - if(present(skipafter))then - do i = 1, skipafter - call sim_message('', iunit=junit) - end do - endif - ! - ! -- return - return -! ! -!200 continue -! call ustop() - ! -end subroutine write_message - -! -- this subroutine prints final messages and then stops with the active -! error code. -subroutine ustop(stopmess, ioutlocal) -! ****************************************************************************** -! Stop program, with option to print message before stopping. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - character, optional, intent(in) :: stopmess*(*) - integer(I4B), optional, intent(in) :: ioutlocal - - !--------------------------------------------------------------------------- - ! - ! -- print the final message - call print_final_message(stopmess, ioutlocal) - ! - ! -- return appropriate error codes when terminating the program - call stop_with_error(ireturnerr) - -end subroutine ustop - -subroutine print_final_message(stopmess, ioutlocal) -! ****************************************************************************** -! Print a final message and close all open files -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - character, optional, intent(in) :: stopmess*(*) - integer(I4B), optional, intent(in) :: ioutlocal - ! -- local - character(len=*), parameter :: fmt = '(1x,a)' - character(len=*), parameter :: msg = 'Stopping due to error(s)' - logical :: errorfound - !--------------------------------------------------------------------------- - call print_notes() - call print_warnings() - errorfound = print_errors() - if (present(stopmess)) then - if (stopmess.ne.' ') then - call sim_message(stopmess, fmt=fmt, iunit=iout) - call sim_message(stopmess, fmt=fmt) - if (present(ioutlocal)) then - if (ioutlocal > 0 .and. ioutlocal .ne. iout) then - write(ioutlocal,fmt) trim(stopmess) - close (ioutlocal) - endif - endif - endif - endif - ! - if (errorfound) then - ireturnerr = 2 - if (iout > 0) then - call sim_message(stopmess, fmt=fmt, iunit=iout) - end if - call sim_message(stopmess, fmt=fmt) - - if (present(ioutlocal)) then - if (ioutlocal > 0 .and. ioutlocal /= iout) write(ioutlocal,fmt) msg - endif - endif - ! - ! -- close all open files - call sim_closefiles() - ! - ! -- return - return - -end subroutine print_final_message - -subroutine converge_reset() -! ****************************************************************************** -! converge_reset -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimVariablesModule, only: isimcnvg -! ------------------------------------------------------------------------------ - ! - isimcnvg = 1 - ! - ! -- Return - return - end subroutine converge_reset - - subroutine converge_check(hasConverged) -! ****************************************************************************** -! convergence check -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimVariablesModule, only: isimcnvg, numnoconverge, isimcontinue - ! -- dummy - logical, intent(inout) :: hasConverged - ! -- format - character(len=*), parameter :: fmtfail = & - "(1x, 'Simulation convergence failure.', & - &' Simulation will terminate after output and deallocation.')" -! ------------------------------------------------------------------------------ - ! - ! -- Initialize - hasConverged = .true. - ! - ! -- Count number of failures - if(isimcnvg == 0) then - numnoconverge = numnoconverge + 1 - end if - ! - ! -- Continue if 'CONTINUE' specified in simulation control file - if(isimcontinue == 1) then - if(isimcnvg == 0) then - isimcnvg = 1 - endif - endif - ! - ! -- - if(isimcnvg == 0) then - !write(iout, fmtfail) - call sim_message('', fmt=fmtfail, iunit=iout) - hasConverged = .false. - endif - ! - ! -- Return - return - end subroutine converge_check - - subroutine final_message() -! ****************************************************************************** -! Create the appropriate final message and terminate the program -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - use SimVariablesModule, only: isimcnvg, numnoconverge, ireturnerr - ! -- local - character(len=LINELENGTH) :: line - ! -- formats - character(len=*), parameter :: fmtnocnvg = & - "(1x, 'Simulation convergence failure occurred ', i0, ' time(s).')" -! ------------------------------------------------------------------------------ - ! - ! -- Write message if any nonconvergence - if(numnoconverge > 0) then - write(line, fmtnocnvg) numnoconverge - call sim_message(line, iunit=iout) - call sim_message(line) - endif - ! - if(isimcnvg == 0) then - ireturnerr = 1 - call print_final_message('Premature termination of simulation.', iout) - else - call print_final_message('Normal termination of simulation.', iout) - endif - ! - ! -- Return or halt - if (iforcestop == 1) then - call stop_with_error(ireturnerr) - end if - - end subroutine final_message - - subroutine sim_closefiles() -! ****************************************************************************** -! Close all opened files. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - implicit none - ! -- dummy - ! -- local - integer(I4B) :: i - logical :: opened -! ------------------------------------------------------------------------------ - ! - ! -- close all open file units - do i = iustart, iunext - 1 - ! - ! -- determine if file unit i is open - inquire(unit=i, opened=opened) - ! - ! -- skip file units that are no longer open - if(.not. opened) then - cycle - end if - ! - ! -- close file unit i - close(i) - end do - ! - ! -- return - return - end subroutine sim_closefiles - -end module SimModule +module SimModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: MAXCHARLEN, LINELENGTH, & + IUSTART, IULAST, & + VSUMMARY, VALL, VDEBUG + use SimVariablesModule, only: istdout, iout, isim_level, ireturnerr, & + iforcestop, iunext + use GenericUtilitiesModule, only: sim_message, stop_with_error + + implicit none + + private + public :: count_errors + public :: store_error + public :: ustop + public :: converge_reset + public :: converge_check + public :: final_message + public :: store_warning + public :: store_note + public :: count_warnings + public :: count_notes + public :: store_error_unit + public :: store_error_filename + public :: print_notes + public :: maxerrors + + character(len=MAXCHARLEN), allocatable, dimension(:) :: sim_errors + character(len=MAXCHARLEN), allocatable, dimension(:) :: sim_warnings + character(len=MAXCHARLEN), allocatable, dimension(:) :: sim_notes + integer(I4B) :: nerrors = 0 + integer(I4B) :: maxerrors = 1000 + integer(I4B) :: maxerrors_exceeded = 0 + integer(I4B) :: nwarnings = 0 + integer(I4B) :: nnotes = 0 + integer(I4B) :: inc_errors = 100 + integer(I4B) :: inc_warnings = 100 + integer(I4B) :: inc_notes = 100 + +contains + +function count_errors() +! ****************************************************************************** +! Return error count +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + integer(I4B) :: count_errors +! ------------------------------------------------------------------------------ + if (allocated(sim_errors)) then + count_errors = nerrors + else + count_errors = 0 + endif + return +end function count_errors + +function count_warnings() +! ****************************************************************************** +! Return warning count +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + integer(I4B) :: count_warnings +! ------------------------------------------------------------------------------ + if (allocated(sim_warnings)) then + count_warnings = nwarnings + else + count_warnings = 0 + endif + return +end function count_warnings + +function count_notes() +! ****************************************************************************** +! Return notes count +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- return + integer(I4B) :: count_notes +! ------------------------------------------------------------------------------ + if (allocated(sim_notes)) then + count_notes = nnotes + else + count_notes = 0 + endif + return +end function count_notes + +subroutine store_error(errmsg) +! ****************************************************************************** +! Store an error message for printing at end of simulation +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ArrayHandlersModule, only: ExpandArray + ! -- dummy + character(len=*), intent(in) :: errmsg + ! -- local + logical :: inc_array + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + ! -- determine if the sim_errors should be expanded + inc_array = .TRUE. + if (allocated(sim_errors)) then + if (count_errors() < size(sim_errors)) then + inc_array = .FALSE. + end if + end if + ! + ! -- resize sim_errors + if (inc_array) then + call ExpandArray(sim_errors, increment=inc_errors) + inc_errors = inc_errors * 1.1 + end if + ! + ! -- store this error + i = count_errors() + 1 + if (i <= maxerrors) then + nerrors = i + sim_errors(i) = errmsg + else + maxerrors_exceeded = maxerrors_exceeded + 1 + end if + ! + return +end subroutine store_error + +subroutine store_error_unit(iunit) +! ****************************************************************************** +! Convert iunit to file name and indicate error reading from this file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + integer(I4B), intent(in) :: iunit + ! -- local + character(len=LINELENGTH) :: fname +! ------------------------------------------------------------------------------ + ! + inquire(unit=iunit, name=fname) + call store_error('ERROR OCCURRED WHILE READING FILE: ') + call store_error(trim(adjustl(fname))) + ! + return +end subroutine store_error_unit + +subroutine store_error_filename(filename) +! ****************************************************************************** +! Indicate error reading from this file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + character(len=*), intent(in) :: filename + ! -- local +! ------------------------------------------------------------------------------ + ! + call store_error('ERROR OCCURRED WHILE READING FILE: ') + call store_error(trim(adjustl(filename))) + ! + return +end subroutine store_error_filename + +subroutine store_warning(warnmsg) +! ****************************************************************************** +! Store a warning message for printing at end of simulation +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ArrayHandlersModule, only: ExpandArray + ! -- dummy + character(len=*), intent(in) :: warnmsg + ! -- local + logical :: inc_array + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + inc_array = .TRUE. + if (allocated(sim_warnings)) then + if (count_warnings() < size(sim_warnings)) then + inc_array = .FALSE. + end if + end if + if (inc_array) then + call ExpandArray(sim_warnings, increment=inc_warnings) + inc_warnings = inc_warnings * 1.1 + end if + i = count_warnings() + 1 + nwarnings = i + sim_warnings(i) = warnmsg + ! + return +end subroutine store_warning + +subroutine store_note(note) +! ****************************************************************************** +! Store a note for printing at end of simulation +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ArrayHandlersModule, only: ExpandArray + ! -- dummy + character(len=*), intent(in) :: note + ! -- local + logical :: inc_array + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + inc_array = .TRUE. + if (allocated(sim_notes)) then + if (count_notes() < size(sim_notes)) then + inc_array = .FALSE. + end if + end if + if (inc_array) then + call ExpandArray(sim_notes, increment=inc_notes) + inc_notes = inc_notes * 1.1 + end if + i = count_notes() + 1 + nnotes = i + sim_notes(i) = note + ! + return +end subroutine store_note + +logical function print_errors() +! ****************************************************************************** +! Print all error messages that have been stored +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- local + integer(I4B) :: i, isize + character(len=LINELENGTH) :: errmsg + ! -- formats + character(len=*), parameter :: stdfmt = "(/,'ERROR REPORT:',/)" +! ------------------------------------------------------------------------------ + ! + print_errors = .false. + if (allocated(sim_errors)) then + isize = count_errors() + if (isize > 0) then + print_errors = .true. + if (iout > 0) write(iout, stdfmt) + call sim_message('', fmt=stdfmt) + do i = 1, isize + call write_message(sim_errors(i)) + if (iout > 0) then + call write_message(sim_errors(i), iout) + end if + enddo + ! + ! -- write the number of errors + write(errmsg, '(i0, a)') isize, ' errors detected.' + call write_message(trim(errmsg)) + if (iout > 0) then + call write_message(trim(errmsg), iout) + end if + ! + ! -- write number of additional errors + if (maxerrors_exceeded > 0) then + write(errmsg, '(i0, a)') maxerrors_exceeded, & + ' additional errors detected but not printed.' + call write_message(trim(errmsg)) + if (iout > 0) then + call write_message(trim(errmsg), iout) + end if + end if + endif + endif + ! + return +end function print_errors + +subroutine print_warnings() +! ****************************************************************************** +! Print all warning messages that have been stored +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- local + integer(I4B) :: i, isize + ! -- formats + character(len=*), parameter :: stdfmt = "(/,'WARNINGS:',/)" +! ------------------------------------------------------------------------------ + ! + if (allocated(sim_warnings)) then + isize = count_warnings() + if (isize>0) then + if (iout>0) then + call sim_message('', fmt=stdfmt, iunit=iout) + end if + call sim_message('', fmt=stdfmt) + do i=1,isize + call write_message(sim_warnings(i)) + if (iout>0) then + call write_message(sim_warnings(i), iout) + end if + end do + end if + ! + ! -- write a blank line + if (iout>0) then + call sim_message('', iunit=iout) + end if + call sim_message('') + end if + ! + return +end subroutine print_warnings + +subroutine print_notes(numberlist) +! ****************************************************************************** +! Print all notes that have been stored +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + logical, intent(in), optional :: numberlist + ! -- local + integer(I4B) :: i, isize + character(len=MAXCHARLEN+10) :: noteplus + logical :: numlist + ! -- formats + character(len=*), parameter :: fmtnotes = "(/,'NOTES:')" + character(len=*), parameter :: fmta = "(i0,'. ',a)" + character(len=*), parameter :: fmtb = '(a)' +! ------------------------------------------------------------------------------ + ! + if (present(numberlist)) then + numlist = numberlist + else + numlist = .true. + endif + ! + if (allocated(sim_notes)) then + isize = count_notes() + if (isize>0) then + if (iout>0) then + call sim_message('', fmt=fmtnotes, iunit=iout) + end if + call sim_message('', fmt=fmtnotes) + do i=1, isize + if (numlist) then + write(noteplus,fmta) i, trim(sim_notes(i)) + else + write(noteplus,fmtb) trim(sim_notes(i)) + endif + call write_message(noteplus) + if (iout > 0) then + call write_message(noteplus, iout) + end if + enddo + endif + endif + ! + return +end subroutine print_notes + +subroutine write_message(message, iunit, error, skipbefore, skipafter) +! ****************************************************************************** +! Subroutine write_message formats and writes a message. +! +! -- Arguments are as follows: +! MESSAGE : message to be written +! IUNIT : the unit number to which the message is written +! ERROR : if true precede message with "Error" +! SKIPBEFORE : number of empty lines before message +! SKIPAFTER : number of empty lines after message +! +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + character (len=*), intent(in) :: message + integer(I4B), intent(in), optional :: iunit + logical, intent(in), optional :: error + integer(I4B), intent(in), optional :: skipbefore + integer(I4B), intent(in), optional :: skipafter + ! -- local + integer(I4B) :: jend, i, nblc, junit, leadblank + integer(I4B) :: itake, j + character(len=20) :: ablank + character(len=MAXCHARLEN) :: amessage +! ------------------------------------------------------------------------------ + ! + amessage = message + if (amessage==' ') return + if (amessage(1:1).ne.' ') amessage = ' ' // trim(amessage) + ! + ! -- initialize local variables + junit = istdout + ablank = ' ' + itake = 0 + j = 0 + ! + ! -- process optional dummy variables + if(present(iunit))then + if (iunit > 0) then + junit = iunit + end if + end if + if(present(skipbefore))then + do i = 1, skipbefore + call sim_message('', iunit=junit) + end do + endif + if(present(error))then + if(error)then + nblc=len_trim(amessage) + amessage=adjustr(amessage(1:nblc+8)) + if(nblc+8.lt.len(amessage)) amessage(nblc+9:)=' ' + amessage(1:8)=' Error: ' + end if + end if + ! + do i=1,20 + if (amessage(i:i).ne.' ') exit + end do + leadblank=i-1 + nblc=len_trim(amessage) + ! +5 continue + jend = j + 78 - itake + if (jend >= nblc) go to 100 + do i=jend,j+1,-1 + if(amessage(i:i).eq.' ') then + if(itake.eq.0) then + call sim_message(amessage(j+1:i), iunit=junit) + itake = 2 + leadblank + else + call sim_message(ablank(1:leadblank+2)//amessage(j+1:i), iunit=junit) + end if + j = i + go to 5 + end if + end do + if(itake == 0)then + call sim_message(amessage(j+1:jend), iunit=junit) + itake = 2 + leadblank + else + call sim_message(ablank(1:leadblank+2)//amessage(j+1:jend), iunit=junit) + end if + j = jend + go to 5 + ! +100 continue + jend = nblc + if (itake == 0)then + call sim_message(amessage(j+1:jend), iunit=junit) + else + call sim_message(ablank(1:leadblank+2)//amessage(j+1:jend), iunit=junit) + end if + ! + if(present(skipafter))then + do i = 1, skipafter + call sim_message('', iunit=junit) + end do + endif + ! + ! -- return + return +! ! +!200 continue +! call ustop() + ! +end subroutine write_message + +! -- this subroutine prints final messages and then stops with the active +! error code. +subroutine ustop(stopmess, ioutlocal) +! ****************************************************************************** +! Stop program, with option to print message before stopping. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + character, optional, intent(in) :: stopmess*(*) + integer(I4B), optional, intent(in) :: ioutlocal + + !--------------------------------------------------------------------------- + ! + ! -- print the final message + call print_final_message(stopmess, ioutlocal) + ! + ! -- return appropriate error codes when terminating the program + call stop_with_error(ireturnerr) + +end subroutine ustop + +subroutine print_final_message(stopmess, ioutlocal) +! ****************************************************************************** +! Print a final message and close all open files +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + character, optional, intent(in) :: stopmess*(*) + integer(I4B), optional, intent(in) :: ioutlocal + ! -- local + character(len=*), parameter :: fmt = '(1x,a)' + character(len=*), parameter :: msg = 'Stopping due to error(s)' + logical :: errorfound + !--------------------------------------------------------------------------- + call print_notes() + call print_warnings() + errorfound = print_errors() + if (present(stopmess)) then + if (stopmess.ne.' ') then + call sim_message(stopmess, fmt=fmt, iunit=iout) + call sim_message(stopmess, fmt=fmt) + if (present(ioutlocal)) then + if (ioutlocal > 0 .and. ioutlocal .ne. iout) then + write(ioutlocal,fmt) trim(stopmess) + close (ioutlocal) + endif + endif + endif + endif + ! + if (errorfound) then + ireturnerr = 2 + if (iout > 0) then + call sim_message(stopmess, fmt=fmt, iunit=iout) + end if + call sim_message(stopmess, fmt=fmt) + + if (present(ioutlocal)) then + if (ioutlocal > 0 .and. ioutlocal /= iout) write(ioutlocal,fmt) msg + endif + endif + ! + ! -- close all open files + call sim_closefiles() + ! + ! -- return + return + +end subroutine print_final_message + +subroutine converge_reset() +! ****************************************************************************** +! converge_reset +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimVariablesModule, only: isimcnvg +! ------------------------------------------------------------------------------ + ! + isimcnvg = 1 + ! + ! -- Return + return + end subroutine converge_reset + + subroutine converge_check(hasConverged) +! ****************************************************************************** +! convergence check +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimVariablesModule, only: isimcnvg, numnoconverge, isimcontinue + ! -- dummy + logical, intent(inout) :: hasConverged + ! -- format + character(len=*), parameter :: fmtfail = & + "(1x, 'Simulation convergence failure.', & + &' Simulation will terminate after output and deallocation.')" +! ------------------------------------------------------------------------------ + ! + ! -- Initialize + hasConverged = .true. + ! + ! -- Count number of failures + if(isimcnvg == 0) then + numnoconverge = numnoconverge + 1 + end if + ! + ! -- Continue if 'CONTINUE' specified in simulation control file + if(isimcontinue == 1) then + if(isimcnvg == 0) then + isimcnvg = 1 + endif + endif + ! + ! -- + if(isimcnvg == 0) then + !write(iout, fmtfail) + call sim_message('', fmt=fmtfail, iunit=iout) + hasConverged = .false. + endif + ! + ! -- Return + return + end subroutine converge_check + + subroutine final_message() +! ****************************************************************************** +! Create the appropriate final message and terminate the program +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + use SimVariablesModule, only: isimcnvg, numnoconverge, ireturnerr + ! -- local + character(len=LINELENGTH) :: line + ! -- formats + character(len=*), parameter :: fmtnocnvg = & + "(1x, 'Simulation convergence failure occurred ', i0, ' time(s).')" +! ------------------------------------------------------------------------------ + ! + ! -- Write message if any nonconvergence + if(numnoconverge > 0) then + write(line, fmtnocnvg) numnoconverge + call sim_message(line, iunit=iout) + call sim_message(line) + endif + ! + if(isimcnvg == 0) then + ireturnerr = 1 + call print_final_message('Premature termination of simulation.', iout) + else + call print_final_message('Normal termination of simulation.', iout) + endif + ! + ! -- Return or halt + if (iforcestop == 1) then + call stop_with_error(ireturnerr) + end if + + end subroutine final_message + + subroutine sim_closefiles() +! ****************************************************************************** +! Close all opened files. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + implicit none + ! -- dummy + ! -- local + integer(I4B) :: i + logical :: opened +! ------------------------------------------------------------------------------ + ! + ! -- close all open file units + do i = iustart, iunext - 1 + ! + ! -- determine if file unit i is open + inquire(unit=i, opened=opened) + ! + ! -- skip file units that are no longer open + if(.not. opened) then + cycle + end if + ! + ! -- close file unit i + close(i) + end do + ! + ! -- return + return + end subroutine sim_closefiles + +end module SimModule diff --git a/src/Utilities/SmoothingFunctions.f90 b/src/Utilities/SmoothingFunctions.f90 index 2fc6b5fce93..911dd50c584 100644 --- a/src/Utilities/SmoothingFunctions.f90 +++ b/src/Utilities/SmoothingFunctions.f90 @@ -185,21 +185,21 @@ subroutine sChSmooth(d, smooth, dwdh) real(DP), intent(in) :: d real(DP), intent(inout) :: smooth real(DP), intent(inout) :: dwdh - ! + ! ! -- local variables - real(DP) :: s - real(DP) :: diff - real(DP) :: aa - real(DP) :: ad - real(DP) :: b - real(DP) :: x + real(DP) :: s + real(DP) :: diff + real(DP) :: aa + real(DP) :: ad + real(DP) :: b + real(DP) :: x real(DP) :: y ! ------------------------------------------------------------------------------ ! code ! smooth = DZERO s = DEM5 - x = d + x = d diff = x - s if ( diff > DZERO ) then smooth = DONE @@ -351,8 +351,8 @@ function sQuadraticSaturation(top, bot, x, eps, bmin) result(y) end if av = DONE / (DONE - teps) bri = DONE - br - if (br < tbmin) then - br = tbmin + if (br < tbmin) then + br = tbmin end if if (br < teps) then y = av * DHALF * (br*br) / teps @@ -372,7 +372,7 @@ function sQuadraticSaturation(top, bot, x, eps, bmin) result(y) end if return - end function sQuadraticSaturation + end function sQuadraticSaturation function svanGenuchtenSaturation(top, bot, x, alpha, beta, sr) result(y) ! ****************************************************************************** @@ -462,7 +462,7 @@ function sQuadraticSaturationDerivative(top, bot, x, eps, bmin) result(y) bri = DONE - br if (br < tbmin) then br = tbmin - end if + end if if (br < teps) then y = av * br / teps elseif (br < (DONE-teps)) then @@ -559,8 +559,8 @@ end function sQSaturationDerivative function sSlope(x, xi, yi, sm, sp, ta) result(y) ! ****************************************************************************** -! Nonlinear smoothing function returns a smoothed value of y that has the value -! yi at xi and yi + (sm * dx) for x-values less than xi and yi + (sp * dx) for +! Nonlinear smoothing function returns a smoothed value of y that has the value +! yi at xi and yi + (sm * dx) for x-values less than xi and yi + (sp * dx) for ! x-values greater than xi, where dx = x - xi. ! ****************************************************************************** ! @@ -581,38 +581,38 @@ function sSlope(x, xi, yi, sm, sp, ta) result(y) real(DP) :: dx real(DP) :: xm real(DP) :: xp - real(DP) :: ym + real(DP) :: ym real(DP) :: yp ! ------------------------------------------------------------------------------ - ! - ! -- set smoothing variable a + ! + ! -- set smoothing variable a if (present(ta)) then a = a else a = DEM8 - end if - ! - ! -- calculate b from smoothing variable a - b = a / (sqrt(DTWO) - DONE) - ! - ! -- calculate contributions to y - dx = x - xi - xm = DHALF * (x + xi - sqrt(dx + b**DTWO - a**DTWO)) - xp = DHALF * (x + xi + sqrt(dx + b**DTWO - a**DTWO)) - ym = sm * (xm - xi) - yp = sp * (xi - xp) - ! - ! -- calculate y from ym and yp contributions - y = yi + ym + yp - ! + end if + ! + ! -- calculate b from smoothing variable a + b = a / (sqrt(DTWO) - DONE) + ! + ! -- calculate contributions to y + dx = x - xi + xm = DHALF * (x + xi - sqrt(dx + b**DTWO - a**DTWO)) + xp = DHALF * (x + xi + sqrt(dx + b**DTWO - a**DTWO)) + ym = sm * (xm - xi) + yp = sp * (xi - xp) + ! + ! -- calculate y from ym and yp contributions + y = yi + ym + yp + ! ! -- return return end function sSlope function sSlopeDerivative(x, xi, sm, sp, ta) result(y) ! ****************************************************************************** -! Derivative of nonlinear smoothing function that has the value yi at xi and -! yi + (sm * dx) for x-values less than xi and yi + (sp * dx) for x-values +! Derivative of nonlinear smoothing function that has the value yi at xi and +! yi + (sm * dx) for x-values less than xi and yi + (sp * dx) for x-values ! greater than xi, where dx = x - xi. ! ****************************************************************************** ! @@ -629,38 +629,38 @@ function sSlopeDerivative(x, xi, sm, sp, ta) result(y) ! -- local real(DP) :: a real(DP) :: b - real(DP) :: dx - real(DP) :: mu + real(DP) :: dx + real(DP) :: mu real(DP) :: rho ! ------------------------------------------------------------------------------ - ! - ! -- set smoothing variable a + ! + ! -- set smoothing variable a if (present(ta)) then a = a else a = DEM8 - end if - ! - ! -- calculate b from smoothing variable a - b = a / (sqrt(DTWO) - DONE) - ! - ! -- calculate contributions to derivative - dx = x - xi - mu = sqrt(dx**DTWO + b**DTWO - a**DTWO) - rho = dx / mu - ! - ! -- calculate derivative from individual contributions - y = DHALF * (sm + sp) - DHALF * rho * (sm - sp) - ! + end if + ! + ! -- calculate b from smoothing variable a + b = a / (sqrt(DTWO) - DONE) + ! + ! -- calculate contributions to derivative + dx = x - xi + mu = sqrt(dx**DTWO + b**DTWO - a**DTWO) + rho = dx / mu + ! + ! -- calculate derivative from individual contributions + y = DHALF * (sm + sp) - DHALF * rho * (sm - sp) + ! ! -- return return end function sSlopeDerivative function sQuadratic0sp(x, xi, tomega) result(y) ! ****************************************************************************** -! Nonlinear smoothing function returns a smoothed value of y that uses a -! quadratic to smooth x over range of xi - epsilon to xi + epsilon. -! Simplification of sQuadraticSlope with sm = 0, sp = 1, and yi = 0. +! Nonlinear smoothing function returns a smoothed value of y that uses a +! quadratic to smooth x over range of xi - epsilon to xi + epsilon. +! Simplification of sQuadraticSlope with sm = 0, sp = 1, and yi = 0. ! From Panday et al. (2013) - eq. 35 - https://dx.doi.org/10.5066/F7R20ZFJ ! ****************************************************************************** ! @@ -677,38 +677,38 @@ function sQuadratic0sp(x, xi, tomega) result(y) real(DP) :: epsilon real(DP) :: dx ! ------------------------------------------------------------------------------ - ! - ! -- set smoothing interval + ! + ! -- set smoothing interval if (present(tomega)) then omega = tomega else omega = DEM6 - end if - ! - ! -- set smoothing interval - epsilon = DHALF * omega - ! - ! -- calculate distance from xi - dx = x - xi - ! - ! -- evaluate smoothing function - if (dx < -epsilon) then - y = xi - else if (dx < epsilon) then - y = (dx**DTWO / (DFOUR * epsilon)) + DHALF * dx + (epsilon / DFOUR) + xi - else - y = x - end if - ! + end if + ! + ! -- set smoothing interval + epsilon = DHALF * omega + ! + ! -- calculate distance from xi + dx = x - xi + ! + ! -- evaluate smoothing function + if (dx < -epsilon) then + y = xi + else if (dx < epsilon) then + y = (dx**DTWO / (DFOUR * epsilon)) + DHALF * dx + (epsilon / DFOUR) + xi + else + y = x + end if + ! ! -- return return end function sQuadratic0sp function sQuadratic0spDerivative(x, xi, tomega) result(y) ! ****************************************************************************** -! Derivative of nonlinear smoothing function returns a smoothed value of y -! that uses a quadratic to smooth x over range of xi - epsilon to xi + epsilon. -! Simplification of sQuadraticSlope with sm = 0, sp = 1, and yi = 0. +! Derivative of nonlinear smoothing function returns a smoothed value of y +! that uses a quadratic to smooth x over range of xi - epsilon to xi + epsilon. +! Simplification of sQuadraticSlope with sm = 0, sp = 1, and yi = 0. ! From Panday et al. (2013) - eq. 35 - https://dx.doi.org/10.5066/F7R20ZFJ ! ****************************************************************************** ! @@ -725,37 +725,37 @@ function sQuadratic0spDerivative(x, xi, tomega) result(y) real(DP) :: epsilon real(DP) :: dx ! ------------------------------------------------------------------------------ - ! - ! -- set smoothing interval + ! + ! -- set smoothing interval if (present(tomega)) then omega = tomega else omega = DEM6 - end if - ! - ! -- set smoothing interval - epsilon = DHALF * omega - ! - ! -- calculate distance from xi - dx = x - xi - ! - ! -- evaluate smoothing function - if (dx < -epsilon) then - y = 0 - else if (dx < epsilon) then - y = (dx / omega) + DHALF - else - y = 1 - end if - ! + end if + ! + ! -- set smoothing interval + epsilon = DHALF * omega + ! + ! -- calculate distance from xi + dx = x - xi + ! + ! -- evaluate smoothing function + if (dx < -epsilon) then + y = 0 + else if (dx < epsilon) then + y = (dx / omega) + DHALF + else + y = 1 + end if + ! ! -- return return - end function sQuadratic0spDerivative + end function sQuadratic0spDerivative function sQuadraticSlope(x, xi, yi, sm, sp, tomega) result(y) ! ****************************************************************************** -! Quadratic smoothing function returns a smoothed value of y that has the value -! yi at xi and yi + (sm * dx) for x-values less than xi and yi + (sp * dx) for +! Quadratic smoothing function returns a smoothed value of y that has the value +! yi at xi and yi + (sm * dx) for x-values less than xi and yi + (sp * dx) for ! x-values greater than xi, where dx = x - xi. ! ****************************************************************************** ! @@ -773,45 +773,45 @@ function sQuadraticSlope(x, xi, yi, sm, sp, tomega) result(y) ! -- local real(DP) :: omega real(DP) :: epsilon - real(DP) :: dx + real(DP) :: dx real(DP) :: c ! ------------------------------------------------------------------------------ - ! - ! -- set smoothing interval + ! + ! -- set smoothing interval if (present(tomega)) then omega = tomega else omega = DEM6 - end if - ! - ! -- set smoothing interval - epsilon = DHALF * omega - ! - ! -- calculate distance from xi - dx = x - xi - ! - ! -- evaluate smoothing function - if (dx < -epsilon) then - y = sm * dx - else if (dx < epsilon) then - c = dx / epsilon - y = DHALF * epsilon * (DHALF * (sp - sm) * (DONE + c**DTWO) + (sm + sp) * c) - else - y = sp * dx - end if - ! - ! -- add value at xi - y = y + yi - ! + end if + ! + ! -- set smoothing interval + epsilon = DHALF * omega + ! + ! -- calculate distance from xi + dx = x - xi + ! + ! -- evaluate smoothing function + if (dx < -epsilon) then + y = sm * dx + else if (dx < epsilon) then + c = dx / epsilon + y = DHALF * epsilon * (DHALF * (sp - sm) * (DONE + c**DTWO) + (sm + sp) * c) + else + y = sp * dx + end if + ! + ! -- add value at xi + y = y + yi + ! ! -- return return - end function sQuadraticSlope + end function sQuadraticSlope function sQuadraticSlopeDerivative(x, xi, sm, sp, tomega) result(y) ! ****************************************************************************** -! Derivative of quadratic smoothing function returns a smoothed value of y -! that has the value yi at xi and yi + (sm * dx) for x-values less than xi and +! Derivative of quadratic smoothing function returns a smoothed value of y +! that has the value yi at xi and yi + (sm * dx) for x-values less than xi and ! yi + (sp * dx) for x-values greater than xi, where dx = x - xi. ! ****************************************************************************** ! @@ -828,36 +828,36 @@ function sQuadraticSlopeDerivative(x, xi, sm, sp, tomega) result(y) ! -- local real(DP) :: omega real(DP) :: epsilon - real(DP) :: dx + real(DP) :: dx real(DP) :: c ! ------------------------------------------------------------------------------ - ! - ! -- set smoothing interval + ! + ! -- set smoothing interval if (present(tomega)) then omega = tomega else omega = DEM6 - end if - ! - ! -- set smoothing interval - epsilon = DHALF * omega - ! - ! -- calculate distance from xi - dx = x - xi - ! - ! -- evaluate smoothing function - if (dx < -epsilon) then - y = sm - else if (dx < epsilon) then - c = dx / epsilon - y = DHALF * ((sp - sm) * c + (sm + sp)) - else - y = sp - end if - ! + end if + ! + ! -- set smoothing interval + epsilon = DHALF * omega + ! + ! -- calculate distance from xi + dx = x - xi + ! + ! -- evaluate smoothing function + if (dx < -epsilon) then + y = sm + else if (dx < epsilon) then + c = dx / epsilon + y = DHALF * ((sp - sm) * c + (sm + sp)) + else + y = sp + end if + ! ! -- return return - end function sQuadraticSlopeDerivative + end function sQuadraticSlopeDerivative end module SmoothingModule diff --git a/src/Utilities/Sparse.f90 b/src/Utilities/Sparse.f90 index 66c87c902ba..0824581c372 100644 --- a/src/Utilities/Sparse.f90 +++ b/src/Utilities/Sparse.f90 @@ -3,9 +3,9 @@ module SparseModule !of a matrix. Module uses FORTRAN 2003 extensions to manage !the data structures in an object oriented fashion. - use KindModule, only: DP, I4B - implicit none - + use KindModule, only: DP, I4B + implicit none + type rowtype integer(I4B) :: nnz ! number of nonzero entries in the row integer(I4B), allocatable, dimension(:) :: icolarray ! array of column numbers diff --git a/src/Utilities/Table.f90 b/src/Utilities/Table.f90 index 175443f70db..e643f58af15 100644 --- a/src/Utilities/Table.f90 +++ b/src/Utilities/Table.f90 @@ -1,935 +1,935 @@ -! Comprehensive table object that stores all of the -! intercell flows, and the inflows and the outflows for -! an advanced package. -module TableModule - - use KindModule, only: I4B, DP - use ConstantsModule, only: LINELENGTH, LENBUDTXT, & - TABSTRING, TABUCSTRING, TABINTEGER, TABREAL, & - TABCENTER - use TableTermModule, only: TableTermType - use InputOutputModule, only: UWWORD, parseline - use SimModule, only: store_error, ustop - use TdisModule, only: kstp, kper - - implicit none - - public :: TableType - public :: table_cr - - type :: TableType - ! - ! -- name, number of control volumes, and number of table terms - character(len=LENBUDTXT) :: name - character(len=LINELENGTH) :: title - character(len=1), pointer :: sep => null() - logical, pointer :: write_csv => null() - logical, pointer :: first_entry => null() - logical, pointer :: transient => null() - logical, pointer :: add_linesep => null() - logical, pointer :: allow_finalization => null() - integer(I4B), pointer :: iout => null() - integer(I4B), pointer :: maxbound => null() - integer(I4B), pointer :: nheaderlines => null() - integer(I4B), pointer :: nlinewidth => null() - integer(I4B), pointer :: ntableterm => null() - integer(I4B), pointer :: ientry => null() - integer(I4B), pointer :: iloc => null() - integer(I4B), pointer :: icount => null() - integer(I4B), pointer :: kstp => null() - integer(I4B), pointer :: kper => null() - ! - ! -- array of table terms, with one separate entry for each term - ! such as rainfall, et, leakage, etc. - type(TableTermType), dimension(:), pointer :: tableterm => null() - ! - ! -- table table object, for writing the typical MODFLOW table - type(TableType), pointer :: table => null() - - character(len=LINELENGTH), pointer :: linesep => null() - character(len=LINELENGTH), pointer :: dataline => null() - character(len=LINELENGTH), dimension(:), pointer :: header => null() - - contains - - procedure :: table_df - procedure :: table_da - procedure :: initialize_column - procedure :: line_to_columns - procedure :: finalize_table - procedure :: set_maxbound - procedure :: set_title - procedure :: print_list_entry - - procedure, private :: allocate_strings - procedure, private :: set_header - procedure, private :: write_header - procedure, private :: write_line - procedure, private :: finalize - procedure, private :: add_error - procedure, private :: reset - - generic, public :: add_term => add_integer, add_real, add_string - procedure, private :: add_integer, add_real, add_string - - end type TableType - - contains - - subroutine table_cr(this, name, title) -! ****************************************************************************** -! table_cr -- Create a new table object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - type(TableType), pointer :: this - character(len=*), intent(in) :: name - character(len=*), intent(in) :: title - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- check if table already associated and reset if necessary - if (associated(this)) then - call this%table_da() - deallocate(this) - nullify(this) - end if - ! - ! -- Create the object - allocate(this) - ! - ! -- initialize variables - this%name = name - this%title = title - ! - ! -- Return - return - end subroutine table_cr - - subroutine table_df(this, maxbound, ntableterm, iout, transient, & - lineseparator, separator, finalize) -! ****************************************************************************** -! table_df -- Define the new table object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableType) :: this - integer(I4B), intent(in) :: maxbound - integer(I4B), intent(in) :: ntableterm - integer(I4B), intent(in) :: iout - logical, intent(in), optional :: transient - logical, intent(in), optional :: lineseparator - character(len=1), intent(in), optional :: separator - logical, intent(in), optional :: finalize -! ------------------------------------------------------------------------------ - ! - ! -- allocate scalars - allocate(this%sep) - allocate(this%write_csv) - allocate(this%first_entry) - allocate(this%transient) - allocate(this%add_linesep) - allocate(this%allow_finalization) - allocate(this%iout) - allocate(this%maxbound) - allocate(this%nheaderlines) - allocate(this%nlinewidth) - allocate(this%ntableterm) - allocate(this%ientry) - allocate(this%iloc) - allocate(this%icount) - ! - ! -- allocate space for tableterm - allocate(this%tableterm(ntableterm)) - ! - ! -- initialize values based on optional dummy variables - if (present(transient)) then - this%transient = transient - else - this%transient = .FALSE. - end if - if (present(separator)) then - this%sep = separator - if (separator == ',') then - this%write_csv = .TRUE. - else - this%write_csv = .FALSE. - end if - else - this%sep = ' ' - this%write_csv = .FALSE. - end if - if (present(lineseparator)) then - this%add_linesep = lineseparator - else - this%add_linesep = .TRUE. - end if - if (present(finalize)) then - this%allow_finalization = finalize - else - this%allow_finalization = .TRUE. - end if - ! - ! -- initialize variables - this%first_entry = .TRUE. - this%iout = iout - this%maxbound = maxbound - this%ntableterm = ntableterm - this%ientry = 0 - this%icount = 0 - ! - ! -- return - return - end subroutine table_df - - subroutine initialize_column(this, text, width, alignment) -! ****************************************************************************** -! initialize_column -- Initialize data for a column -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableType) :: this - character(len=*), intent(in) :: text - integer(I4B), intent(in) :: width - integer(I4B), intent(in), optional :: alignment - ! -- local - character (len=LINELENGTH) :: errmsg - integer(I4B) :: idx - integer(I4B) :: ialign -! ------------------------------------------------------------------------------ - ! - ! -- process optional dummy variables - if (present(alignment)) then - ialign = alignment - else - ialign = TABCENTER - end if - ! - ! -- update index for tableterm - this%ientry = this%ientry + 1 - idx = this%ientry - ! - ! -- check that ientry is in bounds - if (this%ientry > this%ntableterm) then - write(errmsg,'(4x,a,a,a,i0,a,1x,a,1x,a,a,a,1x,i0,1x,a)') & - '****ERROR. TRYING TO ADD COLUMN "', trim(adjustl(text)), '" (', & - this%ientry, ') IN THE', trim(adjustl(this%name)), 'TABLE ("', & - trim(adjustl(this%title)), '") THAT ONLY HAS', this%ntableterm, 'COLUMNS' - call store_error(errmsg) - call ustop() - end if - ! - ! -- initialize table term - call this%tableterm(idx)%initialize(text, width, alignment=ialign) - ! - ! -- create header when all terms have been specified - if (this%ientry == this%ntableterm) then - call this%set_header() - ! - ! -- reset ientry - this%ientry = 0 - end if - ! - ! -- return - return - end subroutine initialize_column - - subroutine set_header(this) -! ****************************************************************************** -! set_header -- Set the table object header -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableType) :: this - ! -- local - character(len=LINELENGTH) :: cval - integer(I4B) :: width - integer(I4B) :: alignment - integer(I4B) :: nlines - integer(I4B) :: iloc - integer(I4B) :: ival - real(DP) :: rval - integer(I4B) :: j - integer(I4B) :: n - integer(I4B) :: nn -! ------------------------------------------------------------------------------ - ! - ! -- initialize variables - width = 0 - nlines = 0 - ! - ! -- determine total width and maximum number of lines - do n = 1, this%ntableterm - width = width + this%tableterm(n)%get_width() - nlines = max(nlines, this%tableterm(n)%get_header_lines()) - end do - ! - ! -- add length of separators - width = width + this%ntableterm - 1 - ! - ! -- allocate the header and line separator - call this%allocate_strings(width, nlines) - ! - ! -- build final header lines - do n = 1, this%ntableterm - call this%tableterm(n)%set_header(nlines) - end do - ! - ! -- build header - do n = 1, nlines - iloc = 1 - this%iloc = 1 - if (this%add_linesep) then - nn = n + 1 - else - nn = n - end if - do j = 1, this%ntableterm - width = this%tableterm(j)%get_width() - alignment = this%tableterm(j)%get_alignment() - call this%tableterm(j)%get_header(n, cval) - if (this%write_csv) then - if ( j == 1) then - write(this%header(nn), '(a)') trim(adjustl(cval)) - else - write(this%header(nn), '(a,",",G0)') & - trim(this%header(nn)), trim(adjustl(cval)) - end if - else - if (j == this%ntableterm) then - call UWWORD(this%header(nn), iloc, width, TABUCSTRING, & - cval(1:width), ival, rval, ALIGNMENT=alignment) - else - call UWWORD(this%header(nn), iloc, width, TABUCSTRING, & - cval(1:width), ival, rval, ALIGNMENT=alignment, & - SEP=this%sep) - end if - end if - end do - end do - ! - ! -- return - return - end subroutine set_header - - subroutine allocate_strings(this, width, nlines) -! ****************************************************************************** -! allocate_strings -- Allocate allocatable character arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableType) :: this - integer(I4B), intent(in) :: width - integer(I4B), intent(in) :: nlines - ! -- local - character(len=width) :: string - character(len=width) :: linesep - integer(I4B) :: n -! ------------------------------------------------------------------------------ - ! - ! -- initialize local variables - string = '' - linesep = repeat('-', width) - ! - ! -- initialize variables - this%nheaderlines = nlines - if (this%add_linesep) then - this%nheaderlines = this%nheaderlines + 2 - end if - this%nlinewidth = width - ! - ! -- allocate deferred length strings - allocate(this%header(this%nheaderlines)) - allocate(this%linesep) - allocate(this%dataline) - ! - ! -- initialize lines - this%linesep = linesep(1:width) - this%dataline = string(1:width) - do n = 1, this%nheaderlines - this%header(n) = string(1:width) - end do - ! - ! -- fill first and last header line with - ! linesep - if (this%add_linesep) then - this%header(1) = linesep(1:width) - this%header(nlines+2) = linesep(1:width) - end if - ! - ! -- return - return - end subroutine allocate_strings - - subroutine write_header(this) -! ****************************************************************************** -! write_table -- Write the table header -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableType) :: this - ! -- local - character(len=LINELENGTH) :: title - integer(I4B) :: width - integer(I4B) :: n -! ------------------------------------------------------------------------------ - ! - ! -- initialize local variables - width = this%nlinewidth - ! - ! -- write the table header - if (this%first_entry) then - ! -- write title - title = this%title - if (this%transient) then - write(title, '(a,a,i6)') trim(adjustl(title)), ' PERIOD ', kper - write(title, '(a,a,i8)') trim(adjustl(title)), ' STEP ', kstp - end if - if (len_trim(title) > 0) then - write(this%iout, '(/,1x,a)') trim(adjustl(title)) - end if - ! - ! -- write header - do n = 1, this%nheaderlines - write(this%iout, '(1x,a)') this%header(n)(1:width) - end do - end if - ! - ! -- reinitialize variables - this%first_entry = .FALSE. - this%ientry = 0 - this%icount = 0 - ! - ! -- return - return - end subroutine write_header - - subroutine write_line(this) -! ****************************************************************************** -! write_line -- Write the data line -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableType) :: this - ! -- local - integer(I4B) :: width -! ------------------------------------------------------------------------------ - ! - ! -- initialize local variables - width = this%nlinewidth - ! - ! -- write the dataline - write(this%iout, '(1x,a)') this%dataline(1:width) - ! - ! -- update column and line counters - this%ientry = 0 - this%iloc = 1 - this%icount = this%icount + 1 - ! - ! -- return - return - end subroutine write_line - - subroutine finalize(this) -! ****************************************************************************** -! finalize -- Private method that test for last line. If last line the -! public finalize_table method is called -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableType) :: this - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- finalize table if last entry - if (this%icount == this%maxbound) then - call this%finalize_table() - end if - ! - ! -- return - return - end subroutine finalize - - subroutine finalize_table(this) -! ****************************************************************************** -! finalize -- Public method to finalize the table -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableType) :: this - ! -- local - integer(I4B) :: width -! ------------------------------------------------------------------------------ - ! - ! -- initialize local variables - width = this%nlinewidth - ! - ! -- write the final table separator - if (this%add_linesep) then - write(this%iout, '(1x,a,/)') this%linesep(1:width) - end if - ! - ! -- reinitialize variables - call this%reset() - ! - ! -- return - return - end subroutine finalize_table - - subroutine table_da(this) -! ****************************************************************************** -! table_da -- deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableType) :: this - ! -- dummy - integer(I4B) :: i -! ------------------------------------------------------------------------------ - ! - ! -- deallocate each table term - do i = 1, this%ntableterm - call this%tableterm(i)%da() - end do - ! - ! -- deallocate space for tableterm - deallocate(this%tableterm) - ! - ! -- deallocate scalars - deallocate(this%sep) - deallocate(this%write_csv) - deallocate(this%first_entry) - deallocate(this%transient) - deallocate(this%add_linesep) - deallocate(this%allow_finalization) - deallocate(this%iout) - deallocate(this%maxbound) - deallocate(this%nheaderlines) - deallocate(this%nlinewidth) - deallocate(this%ntableterm) - deallocate(this%ientry) - deallocate(this%iloc) - deallocate(this%icount) - ! - ! -- Return - return - end subroutine table_da - - subroutine line_to_columns(this, line) -! ****************************************************************************** -! line_to_columns -- convert a line to the correct number of columns -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableType) :: this - character(len=LINELENGTH), intent(in) :: line - ! -- local - character(len=LINELENGTH), allocatable, dimension(:) :: words - integer(I4B) :: nwords - integer(I4B) :: icols - integer(I4B) :: i -! ------------------------------------------------------------------------------ - ! - ! -- write header - if (this%icount == 0 .and. this%ientry == 0) then - call this%write_header() - end if - ! - ! -- parse line into words - call parseline(line, nwords, words, 0) - ! - ! -- calculate the number of entries in line but - ! limit it to the maximum number of columns if - ! the number of words exceeds ntableterm - icols = this%ntableterm - icols = min(nwords, icols) - ! - ! -- add data (as strings) to line - do i = 1, icols - call this%add_term(words(i)) - end do - ! - ! -- add empty strings to complete the line - do i = this%ientry + 1, this%ntableterm - call this%add_term(' ') - end do - ! - ! -- clean up local allocatable array - deallocate(words) - ! - ! -- Return - return - end subroutine line_to_columns - - subroutine add_error(this) -! ****************************************************************************** -! add_error -- evaluate if error condition occurs when adding data to dataline -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableType) :: this - ! -- local - character (len=LINELENGTH) :: errmsg -! ------------------------------------------------------------------------------ - ! - ! -- check that ientry is within bounds - if (this%ientry > this%ntableterm) then - write(errmsg,'(4x,a,1x,i0,5(1x,a),1x,i0,1x,a)') & - '****ERROR. TRYING TO ADD DATA TO COLUMN ', this%ientry, 'IN THE', & - trim(adjustl(this%name)), 'TABLE (', trim(adjustl(this%title)), & - ') THAT ONLY HAS', this%ntableterm, 'COLUMNS' - call store_error(errmsg) - call ustop() - end if - ! - ! -- Return - return - end subroutine add_error - - subroutine add_integer(this, ival) -! ****************************************************************************** -! add_integer -- add integer value to the dataline -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableType) :: this - integer(I4B), intent(in) :: ival - ! -- local - logical :: line_end - character(len=LINELENGTH) :: cval - real(DP) :: rval - integer(I4B) :: width - integer(I4B) :: alignment - integer(I4B) :: j -! ------------------------------------------------------------------------------ - ! - ! -- write header - if (this%icount == 0 .and. this%ientry == 0) then - call this%write_header() - end if - ! - ! -- update index for tableterm - this%ientry = this%ientry + 1 - ! - ! -- check that ientry is within bounds - call this%add_error() - ! - ! -- initialize local variables - j = this%ientry - width = this%tableterm(j)%get_width() - alignment = this%tableterm(j)%get_alignment() - line_end = .FALSE. - if (j == this%ntableterm) then - line_end = .TRUE. - end if - ! - ! -- add data to line - if (this%write_csv) then - if (j == 1) then - write(this%dataline, '(G0)') ival - else - write(this%dataline, '(a,",",G0)') trim(this%dataline), ival - end if - else - if (j == this%ntableterm) then - call UWWORD(this%dataline, this%iloc, width, TABINTEGER, & - cval, ival, rval, ALIGNMENT=alignment) - else - call UWWORD(this%dataline, this%iloc, width, TABINTEGER, & - cval, ival, rval, ALIGNMENT=alignment, SEP=this%sep) - end if - end if - ! - ! -- write the data line, if necessary - if (line_end) then - call this%write_line() - end if - ! - ! -- finalize the table, if necessary - if (this%allow_finalization) then - call this%finalize() - end if - ! - ! -- Return - return - end subroutine add_integer - - subroutine add_real(this, rval) -! ****************************************************************************** -! add_real -- add real value to the dataline -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableType) :: this - real(DP), intent(in) :: rval - ! -- local - logical :: line_end - character(len=LINELENGTH) :: cval - integer(I4B) :: ival - integer(I4B) :: j - integer(I4B) :: width - integer(I4B) :: alignment -! ------------------------------------------------------------------------------ - ! - ! -- write header - if (this%icount == 0 .and. this%ientry == 0) then - call this%write_header() - end if - ! - ! -- update index for tableterm - this%ientry = this%ientry + 1 - ! - ! -- check that ientry is within bounds - call this%add_error() - ! - ! -- initialize local variables - j = this%ientry - width = this%tableterm(j)%get_width() - alignment = this%tableterm(j)%get_alignment() - line_end = .FALSE. - if (j == this%ntableterm) then - line_end = .TRUE. - end if - ! - ! -- add data to line - if (this%write_csv) then - if (j == 1) then - write(this%dataline, '(G0)') rval - else - write(this%dataline, '(a,",",G0)') trim(this%dataline), rval - end if - else - if (j == this%ntableterm) then - call UWWORD(this%dataline, this%iloc, width, TABREAL, & - cval, ival, rval, ALIGNMENT=alignment) - else - call UWWORD(this%dataline, this%iloc, width, TABREAL, & - cval, ival, rval, ALIGNMENT=alignment, SEP=this%sep) - end if - end if - ! - ! -- write the data line, if necessary - if (line_end) then - call this%write_line() - end if - ! - ! -- finalize the table, if necessary - if (this%allow_finalization) then - call this%finalize() - end if - ! - ! -- Return - return - end subroutine add_real - - subroutine add_string(this, cval) -! ****************************************************************************** -! add_string -- add string value to the dataline -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableType) :: this - character(len=*) :: cval - ! -- local - logical :: line_end - integer(I4B) :: j - integer(I4B) :: ival - real(DP) :: rval - integer(I4B) :: width - integer(I4B) :: alignment -! ------------------------------------------------------------------------------ - ! - ! -- write header - if (this%icount == 0 .and. this%ientry == 0) then - call this%write_header() - end if - ! - ! -- update index for tableterm - this%ientry = this%ientry + 1 - ! - ! -- check that ientry is within bounds - call this%add_error() - ! - ! -- initialize local variables - j = this%ientry - width = this%tableterm(j)%get_width() - alignment = this%tableterm(j)%get_alignment() - line_end = .FALSE. - if (j == this%ntableterm) then - line_end = .TRUE. - end if - ! - ! -- add data to line - if (this%write_csv) then - if (j == 1) then - write(this%dataline, '(a)') trim(adjustl(cval)) - else - write(this%dataline, '(a,",",a)') & - trim(this%dataline), trim(adjustl(cval)) - end if - else - if (j == this%ntableterm) then - call UWWORD(this%dataline, this%iloc, width, TABSTRING, & - cval, ival, rval, ALIGNMENT=alignment) - else - call UWWORD(this%dataline, this%iloc, width, TABSTRING, & - cval, ival, rval, ALIGNMENT=alignment, SEP=this%sep) - end if - end if - ! - ! -- write the data line, if necessary - if (line_end) then - call this%write_line() - end if - ! - ! -- finalize the table, if necessary - if (this%allow_finalization) then - call this%finalize() - end if - ! - ! -- Return - return - end subroutine add_string - - subroutine set_maxbound(this, maxbound) -! ****************************************************************************** -! set_maxbound -- reset maxbound -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableType) :: this - integer(I4B), intent(in) :: maxbound - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- set maxbound - this%maxbound = maxbound - ! - ! -- reset counters - call this%reset() - ! - ! -- return - return - end subroutine set_maxbound - - subroutine set_title(this, title) -! ****************************************************************************** -! set_maxbound -- reset maxbound -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableType) :: this - character(len=*), intent(in) :: title - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- set maxbound - this%title = title - ! - ! -- return - return - end subroutine set_title - - subroutine print_list_entry(this, i, nodestr, q, bname) -! ****************************************************************************** -! print_list_entry -- write flow term table values -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableType) :: this - integer(I4B), intent(in) :: i - character(len=*), intent(in) :: nodestr - real(DP), intent(in) :: q - character(len=*), intent(in) :: bname - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- fill table terms - call this%add_term(i) - call this%add_term(nodestr) - call this%add_term(q) - if (this%ntableterm > 3) then - call this%add_term(bname) - end if - ! - ! -- return - return - end subroutine print_list_entry - - subroutine reset(this) -! ****************************************************************************** -! reset -- Private method to reset table counters -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableType) :: this - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- reset counters - this%ientry = 0 - this%icount = 0 - this%first_entry = .TRUE. - ! - ! -- return - return - end subroutine reset - -end module TableModule +! Comprehensive table object that stores all of the +! intercell flows, and the inflows and the outflows for +! an advanced package. +module TableModule + + use KindModule, only: I4B, DP + use ConstantsModule, only: LINELENGTH, LENBUDTXT, & + TABSTRING, TABUCSTRING, TABINTEGER, TABREAL, & + TABCENTER + use TableTermModule, only: TableTermType + use InputOutputModule, only: UWWORD, parseline + use SimModule, only: store_error, ustop + use TdisModule, only: kstp, kper + + implicit none + + public :: TableType + public :: table_cr + + type :: TableType + ! + ! -- name, number of control volumes, and number of table terms + character(len=LENBUDTXT) :: name + character(len=LINELENGTH) :: title + character(len=1), pointer :: sep => null() + logical, pointer :: write_csv => null() + logical, pointer :: first_entry => null() + logical, pointer :: transient => null() + logical, pointer :: add_linesep => null() + logical, pointer :: allow_finalization => null() + integer(I4B), pointer :: iout => null() + integer(I4B), pointer :: maxbound => null() + integer(I4B), pointer :: nheaderlines => null() + integer(I4B), pointer :: nlinewidth => null() + integer(I4B), pointer :: ntableterm => null() + integer(I4B), pointer :: ientry => null() + integer(I4B), pointer :: iloc => null() + integer(I4B), pointer :: icount => null() + integer(I4B), pointer :: kstp => null() + integer(I4B), pointer :: kper => null() + ! + ! -- array of table terms, with one separate entry for each term + ! such as rainfall, et, leakage, etc. + type(TableTermType), dimension(:), pointer :: tableterm => null() + ! + ! -- table table object, for writing the typical MODFLOW table + type(TableType), pointer :: table => null() + + character(len=LINELENGTH), pointer :: linesep => null() + character(len=LINELENGTH), pointer :: dataline => null() + character(len=LINELENGTH), dimension(:), pointer :: header => null() + + contains + + procedure :: table_df + procedure :: table_da + procedure :: initialize_column + procedure :: line_to_columns + procedure :: finalize_table + procedure :: set_maxbound + procedure :: set_title + procedure :: print_list_entry + + procedure, private :: allocate_strings + procedure, private :: set_header + procedure, private :: write_header + procedure, private :: write_line + procedure, private :: finalize + procedure, private :: add_error + procedure, private :: reset + + generic, public :: add_term => add_integer, add_real, add_string + procedure, private :: add_integer, add_real, add_string + + end type TableType + + contains + + subroutine table_cr(this, name, title) +! ****************************************************************************** +! table_cr -- Create a new table object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + type(TableType), pointer :: this + character(len=*), intent(in) :: name + character(len=*), intent(in) :: title + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- check if table already associated and reset if necessary + if (associated(this)) then + call this%table_da() + deallocate(this) + nullify(this) + end if + ! + ! -- Create the object + allocate(this) + ! + ! -- initialize variables + this%name = name + this%title = title + ! + ! -- Return + return + end subroutine table_cr + + subroutine table_df(this, maxbound, ntableterm, iout, transient, & + lineseparator, separator, finalize) +! ****************************************************************************** +! table_df -- Define the new table object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableType) :: this + integer(I4B), intent(in) :: maxbound + integer(I4B), intent(in) :: ntableterm + integer(I4B), intent(in) :: iout + logical, intent(in), optional :: transient + logical, intent(in), optional :: lineseparator + character(len=1), intent(in), optional :: separator + logical, intent(in), optional :: finalize +! ------------------------------------------------------------------------------ + ! + ! -- allocate scalars + allocate(this%sep) + allocate(this%write_csv) + allocate(this%first_entry) + allocate(this%transient) + allocate(this%add_linesep) + allocate(this%allow_finalization) + allocate(this%iout) + allocate(this%maxbound) + allocate(this%nheaderlines) + allocate(this%nlinewidth) + allocate(this%ntableterm) + allocate(this%ientry) + allocate(this%iloc) + allocate(this%icount) + ! + ! -- allocate space for tableterm + allocate(this%tableterm(ntableterm)) + ! + ! -- initialize values based on optional dummy variables + if (present(transient)) then + this%transient = transient + else + this%transient = .FALSE. + end if + if (present(separator)) then + this%sep = separator + if (separator == ',') then + this%write_csv = .TRUE. + else + this%write_csv = .FALSE. + end if + else + this%sep = ' ' + this%write_csv = .FALSE. + end if + if (present(lineseparator)) then + this%add_linesep = lineseparator + else + this%add_linesep = .TRUE. + end if + if (present(finalize)) then + this%allow_finalization = finalize + else + this%allow_finalization = .TRUE. + end if + ! + ! -- initialize variables + this%first_entry = .TRUE. + this%iout = iout + this%maxbound = maxbound + this%ntableterm = ntableterm + this%ientry = 0 + this%icount = 0 + ! + ! -- return + return + end subroutine table_df + + subroutine initialize_column(this, text, width, alignment) +! ****************************************************************************** +! initialize_column -- Initialize data for a column +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableType) :: this + character(len=*), intent(in) :: text + integer(I4B), intent(in) :: width + integer(I4B), intent(in), optional :: alignment + ! -- local + character (len=LINELENGTH) :: errmsg + integer(I4B) :: idx + integer(I4B) :: ialign +! ------------------------------------------------------------------------------ + ! + ! -- process optional dummy variables + if (present(alignment)) then + ialign = alignment + else + ialign = TABCENTER + end if + ! + ! -- update index for tableterm + this%ientry = this%ientry + 1 + idx = this%ientry + ! + ! -- check that ientry is in bounds + if (this%ientry > this%ntableterm) then + write(errmsg,'(4x,a,a,a,i0,a,1x,a,1x,a,a,a,1x,i0,1x,a)') & + '****ERROR. TRYING TO ADD COLUMN "', trim(adjustl(text)), '" (', & + this%ientry, ') IN THE', trim(adjustl(this%name)), 'TABLE ("', & + trim(adjustl(this%title)), '") THAT ONLY HAS', this%ntableterm, 'COLUMNS' + call store_error(errmsg) + call ustop() + end if + ! + ! -- initialize table term + call this%tableterm(idx)%initialize(text, width, alignment=ialign) + ! + ! -- create header when all terms have been specified + if (this%ientry == this%ntableterm) then + call this%set_header() + ! + ! -- reset ientry + this%ientry = 0 + end if + ! + ! -- return + return + end subroutine initialize_column + + subroutine set_header(this) +! ****************************************************************************** +! set_header -- Set the table object header +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableType) :: this + ! -- local + character(len=LINELENGTH) :: cval + integer(I4B) :: width + integer(I4B) :: alignment + integer(I4B) :: nlines + integer(I4B) :: iloc + integer(I4B) :: ival + real(DP) :: rval + integer(I4B) :: j + integer(I4B) :: n + integer(I4B) :: nn +! ------------------------------------------------------------------------------ + ! + ! -- initialize variables + width = 0 + nlines = 0 + ! + ! -- determine total width and maximum number of lines + do n = 1, this%ntableterm + width = width + this%tableterm(n)%get_width() + nlines = max(nlines, this%tableterm(n)%get_header_lines()) + end do + ! + ! -- add length of separators + width = width + this%ntableterm - 1 + ! + ! -- allocate the header and line separator + call this%allocate_strings(width, nlines) + ! + ! -- build final header lines + do n = 1, this%ntableterm + call this%tableterm(n)%set_header(nlines) + end do + ! + ! -- build header + do n = 1, nlines + iloc = 1 + this%iloc = 1 + if (this%add_linesep) then + nn = n + 1 + else + nn = n + end if + do j = 1, this%ntableterm + width = this%tableterm(j)%get_width() + alignment = this%tableterm(j)%get_alignment() + call this%tableterm(j)%get_header(n, cval) + if (this%write_csv) then + if ( j == 1) then + write(this%header(nn), '(a)') trim(adjustl(cval)) + else + write(this%header(nn), '(a,",",G0)') & + trim(this%header(nn)), trim(adjustl(cval)) + end if + else + if (j == this%ntableterm) then + call UWWORD(this%header(nn), iloc, width, TABUCSTRING, & + cval(1:width), ival, rval, ALIGNMENT=alignment) + else + call UWWORD(this%header(nn), iloc, width, TABUCSTRING, & + cval(1:width), ival, rval, ALIGNMENT=alignment, & + SEP=this%sep) + end if + end if + end do + end do + ! + ! -- return + return + end subroutine set_header + + subroutine allocate_strings(this, width, nlines) +! ****************************************************************************** +! allocate_strings -- Allocate allocatable character arrays +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableType) :: this + integer(I4B), intent(in) :: width + integer(I4B), intent(in) :: nlines + ! -- local + character(len=width) :: string + character(len=width) :: linesep + integer(I4B) :: n +! ------------------------------------------------------------------------------ + ! + ! -- initialize local variables + string = '' + linesep = repeat('-', width) + ! + ! -- initialize variables + this%nheaderlines = nlines + if (this%add_linesep) then + this%nheaderlines = this%nheaderlines + 2 + end if + this%nlinewidth = width + ! + ! -- allocate deferred length strings + allocate(this%header(this%nheaderlines)) + allocate(this%linesep) + allocate(this%dataline) + ! + ! -- initialize lines + this%linesep = linesep(1:width) + this%dataline = string(1:width) + do n = 1, this%nheaderlines + this%header(n) = string(1:width) + end do + ! + ! -- fill first and last header line with + ! linesep + if (this%add_linesep) then + this%header(1) = linesep(1:width) + this%header(nlines+2) = linesep(1:width) + end if + ! + ! -- return + return + end subroutine allocate_strings + + subroutine write_header(this) +! ****************************************************************************** +! write_table -- Write the table header +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableType) :: this + ! -- local + character(len=LINELENGTH) :: title + integer(I4B) :: width + integer(I4B) :: n +! ------------------------------------------------------------------------------ + ! + ! -- initialize local variables + width = this%nlinewidth + ! + ! -- write the table header + if (this%first_entry) then + ! -- write title + title = this%title + if (this%transient) then + write(title, '(a,a,i6)') trim(adjustl(title)), ' PERIOD ', kper + write(title, '(a,a,i8)') trim(adjustl(title)), ' STEP ', kstp + end if + if (len_trim(title) > 0) then + write(this%iout, '(/,1x,a)') trim(adjustl(title)) + end if + ! + ! -- write header + do n = 1, this%nheaderlines + write(this%iout, '(1x,a)') this%header(n)(1:width) + end do + end if + ! + ! -- reinitialize variables + this%first_entry = .FALSE. + this%ientry = 0 + this%icount = 0 + ! + ! -- return + return + end subroutine write_header + + subroutine write_line(this) +! ****************************************************************************** +! write_line -- Write the data line +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableType) :: this + ! -- local + integer(I4B) :: width +! ------------------------------------------------------------------------------ + ! + ! -- initialize local variables + width = this%nlinewidth + ! + ! -- write the dataline + write(this%iout, '(1x,a)') this%dataline(1:width) + ! + ! -- update column and line counters + this%ientry = 0 + this%iloc = 1 + this%icount = this%icount + 1 + ! + ! -- return + return + end subroutine write_line + + subroutine finalize(this) +! ****************************************************************************** +! finalize -- Private method that test for last line. If last line the +! public finalize_table method is called +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- finalize table if last entry + if (this%icount == this%maxbound) then + call this%finalize_table() + end if + ! + ! -- return + return + end subroutine finalize + + subroutine finalize_table(this) +! ****************************************************************************** +! finalize -- Public method to finalize the table +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableType) :: this + ! -- local + integer(I4B) :: width +! ------------------------------------------------------------------------------ + ! + ! -- initialize local variables + width = this%nlinewidth + ! + ! -- write the final table separator + if (this%add_linesep) then + write(this%iout, '(1x,a,/)') this%linesep(1:width) + end if + ! + ! -- reinitialize variables + call this%reset() + ! + ! -- return + return + end subroutine finalize_table + + subroutine table_da(this) +! ****************************************************************************** +! table_da -- deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableType) :: this + ! -- dummy + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + ! -- deallocate each table term + do i = 1, this%ntableterm + call this%tableterm(i)%da() + end do + ! + ! -- deallocate space for tableterm + deallocate(this%tableterm) + ! + ! -- deallocate scalars + deallocate(this%sep) + deallocate(this%write_csv) + deallocate(this%first_entry) + deallocate(this%transient) + deallocate(this%add_linesep) + deallocate(this%allow_finalization) + deallocate(this%iout) + deallocate(this%maxbound) + deallocate(this%nheaderlines) + deallocate(this%nlinewidth) + deallocate(this%ntableterm) + deallocate(this%ientry) + deallocate(this%iloc) + deallocate(this%icount) + ! + ! -- Return + return + end subroutine table_da + + subroutine line_to_columns(this, line) +! ****************************************************************************** +! line_to_columns -- convert a line to the correct number of columns +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableType) :: this + character(len=LINELENGTH), intent(in) :: line + ! -- local + character(len=LINELENGTH), allocatable, dimension(:) :: words + integer(I4B) :: nwords + integer(I4B) :: icols + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + ! -- write header + if (this%icount == 0 .and. this%ientry == 0) then + call this%write_header() + end if + ! + ! -- parse line into words + call parseline(line, nwords, words, 0) + ! + ! -- calculate the number of entries in line but + ! limit it to the maximum number of columns if + ! the number of words exceeds ntableterm + icols = this%ntableterm + icols = min(nwords, icols) + ! + ! -- add data (as strings) to line + do i = 1, icols + call this%add_term(words(i)) + end do + ! + ! -- add empty strings to complete the line + do i = this%ientry + 1, this%ntableterm + call this%add_term(' ') + end do + ! + ! -- clean up local allocatable array + deallocate(words) + ! + ! -- Return + return + end subroutine line_to_columns + + subroutine add_error(this) +! ****************************************************************************** +! add_error -- evaluate if error condition occurs when adding data to dataline +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableType) :: this + ! -- local + character (len=LINELENGTH) :: errmsg +! ------------------------------------------------------------------------------ + ! + ! -- check that ientry is within bounds + if (this%ientry > this%ntableterm) then + write(errmsg,'(4x,a,1x,i0,5(1x,a),1x,i0,1x,a)') & + '****ERROR. TRYING TO ADD DATA TO COLUMN ', this%ientry, 'IN THE', & + trim(adjustl(this%name)), 'TABLE (', trim(adjustl(this%title)), & + ') THAT ONLY HAS', this%ntableterm, 'COLUMNS' + call store_error(errmsg) + call ustop() + end if + ! + ! -- Return + return + end subroutine add_error + + subroutine add_integer(this, ival) +! ****************************************************************************** +! add_integer -- add integer value to the dataline +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableType) :: this + integer(I4B), intent(in) :: ival + ! -- local + logical :: line_end + character(len=LINELENGTH) :: cval + real(DP) :: rval + integer(I4B) :: width + integer(I4B) :: alignment + integer(I4B) :: j +! ------------------------------------------------------------------------------ + ! + ! -- write header + if (this%icount == 0 .and. this%ientry == 0) then + call this%write_header() + end if + ! + ! -- update index for tableterm + this%ientry = this%ientry + 1 + ! + ! -- check that ientry is within bounds + call this%add_error() + ! + ! -- initialize local variables + j = this%ientry + width = this%tableterm(j)%get_width() + alignment = this%tableterm(j)%get_alignment() + line_end = .FALSE. + if (j == this%ntableterm) then + line_end = .TRUE. + end if + ! + ! -- add data to line + if (this%write_csv) then + if (j == 1) then + write(this%dataline, '(G0)') ival + else + write(this%dataline, '(a,",",G0)') trim(this%dataline), ival + end if + else + if (j == this%ntableterm) then + call UWWORD(this%dataline, this%iloc, width, TABINTEGER, & + cval, ival, rval, ALIGNMENT=alignment) + else + call UWWORD(this%dataline, this%iloc, width, TABINTEGER, & + cval, ival, rval, ALIGNMENT=alignment, SEP=this%sep) + end if + end if + ! + ! -- write the data line, if necessary + if (line_end) then + call this%write_line() + end if + ! + ! -- finalize the table, if necessary + if (this%allow_finalization) then + call this%finalize() + end if + ! + ! -- Return + return + end subroutine add_integer + + subroutine add_real(this, rval) +! ****************************************************************************** +! add_real -- add real value to the dataline +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableType) :: this + real(DP), intent(in) :: rval + ! -- local + logical :: line_end + character(len=LINELENGTH) :: cval + integer(I4B) :: ival + integer(I4B) :: j + integer(I4B) :: width + integer(I4B) :: alignment +! ------------------------------------------------------------------------------ + ! + ! -- write header + if (this%icount == 0 .and. this%ientry == 0) then + call this%write_header() + end if + ! + ! -- update index for tableterm + this%ientry = this%ientry + 1 + ! + ! -- check that ientry is within bounds + call this%add_error() + ! + ! -- initialize local variables + j = this%ientry + width = this%tableterm(j)%get_width() + alignment = this%tableterm(j)%get_alignment() + line_end = .FALSE. + if (j == this%ntableterm) then + line_end = .TRUE. + end if + ! + ! -- add data to line + if (this%write_csv) then + if (j == 1) then + write(this%dataline, '(G0)') rval + else + write(this%dataline, '(a,",",G0)') trim(this%dataline), rval + end if + else + if (j == this%ntableterm) then + call UWWORD(this%dataline, this%iloc, width, TABREAL, & + cval, ival, rval, ALIGNMENT=alignment) + else + call UWWORD(this%dataline, this%iloc, width, TABREAL, & + cval, ival, rval, ALIGNMENT=alignment, SEP=this%sep) + end if + end if + ! + ! -- write the data line, if necessary + if (line_end) then + call this%write_line() + end if + ! + ! -- finalize the table, if necessary + if (this%allow_finalization) then + call this%finalize() + end if + ! + ! -- Return + return + end subroutine add_real + + subroutine add_string(this, cval) +! ****************************************************************************** +! add_string -- add string value to the dataline +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableType) :: this + character(len=*) :: cval + ! -- local + logical :: line_end + integer(I4B) :: j + integer(I4B) :: ival + real(DP) :: rval + integer(I4B) :: width + integer(I4B) :: alignment +! ------------------------------------------------------------------------------ + ! + ! -- write header + if (this%icount == 0 .and. this%ientry == 0) then + call this%write_header() + end if + ! + ! -- update index for tableterm + this%ientry = this%ientry + 1 + ! + ! -- check that ientry is within bounds + call this%add_error() + ! + ! -- initialize local variables + j = this%ientry + width = this%tableterm(j)%get_width() + alignment = this%tableterm(j)%get_alignment() + line_end = .FALSE. + if (j == this%ntableterm) then + line_end = .TRUE. + end if + ! + ! -- add data to line + if (this%write_csv) then + if (j == 1) then + write(this%dataline, '(a)') trim(adjustl(cval)) + else + write(this%dataline, '(a,",",a)') & + trim(this%dataline), trim(adjustl(cval)) + end if + else + if (j == this%ntableterm) then + call UWWORD(this%dataline, this%iloc, width, TABSTRING, & + cval, ival, rval, ALIGNMENT=alignment) + else + call UWWORD(this%dataline, this%iloc, width, TABSTRING, & + cval, ival, rval, ALIGNMENT=alignment, SEP=this%sep) + end if + end if + ! + ! -- write the data line, if necessary + if (line_end) then + call this%write_line() + end if + ! + ! -- finalize the table, if necessary + if (this%allow_finalization) then + call this%finalize() + end if + ! + ! -- Return + return + end subroutine add_string + + subroutine set_maxbound(this, maxbound) +! ****************************************************************************** +! set_maxbound -- reset maxbound +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableType) :: this + integer(I4B), intent(in) :: maxbound + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- set maxbound + this%maxbound = maxbound + ! + ! -- reset counters + call this%reset() + ! + ! -- return + return + end subroutine set_maxbound + + subroutine set_title(this, title) +! ****************************************************************************** +! set_maxbound -- reset maxbound +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableType) :: this + character(len=*), intent(in) :: title + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- set maxbound + this%title = title + ! + ! -- return + return + end subroutine set_title + + subroutine print_list_entry(this, i, nodestr, q, bname) +! ****************************************************************************** +! print_list_entry -- write flow term table values +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableType) :: this + integer(I4B), intent(in) :: i + character(len=*), intent(in) :: nodestr + real(DP), intent(in) :: q + character(len=*), intent(in) :: bname + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- fill table terms + call this%add_term(i) + call this%add_term(nodestr) + call this%add_term(q) + if (this%ntableterm > 3) then + call this%add_term(bname) + end if + ! + ! -- return + return + end subroutine print_list_entry + + subroutine reset(this) +! ****************************************************************************** +! reset -- Private method to reset table counters +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- reset counters + this%ientry = 0 + this%icount = 0 + this%first_entry = .TRUE. + ! + ! -- return + return + end subroutine reset + +end module TableModule diff --git a/src/Utilities/TableTerm.f90 b/src/Utilities/TableTerm.f90 index e5f00efccac..f00d1cc7cd1 100644 --- a/src/Utilities/TableTerm.f90 +++ b/src/Utilities/TableTerm.f90 @@ -1,325 +1,325 @@ -! A table term is the information needed to describe flow. -! The table object contains an array of table terms. -! For an advanced package. The table object describes all of -! the flows. -module TableTermModule - - use KindModule, only: I4B, DP - use ConstantsModule, only: LINELENGTH, LENBUDTXT, DZERO, & - TABLEFT, TABCENTER, TABRIGHT, & - TABSTRING, TABUCSTRING, TABINTEGER, TABREAL - use InputOutputModule, only: UPCASE, parseline - - implicit none - - public :: TableTermType - - - type :: TableTermType - character(len=LINELENGTH), pointer :: tag => null() - integer(I4B), pointer :: width => null() - integer(I4B), pointer :: alignment => null() - integer(I4B), pointer :: nheader_lines => null() - - character(len=LINELENGTH), dimension(:), pointer :: initial_lines => null() - character(len=LINELENGTH), dimension(:), pointer :: header_lines => null() - - contains - - procedure :: initialize - procedure, private :: allocate_scalars - procedure :: get_width - procedure :: get_alignment - procedure :: get_header_lines - procedure :: set_header - procedure :: get_header - procedure :: da - - - end type TableTermType - - contains - - subroutine initialize(this, tag, width, alignment) -! ****************************************************************************** -! initialize -- initialize the table term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableTermType) :: this - character(len=*), intent(in) :: tag - integer(I4B), intent(in) :: width - integer(I4B), intent(in), optional :: alignment - ! -- local - character(len=LINELENGTH) :: string - character(len=LINELENGTH) :: tstring - character(len=LINELENGTH), allocatable, dimension(:) :: words - integer(I4B) :: nwords - integer(I4B) :: ilen - integer(I4B) :: i - integer(I4B) :: j - -! ------------------------------------------------------------------------------ - ! - ! -- allocate scalars - call this%allocate_scalars() - - ! -- process dummy variables - this%tag = tag - - if (present(alignment)) then - this%alignment = alignment - else - this%alignment = TABCENTER - end if - - this%width = width - ! - ! -- parse tag into words - call parseline(tag, nwords, words, 0) - ! - ! -- abbreviate any words that exceed the specified width - ! and trim trailing characters - do i = 1, nwords - ilen = len(trim(words(i))) - if (ilen > width) then - words(i)(width:width) = '.' - do j = width + 1, ilen - words(i)(j:j) = ' ' - end do - end if - end do - ! - ! -- combine words that fit into width - i = 0 - do - i = i + 1 - if (i > nwords) then - exit - end if - string = trim(adjustl(words(i))) - tstring = string - do j = i + 1, nwords - if (len(trim(adjustl(string))) > 0) then - tstring = trim(adjustl(tstring)) // ' ' // trim(adjustl(words(j))) - else - tstring = trim(adjustl(words(j))) - end if - ilen = len(trim(adjustl(tstring))) - if (ilen == 0) then - continue - else if (ilen <= width) then - words(j) = ' ' - string = tstring - else - exit - end if - end do - words(i) = string - end do - ! - ! -- calculate the number of header lines - do i = 1, nwords - ilen = len(trim(adjustl(words(i)))) - if (ilen > 0) then - this%nheader_lines = this%nheader_lines + 1 - end if - end do - ! - ! allocate initial_lines and fill with words - allocate(this%initial_lines(this%nheader_lines)) - do i = 1, this%nheader_lines - this%initial_lines(i) = words(i)(1:width) - end do - ! - ! -- deallocate words - deallocate(words) - ! - ! -- return - return - - end subroutine initialize - - function get_width(this) -! ****************************************************************************** -! get_width -- get column width -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return variable - integer(I4B) :: get_width - ! -- modules - ! -- dummy - class(TableTermType) :: this - ! -- local -! ------------------------------------------------------------------------------ - get_width = this%width - ! - ! -- return - return - end function get_width - - function get_alignment(this) -! ****************************************************************************** -! get_width -- get column width -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return variable - integer(I4B) :: get_alignment - ! -- modules - ! -- dummy - class(TableTermType) :: this - ! -- local -! ------------------------------------------------------------------------------ - get_alignment = this%alignment - ! - ! -- return - return - end function get_alignment - - function get_header_lines(this) -! ****************************************************************************** -! get_header_lines -- get the number of lines in initial_lines -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return variable - integer(I4B) :: get_header_lines - ! -- modules - ! -- dummy - class(TableTermType) :: this - ! -- local -! ------------------------------------------------------------------------------ - get_header_lines = this%nheader_lines - ! - ! -- return - return - end function get_header_lines - - subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -- allocate table term scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableTermType) :: this -! ------------------------------------------------------------------------------ - ! - ! -- allocate scalars - allocate(this%tag) - allocate(this%alignment) - allocate(this%width) - allocate(this%nheader_lines) - ! - ! -- initialize scalars - this%nheader_lines = 0 - ! - ! -- return - return - end subroutine allocate_scalars - - subroutine da(this) -! ****************************************************************************** -! da -- deallocate table terms -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableTermType) :: this - ! -- local - !integer(I4B) :: n -! ------------------------------------------------------------------------------ - ! - ! -- deallocate scalars - deallocate(this%tag) - deallocate(this%alignment) - deallocate(this%width) - deallocate(this%nheader_lines) - deallocate(this%header_lines) - ! - ! -- return - end subroutine da - - subroutine set_header(this, nlines) -! ****************************************************************************** -! set_header -- set final header lines for table term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableTermType) :: this - integer(I4B), intent(in) :: nlines - ! -- local - character(len=this%width) :: string - integer(I4B) :: idiff - integer(I4B) :: i0 - integer(I4B) :: i - integer(I4B) :: j -! ------------------------------------------------------------------------------ - ! - ! -- initialize variables - string = ' ' - ! - ! allocate header_lines - allocate(this%header_lines(nlines)) - ! - ! -- initialize header lines - do i = 1, nlines - this%header_lines(i) = string - end do - ! - ! -- fill header_lines with initial_lines from - ! bottom to top - idiff = nlines - this%nheader_lines - i0 = 1 - idiff - do i = this%nheader_lines, 1, -1 - j = i + idiff - this%header_lines(j) = this%initial_lines(i) - end do - ! - ! -- deallocate temporary header lines - deallocate(this%initial_lines) - ! - ! -- reinitialize nheader_lines - this%nheader_lines = nlines - ! - ! -- return - end subroutine set_header - - subroutine get_header(this, iline, cval) -! ****************************************************************************** -! get_header -- get header entry for table term iline -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TableTermType) :: this - integer(I4B), intent(in) :: iline - character(len=*), intent(inout) :: cval - ! -- return variable - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- set return value - cval = this%header_lines(iline)(1:this%width) - ! - ! -- return - end subroutine get_header - +! A table term is the information needed to describe flow. +! The table object contains an array of table terms. +! For an advanced package. The table object describes all of +! the flows. +module TableTermModule + + use KindModule, only: I4B, DP + use ConstantsModule, only: LINELENGTH, LENBUDTXT, DZERO, & + TABLEFT, TABCENTER, TABRIGHT, & + TABSTRING, TABUCSTRING, TABINTEGER, TABREAL + use InputOutputModule, only: UPCASE, parseline + + implicit none + + public :: TableTermType + + + type :: TableTermType + character(len=LINELENGTH), pointer :: tag => null() + integer(I4B), pointer :: width => null() + integer(I4B), pointer :: alignment => null() + integer(I4B), pointer :: nheader_lines => null() + + character(len=LINELENGTH), dimension(:), pointer :: initial_lines => null() + character(len=LINELENGTH), dimension(:), pointer :: header_lines => null() + + contains + + procedure :: initialize + procedure, private :: allocate_scalars + procedure :: get_width + procedure :: get_alignment + procedure :: get_header_lines + procedure :: set_header + procedure :: get_header + procedure :: da + + + end type TableTermType + + contains + + subroutine initialize(this, tag, width, alignment) +! ****************************************************************************** +! initialize -- initialize the table term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableTermType) :: this + character(len=*), intent(in) :: tag + integer(I4B), intent(in) :: width + integer(I4B), intent(in), optional :: alignment + ! -- local + character(len=LINELENGTH) :: string + character(len=LINELENGTH) :: tstring + character(len=LINELENGTH), allocatable, dimension(:) :: words + integer(I4B) :: nwords + integer(I4B) :: ilen + integer(I4B) :: i + integer(I4B) :: j + +! ------------------------------------------------------------------------------ + ! + ! -- allocate scalars + call this%allocate_scalars() + + ! -- process dummy variables + this%tag = tag + + if (present(alignment)) then + this%alignment = alignment + else + this%alignment = TABCENTER + end if + + this%width = width + ! + ! -- parse tag into words + call parseline(tag, nwords, words, 0) + ! + ! -- abbreviate any words that exceed the specified width + ! and trim trailing characters + do i = 1, nwords + ilen = len(trim(words(i))) + if (ilen > width) then + words(i)(width:width) = '.' + do j = width + 1, ilen + words(i)(j:j) = ' ' + end do + end if + end do + ! + ! -- combine words that fit into width + i = 0 + do + i = i + 1 + if (i > nwords) then + exit + end if + string = trim(adjustl(words(i))) + tstring = string + do j = i + 1, nwords + if (len(trim(adjustl(string))) > 0) then + tstring = trim(adjustl(tstring)) // ' ' // trim(adjustl(words(j))) + else + tstring = trim(adjustl(words(j))) + end if + ilen = len(trim(adjustl(tstring))) + if (ilen == 0) then + continue + else if (ilen <= width) then + words(j) = ' ' + string = tstring + else + exit + end if + end do + words(i) = string + end do + ! + ! -- calculate the number of header lines + do i = 1, nwords + ilen = len(trim(adjustl(words(i)))) + if (ilen > 0) then + this%nheader_lines = this%nheader_lines + 1 + end if + end do + ! + ! allocate initial_lines and fill with words + allocate(this%initial_lines(this%nheader_lines)) + do i = 1, this%nheader_lines + this%initial_lines(i) = words(i)(1:width) + end do + ! + ! -- deallocate words + deallocate(words) + ! + ! -- return + return + + end subroutine initialize + + function get_width(this) +! ****************************************************************************** +! get_width -- get column width +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return variable + integer(I4B) :: get_width + ! -- modules + ! -- dummy + class(TableTermType) :: this + ! -- local +! ------------------------------------------------------------------------------ + get_width = this%width + ! + ! -- return + return + end function get_width + + function get_alignment(this) +! ****************************************************************************** +! get_width -- get column width +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return variable + integer(I4B) :: get_alignment + ! -- modules + ! -- dummy + class(TableTermType) :: this + ! -- local +! ------------------------------------------------------------------------------ + get_alignment = this%alignment + ! + ! -- return + return + end function get_alignment + + function get_header_lines(this) +! ****************************************************************************** +! get_header_lines -- get the number of lines in initial_lines +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return variable + integer(I4B) :: get_header_lines + ! -- modules + ! -- dummy + class(TableTermType) :: this + ! -- local +! ------------------------------------------------------------------------------ + get_header_lines = this%nheader_lines + ! + ! -- return + return + end function get_header_lines + + subroutine allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars -- allocate table term scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableTermType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- allocate scalars + allocate(this%tag) + allocate(this%alignment) + allocate(this%width) + allocate(this%nheader_lines) + ! + ! -- initialize scalars + this%nheader_lines = 0 + ! + ! -- return + return + end subroutine allocate_scalars + + subroutine da(this) +! ****************************************************************************** +! da -- deallocate table terms +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableTermType) :: this + ! -- local + !integer(I4B) :: n +! ------------------------------------------------------------------------------ + ! + ! -- deallocate scalars + deallocate(this%tag) + deallocate(this%alignment) + deallocate(this%width) + deallocate(this%nheader_lines) + deallocate(this%header_lines) + ! + ! -- return + end subroutine da + + subroutine set_header(this, nlines) +! ****************************************************************************** +! set_header -- set final header lines for table term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableTermType) :: this + integer(I4B), intent(in) :: nlines + ! -- local + character(len=this%width) :: string + integer(I4B) :: idiff + integer(I4B) :: i0 + integer(I4B) :: i + integer(I4B) :: j +! ------------------------------------------------------------------------------ + ! + ! -- initialize variables + string = ' ' + ! + ! allocate header_lines + allocate(this%header_lines(nlines)) + ! + ! -- initialize header lines + do i = 1, nlines + this%header_lines(i) = string + end do + ! + ! -- fill header_lines with initial_lines from + ! bottom to top + idiff = nlines - this%nheader_lines + i0 = 1 - idiff + do i = this%nheader_lines, 1, -1 + j = i + idiff + this%header_lines(j) = this%initial_lines(i) + end do + ! + ! -- deallocate temporary header lines + deallocate(this%initial_lines) + ! + ! -- reinitialize nheader_lines + this%nheader_lines = nlines + ! + ! -- return + end subroutine set_header + + subroutine get_header(this, iline, cval) +! ****************************************************************************** +! get_header -- get header entry for table term iline +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableTermType) :: this + integer(I4B), intent(in) :: iline + character(len=*), intent(inout) :: cval + ! -- return variable + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- set return value + cval = this%header_lines(iline)(1:this%width) + ! + ! -- return + end subroutine get_header + end module TableTermModule \ No newline at end of file diff --git a/src/Utilities/TimeSeries/TimeArraySeries.f90 b/src/Utilities/TimeSeries/TimeArraySeries.f90 index e047fd7a237..2f2645511c0 100644 --- a/src/Utilities/TimeSeries/TimeArraySeries.f90 +++ b/src/Utilities/TimeSeries/TimeArraySeries.f90 @@ -1,876 +1,876 @@ -module TimeArraySeriesModule - - use ArrayReadersModule, only: ReadArray - use BlockParserModule, only: BlockParserType - use ConstantsModule, only: LINELENGTH, UNDEFINED, STEPWISE, LINEAR, & - LENTIMESERIESNAME, LENBIGLINE, DZERO, DONE - use GenericUtilitiesModule, only: IS_SAME - use InputOutputModule, only: GetUnit, openfile - use KindModule, only: DP, I4B - use ListModule, only: ListType, ListNodeType - use SimModule, only: count_errors, store_error, store_error_unit, & - ustop - use TimeArrayModule, only: TimeArrayType, ConstructTimeArray, & - AddTimeArrayToList, CastAsTimeArrayType, & - GetTimeArrayFromList - use BaseDisModule, only: DisBaseType - use, intrinsic :: iso_fortran_env, only: IOSTAT_END - - implicit none - private - public :: TimeArraySeriesType, ConstructTimeArraySeries, & - CastAsTimeArraySeriesType, GetTimeArraySeriesFromList - - type TimeArraySeriesType - ! -- Public members - character(len=LENTIMESERIESNAME), public :: Name = '' - ! -- Private members - integer(I4B), private :: inunit = 0 - integer(I4B), private :: iout = 0 - integer(I4B), private :: iMethod = UNDEFINED - real(DP), private :: sfac = DONE - character(len=LINELENGTH), private :: dataFile = '' - logical, private :: autoDeallocate = .true. - type(ListType), pointer, private :: list => null() - class(DisBaseType), pointer, private :: dis => null() - type(BlockParserType), private :: parser - contains - ! -- Public procedures - procedure, public :: tas_init - procedure, public :: GetAverageValues - procedure, public :: GetInunit - procedure, public :: da => tas_da - ! -- Private procedures - procedure, private :: get_integrated_values - procedure, private :: get_latest_preceding_node - procedure, private :: get_values_at_time - procedure, private :: get_surrounding_records - procedure, private :: read_next_array - procedure, private :: DeallocateBackward - end type TimeArraySeriesType - -contains - - ! -- Constructor for TimeArraySeriesType - - subroutine ConstructTimeArraySeries(newTas, filename) -! ****************************************************************************** -! ConstructTimeArraySeries -- Allocate a new TimeArraySeriesType object. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - type(TimeArraySeriesType), pointer, intent(out) :: newTas - character(len=*), intent(in) :: filename - ! -- local - character(len=LINELENGTH) :: ermsg - logical :: lex -! ------------------------------------------------------------------------------ - ! formats - 10 format('Error: Time-array-series file "',a,'" does not exist.') - ! - ! -- Allocate a new object of type TimeArraySeriesType - allocate(newTas) - allocate(newTas%list) - ! - ! -- Ensure that input file exists - inquire(file=filename,exist=lex) - if (.not. lex) then - write(ermsg,10)trim(filename) - call store_error(ermsg) - call ustop() - endif - newTas%datafile = filename - ! - return - end subroutine ConstructTimeArraySeries - - ! -- Public procedures - - subroutine tas_init(this, fname, dis, iout, tasname, autoDeallocate) -! ****************************************************************************** -! tas_init -- initialize the time array series -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeArraySeriesType), intent(inout) :: this - character(len=*), intent(in) :: fname - class(DisBaseType), pointer, intent(inout) :: dis - integer(I4B), intent(in) :: iout - character(len=*), intent(inout) :: tasname - logical, optional, intent(in) :: autoDeallocate - ! -- local - integer(I4B) :: istatus - integer(I4B) :: ierr - integer(I4B) :: inunit - character(len=40) :: keyword, keyvalue - character(len=LINELENGTH) :: ermsg - logical :: found, continueread, endOfBlock -! ------------------------------------------------------------------------------ - ! - ! -- initialize some variables - if (present(autoDeallocate)) this%autoDeallocate = autoDeallocate - this%dataFile = fname - allocate(this%list) - ! - ! -- assign members - this%dis => dis - this%iout = iout - ! - ! -- open time-array series input file - inunit = GetUnit() - this%inunit = inunit - call openfile(inunit, 0, fname, 'TAS6') - ! - ! -- initialize block parser - call this%parser%Initialize(this%inunit, this%iout) - ! - ! -- read ATTRIBUTES block - continueread = .false. - ierr = 0 - ! - ! -- get BEGIN line of ATTRIBUTES block - call this%parser%GetBlock('ATTRIBUTES', found, ierr, & - supportOpenClose=.true.) - if (.not. found) then - ermsg = 'Error: Attributes block not found in file: ' // & - trim(fname) - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- parse ATTRIBUTES entries - do - ! -- read line from input - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - ! - ! -- get the keyword - call this%parser%GetStringCaps(keyword) - ! - ! -- get the word following the keyword (the key value) - call this%parser%GetStringCaps(keyvalue) - select case (keyword) - case ('NAME') - this%Name = keyvalue - tasname = keyvalue - case ('METHOD') - select case (keyvalue) - case ('STEPWISE') - this%iMethod = STEPWISE - case ('LINEAR') - this%iMethod = LINEAR - case default - ermsg = 'Unknown interpolation method: "' // trim(keyvalue) // '"' - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - case ('AUTODEALLOCATE') - this%autoDeallocate = (keyvalue == 'TRUE') - case ('SFAC') - read(keyvalue,*,iostat=istatus)this%sfac - if (istatus /= 0) then - ermsg = 'Error reading numeric SFAC value from "' // trim(keyvalue) & - // '"' - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - case default - ermsg = 'Unknown option found in ATTRIBUTES block: "' // & - trim(keyword) // '"' - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - enddo - ! - ! -- ensure that NAME and METHOD have been specified - if (this%Name == '') then - ermsg = 'Error: Name not specified for time array series in file: ' // & - trim(this%dataFile) - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - if (this%iMethod == UNDEFINED) then - ermsg = 'Error: Interpolation method not specified for time' // & - ' array series in file: ' // trim(this%dataFile) - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- handle any errors encountered so far - if (count_errors()>0) then - ermsg = 'Error(s) encountered initializing time array series from file: ' // & - trim(this%dataFile) - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- try to read first time array into linked list - if (.not. this%read_next_array()) then - ermsg = 'Error encountered reading time-array data from file: ' // & - trim(this%dataFile) - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - return - end subroutine tas_init - - subroutine GetAverageValues(this, nvals, values, time0, time1) -! ****************************************************************************** -! GetAverageValues -- populate an array time-weighted average value for a -! specified time span. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeArraySeriesType), intent(inout) :: this - integer(I4B), intent(in) :: nvals - real(DP), dimension(nvals), intent(inout) :: values - real(DP), intent(in) :: time0 - real(DP), intent(in) :: time1 - ! -- local - integer(I4B) :: i - real(DP) :: timediff -! ------------------------------------------------------------------------------ - ! - timediff = time1 - time0 - if (timediff > 0) then - call this%get_integrated_values(nvals, values, time0, time1) - do i=1,nvals - values(i) = values(i) / timediff - enddo - else - ! -- time0 and time1 are the same, so skip the integration step. - call this%get_values_at_time(nvals, values, time0) - endif - ! - return - end subroutine GetAverageValues - - function GetInunit(this) -! ****************************************************************************** -! GetInunit -- return unit number -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - integer(I4B) :: GetInunit - ! -- dummy - class(TimeArraySeriesType) :: this -! ------------------------------------------------------------------------------ - ! - GetInunit = this%inunit - ! - return - end function GetInunit - - ! -- Private procedures - - subroutine get_surrounding_records(this, time, taEarlier, taLater) -! ****************************************************************************** -! get_surrounding_records -- get_surrounding_records -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeArraySeriesType), intent(inout) :: this - real(DP), intent(in) :: time - type(TimeArrayType), pointer, intent(inout) :: taEarlier - type(TimeArrayType), pointer, intent(inout) :: taLater - ! -- local - real(DP) :: time0, time1 - type(ListNodeType), pointer :: currNode => null() - type(ListNodeType), pointer :: node0 => null() - type(ListNodeType), pointer :: node1 => null() - type(TimeArrayType), pointer :: ta => null(), ta0 => null(), ta1 => null() - class(*), pointer :: obj -! ------------------------------------------------------------------------------ - ! - taEarlier => null() - taLater => null() - ! - if (associated(this%list%firstNode)) then - currNode => this%list%firstNode - endif - ! - ! -- If the next node is earlier than time of interest, advance along - ! linked list until the next node is later than time of interest. - do - if (associated(currNode)) then - if (associated(currNode%nextNode)) then - obj => currNode%nextNode%GetItem() - ta => CastAsTimeArrayType(obj) - if (ta%taTime <= time) then - currNode => currNode%nextNode - else - exit - endif - else - ! -- read another array - if (.not. this%read_next_array()) exit - endif - else - exit - endif - enddo - ! - if (associated(currNode)) then - ! - ! -- find earlier record - node0 => currNode - obj => node0%GetItem() - ta0 => CastAsTimeArrayType(obj) - time0 = ta0%taTime - do while (time0 > time) - if (associated(node0%prevNode)) then - node0 => node0%prevNode - obj => node0%GetItem() - ta0 => CastAsTimeArrayType(obj) - time0 = ta0%taTime - else - exit - endif - enddo - ! - ! -- find later record - node1 => currNode - obj => node1%GetItem() - ta1 => CastAsTimeArrayType(obj) - time1 = ta1%taTime - do while (time1 < time) - if (associated(node1%nextNode)) then - node1 => node1%nextNode - obj => node1%GetItem() - ta1 => CastAsTimeArrayType(obj) - time1 = ta1%taTime - else - ! -- get next array - if (.not. this%read_next_array()) then - ! -- end of file reached, so exit loop - exit - endif - endif - enddo - ! - endif - ! - if (time0 <= time) taEarlier => ta0 - if (time1 >= time) taLater => ta1 - ! - return - end subroutine get_surrounding_records - - logical function read_next_array(this) -! ****************************************************************************** -! read_next_array -- Read next time array from input file and append to list. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeArraySeriesType), intent(inout) :: this - ! -- local - integer(I4B) :: i, ierr, istart, istat, istop, lloc, nrow, ncol, nodesperlayer - logical :: lopen, isFound - character(len=LINELENGTH) :: ermsg - type(TimeArrayType), pointer :: ta => null() -! ------------------------------------------------------------------------------ - ! - istart = 1 - istat = 0 - istop = 1 - lloc = 1 - ! Get dimensions for supported discretization type - if (this%dis%supports_layers()) then - nodesperlayer = this%dis%get_ncpl() - if(size(this%dis%mshape) == 3) then - nrow = this%dis%mshape(2) - ncol = this%dis%mshape(3) - else - nrow = 1 - ncol = this%dis%mshape(2) - endif - else - ermsg = 'Time array series is not supported for selected discretization type.' - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - read_next_array = .false. - inquire(unit=this%inunit,opened=lopen) - if (lopen) then - call ConstructTimeArray(ta, this%dis) - ! -- read a time and an array from the input file - ! -- Get a TIME block and read the time - call this%parser%GetBlock('TIME', isFound, ierr, & - supportOpenClose=.true.) - if (isFound) then - ta%taTime = this%parser%GetDouble() - ! -- Read the array - call ReadArray(this%parser%iuactive, ta%taArray, this%Name, & - this%dis%ndim, ncol, nrow, 1, nodesperlayer, & - this%iout, 0, 0) - ! - ! -- multiply values by sfac - do i = 1, nodesperlayer - ta%taArray(i) = ta%taArray(i) * this%sfac - enddo - ! - ! -- append the new time array to the list - call AddTimeArrayToList(this%list, ta) - read_next_array = .true. - ! - ! -- make sure block is closed - call this%parser%terminateblock() - endif - endif - return ! Normal return - ! - return - end function read_next_array - - subroutine get_values_at_time(this, nvals, values, time) -! ****************************************************************************** -! get_values_at_time -- Return an array of values for a specified time, same -! units as time-series values. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeArraySeriesType), intent(inout) :: this - integer(I4B), intent(in) :: nvals - real(DP), dimension(nvals), intent(inout) :: values - real(DP), intent(in) :: time ! time of interest - ! -- local - integer(I4B) :: i, ierr - real(DP) :: ratio, time0, time1, timediff, timediffi, val0, val1, & - valdiff - character(len=LINELENGTH) :: ermsg - type(TimeArrayType), pointer :: taEarlier => null() - type(TimeArrayType), pointer :: taLater => null() - ! formats - 10 format('Error getting array at time ',g10.3, & - ' for time-array series "',a,'"') -! ------------------------------------------------------------------------------ - ! - ierr = 0 - call this%get_surrounding_records(time,taEarlier,taLater) - if (associated(taEarlier)) then - if (associated(taLater)) then - ! -- values are available for both earlier and later times - if (this%iMethod == STEPWISE) then - ! -- Just populate values from elements of earlier time array - values = taEarlier%taArray - elseif (this%iMethod == LINEAR) then - ! -- perform linear interpolation - time0 = taEarlier%taTime - time1 = taLater%tatime - timediff = time1 - time0 - timediffi = time - time0 - if (timediff>0) then - ratio = timediffi/timediff - else - ! -- should not happen if TS does not contain duplicate times - ratio = 0.5d0 - endif - ! -- Iterate through all elements and perform interpolation. - do i=1,nvals - val0 = taEarlier%taArray(i) - val1 = taLater%taArray(i) - valdiff = val1 - val0 - values(i) = val0 + (ratio*valdiff) - enddo - else - ierr = 1 - endif - else - if (IS_SAME(taEarlier%taTime, time)) then - values = taEarlier%taArray - else - ! -- Only earlier time is available, and it is not time of interest; - ! however, if method is STEPWISE, use value for earlier time. - if (this%iMethod == STEPWISE) then - values = taEarlier%taArray - else - ierr = 1 - endif - endif - endif - else - if (associated(taLater)) then - if (IS_SAME(taLater%taTime, time)) then - values = taLater%taArray - else - ! -- only later time is available, and it is not time of interest - ierr = 1 - endif - else - ! -- Neither earlier nor later time is available. - ! This should never happen! - ierr = 1 - endif - endif - ! - if (ierr > 0) then - write(ermsg,10)time,trim(this%Name) - call store_error(ermsg) - call store_error_unit(this%inunit) - call ustop() - endif - ! - return - end subroutine get_values_at_time - - subroutine get_integrated_values(this, nvals, values, time0, time1) -! ****************************************************************************** -! get_integrated_values -- Populates an array with integrated values for a -! specified time span. Units: (ts-value-unit)*time -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeArraySeriesType), intent(inout) :: this - integer(I4B), intent(in) :: nvals - real(DP), dimension(nvals), intent(inout) :: values - real(DP), intent(in) :: time0 - real(DP), intent(in) :: time1 - ! -- local - integer(I4B) :: i - real(DP) :: area, currTime, nextTime, ratio0, ratio1, t0, & - t01, t1, timediff, value, value0, value1, valuediff - logical :: ldone - character(len=LINELENGTH) :: ermsg - type(ListNodeType), pointer :: precNode => null() - type(ListNodeType), pointer :: currNode => null(), nextNode => null() - type(TimeArrayType), pointer :: currRecord => null(), nextRecord => null() - class(*), pointer :: currObj => null(), nextObj => null() - ! -- formats -10 format('Error encountered while performing integration', & - ' for time-array series "',a,'" for time interval: ', & - g12.5,' to ',g12.5) -! ------------------------------------------------------------------------------ - ! - values = DZERO - value = DZERO - ldone = .false. - t1 = -DONE - call this%get_latest_preceding_node(time0, precNode) - if (associated(precNode)) then - currNode => precNode - do while (.not. ldone) - currObj => currNode%GetItem() - currRecord => CastAsTimeArrayType(currObj) - currTime = currRecord%taTime - if (currTime < time1) then - if (.not. associated(currNode%nextNode)) then - ! -- try to read the next array - if (.not. this%read_next_array()) then - write(ermsg,10)trim(this%Name),time0,time1 - call store_error(ermsg) - call store_error_unit(this%inunit) - call ustop() - endif - endif - if (associated(currNode%nextNode)) then - nextNode => currNode%nextNode - nextObj => nextNode%GetItem() - nextRecord => CastAsTimeArrayType(nextObj) - nextTime = nextRecord%taTime - ! -- determine lower and upper limits of time span of interest - ! within current interval - if (currTime >= time0) then - t0 = currTime - else - t0 = time0 - endif - if (nextTime <= time1) then - t1 = nextTime - else - t1 = time1 - endif - ! -- For each element, find area of rectangle - ! or trapezoid delimited by t0 and t1. - t01 = t1 - t0 - select case (this%iMethod) - case (STEPWISE) - do i=1,nvals - ! -- compute area of a rectangle - value0 = currRecord%taArray(i) - area = value0 * t01 - ! -- add area to integrated value - values(i) = values(i) + area - enddo - case (LINEAR) - do i=1,nvals - ! -- compute area of a trapezoid - timediff = nextTime - currTime - ratio0 = (t0 - currTime) / timediff - ratio1 = (t1 - currTime) / timediff - valuediff = nextRecord%taArray(i) - currRecord%taArray(i) - value0 = currRecord%taArray(i) + ratio0 * valuediff - value1 = currRecord%taArray(i) + ratio1 * valuediff - area = 0.5d0 * t01 * (value0 + value1) - ! -- add area to integrated value - values(i) = values(i) + area - enddo - end select - else - write(ermsg,10)trim(this%Name),time0,time1 - call store_error(ermsg) - call store_error('(Probable programming error)') - call ustop() - endif - else - ! Current node time = time1 so should be done - ldone = .true. - endif - ! - ! -- Are we done yet? - if (t1 >= time1) then - ldone = .true. - else - if (.not. associated(currNode%nextNode)) then - ! -- try to read the next array - if (.not. this%read_next_array()) then - write(ermsg,10)trim(this%Name),time0,time1 - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - endif - if (associated(currNode%nextNode)) then - currNode => currNode%nextNode - else - write(ermsg,10)trim(this%Name),time0,time1 - call store_error(ermsg) - call store_error('(Probable programming error)') - call ustop() - endif - endif - enddo - endif - ! - if (this%autoDeallocate) then - if (associated(precNode)) then - if (associated(precNode%prevNode))then - call this%DeallocateBackward(precNode%prevNode) - endif - endif - endif - ! - return - end subroutine get_integrated_values - - subroutine DeallocateBackward(this, fromNode) -! ****************************************************************************** -! DeallocateBackward -- Deallocate fromNode and all previous nodes in list; -! reassign firstNode. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeArraySeriesType), intent(inout) :: this - type(ListNodeType), pointer, intent(inout) :: fromNode - ! - ! -- local - type(ListNodeType), pointer :: current => null() - type(ListNodeType), pointer :: prev => null() - type(TimeArrayType), pointer :: ta => null() - class(*), pointer :: obj => null() -! ------------------------------------------------------------------------------ - ! - if (associated(fromNode)) then - ! -- reassign firstNode - if (associated(fromNode%nextNode)) then - this%list%firstNode => fromNode%nextNode - else - this%list%firstNode => null() - endif - ! -- deallocate fromNode and all previous nodes - current => fromNode - do while (associated(current)) - prev => current%prevNode - obj => current%GetItem() - ta => CastAsTimeArrayType(obj) - ! -- Deallocate the contents of this time array, - ! then remove it from the list - call ta%da() - call this%list%RemoveNode(current, .true.) - current => prev - enddo - fromNode => null() - endif - ! - return - end subroutine DeallocateBackward - - subroutine get_latest_preceding_node(this, time, tslNode) -! ****************************************************************************** -! get_latest_preceding_node -- Return pointer to ListNodeType object for the -! node representing the latest preceding time in the time series -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeArraySeriesType), intent(inout) :: this - real(DP), intent(in) :: time - type(ListNodeType), pointer, intent(inout) :: tslNode - ! -- local - real(DP) :: time0 - type(ListNodeType), pointer :: currNode => null() - type(ListNodeType), pointer :: node0 => null() - type(TimeArrayType), pointer :: ta => null() - type(TimeArrayType), pointer :: ta0 => null() - class(*), pointer :: obj => null() -! ------------------------------------------------------------------------------ - ! - tslNode => null() - if (associated(this%list%firstNode)) then - currNode => this%list%firstNode - else - call store_error('probable programming error in get_latest_preceding_node') - call ustop() - endif - ! - continue - ! -- If the next node is earlier than time of interest, advance along - ! linked list until the next node is later than time of interest. - do - if (associated(currNode)) then - if (associated(currNode%nextNode)) then - obj => currNode%nextNode%GetItem() - ta => CastAsTimeArrayType(obj) - if (ta%taTime < time .or. IS_SAME(ta%taTime, time)) then - currNode => currNode%nextNode - else - exit - endif - else - ! -- read another record - if (.not. this%read_next_array()) exit - endif - else - exit - endif - enddo - ! - if (associated(currNode)) then - ! - ! -- find earlier record - node0 => currNode - obj => node0%GetItem() - ta0 => CastAsTimeArrayType(obj) - time0 = ta0%taTime - do while (time0 > time) - if (associated(node0%prevNode)) then - node0 => node0%prevNode - obj => node0%GetItem() - ta0 => CastAsTimeArrayType(obj) - time0 = ta0%taTime - else - exit - endif - enddo - endif - ! - if (time0 <= time) tslNode => node0 - ! - return - end subroutine get_latest_preceding_node - - subroutine tas_da(this) -! ****************************************************************************** -! tas_da -- deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeArraySeriesType), intent(inout) :: this - ! -- local - integer :: i, n - type(TimeArrayType), pointer :: ta => null() -! ------------------------------------------------------------------------------ - ! - ! -- Deallocate contents of each time array in list - n = this%list%Count() - do i=1,n - ta => GetTimeArrayFromList(this%list, i) - call ta%da() - enddo - ! - ! -- Deallocate the list of time arrays - call this%list%Clear(.true.) - deallocate(this%list) - ! - return - end subroutine tas_da - - ! -- Procedures not type-bound - - function CastAsTimeArraySeriesType(obj) result (res) -! ****************************************************************************** -! CastAsTimeArraySeriesType -- Cast an unlimited polymorphic object as -! class(TimeArraySeriesType) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(*), pointer, intent(inout) :: obj - type(TimeArraySeriesType), pointer :: res -! ------------------------------------------------------------------------------ - ! - res => null() - if (.not. associated(obj)) return - ! - select type (obj) - type is (TimeArraySeriesType) - res => obj - end select - ! - return - end function CastAsTimeArraySeriesType - - function GetTimeArraySeriesFromList(list, indx) result (res) -! ****************************************************************************** -! GetTimeArraySeriesFromList -- get time array from list -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - type(ListType), intent(inout) :: list - integer, intent(in) :: indx - type(TimeArraySeriesType), pointer :: res - ! -- local - class(*), pointer :: obj -! ------------------------------------------------------------------------------ - ! - obj => list%GetItem(indx) - res => CastAsTimeArraySeriesType(obj) - ! - return - end function GetTimeArraySeriesFromList - -end module TimeArraySeriesModule +module TimeArraySeriesModule + + use ArrayReadersModule, only: ReadArray + use BlockParserModule, only: BlockParserType + use ConstantsModule, only: LINELENGTH, UNDEFINED, STEPWISE, LINEAR, & + LENTIMESERIESNAME, LENBIGLINE, DZERO, DONE + use GenericUtilitiesModule, only: IS_SAME + use InputOutputModule, only: GetUnit, openfile + use KindModule, only: DP, I4B + use ListModule, only: ListType, ListNodeType + use SimModule, only: count_errors, store_error, store_error_unit, & + ustop + use TimeArrayModule, only: TimeArrayType, ConstructTimeArray, & + AddTimeArrayToList, CastAsTimeArrayType, & + GetTimeArrayFromList + use BaseDisModule, only: DisBaseType + use, intrinsic :: iso_fortran_env, only: IOSTAT_END + + implicit none + private + public :: TimeArraySeriesType, ConstructTimeArraySeries, & + CastAsTimeArraySeriesType, GetTimeArraySeriesFromList + + type TimeArraySeriesType + ! -- Public members + character(len=LENTIMESERIESNAME), public :: Name = '' + ! -- Private members + integer(I4B), private :: inunit = 0 + integer(I4B), private :: iout = 0 + integer(I4B), private :: iMethod = UNDEFINED + real(DP), private :: sfac = DONE + character(len=LINELENGTH), private :: dataFile = '' + logical, private :: autoDeallocate = .true. + type(ListType), pointer, private :: list => null() + class(DisBaseType), pointer, private :: dis => null() + type(BlockParserType), private :: parser + contains + ! -- Public procedures + procedure, public :: tas_init + procedure, public :: GetAverageValues + procedure, public :: GetInunit + procedure, public :: da => tas_da + ! -- Private procedures + procedure, private :: get_integrated_values + procedure, private :: get_latest_preceding_node + procedure, private :: get_values_at_time + procedure, private :: get_surrounding_records + procedure, private :: read_next_array + procedure, private :: DeallocateBackward + end type TimeArraySeriesType + +contains + + ! -- Constructor for TimeArraySeriesType + + subroutine ConstructTimeArraySeries(newTas, filename) +! ****************************************************************************** +! ConstructTimeArraySeries -- Allocate a new TimeArraySeriesType object. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + type(TimeArraySeriesType), pointer, intent(out) :: newTas + character(len=*), intent(in) :: filename + ! -- local + character(len=LINELENGTH) :: ermsg + logical :: lex +! ------------------------------------------------------------------------------ + ! formats + 10 format('Error: Time-array-series file "',a,'" does not exist.') + ! + ! -- Allocate a new object of type TimeArraySeriesType + allocate(newTas) + allocate(newTas%list) + ! + ! -- Ensure that input file exists + inquire(file=filename,exist=lex) + if (.not. lex) then + write(ermsg,10)trim(filename) + call store_error(ermsg) + call ustop() + endif + newTas%datafile = filename + ! + return + end subroutine ConstructTimeArraySeries + + ! -- Public procedures + + subroutine tas_init(this, fname, dis, iout, tasname, autoDeallocate) +! ****************************************************************************** +! tas_init -- initialize the time array series +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeArraySeriesType), intent(inout) :: this + character(len=*), intent(in) :: fname + class(DisBaseType), pointer, intent(inout) :: dis + integer(I4B), intent(in) :: iout + character(len=*), intent(inout) :: tasname + logical, optional, intent(in) :: autoDeallocate + ! -- local + integer(I4B) :: istatus + integer(I4B) :: ierr + integer(I4B) :: inunit + character(len=40) :: keyword, keyvalue + character(len=LINELENGTH) :: ermsg + logical :: found, continueread, endOfBlock +! ------------------------------------------------------------------------------ + ! + ! -- initialize some variables + if (present(autoDeallocate)) this%autoDeallocate = autoDeallocate + this%dataFile = fname + allocate(this%list) + ! + ! -- assign members + this%dis => dis + this%iout = iout + ! + ! -- open time-array series input file + inunit = GetUnit() + this%inunit = inunit + call openfile(inunit, 0, fname, 'TAS6') + ! + ! -- initialize block parser + call this%parser%Initialize(this%inunit, this%iout) + ! + ! -- read ATTRIBUTES block + continueread = .false. + ierr = 0 + ! + ! -- get BEGIN line of ATTRIBUTES block + call this%parser%GetBlock('ATTRIBUTES', found, ierr, & + supportOpenClose=.true.) + if (.not. found) then + ermsg = 'Error: Attributes block not found in file: ' // & + trim(fname) + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- parse ATTRIBUTES entries + do + ! -- read line from input + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + ! + ! -- get the keyword + call this%parser%GetStringCaps(keyword) + ! + ! -- get the word following the keyword (the key value) + call this%parser%GetStringCaps(keyvalue) + select case (keyword) + case ('NAME') + this%Name = keyvalue + tasname = keyvalue + case ('METHOD') + select case (keyvalue) + case ('STEPWISE') + this%iMethod = STEPWISE + case ('LINEAR') + this%iMethod = LINEAR + case default + ermsg = 'Unknown interpolation method: "' // trim(keyvalue) // '"' + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + case ('AUTODEALLOCATE') + this%autoDeallocate = (keyvalue == 'TRUE') + case ('SFAC') + read(keyvalue,*,iostat=istatus)this%sfac + if (istatus /= 0) then + ermsg = 'Error reading numeric SFAC value from "' // trim(keyvalue) & + // '"' + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + case default + ermsg = 'Unknown option found in ATTRIBUTES block: "' // & + trim(keyword) // '"' + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + enddo + ! + ! -- ensure that NAME and METHOD have been specified + if (this%Name == '') then + ermsg = 'Error: Name not specified for time array series in file: ' // & + trim(this%dataFile) + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + if (this%iMethod == UNDEFINED) then + ermsg = 'Error: Interpolation method not specified for time' // & + ' array series in file: ' // trim(this%dataFile) + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- handle any errors encountered so far + if (count_errors()>0) then + ermsg = 'Error(s) encountered initializing time array series from file: ' // & + trim(this%dataFile) + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- try to read first time array into linked list + if (.not. this%read_next_array()) then + ermsg = 'Error encountered reading time-array data from file: ' // & + trim(this%dataFile) + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + return + end subroutine tas_init + + subroutine GetAverageValues(this, nvals, values, time0, time1) +! ****************************************************************************** +! GetAverageValues -- populate an array time-weighted average value for a +! specified time span. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeArraySeriesType), intent(inout) :: this + integer(I4B), intent(in) :: nvals + real(DP), dimension(nvals), intent(inout) :: values + real(DP), intent(in) :: time0 + real(DP), intent(in) :: time1 + ! -- local + integer(I4B) :: i + real(DP) :: timediff +! ------------------------------------------------------------------------------ + ! + timediff = time1 - time0 + if (timediff > 0) then + call this%get_integrated_values(nvals, values, time0, time1) + do i=1,nvals + values(i) = values(i) / timediff + enddo + else + ! -- time0 and time1 are the same, so skip the integration step. + call this%get_values_at_time(nvals, values, time0) + endif + ! + return + end subroutine GetAverageValues + + function GetInunit(this) +! ****************************************************************************** +! GetInunit -- return unit number +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + integer(I4B) :: GetInunit + ! -- dummy + class(TimeArraySeriesType) :: this +! ------------------------------------------------------------------------------ + ! + GetInunit = this%inunit + ! + return + end function GetInunit + + ! -- Private procedures + + subroutine get_surrounding_records(this, time, taEarlier, taLater) +! ****************************************************************************** +! get_surrounding_records -- get_surrounding_records +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeArraySeriesType), intent(inout) :: this + real(DP), intent(in) :: time + type(TimeArrayType), pointer, intent(inout) :: taEarlier + type(TimeArrayType), pointer, intent(inout) :: taLater + ! -- local + real(DP) :: time0, time1 + type(ListNodeType), pointer :: currNode => null() + type(ListNodeType), pointer :: node0 => null() + type(ListNodeType), pointer :: node1 => null() + type(TimeArrayType), pointer :: ta => null(), ta0 => null(), ta1 => null() + class(*), pointer :: obj +! ------------------------------------------------------------------------------ + ! + taEarlier => null() + taLater => null() + ! + if (associated(this%list%firstNode)) then + currNode => this%list%firstNode + endif + ! + ! -- If the next node is earlier than time of interest, advance along + ! linked list until the next node is later than time of interest. + do + if (associated(currNode)) then + if (associated(currNode%nextNode)) then + obj => currNode%nextNode%GetItem() + ta => CastAsTimeArrayType(obj) + if (ta%taTime <= time) then + currNode => currNode%nextNode + else + exit + endif + else + ! -- read another array + if (.not. this%read_next_array()) exit + endif + else + exit + endif + enddo + ! + if (associated(currNode)) then + ! + ! -- find earlier record + node0 => currNode + obj => node0%GetItem() + ta0 => CastAsTimeArrayType(obj) + time0 = ta0%taTime + do while (time0 > time) + if (associated(node0%prevNode)) then + node0 => node0%prevNode + obj => node0%GetItem() + ta0 => CastAsTimeArrayType(obj) + time0 = ta0%taTime + else + exit + endif + enddo + ! + ! -- find later record + node1 => currNode + obj => node1%GetItem() + ta1 => CastAsTimeArrayType(obj) + time1 = ta1%taTime + do while (time1 < time) + if (associated(node1%nextNode)) then + node1 => node1%nextNode + obj => node1%GetItem() + ta1 => CastAsTimeArrayType(obj) + time1 = ta1%taTime + else + ! -- get next array + if (.not. this%read_next_array()) then + ! -- end of file reached, so exit loop + exit + endif + endif + enddo + ! + endif + ! + if (time0 <= time) taEarlier => ta0 + if (time1 >= time) taLater => ta1 + ! + return + end subroutine get_surrounding_records + + logical function read_next_array(this) +! ****************************************************************************** +! read_next_array -- Read next time array from input file and append to list. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeArraySeriesType), intent(inout) :: this + ! -- local + integer(I4B) :: i, ierr, istart, istat, istop, lloc, nrow, ncol, nodesperlayer + logical :: lopen, isFound + character(len=LINELENGTH) :: ermsg + type(TimeArrayType), pointer :: ta => null() +! ------------------------------------------------------------------------------ + ! + istart = 1 + istat = 0 + istop = 1 + lloc = 1 + ! Get dimensions for supported discretization type + if (this%dis%supports_layers()) then + nodesperlayer = this%dis%get_ncpl() + if(size(this%dis%mshape) == 3) then + nrow = this%dis%mshape(2) + ncol = this%dis%mshape(3) + else + nrow = 1 + ncol = this%dis%mshape(2) + endif + else + ermsg = 'Time array series is not supported for selected discretization type.' + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + read_next_array = .false. + inquire(unit=this%inunit,opened=lopen) + if (lopen) then + call ConstructTimeArray(ta, this%dis) + ! -- read a time and an array from the input file + ! -- Get a TIME block and read the time + call this%parser%GetBlock('TIME', isFound, ierr, & + supportOpenClose=.true.) + if (isFound) then + ta%taTime = this%parser%GetDouble() + ! -- Read the array + call ReadArray(this%parser%iuactive, ta%taArray, this%Name, & + this%dis%ndim, ncol, nrow, 1, nodesperlayer, & + this%iout, 0, 0) + ! + ! -- multiply values by sfac + do i = 1, nodesperlayer + ta%taArray(i) = ta%taArray(i) * this%sfac + enddo + ! + ! -- append the new time array to the list + call AddTimeArrayToList(this%list, ta) + read_next_array = .true. + ! + ! -- make sure block is closed + call this%parser%terminateblock() + endif + endif + return ! Normal return + ! + return + end function read_next_array + + subroutine get_values_at_time(this, nvals, values, time) +! ****************************************************************************** +! get_values_at_time -- Return an array of values for a specified time, same +! units as time-series values. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeArraySeriesType), intent(inout) :: this + integer(I4B), intent(in) :: nvals + real(DP), dimension(nvals), intent(inout) :: values + real(DP), intent(in) :: time ! time of interest + ! -- local + integer(I4B) :: i, ierr + real(DP) :: ratio, time0, time1, timediff, timediffi, val0, val1, & + valdiff + character(len=LINELENGTH) :: ermsg + type(TimeArrayType), pointer :: taEarlier => null() + type(TimeArrayType), pointer :: taLater => null() + ! formats + 10 format('Error getting array at time ',g10.3, & + ' for time-array series "',a,'"') +! ------------------------------------------------------------------------------ + ! + ierr = 0 + call this%get_surrounding_records(time,taEarlier,taLater) + if (associated(taEarlier)) then + if (associated(taLater)) then + ! -- values are available for both earlier and later times + if (this%iMethod == STEPWISE) then + ! -- Just populate values from elements of earlier time array + values = taEarlier%taArray + elseif (this%iMethod == LINEAR) then + ! -- perform linear interpolation + time0 = taEarlier%taTime + time1 = taLater%tatime + timediff = time1 - time0 + timediffi = time - time0 + if (timediff>0) then + ratio = timediffi/timediff + else + ! -- should not happen if TS does not contain duplicate times + ratio = 0.5d0 + endif + ! -- Iterate through all elements and perform interpolation. + do i=1,nvals + val0 = taEarlier%taArray(i) + val1 = taLater%taArray(i) + valdiff = val1 - val0 + values(i) = val0 + (ratio*valdiff) + enddo + else + ierr = 1 + endif + else + if (IS_SAME(taEarlier%taTime, time)) then + values = taEarlier%taArray + else + ! -- Only earlier time is available, and it is not time of interest; + ! however, if method is STEPWISE, use value for earlier time. + if (this%iMethod == STEPWISE) then + values = taEarlier%taArray + else + ierr = 1 + endif + endif + endif + else + if (associated(taLater)) then + if (IS_SAME(taLater%taTime, time)) then + values = taLater%taArray + else + ! -- only later time is available, and it is not time of interest + ierr = 1 + endif + else + ! -- Neither earlier nor later time is available. + ! This should never happen! + ierr = 1 + endif + endif + ! + if (ierr > 0) then + write(ermsg,10)time,trim(this%Name) + call store_error(ermsg) + call store_error_unit(this%inunit) + call ustop() + endif + ! + return + end subroutine get_values_at_time + + subroutine get_integrated_values(this, nvals, values, time0, time1) +! ****************************************************************************** +! get_integrated_values -- Populates an array with integrated values for a +! specified time span. Units: (ts-value-unit)*time +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeArraySeriesType), intent(inout) :: this + integer(I4B), intent(in) :: nvals + real(DP), dimension(nvals), intent(inout) :: values + real(DP), intent(in) :: time0 + real(DP), intent(in) :: time1 + ! -- local + integer(I4B) :: i + real(DP) :: area, currTime, nextTime, ratio0, ratio1, t0, & + t01, t1, timediff, value, value0, value1, valuediff + logical :: ldone + character(len=LINELENGTH) :: ermsg + type(ListNodeType), pointer :: precNode => null() + type(ListNodeType), pointer :: currNode => null(), nextNode => null() + type(TimeArrayType), pointer :: currRecord => null(), nextRecord => null() + class(*), pointer :: currObj => null(), nextObj => null() + ! -- formats +10 format('Error encountered while performing integration', & + ' for time-array series "',a,'" for time interval: ', & + g12.5,' to ',g12.5) +! ------------------------------------------------------------------------------ + ! + values = DZERO + value = DZERO + ldone = .false. + t1 = -DONE + call this%get_latest_preceding_node(time0, precNode) + if (associated(precNode)) then + currNode => precNode + do while (.not. ldone) + currObj => currNode%GetItem() + currRecord => CastAsTimeArrayType(currObj) + currTime = currRecord%taTime + if (currTime < time1) then + if (.not. associated(currNode%nextNode)) then + ! -- try to read the next array + if (.not. this%read_next_array()) then + write(ermsg,10)trim(this%Name),time0,time1 + call store_error(ermsg) + call store_error_unit(this%inunit) + call ustop() + endif + endif + if (associated(currNode%nextNode)) then + nextNode => currNode%nextNode + nextObj => nextNode%GetItem() + nextRecord => CastAsTimeArrayType(nextObj) + nextTime = nextRecord%taTime + ! -- determine lower and upper limits of time span of interest + ! within current interval + if (currTime >= time0) then + t0 = currTime + else + t0 = time0 + endif + if (nextTime <= time1) then + t1 = nextTime + else + t1 = time1 + endif + ! -- For each element, find area of rectangle + ! or trapezoid delimited by t0 and t1. + t01 = t1 - t0 + select case (this%iMethod) + case (STEPWISE) + do i=1,nvals + ! -- compute area of a rectangle + value0 = currRecord%taArray(i) + area = value0 * t01 + ! -- add area to integrated value + values(i) = values(i) + area + enddo + case (LINEAR) + do i=1,nvals + ! -- compute area of a trapezoid + timediff = nextTime - currTime + ratio0 = (t0 - currTime) / timediff + ratio1 = (t1 - currTime) / timediff + valuediff = nextRecord%taArray(i) - currRecord%taArray(i) + value0 = currRecord%taArray(i) + ratio0 * valuediff + value1 = currRecord%taArray(i) + ratio1 * valuediff + area = 0.5d0 * t01 * (value0 + value1) + ! -- add area to integrated value + values(i) = values(i) + area + enddo + end select + else + write(ermsg,10)trim(this%Name),time0,time1 + call store_error(ermsg) + call store_error('(Probable programming error)') + call ustop() + endif + else + ! Current node time = time1 so should be done + ldone = .true. + endif + ! + ! -- Are we done yet? + if (t1 >= time1) then + ldone = .true. + else + if (.not. associated(currNode%nextNode)) then + ! -- try to read the next array + if (.not. this%read_next_array()) then + write(ermsg,10)trim(this%Name),time0,time1 + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + endif + if (associated(currNode%nextNode)) then + currNode => currNode%nextNode + else + write(ermsg,10)trim(this%Name),time0,time1 + call store_error(ermsg) + call store_error('(Probable programming error)') + call ustop() + endif + endif + enddo + endif + ! + if (this%autoDeallocate) then + if (associated(precNode)) then + if (associated(precNode%prevNode))then + call this%DeallocateBackward(precNode%prevNode) + endif + endif + endif + ! + return + end subroutine get_integrated_values + + subroutine DeallocateBackward(this, fromNode) +! ****************************************************************************** +! DeallocateBackward -- Deallocate fromNode and all previous nodes in list; +! reassign firstNode. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeArraySeriesType), intent(inout) :: this + type(ListNodeType), pointer, intent(inout) :: fromNode + ! + ! -- local + type(ListNodeType), pointer :: current => null() + type(ListNodeType), pointer :: prev => null() + type(TimeArrayType), pointer :: ta => null() + class(*), pointer :: obj => null() +! ------------------------------------------------------------------------------ + ! + if (associated(fromNode)) then + ! -- reassign firstNode + if (associated(fromNode%nextNode)) then + this%list%firstNode => fromNode%nextNode + else + this%list%firstNode => null() + endif + ! -- deallocate fromNode and all previous nodes + current => fromNode + do while (associated(current)) + prev => current%prevNode + obj => current%GetItem() + ta => CastAsTimeArrayType(obj) + ! -- Deallocate the contents of this time array, + ! then remove it from the list + call ta%da() + call this%list%RemoveNode(current, .true.) + current => prev + enddo + fromNode => null() + endif + ! + return + end subroutine DeallocateBackward + + subroutine get_latest_preceding_node(this, time, tslNode) +! ****************************************************************************** +! get_latest_preceding_node -- Return pointer to ListNodeType object for the +! node representing the latest preceding time in the time series +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeArraySeriesType), intent(inout) :: this + real(DP), intent(in) :: time + type(ListNodeType), pointer, intent(inout) :: tslNode + ! -- local + real(DP) :: time0 + type(ListNodeType), pointer :: currNode => null() + type(ListNodeType), pointer :: node0 => null() + type(TimeArrayType), pointer :: ta => null() + type(TimeArrayType), pointer :: ta0 => null() + class(*), pointer :: obj => null() +! ------------------------------------------------------------------------------ + ! + tslNode => null() + if (associated(this%list%firstNode)) then + currNode => this%list%firstNode + else + call store_error('probable programming error in get_latest_preceding_node') + call ustop() + endif + ! + continue + ! -- If the next node is earlier than time of interest, advance along + ! linked list until the next node is later than time of interest. + do + if (associated(currNode)) then + if (associated(currNode%nextNode)) then + obj => currNode%nextNode%GetItem() + ta => CastAsTimeArrayType(obj) + if (ta%taTime < time .or. IS_SAME(ta%taTime, time)) then + currNode => currNode%nextNode + else + exit + endif + else + ! -- read another record + if (.not. this%read_next_array()) exit + endif + else + exit + endif + enddo + ! + if (associated(currNode)) then + ! + ! -- find earlier record + node0 => currNode + obj => node0%GetItem() + ta0 => CastAsTimeArrayType(obj) + time0 = ta0%taTime + do while (time0 > time) + if (associated(node0%prevNode)) then + node0 => node0%prevNode + obj => node0%GetItem() + ta0 => CastAsTimeArrayType(obj) + time0 = ta0%taTime + else + exit + endif + enddo + endif + ! + if (time0 <= time) tslNode => node0 + ! + return + end subroutine get_latest_preceding_node + + subroutine tas_da(this) +! ****************************************************************************** +! tas_da -- deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeArraySeriesType), intent(inout) :: this + ! -- local + integer :: i, n + type(TimeArrayType), pointer :: ta => null() +! ------------------------------------------------------------------------------ + ! + ! -- Deallocate contents of each time array in list + n = this%list%Count() + do i=1,n + ta => GetTimeArrayFromList(this%list, i) + call ta%da() + enddo + ! + ! -- Deallocate the list of time arrays + call this%list%Clear(.true.) + deallocate(this%list) + ! + return + end subroutine tas_da + + ! -- Procedures not type-bound + + function CastAsTimeArraySeriesType(obj) result (res) +! ****************************************************************************** +! CastAsTimeArraySeriesType -- Cast an unlimited polymorphic object as +! class(TimeArraySeriesType) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(*), pointer, intent(inout) :: obj + type(TimeArraySeriesType), pointer :: res +! ------------------------------------------------------------------------------ + ! + res => null() + if (.not. associated(obj)) return + ! + select type (obj) + type is (TimeArraySeriesType) + res => obj + end select + ! + return + end function CastAsTimeArraySeriesType + + function GetTimeArraySeriesFromList(list, indx) result (res) +! ****************************************************************************** +! GetTimeArraySeriesFromList -- get time array from list +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + type(ListType), intent(inout) :: list + integer, intent(in) :: indx + type(TimeArraySeriesType), pointer :: res + ! -- local + class(*), pointer :: obj +! ------------------------------------------------------------------------------ + ! + obj => list%GetItem(indx) + res => CastAsTimeArraySeriesType(obj) + ! + return + end function GetTimeArraySeriesFromList + +end module TimeArraySeriesModule diff --git a/src/Utilities/TimeSeries/TimeArraySeriesManager.f90 b/src/Utilities/TimeSeries/TimeArraySeriesManager.f90 index 254828ed4c6..508253baf81 100644 --- a/src/Utilities/TimeSeries/TimeArraySeriesManager.f90 +++ b/src/Utilities/TimeSeries/TimeArraySeriesManager.f90 @@ -1,452 +1,452 @@ -module TimeArraySeriesManagerModule - - use KindModule, only: DP, I4B - use BlockParserModule, only: BlockParserType - use ConstantsModule, only: DZERO, LENTIMESERIESNAME, LINELENGTH, & - MAXCHARLEN, LENHUGELINE - use InputOutputModule, only: GetUnit, openfile - use ListModule, only: ListType - use SimModule, only: store_error, store_error_unit, ustop - use TdisModule, only: delt, totimc, kper, kstp - use TimeArraySeriesLinkModule, only: TimeArraySeriesLinkType, & - ConstructTimeArraySeriesLink, & - GetTimeArraySeriesLinkFromList, & - AddTimeArraySeriesLinkToList - use TimeArraySeriesModule, only: TimeArraySeriesType, & - ConstructTimeArraySeries - use BaseDisModule, only: DisBaseType - - implicit none - - private - public :: TimeArraySeriesManagerType, tasmanager_cr - - type TimeArraySeriesManagerType - ! -- Public members - integer(I4B), public :: iout = 0 ! output unit num - class(DisBaseType), pointer, public :: dis => null() ! pointer to dis - ! -- Private members - type(ListType), pointer, private :: boundTasLinks => null() ! list of TAS links - character(len=LINELENGTH), allocatable, dimension(:) :: tasfiles ! list of TA file names - type(TimeArraySeriesType), dimension(:), pointer, contiguous :: taslist ! array of TA pointers - character(len=LENTIMESERIESNAME), allocatable, dimension(:) :: tasnames ! array of TA names - contains - ! -- Public procedures - procedure, public :: tasmanager_df - procedure, public :: ad => tasmgr_ad - procedure, public :: da => tasmgr_da - procedure, public :: add_tasfile - procedure, public :: CountLinks - procedure, public :: GetLink - procedure, public :: MakeTasLink - procedure, public :: Reset - ! -- Private procedures - procedure, private :: tasmgr_add_link - procedure, private :: tasmgr_convert_flux - end type TimeArraySeriesManagerType - -contains - -! -- Type-bound procedures of TimeArraySeriesManagerType - - ! -- Public procedures - - subroutine tasmanager_cr(this, dis, iout) -! ****************************************************************************** -! tasmanager_cr -- create the tasmanager -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - type(TimeArraySeriesManagerType) :: this - class(DisBaseType), pointer :: dis - integer(I4B), intent(in) :: iout -! ------------------------------------------------------------------------------ - ! - this%iout = iout - this%dis => dis - allocate(this%boundTasLinks) - allocate(this%tasfiles(0)) - ! - return - end subroutine tasmanager_cr - - subroutine tasmanager_df(this) -! ****************************************************************************** -! tasmanager_df -- define -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeArraySeriesManagerType) :: this - ! -- local - type(TimeArraySeriesType), pointer :: tasptr => null() - integer(I4B) :: nfiles - integer(I4B) :: i -! ------------------------------------------------------------------------------ - ! - ! -- determine how many tasfiles. This is the number of time array series - ! so allocate arrays to store them - nfiles = size(this%tasfiles) - allocate(this%taslist(nfiles)) - allocate(this%tasnames(nfiles)) - ! - ! -- Setup a time array series for each file specified - do i = 1, nfiles - tasptr => this%taslist(i) - call tasptr%tas_init(this%tasfiles(i), this%dis, & - this%iout, this%tasnames(i)) - enddo - ! - return - end subroutine tasmanager_df - - subroutine tasmgr_ad(this) -! ****************************************************************************** -! tasmgr_ad -- time step (or subtime step) advance. -! Call this each time step or subtime step. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeArraySeriesManagerType) :: this - ! -- local - type(TimeArraySeriesLinkType), pointer :: tasLink => null() - type(TimeArraySeriesType), pointer :: timearrayseries => null() - integer(I4B) :: i, j, nlinks, nvals, isize1, isize2, inunit - real(DP) :: begintime, endtime - character(len=MAXCHARLEN) :: ermsg - ! formats - character(len=*),parameter :: fmt5 = & - "(/,'Time-array-series controlled arrays in stress period ', & - &i0, ', time step ', i0, ':')" -10 format('"',a, '" package: ',a,' array obtained from time-array series "',a,'"') -! ------------------------------------------------------------------------------ - ! - ! -- Initialize time variables - begintime = totimc - endtime = begintime + delt - ! - ! -- Iterate through boundtaslinks and update specified - ! array with array of average values obtained from - ! appropriate time series. - if (associated(this%boundTasLinks)) then - nlinks = this%boundTasLinks%Count() - do i = 1, nlinks - tasLink => GetTimeArraySeriesLinkFromList(this%boundTasLinks, i) - if (tasLink%Iprpak == 1 .and. i==1) then - write(this%iout, fmt5) kper, kstp - endif - if (tasLink%UseDefaultProc) then - timearrayseries => tasLink%timeArraySeries - nvals = size(tasLink%BndArray) - ! - ! -- Fill the package array with integrated values - call timearrayseries%GetAverageValues(nvals, tasLink%BndArray, & - begintime, endtime) - ! - ! -- If conversion from flux to flow is required, multiply by cell area - if (tasLink%ConvertFlux) then - call this%tasmgr_convert_flux(tasLink) - endif - ! - ! -- If PRINT_INPUT is specified, write information - ! regarding source of time-array series data - if (tasLink%Iprpak == 1) then - write(this%iout,10) trim(tasLink%PackageName), & - trim(tasLink%Text), & - trim(tasLink%timeArraySeries%Name) - endif - endif - if (i == nlinks) then - write(this%iout, '()') - endif - enddo - ! - ! -- Now that all array values have been substituted, can now multiply - ! an array by a multiplier array - do i = 1, nlinks - tasLink => GetTimeArraySeriesLinkFromList(this%boundTasLinks, i) - if (tasLink%UseDefaultProc) then - if (associated(tasLink%RMultArray)) then - isize1 = size(tasLink%BndArray) - isize2 = size(tasLink%RMultArray) - if (isize1 == isize2 .and. isize1 == nvals) then - do j = 1, nvals - tasLink%BndArray(j) = tasLink%BndArray(j) * tasLink%RMultArray(j) - enddo - else - ermsg = 'Size mismatch between boundary and multiplier arrays' // & - ' using time-array series: ' // & - trim(tasLink%TimeArraySeries%Name) - call store_error(ermsg) - inunit = tasLink%TimeArraySeries%GetInunit() - call store_error_unit(inunit) - call ustop() - endif - endif - endif - enddo - endif - ! - return - end subroutine tasmgr_ad - - subroutine tasmgr_da(this) -! ****************************************************************************** -! tasmgr_da -- deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeArraySeriesManagerType) :: this - ! -- local - integer :: i, n - type(TimeArraySeriesLinkType), pointer :: tasLink => null() -! ------------------------------------------------------------------------------ - ! - ! -- Deallocate contents of each TimeArraySeriesType object in list - ! of time-array series links. - n = this%boundTasLinks%Count() - do i=1,n - tasLink => GetTimeArraySeriesLinkFromList(this%boundTasLinks, i) - call tasLink%da() - enddo - ! - ! -- Deallocate the list of time-array series links. - call this%boundTasLinks%Clear(.true.) - deallocate(this%boundTasLinks) - deallocate(this%tasfiles) - deallocate(this%taslist) - deallocate(this%tasnames) - ! - ! -- nullify pointers - this%dis => null() - this%boundTasLinks => null() - ! - return - end subroutine tasmgr_da - - subroutine add_tasfile(this, fname) -! ****************************************************************************** -! add_tasfile -- add a tas file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ArrayHandlersModule, only: ExpandArray - ! -- dummy - class(TimeArraySeriesManagerType) :: this - character(len=*), intent(in) :: fname - ! -- local - integer(I4B) :: indx -! ------------------------------------------------------------------------------ - ! - call ExpandArray(this%tasfiles, 1) - indx = size(this%tasfiles) - this%tasfiles(indx) = fname - ! - return - end subroutine add_tasfile - - subroutine Reset(this, pkgName) -! ****************************************************************************** -! Reset -- zero out arrays that are represented with time series. -! Delete all existing links from time array series to package arrays as they -! will need to be created with a new BEGIN PERIOD block. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TimeArraySeriesManagerType) :: this - character(len=*), intent(in) :: pkgName - ! -- local - integer(I4B) :: i, j, nlinks - type(TimeArraySeriesLinkType), pointer :: taslink -! ------------------------------------------------------------------------------ - ! - ! -- Reassign all linked elements to zero - nlinks = this%boundTasLinks%Count() - do i = 1, nlinks - taslink => GetTimeArraySeriesLinkFromList(this%boundTasLinks, i) - if (associated(taslink)) then - do j = 1, size(taslink%BndArray) - taslink%BndArray(j) = DZERO - enddo - endif - enddo - ! - ! -- Delete all existing time array links - if (associated(this%boundTasLinks)) then - ! Deallocate and remove all links belonging to package - nlinks = this%boundTasLinks%Count() - do i = nlinks, 1, -1 - taslink => GetTimeArraySeriesLinkFromList(this%boundTasLinks, i) - if (associated(taslink)) then - call taslink%da() - call this%boundTasLinks%RemoveNode(i, .true.) - endif - enddo - endif - ! - return - end subroutine Reset - - subroutine MakeTasLink(this, pkgName, bndArray, iprpak, & - tasName, text, convertFlux, nodelist, inunit) -! ****************************************************************************** -! MakeTasLink -- Make link from TAS to package array -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeArraySeriesManagerType) :: this - character(len=*), intent(in) :: pkgName - real(DP), dimension(:), pointer :: bndArray - integer(I4B), intent(in) :: iprpak - character(len=*), intent(in) :: tasName - character(len=*), intent(in) :: text - logical, intent(in) :: convertFlux - integer(I4B), dimension(:), pointer, contiguous, intent(in) :: nodelist - integer(I4B), intent(in) :: inunit - ! -- local - integer(I4B) :: i, nfiles, iloc - character(LINELENGTH) :: ermsg - type(TimeArraySeriesLinkType), pointer :: newTasLink - type(TimeArraySeriesType), pointer :: tasptr => null() -! ------------------------------------------------------------------------------ - ! - ! -- Find the time array series - nfiles = size(this%tasnames) - iloc = 0 - do i = 1, nfiles - if (this%tasnames(i) == tasname) then - iloc = i - exit - endif - end do - if (iloc == 0) then - ermsg = 'Error: Time-array series "' // trim(tasName) // '" not found.' - call store_error(ermsg) - call store_error_unit(inunit) - call ustop() - endif - tasptr => this%taslist(iloc) - ! - ! -- Construct a time-array series link - newTasLink => null() - call ConstructTimeArraySeriesLink(newTasLink, tasptr, & - pkgName, bndArray, iprpak, & - text) - newTasLink%ConvertFlux = convertFlux - newTasLink%nodelist => nodelist - ! - ! -- Add link to list of links - call this%tasmgr_add_link(newTasLink) - ! - return - end subroutine MakeTasLink - - function GetLink(this, indx) result(tasLink) -! ****************************************************************************** -! GetLink -- get link from the boundtaslinks list -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeArraySeriesManagerType) :: this - integer(I4B), intent(in) :: indx - type(TimeArraySeriesLinkType), pointer :: tasLink - ! -- local -! ------------------------------------------------------------------------------ - ! - tasLink => null() - ! - if (associated(this%boundTasLinks)) then - tasLink => GetTimeArraySeriesLinkFromList(this%boundTasLinks, indx) - endif - ! - return - end function GetLink - - function CountLinks(this) -! ****************************************************************************** -! CountLinks -- count number of links in the boundtaslinks list -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - integer(I4B) :: CountLinks - ! -- dummy - class(TimeArraySeriesManagerType) :: this -! ------------------------------------------------------------------------------ - ! - if (associated(this%boundtaslinks)) then - CountLinks = this%boundTasLinks%Count() - else - CountLinks = 0 - endif - ! - return - end function CountLinks - - ! -- Private procedures - - subroutine tasmgr_convert_flux(this, tasLink) -! ****************************************************************************** -! tasmgr_convert_flux -- convert the array from a flux to a flow rate by -! multiplying by the cell area -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeArraySeriesManagerType) :: this - type(TimeArraySeriesLinkType), pointer, intent(inout) :: tasLink - ! -- local - integer(I4B) :: i, n, noder - real(DP) :: area -! ------------------------------------------------------------------------------ - ! - n = size(tasLink%BndArray) - do i=1,n - noder = tasLink%nodelist(i) - if (noder > 0) then - area = this%dis%get_area(noder) - tasLink%BndArray(i) = tasLink%BndArray(i) * area - endif - enddo - ! - return - end subroutine tasmgr_convert_flux - - subroutine tasmgr_add_link(this, tasLink) -! ****************************************************************************** -! tasmgr_add_link -- add a time arrays series link -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeArraySeriesManagerType) :: this - type(TimeArraySeriesLinkType), pointer :: tasLink - ! -- local -! ------------------------------------------------------------------------------ - ! - call AddTimeArraySeriesLinkToList(this%boundTasLinks, tasLink) - ! - return - end subroutine tasmgr_add_link - -end module TimeArraySeriesManagerModule - +module TimeArraySeriesManagerModule + + use KindModule, only: DP, I4B + use BlockParserModule, only: BlockParserType + use ConstantsModule, only: DZERO, LENTIMESERIESNAME, LINELENGTH, & + MAXCHARLEN, LENHUGELINE + use InputOutputModule, only: GetUnit, openfile + use ListModule, only: ListType + use SimModule, only: store_error, store_error_unit, ustop + use TdisModule, only: delt, totimc, kper, kstp + use TimeArraySeriesLinkModule, only: TimeArraySeriesLinkType, & + ConstructTimeArraySeriesLink, & + GetTimeArraySeriesLinkFromList, & + AddTimeArraySeriesLinkToList + use TimeArraySeriesModule, only: TimeArraySeriesType, & + ConstructTimeArraySeries + use BaseDisModule, only: DisBaseType + + implicit none + + private + public :: TimeArraySeriesManagerType, tasmanager_cr + + type TimeArraySeriesManagerType + ! -- Public members + integer(I4B), public :: iout = 0 ! output unit num + class(DisBaseType), pointer, public :: dis => null() ! pointer to dis + ! -- Private members + type(ListType), pointer, private :: boundTasLinks => null() ! list of TAS links + character(len=LINELENGTH), allocatable, dimension(:) :: tasfiles ! list of TA file names + type(TimeArraySeriesType), dimension(:), pointer, contiguous :: taslist ! array of TA pointers + character(len=LENTIMESERIESNAME), allocatable, dimension(:) :: tasnames ! array of TA names + contains + ! -- Public procedures + procedure, public :: tasmanager_df + procedure, public :: ad => tasmgr_ad + procedure, public :: da => tasmgr_da + procedure, public :: add_tasfile + procedure, public :: CountLinks + procedure, public :: GetLink + procedure, public :: MakeTasLink + procedure, public :: Reset + ! -- Private procedures + procedure, private :: tasmgr_add_link + procedure, private :: tasmgr_convert_flux + end type TimeArraySeriesManagerType + +contains + +! -- Type-bound procedures of TimeArraySeriesManagerType + + ! -- Public procedures + + subroutine tasmanager_cr(this, dis, iout) +! ****************************************************************************** +! tasmanager_cr -- create the tasmanager +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + type(TimeArraySeriesManagerType) :: this + class(DisBaseType), pointer :: dis + integer(I4B), intent(in) :: iout +! ------------------------------------------------------------------------------ + ! + this%iout = iout + this%dis => dis + allocate(this%boundTasLinks) + allocate(this%tasfiles(0)) + ! + return + end subroutine tasmanager_cr + + subroutine tasmanager_df(this) +! ****************************************************************************** +! tasmanager_df -- define +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeArraySeriesManagerType) :: this + ! -- local + type(TimeArraySeriesType), pointer :: tasptr => null() + integer(I4B) :: nfiles + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + ! -- determine how many tasfiles. This is the number of time array series + ! so allocate arrays to store them + nfiles = size(this%tasfiles) + allocate(this%taslist(nfiles)) + allocate(this%tasnames(nfiles)) + ! + ! -- Setup a time array series for each file specified + do i = 1, nfiles + tasptr => this%taslist(i) + call tasptr%tas_init(this%tasfiles(i), this%dis, & + this%iout, this%tasnames(i)) + enddo + ! + return + end subroutine tasmanager_df + + subroutine tasmgr_ad(this) +! ****************************************************************************** +! tasmgr_ad -- time step (or subtime step) advance. +! Call this each time step or subtime step. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeArraySeriesManagerType) :: this + ! -- local + type(TimeArraySeriesLinkType), pointer :: tasLink => null() + type(TimeArraySeriesType), pointer :: timearrayseries => null() + integer(I4B) :: i, j, nlinks, nvals, isize1, isize2, inunit + real(DP) :: begintime, endtime + character(len=MAXCHARLEN) :: ermsg + ! formats + character(len=*),parameter :: fmt5 = & + "(/,'Time-array-series controlled arrays in stress period ', & + &i0, ', time step ', i0, ':')" +10 format('"',a, '" package: ',a,' array obtained from time-array series "',a,'"') +! ------------------------------------------------------------------------------ + ! + ! -- Initialize time variables + begintime = totimc + endtime = begintime + delt + ! + ! -- Iterate through boundtaslinks and update specified + ! array with array of average values obtained from + ! appropriate time series. + if (associated(this%boundTasLinks)) then + nlinks = this%boundTasLinks%Count() + do i = 1, nlinks + tasLink => GetTimeArraySeriesLinkFromList(this%boundTasLinks, i) + if (tasLink%Iprpak == 1 .and. i==1) then + write(this%iout, fmt5) kper, kstp + endif + if (tasLink%UseDefaultProc) then + timearrayseries => tasLink%timeArraySeries + nvals = size(tasLink%BndArray) + ! + ! -- Fill the package array with integrated values + call timearrayseries%GetAverageValues(nvals, tasLink%BndArray, & + begintime, endtime) + ! + ! -- If conversion from flux to flow is required, multiply by cell area + if (tasLink%ConvertFlux) then + call this%tasmgr_convert_flux(tasLink) + endif + ! + ! -- If PRINT_INPUT is specified, write information + ! regarding source of time-array series data + if (tasLink%Iprpak == 1) then + write(this%iout,10) trim(tasLink%PackageName), & + trim(tasLink%Text), & + trim(tasLink%timeArraySeries%Name) + endif + endif + if (i == nlinks) then + write(this%iout, '()') + endif + enddo + ! + ! -- Now that all array values have been substituted, can now multiply + ! an array by a multiplier array + do i = 1, nlinks + tasLink => GetTimeArraySeriesLinkFromList(this%boundTasLinks, i) + if (tasLink%UseDefaultProc) then + if (associated(tasLink%RMultArray)) then + isize1 = size(tasLink%BndArray) + isize2 = size(tasLink%RMultArray) + if (isize1 == isize2 .and. isize1 == nvals) then + do j = 1, nvals + tasLink%BndArray(j) = tasLink%BndArray(j) * tasLink%RMultArray(j) + enddo + else + ermsg = 'Size mismatch between boundary and multiplier arrays' // & + ' using time-array series: ' // & + trim(tasLink%TimeArraySeries%Name) + call store_error(ermsg) + inunit = tasLink%TimeArraySeries%GetInunit() + call store_error_unit(inunit) + call ustop() + endif + endif + endif + enddo + endif + ! + return + end subroutine tasmgr_ad + + subroutine tasmgr_da(this) +! ****************************************************************************** +! tasmgr_da -- deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeArraySeriesManagerType) :: this + ! -- local + integer :: i, n + type(TimeArraySeriesLinkType), pointer :: tasLink => null() +! ------------------------------------------------------------------------------ + ! + ! -- Deallocate contents of each TimeArraySeriesType object in list + ! of time-array series links. + n = this%boundTasLinks%Count() + do i=1,n + tasLink => GetTimeArraySeriesLinkFromList(this%boundTasLinks, i) + call tasLink%da() + enddo + ! + ! -- Deallocate the list of time-array series links. + call this%boundTasLinks%Clear(.true.) + deallocate(this%boundTasLinks) + deallocate(this%tasfiles) + deallocate(this%taslist) + deallocate(this%tasnames) + ! + ! -- nullify pointers + this%dis => null() + this%boundTasLinks => null() + ! + return + end subroutine tasmgr_da + + subroutine add_tasfile(this, fname) +! ****************************************************************************** +! add_tasfile -- add a tas file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ArrayHandlersModule, only: ExpandArray + ! -- dummy + class(TimeArraySeriesManagerType) :: this + character(len=*), intent(in) :: fname + ! -- local + integer(I4B) :: indx +! ------------------------------------------------------------------------------ + ! + call ExpandArray(this%tasfiles, 1) + indx = size(this%tasfiles) + this%tasfiles(indx) = fname + ! + return + end subroutine add_tasfile + + subroutine Reset(this, pkgName) +! ****************************************************************************** +! Reset -- zero out arrays that are represented with time series. +! Delete all existing links from time array series to package arrays as they +! will need to be created with a new BEGIN PERIOD block. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TimeArraySeriesManagerType) :: this + character(len=*), intent(in) :: pkgName + ! -- local + integer(I4B) :: i, j, nlinks + type(TimeArraySeriesLinkType), pointer :: taslink +! ------------------------------------------------------------------------------ + ! + ! -- Reassign all linked elements to zero + nlinks = this%boundTasLinks%Count() + do i = 1, nlinks + taslink => GetTimeArraySeriesLinkFromList(this%boundTasLinks, i) + if (associated(taslink)) then + do j = 1, size(taslink%BndArray) + taslink%BndArray(j) = DZERO + enddo + endif + enddo + ! + ! -- Delete all existing time array links + if (associated(this%boundTasLinks)) then + ! Deallocate and remove all links belonging to package + nlinks = this%boundTasLinks%Count() + do i = nlinks, 1, -1 + taslink => GetTimeArraySeriesLinkFromList(this%boundTasLinks, i) + if (associated(taslink)) then + call taslink%da() + call this%boundTasLinks%RemoveNode(i, .true.) + endif + enddo + endif + ! + return + end subroutine Reset + + subroutine MakeTasLink(this, pkgName, bndArray, iprpak, & + tasName, text, convertFlux, nodelist, inunit) +! ****************************************************************************** +! MakeTasLink -- Make link from TAS to package array +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeArraySeriesManagerType) :: this + character(len=*), intent(in) :: pkgName + real(DP), dimension(:), pointer :: bndArray + integer(I4B), intent(in) :: iprpak + character(len=*), intent(in) :: tasName + character(len=*), intent(in) :: text + logical, intent(in) :: convertFlux + integer(I4B), dimension(:), pointer, contiguous, intent(in) :: nodelist + integer(I4B), intent(in) :: inunit + ! -- local + integer(I4B) :: i, nfiles, iloc + character(LINELENGTH) :: ermsg + type(TimeArraySeriesLinkType), pointer :: newTasLink + type(TimeArraySeriesType), pointer :: tasptr => null() +! ------------------------------------------------------------------------------ + ! + ! -- Find the time array series + nfiles = size(this%tasnames) + iloc = 0 + do i = 1, nfiles + if (this%tasnames(i) == tasname) then + iloc = i + exit + endif + end do + if (iloc == 0) then + ermsg = 'Error: Time-array series "' // trim(tasName) // '" not found.' + call store_error(ermsg) + call store_error_unit(inunit) + call ustop() + endif + tasptr => this%taslist(iloc) + ! + ! -- Construct a time-array series link + newTasLink => null() + call ConstructTimeArraySeriesLink(newTasLink, tasptr, & + pkgName, bndArray, iprpak, & + text) + newTasLink%ConvertFlux = convertFlux + newTasLink%nodelist => nodelist + ! + ! -- Add link to list of links + call this%tasmgr_add_link(newTasLink) + ! + return + end subroutine MakeTasLink + + function GetLink(this, indx) result(tasLink) +! ****************************************************************************** +! GetLink -- get link from the boundtaslinks list +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeArraySeriesManagerType) :: this + integer(I4B), intent(in) :: indx + type(TimeArraySeriesLinkType), pointer :: tasLink + ! -- local +! ------------------------------------------------------------------------------ + ! + tasLink => null() + ! + if (associated(this%boundTasLinks)) then + tasLink => GetTimeArraySeriesLinkFromList(this%boundTasLinks, indx) + endif + ! + return + end function GetLink + + function CountLinks(this) +! ****************************************************************************** +! CountLinks -- count number of links in the boundtaslinks list +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + integer(I4B) :: CountLinks + ! -- dummy + class(TimeArraySeriesManagerType) :: this +! ------------------------------------------------------------------------------ + ! + if (associated(this%boundtaslinks)) then + CountLinks = this%boundTasLinks%Count() + else + CountLinks = 0 + endif + ! + return + end function CountLinks + + ! -- Private procedures + + subroutine tasmgr_convert_flux(this, tasLink) +! ****************************************************************************** +! tasmgr_convert_flux -- convert the array from a flux to a flow rate by +! multiplying by the cell area +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeArraySeriesManagerType) :: this + type(TimeArraySeriesLinkType), pointer, intent(inout) :: tasLink + ! -- local + integer(I4B) :: i, n, noder + real(DP) :: area +! ------------------------------------------------------------------------------ + ! + n = size(tasLink%BndArray) + do i=1,n + noder = tasLink%nodelist(i) + if (noder > 0) then + area = this%dis%get_area(noder) + tasLink%BndArray(i) = tasLink%BndArray(i) * area + endif + enddo + ! + return + end subroutine tasmgr_convert_flux + + subroutine tasmgr_add_link(this, tasLink) +! ****************************************************************************** +! tasmgr_add_link -- add a time arrays series link +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeArraySeriesManagerType) :: this + type(TimeArraySeriesLinkType), pointer :: tasLink + ! -- local +! ------------------------------------------------------------------------------ + ! + call AddTimeArraySeriesLinkToList(this%boundTasLinks, tasLink) + ! + return + end subroutine tasmgr_add_link + +end module TimeArraySeriesManagerModule + diff --git a/src/Utilities/TimeSeries/TimeSeries.f90 b/src/Utilities/TimeSeries/TimeSeries.f90 index 5ada64f8b59..2b11a0d15e7 100644 --- a/src/Utilities/TimeSeries/TimeSeries.f90 +++ b/src/Utilities/TimeSeries/TimeSeries.f90 @@ -1,1465 +1,1465 @@ -module TimeSeriesModule - - use KindModule, only: DP, I4B - use BlockParserModule, only: BlockParserType - use ConstantsModule, only: LINELENGTH, UNDEFINED, STEPWISE, LINEAR, & - LINEAREND, LENTIMESERIESNAME, LENHUGELINE, & - DZERO, DONE, DNODATA - use GenericUtilitiesModule, only: IS_SAME - use InputOutputModule, only: GetUnit, openfile, ParseLine, upcase - use ListModule, only: ListType, ListNodeType - use SimModule, only: count_errors, store_error, & - store_error_unit, ustop - use TimeSeriesRecordModule, only: TimeSeriesRecordType, & - ConstructTimeSeriesRecord, & - CastAsTimeSeriesRecordType, & - AddTimeSeriesRecordToList - - private - public :: TimeSeriesType, TimeSeriesFileType, ConstructTimeSeriesFile, & - TimeSeriesContainerType, AddTimeSeriesFileToList, & - GetTimeSeriesFileFromList, CastAsTimeSeriesFileClass, & - SameTimeSeries - - type TimeSeriesType - ! -- Public members - integer(I4B), public :: iMethod = UNDEFINED - character(len=LENTIMESERIESNAME), public :: Name = '' - ! -- Private members - real(DP), private :: sfac = DONE - logical, public :: autoDeallocate = .true. - type(ListType), pointer, private :: list => null() - class(TimeSeriesFileType), pointer, private :: tsfile => null() - contains - ! -- Public procedures - procedure, public :: AddTimeSeriesRecord - procedure, public :: Clear - procedure, public :: FindLatestTime - procedure, public :: get_surrounding_records - procedure, public :: get_surrounding_nodes - procedure, public :: GetCurrentTimeSeriesRecord - procedure, public :: GetNextTimeSeriesRecord - procedure, public :: GetPreviousTimeSeriesRecord - procedure, public :: GetTimeSeriesRecord - procedure, public :: GetValue - procedure, public :: InitializeTimeSeries => initialize_time_series - procedure, public :: InsertTsr - procedure, public :: Reset - ! -- Private procedures - procedure, private :: da => ts_da - procedure, private :: get_average_value - procedure, private :: get_integrated_value - procedure, private :: get_latest_preceding_node - procedure, private :: get_value_at_time - procedure, private :: initialize_time_series - procedure, private :: read_next_record - end type TimeSeriesType - - type TimeSeriesFileType - ! -- Private members - integer(I4B), public :: inunit = 0 - integer(I4B), public :: iout = 0 - integer(I4B), public :: nTimeSeries = 0 - character(len=LINELENGTH), public :: datafile = '' - type(TimeSeriesType), dimension(:), pointer, contiguous, public :: timeSeries => null() - type(BlockParserType), pointer, public :: parser - contains - ! -- Public procedures - procedure, public :: Count - procedure, public :: Initializetsfile - procedure, public :: GetTimeSeries - procedure, public :: da => tsf_da - ! -- Private procedures - procedure, private :: read_tsfile_line - end type TimeSeriesFileType - - type TimeSeriesContainerType - ! -- Public members - type(TimeSeriesType), pointer, public :: timeSeries => null() - end type TimeSeriesContainerType - -contains - - ! -- non-type-bound procedures - - subroutine ConstructTimeSeriesFile(newTimeSeriesFile) -! ****************************************************************************** -! ConstructTimeSeriesFile -- construct ts tsfile -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - type(TimeSeriesFileType), pointer, intent(inout) :: newTimeSeriesFile -! ------------------------------------------------------------------------------ - ! - allocate(newTimeSeriesFile) - allocate(newTimeSeriesFile%parser) - return - end subroutine ConstructTimeSeriesFile - - function CastAsTimeSeriesFileType(obj) result(res) -! ****************************************************************************** -! CastAsTimeSeriesFileType -- Cast an unlimited polymorphic object as -! class(TimeSeriesFileType) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(*), pointer, intent(inout) :: obj - ! -- return - type(TimeSeriesFileType), pointer :: res -! ------------------------------------------------------------------------------ - ! - res => null() - if (.not. associated(obj)) return - ! - select type (obj) - type is (TimeSeriesFileType) - res => obj - end select - return - end function CastAsTimeSeriesFileType - - function CastAsTimeSeriesFileClass(obj) result(res) -! ****************************************************************************** -! CastAsTimeSeriesFileClass -- Cast an unlimited polymorphic object as -! class(TimeSeriesFileType) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(*), pointer, intent(inout) :: obj - ! -- return - type(TimeSeriesFileType), pointer :: res -! ------------------------------------------------------------------------------ - ! - res => null() - if (.not. associated(obj)) return - ! - select type (obj) - class is (TimeSeriesFileType) - res => obj - end select - return - end function CastAsTimeSeriesFileClass - - subroutine AddTimeSeriesFileToList(list, tsfile) -! ****************************************************************************** -! AddTimeSeriesFileToList -- add to list -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - type(ListType), intent(inout) :: list - class(TimeSeriesFileType), pointer, intent(inout) :: tsfile - ! -- local - class(*), pointer :: obj -! ------------------------------------------------------------------------------ - ! - obj => tsfile - call list%Add(obj) - ! - return - end subroutine AddTimeSeriesFileToList - - function GetTimeSeriesFileFromList(list, idx) result (res) -! ****************************************************************************** -! GetTimeSeriesFileFromList -- get from list -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx - type(TimeSeriesFileType), pointer :: res - ! -- local - class(*), pointer :: obj -! ------------------------------------------------------------------------------ - ! - obj => list%GetItem(idx) - res => CastAsTimeSeriesFileType(obj) - ! - if (.not. associated(res)) then - res => CastAsTimeSeriesFileClass(obj) - endif - ! - return - end function GetTimeSeriesFileFromList - - function SameTimeSeries(ts1, ts2) result (same) -! ****************************************************************************** -! SameTimeSeries -- Compare two time series; if they are identical, return true. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - type(TimeSeriesType), intent(in) :: ts1 - type(TimeSeriesType), intent(in) :: ts2 - logical :: same - ! -- local - integer :: i, n1, n2 - type(TimeSeriesRecordType), pointer :: tsr1, tsr2 -! ------------------------------------------------------------------------------ - ! - same = .false. - n1 = ts1%list%Count() - n2 = ts2%list%Count() - if (n1 /= n2) return - ! - call ts1%Reset() - call ts2%Reset() - ! - do i=1,n1 - tsr1 => ts1%GetNextTimeSeriesRecord() - tsr2 => ts2%GetNextTimeSeriesRecord() - if (tsr1%tsrTime /= tsr2%tsrTime) return - if (tsr1%tsrValue /= tsr2%tsrValue) return - enddo - ! - same = .true. - ! - return - end function SameTimeSeries - - ! Type-bound procedures of TimeSeriesType - - function GetValue(this, time0, time1) -! ****************************************************************************** -! GetValue -- get ts value -! If iMethod is STEPWISE or LINEAR: -! Return a time-weighted average value for a specified time span. -! If iMethod is LINEAREND: -! Return value at time1. Time0 argument is ignored. -! Units: (ts-value-unit) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - real(DP) :: GetValue - ! -- dummy - class(TimeSeriesType), intent(inout) :: this - real(DP), intent(in) :: time0 - real(DP), intent(in) :: time1 -! ------------------------------------------------------------------------------ - ! - select case (this%iMethod) - case (STEPWISE, LINEAR) - GetValue = this%get_average_value(time0, time1) - case (LINEAREND) - GetValue = this%get_value_at_time(time1) - end select - ! - return - end function GetValue - - subroutine initialize_time_series(this, tsfile, name, autoDeallocate) -! ****************************************************************************** -! initialize_time_series -- initialize time series -! Open time-series file and read options and first time-series record. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesType), intent(inout) :: this - class(TimeSeriesFileType), target :: tsfile - character(len=*), intent(in) :: name - logical, intent(in), optional :: autoDeallocate - ! -- local - character(len=LINELENGTH) :: ermsg - character(len=LENTIMESERIESNAME) :: tsNameTemp -! ------------------------------------------------------------------------------ - ! - ! -- Assign the time-series tsfile, name, and autoDeallocate - this%tsfile => tsfile - ! Store time-series name as all caps - tsNameTemp = name - call UPCASE(tsNameTemp) - this%Name = tsNameTemp - ! - this%iMethod = UNDEFINED - ! - if (present(autoDeallocate)) this%autoDeallocate = autoDeallocate - ! - ! -- allocate the list - allocate(this%list) - ! - ! -- ensure that NAME has been specified - if (this%Name == '') then - ermsg = 'Error: Name not specified for time series.' - call store_error(ermsg) - call ustop() - endif - ! - return - end subroutine initialize_time_series - - subroutine get_surrounding_records(this, time, tsrecEarlier, tsrecLater) -! ****************************************************************************** -! get_surrounding_records -- get surrounding records -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesType), intent(inout) :: this - real(DP), intent(in) :: time - type(TimeSeriesRecordType), pointer, intent(inout) :: tsrecEarlier - type(TimeSeriesRecordType), pointer, intent(inout) :: tsrecLater - ! -- local - real(DP) :: time0, time1 - type(ListNodeType), pointer :: currNode => null() - type(ListNodeType), pointer :: tsNode0 => null() - type(ListNodeType), pointer :: tsNode1 => null() - type(TimeSeriesRecordType), pointer :: tsr => null(), tsrec0 => null() - type(TimeSeriesRecordType), pointer :: tsrec1 => null() - class(*), pointer :: obj => null() -! ------------------------------------------------------------------------------ - ! - tsrecEarlier => null() - tsrecLater => null() - ! - if (associated(this%list%firstNode)) then - currNode => this%list%firstNode - endif - ! - ! -- If the next node is earlier than time of interest, advance along - ! linked list until the next node is later than time of interest. - do - if (associated(currNode)) then - if (associated(currNode%nextNode)) then - obj => currNode%nextNode%GetItem() - tsr => CastAsTimeSeriesRecordType(obj) - if (tsr%tsrTime < time .and. .not. IS_SAME(tsr%tsrTime, time)) then - currNode => currNode%nextNode - else - exit - endif - else - ! -- read another record - if (.not. this%read_next_record()) exit - endif - else - exit - endif - enddo - ! - if (associated(currNode)) then - ! - ! -- find earlier record - tsNode0 => currNode - obj => tsNode0%GetItem() - tsrec0 => CastAsTimeSeriesRecordType(obj) - time0 = tsrec0%tsrTime - do while (time0 > time) - if (associated(tsNode0%prevNode)) then - tsNode0 => tsNode0%prevNode - obj => tsNode0%GetItem() - tsrec0 => CastAsTimeSeriesRecordType(obj) - time0 = tsrec0%tsrTime - else - exit - endif - enddo - ! - ! -- find later record - tsNode1 => currNode - obj => tsNode1%GetItem() - tsrec1 => CastAsTimeSeriesRecordType(obj) - time1 = tsrec1%tsrTime - do while (time1 < time .and. .not. IS_SAME(time1, time)) - if (associated(tsNode1%nextNode)) then - tsNode1 => tsNode1%nextNode - obj => tsNode1%GetItem() - tsrec1 => CastAsTimeSeriesRecordType(obj) - time1 = tsrec1%tsrTime - else - ! -- get next record - if (.not. this%read_next_record()) then - ! -- end of file reached, so exit loop - exit - endif - endif - enddo - ! - endif - ! - if (time0 < time .or. IS_SAME(time0, time)) tsrecEarlier => tsrec0 - if (time1 > time .or. IS_SAME(time1, time)) tsrecLater => tsrec1 - ! - return - end subroutine get_surrounding_records - - subroutine get_surrounding_nodes(this, time, nodeEarlier, nodeLater) -! ****************************************************************************** -! get_surrounding_nodes -- get surrounding nodes -! This subroutine is for working with time series already entirely stored -! in memory -- it does not read data from a file. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesType), intent(inout) :: this - real(DP), intent(in) :: time - type(ListNodeType), pointer, intent(inout) :: nodeEarlier - type(ListNodeType), pointer, intent(inout) :: nodeLater - ! -- local - real(DP) :: time0, time1 - type(ListNodeType), pointer :: currNode => null() - type(ListNodeType), pointer :: tsNode0 => null() - type(ListNodeType), pointer :: tsNode1 => null() - type(TimeSeriesRecordType), pointer :: tsr => null(), tsrec0 => null() - type(TimeSeriesRecordType), pointer :: tsrec1 => null() - type(TimeSeriesRecordType), pointer :: tsrecEarlier - type(TimeSeriesRecordType), pointer :: tsrecLater - class(*), pointer :: obj => null() -! ------------------------------------------------------------------------------ - ! - tsrecEarlier => null() - tsrecLater => null() - nodeEarlier => null() - nodeLater => null() - ! - if (associated(this%list%firstNode)) then - currNode => this%list%firstNode - endif - ! - ! -- If the next node is earlier than time of interest, advance along - ! linked list until the next node is later than time of interest. - do - if (associated(currNode)) then - if (associated(currNode%nextNode)) then - obj => currNode%nextNode%GetItem() - tsr => CastAsTimeSeriesRecordType(obj) - if (tsr%tsrTime < time .and. .not. IS_SAME(tsr%tsrTime, time)) then - currNode => currNode%nextNode - else - exit - endif - else - exit - endif - else - exit - endif - enddo - ! - if (associated(currNode)) then - ! - ! -- find earlier record - tsNode0 => currNode - obj => tsNode0%GetItem() - tsrec0 => CastAsTimeSeriesRecordType(obj) - time0 = tsrec0%tsrTime - do while (time0 > time) - if (associated(tsNode0%prevNode)) then - tsNode0 => tsNode0%prevNode - obj => tsNode0%GetItem() - tsrec0 => CastAsTimeSeriesRecordType(obj) - time0 = tsrec0%tsrTime - else - exit - endif - enddo - ! - ! -- find later record - tsNode1 => currNode - obj => tsNode1%GetItem() - tsrec1 => CastAsTimeSeriesRecordType(obj) - time1 = tsrec1%tsrTime - do while (time1 < time .and. .not. IS_SAME(time1, time)) - if (associated(tsNode1%nextNode)) then - tsNode1 => tsNode1%nextNode - obj => tsNode1%GetItem() - tsrec1 => CastAsTimeSeriesRecordType(obj) - time1 = tsrec1%tsrTime - else - exit - endif - enddo - ! - endif - ! - if (time0 < time .or. IS_SAME(time0, time)) then - tsrecEarlier => tsrec0 - nodeEarlier => tsNode0 - endif - if (time1 > time .or. IS_SAME(time1, time)) then - tsrecLater => tsrec1 - nodeLater => tsNode1 - endif - ! - return - end subroutine get_surrounding_nodes - - logical function read_next_record(this) -! ****************************************************************************** -! read_next_record -- read next record -! Read next time-series record from input file. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesType), intent(inout) :: this - ! -- local -! ------------------------------------------------------------------------------ - ! - read_next_record = this%tsfile%read_tsfile_line() - return - ! - end function read_next_record - - function get_value_at_time(this, time) -! ****************************************************************************** -! get_value_at_time -- get value for a time -! Return a value for a specified time, same units as time-series values. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - real(DP) :: get_value_at_time - ! -- dummy - class(TimeSeriesType), intent(inout) :: this - real(DP), intent(in) :: time ! time of interest - ! -- local - integer(I4B) :: ierr - real(DP) :: ratio, time0, time1, timediff, timediffi, val0, val1, & - valdiff - character(len=LINELENGTH) :: errmsg - type(TimeSeriesRecordType), pointer :: tsrEarlier => null() - type(TimeSeriesRecordType), pointer :: tsrLater => null() - ! -- formats - 10 format('Error getting value at time ',g10.3,' for time series "',a,'"') -! ------------------------------------------------------------------------------ - ! - ierr = 0 - call this%get_surrounding_records(time,tsrEarlier,tsrLater) - if (associated(tsrEarlier)) then - if (associated(tsrLater)) then - ! -- values are available for both earlier and later times - if (this%iMethod == STEPWISE) then - get_value_at_time = tsrEarlier%tsrValue - elseif (this%iMethod == LINEAR .or. this%iMethod == LINEAREND) then - ! -- For get_value_at_time, result is the same for either - ! linear method. - ! -- Perform linear interpolation. - time0 = tsrEarlier%tsrTime - time1 = tsrLater%tsrtime - timediff = time1 - time0 - timediffi = time - time0 - if (timediff>0) then - ratio = timediffi/timediff - else - ! -- should not happen if TS does not contain duplicate times - ratio = 0.5d0 - endif - val0 = tsrEarlier%tsrValue - val1 = tsrLater%tsrValue - valdiff = val1 - val0 - get_value_at_time = val0 + (ratio*valdiff) - else - ierr = 1 - endif - else - if (IS_SAME(tsrEarlier%tsrTime, time)) then - get_value_at_time = tsrEarlier%tsrValue - else - ! -- Only earlier time is available, and it is not time of interest; - ! however, if method is STEPWISE, use value for earlier time. - if (this%iMethod == STEPWISE) then - get_value_at_time = tsrEarlier%tsrValue - else - ierr = 1 - endif - endif - endif - else - if (associated(tsrLater)) then - if (IS_SAME(tsrLater%tsrTime, time)) then - get_value_at_time = tsrLater%tsrValue - else - ! -- only later time is available, and it is not time of interest - ierr = 1 - endif - else - ! -- Neither earlier nor later time is available. - ! This should never happen! - ierr = 1 - endif - endif - ! - if (ierr > 0) then - write(errmsg,10)time,trim(this%Name) - call store_error(errmsg) - call ustop() - endif - ! - return - end function get_value_at_time - - function get_integrated_value(this, time0, time1) -! ****************************************************************************** -! get_integrated_value -- get integrated value -! Return an integrated value for a specified time span. -! Units: (ts-value-unit)*time -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - real(DP) :: get_integrated_value - ! -- dummy - class(TimeSeriesType), intent(inout) :: this - real(DP), intent(in) :: time0 - real(DP), intent(in) :: time1 - ! -- local - real(DP) :: area, currTime, nextTime, ratio0, ratio1, t0, t01, t1, & - timediff, value, value0, value1, valuediff - logical :: ldone - character(len=LINELENGTH) :: errmsg - type(ListNodeType), pointer :: tslNodePreceding => null() - type(ListNodeType), pointer :: currNode => null(), nextNode => null() - type(TimeSeriesRecordType), pointer :: currRecord => null() - type(TimeSeriesRecordType), pointer :: nextRecord => null() - class(*), pointer :: currObj => null(), nextObj => null() - ! -- formats - 10 format('Error encountered while performing integration', & - ' for time series "',a,'" for time interval: ',g12.5,' to ',g12.5) -! ------------------------------------------------------------------------------ - ! - value = DZERO - ldone = .false. - t1 = -DONE - call this%get_latest_preceding_node(time0, tslNodePreceding) - if (associated(tslNodePreceding)) then - currNode => tslNodePreceding - do while (.not. ldone) - currObj => currNode%GetItem() - currRecord => CastAsTimeSeriesRecordType(currObj) - currTime = currRecord%tsrTime - if (IS_SAME(currTime, time1)) then - ! Current node time = time1 so should be ldone - ldone = .true. - elseif (currTime < time1) then - if (.not. associated(currNode%nextNode)) then - ! -- try to read the next record - if (.not. this%read_next_record()) then - write(errmsg,10)trim(this%Name),time0,time1 - call store_error(errmsg) - call ustop() - endif - endif - if (associated(currNode%nextNode)) then - nextNode => currNode%nextNode - nextObj => nextNode%GetItem() - nextRecord => CastAsTimeSeriesRecordType(nextObj) - nextTime = nextRecord%tsrTime - ! -- determine lower and upper limits of time span of interest - ! within current interval - if (currTime > time0 .or. IS_SAME(currTime, time0)) then - t0 = currTime - else - t0 = time0 - endif - if (nextTime < time1 .or. IS_SAME(nextTime, time1)) then - t1 = nextTime - else - t1 = time1 - endif - ! -- find area of rectangle or trapezoid delimited by t0 and t1 - t01 = t1 - t0 - select case (this%iMethod) - case (STEPWISE) - ! -- compute area of a rectangle - value0 = currRecord%tsrValue - area = value0 * t01 - case (LINEAR, LINEAREND) - ! -- compute area of a trapezoid - timediff = nextTime - currTime - ratio0 = (t0 - currTime) / timediff - ratio1 = (t1 - currTime) / timediff - valuediff = nextRecord%tsrValue - currRecord%tsrValue - value0 = currRecord%tsrValue + ratio0 * valuediff - value1 = currRecord%tsrValue + ratio1 * valuediff - if (this%iMethod == LINEAR) then - area = 0.5d0 * t01 * (value0 + value1) - elseif (this%iMethod == LINEAREND) then - area = DZERO - value = value1 - endif - end select - ! -- add area to integrated value - value = value + area - endif - endif - ! - ! -- Are we done yet? - if (t1 > time1) then - ldone = .true. - elseif (IS_SAME(t1, time1)) then - ldone = .true. - else - ! -- We are not done yet - if (.not. associated(currNode%nextNode)) then - ! -- Not done and no more data, so try to read the next record - if (.not. this%read_next_record()) then - write(errmsg,10)trim(this%Name),time0,time1 - call store_error(errmsg) - call ustop() - endif - elseif (associated(currNode%nextNode)) then - currNode => currNode%nextNode - endif - endif - enddo - endif - ! - get_integrated_value = value - if (this%autoDeallocate) then - if (associated(tslNodePreceding)) then - if (associated(tslNodePreceding%prevNode))then - call this%list%DeallocateBackward(tslNodePreceding%prevNode) - endif - endif - endif - return - end function get_integrated_value - - function get_average_value(this, time0, time1) -! ****************************************************************************** -! get_average_value -- get average value -! Return a time-weighted average value for a specified time span. -! Units: (ts-value-unit) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - real(DP) :: get_average_value - ! -- dummy - class(TimeSeriesType), intent(inout) :: this - real(DP), intent(in) :: time0 - real(DP), intent(in) :: time1 - ! -- local - real(DP) :: timediff, value, valueIntegrated -! ------------------------------------------------------------------------------ - ! - timediff = time1 - time0 - if (timediff > 0) then - valueIntegrated = this%get_integrated_value(time0, time1) - if (this%iMethod == LINEAREND) then - value = valueIntegrated - else - value = valueIntegrated / timediff - endif - else - ! -- time0 and time1 are the same - value = this%get_value_at_time(time0) - endif - get_average_value = value - ! - return - end function get_average_value - - subroutine get_latest_preceding_node(this, time, tslNode) -! ****************************************************************************** -! get_latest_preceding_node -- get latest prececing node -! Return pointer to ListNodeType object for the node -! representing the latest preceding time in the time series -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesType), intent(inout) :: this - real(DP), intent(in) :: time - type(ListNodeType), pointer, intent(inout) :: tslNode - ! -- local - real(DP) :: time0 - type(ListNodeType), pointer :: currNode => null() - type(ListNodeType), pointer :: tsNode0 => null() - type(TimeSeriesRecordType), pointer :: tsr => null() - type(TimeSeriesRecordType), pointer :: tsrec0 => null() - class(*), pointer :: obj => null() -! ------------------------------------------------------------------------------ - ! - tslNode => null() - if (associated(this%list%firstNode)) then - currNode => this%list%firstNode - else - call store_error('probable programming error in get_latest_preceding_node') - call ustop() - endif - ! - ! -- If the next node is earlier than time of interest, advance along - ! linked list until the next node is later than time of interest. - do - if (associated(currNode)) then - if (associated(currNode%nextNode)) then - obj => currNode%nextNode%GetItem() - tsr => CastAsTimeSeriesRecordType(obj) - if (tsr%tsrTime < time .or. IS_SAME(tsr%tsrTime, time)) then - currNode => currNode%nextNode - else - exit - endif - else - ! -- read another record - if (.not. this%read_next_record()) exit - endif - else - exit - endif - enddo - ! - if (associated(currNode)) then - ! - ! -- find earlier record - tsNode0 => currNode - obj => tsNode0%GetItem() - tsrec0 => CastAsTimeSeriesRecordType(obj) - time0 = tsrec0%tsrTime - do while (time0 > time) - if (associated(tsNode0%prevNode)) then - tsNode0 => tsNode0%prevNode - obj => tsNode0%GetItem() - tsrec0 => CastAsTimeSeriesRecordType(obj) - time0 = tsrec0%tsrTime - else - exit - endif - enddo - endif - ! - if (time0 < time .or. IS_SAME(time0, time)) tslNode => tsNode0 - ! - return - end subroutine get_latest_preceding_node - - subroutine ts_da(this) -! ****************************************************************************** -! ts_da -- deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesType), intent(inout) :: this -! ------------------------------------------------------------------------------ - ! - if (associated(this%list)) then - call this%list%Clear(.true.) - deallocate(this%list) - endif - ! - return - end subroutine ts_da - - subroutine AddTimeSeriesRecord(this, tsr) -! ****************************************************************************** -! AddTimeSeriesRecord -- add ts record -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesType) :: this - type(TimeSeriesRecordType), pointer, intent(inout) :: tsr - ! -- local - class(*), pointer :: obj -! ------------------------------------------------------------------------------ - ! - obj => tsr - call this%list%Add(obj) - ! - return - end subroutine AddTimeSeriesRecord - - function GetCurrentTimeSeriesRecord(this) result (res) -! ****************************************************************************** -! GetCurrentTimeSeriesRecord -- get current ts record -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesType) :: this - ! result - type(TimeSeriesRecordType), pointer :: res - ! -- local - class(*), pointer :: obj -! ------------------------------------------------------------------------------ - ! - obj => null() - res => null() - obj => this%list%GetItem() - if (associated(obj)) then - res => CastAsTimeSeriesRecordType(obj) - endif - ! - return - end function GetCurrentTimeSeriesRecord - - function GetPreviousTimeSeriesRecord(this) result (res) -! ****************************************************************************** -! GetPreviousTimeSeriesRecord -- get previous ts record -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesType) :: this - ! result - type(TimeSeriesRecordType), pointer :: res - ! -- local - class(*), pointer :: obj -! ------------------------------------------------------------------------------ - ! - obj => null() - res => null() - obj => this%list%GetPreviousItem() - if (associated(obj)) then - res => CastAsTimeSeriesRecordType(obj) - endif - ! - return - end function GetPreviousTimeSeriesRecord - - function GetNextTimeSeriesRecord(this) result (res) -! ****************************************************************************** -! GetNextTimeSeriesRecord -- get next ts record -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesType) :: this - ! result - type(TimeSeriesRecordType), pointer :: res - ! -- local - class(*), pointer :: obj -! ------------------------------------------------------------------------------ - ! - obj => null() - res => null() - obj => this%list%GetNextItem() - if (associated(obj)) then - res => CastAsTimeSeriesRecordType(obj) - endif - ! - return - end function GetNextTimeSeriesRecord - - function GetTimeSeriesRecord(this, time, epsi) result (res) -! ****************************************************************************** -! GetTimeSeriesRecord -- get ts record -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesType) :: this - double precision, intent(in) :: time - double precision, intent(in) :: epsi - ! result - type(TimeSeriesRecordType), pointer :: res - ! -- local - type(TimeSeriesRecordType), pointer :: tsr -! ------------------------------------------------------------------------------ - ! - call this%list%Reset() - res => null() - do - tsr => this%GetNextTimeSeriesRecord() - if (associated(tsr)) then - if (IS_SAME(tsr%tsrTime, time)) then - res => tsr - exit - endif - if (tsr%tsrTime > time) exit - else - exit - endif - enddo - ! - return - end function GetTimeSeriesRecord - - subroutine Reset(this) -! ****************************************************************************** -! Reset -- reset -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesType) :: this -! ------------------------------------------------------------------------------ - ! - call this%list%Reset() - ! - return - end subroutine Reset - - subroutine InsertTsr(this, tsr) -! ****************************************************************************** -! InsertTsr -- insert ts record -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesType), intent(inout) :: this - type(TimeSeriesRecordType), pointer, intent(inout) :: tsr - ! -- local - double precision :: badtime, time, time0, time1 - type(TimeSeriesRecordType), pointer :: tsrEarlier, tsrLater - type(ListNodeType), pointer :: nodeEarlier, nodeLater - class(*), pointer :: obj -! ------------------------------------------------------------------------------ - ! - badtime = -9.0d30 - time0 = badtime - time1 = badtime - time = tsr%tsrTime - call this%get_surrounding_nodes(time, nodeEarlier, nodeLater) - ! - if (associated(nodeEarlier)) then - obj => nodeEarlier%GetItem() - tsrEarlier => CastAsTimeSeriesRecordType(obj) - if (associated(tsrEarlier)) then - time0 = tsrEarlier%tsrTime - endif - endif - ! - if (associated(nodeLater)) then - obj => nodeLater%GetItem() - tsrLater => CastAsTimeSeriesRecordType(obj) - if (associated(tsrLater)) then - time1 = tsrLater%tsrTime - endif - endif - ! - if (time0 > badtime) then - ! Time0 is valid - if (time1 > badtime) then - ! Both time0 and time1 are valid - if (time > time0 .and. time < time1) then - ! Insert record between two list nodes - obj => tsr - call this%list%InsertBefore(obj, nodeLater) - else - ! No need to insert a time series record, but if existing record - ! for time of interest has NODATA as tsrValue, replace tsrValue - if (time == time0 .and. tsrEarlier%tsrValue == DNODATA .and. & - tsr%tsrValue /= DNODATA) then - tsrEarlier%tsrValue = tsr%tsrValue - elseif (time == time1 .and. tsrLater%tsrValue == DNODATA .and. & - tsr%tsrValue /= DNODATA) then - tsrLater%tsrValue = tsr%tsrValue - endif - endif - else - ! Time0 is valid and time1 is invalid. Just add tsr to the list. - call this%AddTimeSeriesRecord(tsr) - endif - else - ! Time0 is invalid, so time1 must be for first node in list - if (time1 > badtime) then - ! Time 1 is valid - if (time < time1) then - ! Insert tsr at beginning of list - obj => tsr - call this%list%InsertBefore(obj, nodeLater) - elseif (time == time1) then - ! No need to insert a time series record, but if existing record - ! for time of interest has NODATA as tsrValue, replace tsrValue - if (tsrLater%tsrValue == DNODATA .and. tsr%tsrValue /= DNODATA) then - tsrLater%tsrValue = tsr%tsrValue - endif - endif - else - ! Both time0 and time1 are invalid. Just add tsr to the list. - call this%AddTimeSeriesRecord(tsr) - endif - endif - ! - return - end subroutine InsertTsr - - function FindLatestTime(this) result (endtime) -! ****************************************************************************** -! FindLatestTime -- find latest time -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesType), intent(inout) :: this - ! -- local - integer :: nrecords - double precision :: endtime - type(TimeSeriesRecordType), pointer :: tsr - class(*), pointer :: obj -! ------------------------------------------------------------------------------ - ! - nrecords = this%list%Count() - obj => this%list%GetItem(nrecords) - tsr => CastAsTimeSeriesRecordType(obj) - endtime = tsr%tsrTime - ! - return - end function FindLatestTime - - subroutine Clear(this, destroy) -! ****************************************************************************** -! Clear -- Clear the list of time series records -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesType), intent(inout) :: this - logical, optional, intent(in) :: destroy -! ------------------------------------------------------------------------------ - ! - call this%list%Clear(destroy) - ! - return - end subroutine Clear - -! Type-bound procedures of TimeSeriesFileType - - function Count(this) -! ****************************************************************************** -! Count --count number of time series -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - integer(I4B) :: Count - ! -- dummy - class(TimeSeriesFileType) :: this -! ------------------------------------------------------------------------------ - ! - if (associated(this%timeSeries)) then - Count = size(this%timeSeries) - else - Count = 0 - endif - return - end function Count - - function GetTimeSeries(this, indx) result (res) -! ****************************************************************************** -! GetTimeSeries -- get ts -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesFileType) :: this - integer(I4B), intent(in) :: indx - ! result - type(TimeSeriesType), pointer :: res -! ------------------------------------------------------------------------------ - ! - res => null() - if (indx > 0 .and. indx <= this%nTimeSeries) then - res => this%timeSeries(indx) - endif - return - end function GetTimeSeries - - subroutine Initializetsfile(this, filename, iout, autoDeallocate) -! ****************************************************************************** -! Initializetsfile -- Open time-series tsfile file and read options and first -! record, which may contain data to define multiple time series. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesFileType), target, intent(inout) :: this - character(len=*), intent(in) :: filename - integer(I4B), intent(in) :: iout - logical, optional, intent(in) :: autoDeallocate - ! -- local - integer(I4B) :: iMethod, istatus, j, nwords - integer(I4B) :: ierr, inunit - logical :: autoDeallocateLocal = .true. - logical :: continueread, found, endOfBlock - real(DP) :: sfaclocal - character(len=40) :: keyword, keyvalue - character(len=LINELENGTH) :: ermsg - character(len=LENHUGELINE) :: line - character(len=LENTIMESERIESNAME), allocatable, dimension(:) :: words -! ------------------------------------------------------------------------------ - ! - ! -- Initialize some variables - if (present(autoDeallocate)) autoDeallocateLocal = autoDeallocate - iMethod = UNDEFINED - ! - ! -- Assign members - this%iout = iout - this%datafile = filename - ! - ! -- Open the time-series tsfile input file - this%inunit = GetUnit() - inunit = this%inunit - call openfile(inunit,0,filename,'TS6') - ! - ! -- Initialize block parser - call this%parser%Initialize(this%inunit, this%iout) - ! - ! -- Read the ATTRIBUTES block and count time series - continueread = .false. - ierr = 0 - ! - ! -- get BEGIN line of ATTRIBUTES block - call this%parser%GetBlock('ATTRIBUTES', found, ierr, & - supportOpenClose=.true.) - if (ierr /= 0) then - ! end of file - ermsg = 'End-of-file encountered while searching for' // & - ' ATTRIBUTES in time-series ' // & - 'input file "' // trim(this%datafile) // '"' - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - elseif (.not. found) then - ermsg = 'ATTRIBUTES block not found in time-series ' // & - 'tsfile input file "' // trim(this%datafile) // '"' - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - ! -- parse ATTRIBUTES entries - do - ! -- read a line from input - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - ! - ! -- get the keyword - call this%parser%GetStringCaps(keyword) - ! - ! support either NAME or NAMES as equivalent keywords - if (keyword=='NAMES') keyword = 'NAME' - ! - if (keyword /= 'NAME' .and. keyword /= 'METHODS' .and. keyword /= 'SFACS') then - ! -- get the word following the keyword (the key value) - call this%parser%GetStringCaps(keyvalue) - endif - ! - select case (keyword) - case ('NAME') -! line = line(istart:linelen) - call this%parser%GetRemainingLine(line) - call ParseLine(line, nwords, words, this%parser%iuactive) - this%nTimeSeries = nwords - ! -- Allocate the timeSeries array and initialize each - ! time series. - allocate(this%timeSeries(this%nTimeSeries)) - do j=1,this%nTimeSeries - call this%timeSeries(j)%initialize_time_series(this, words(j), & - autoDeallocateLocal) - enddo - case ('METHOD') - if (this%nTimeSeries == 0) then - ermsg = 'Error: NAME attribute not provided before METHOD in file: ' & - // trim(filename) - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - select case (keyvalue) - case ('STEPWISE') - iMethod = STEPWISE - case ('LINEAR') - iMethod = LINEAR - case ('LINEAREND') - iMethod = LINEAREND - case default - ermsg = 'Unknown interpolation method: "' // trim(keyvalue) // '"' - call store_error(ermsg) - end select - do j=1,this%nTimeSeries - this%timeSeries(j)%iMethod = iMethod - enddo - case ('METHODS') - if (this%nTimeSeries == 0) then - ermsg = 'Error: NAME attribute not provided before METHODS in file: ' & - // trim(filename) - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - call this%parser%GetRemainingLine(line) - call ParseLine(line, nwords, words, this%parser%iuactive) - if (nwords < this%nTimeSeries) then - ermsg = 'Error: METHODS attribute does not list a method for' // & - ' all time series.' - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - do j=1,this%nTimeSeries - call upcase(words(j)) - select case (words(j)) - case ('STEPWISE') - iMethod = STEPWISE - case ('LINEAR') - iMethod = LINEAR - case ('LINEAREND') - iMethod = LINEAREND - case default - ermsg = 'Unknown interpolation method: "' // trim(words(j)) // '"' - call store_error(ermsg) - end select - this%timeSeries(j)%iMethod = iMethod - enddo - case ('SFAC') - if (this%nTimeSeries == 0) then - ermsg = 'Error: NAME attribute not provided before SFAC in file: ' & - // trim(filename) - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - read(keyvalue,*,iostat=istatus)sfaclocal - if (istatus /= 0) then - ermsg = 'Error reading numeric value from: "' // trim(keyvalue) // '"' - call store_error(ermsg) - endif - do j=1,this%nTimeSeries - this%timeSeries(j)%sfac = sfaclocal - enddo - case ('SFACS') - if (this%nTimeSeries == 0) then - ermsg = 'Error: NAME attribute not provided before SFACS in file: ' & - // trim(filename) - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - endif - do j=1,this%nTimeSeries - sfaclocal = this%parser%GetDouble() - this%timeSeries(j)%sfac = sfaclocal - enddo - case ('AUTODEALLOCATE') - do j=1,this%nTimeSeries - this%timeSeries(j)%autoDeallocate = (keyvalue == 'TRUE') - enddo - case default - ermsg = 'Unknown option found in ATTRIBUTES block: "' // & - trim(keyword) // '"' - call store_error(ermsg) - call this%parser%StoreErrorUnit() - call ustop() - end select - enddo - ! - ! -- Get TIMESERIES block - call this%parser%GetBlock('TIMESERIES', found, ierr, & - supportOpenClose=.true.) - ! - ! -- Read the first line of time-series data - if (.not. this%read_tsfile_line()) then - ermsg = 'Error: No time-series data contained in file: ' // & - trim(this%datafile) - call store_error(ermsg) - endif - ! - ! -- Clean up and return - if (allocated(words)) deallocate(words) - ! - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - call ustop() - endif - ! - return - end subroutine Initializetsfile - - logical function read_tsfile_line(this) -! ****************************************************************************** -! read_tsfile_line -- read tsfile line -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesFileType), intent(inout) :: this - ! -- local - real(DP) :: tsrTime, tsrValue - integer(I4B) :: i - logical :: eof, endOfBlock - type(TimeSeriesRecordType), pointer :: tsRecord => null() -! ------------------------------------------------------------------------------ - ! - eof = .false. - read_tsfile_line = .false. - ! - ! -- Get an arbitrary length, non-comment, non-blank line - ! from the input file. - call this%parser%GetNextLine(endOfBlock) - ! - ! -- Get the time - tsrTime = this%parser%GetDouble() - ! - ! -- Construct a new record and append a new node to each time series - tsloop: do i=1,this%nTimeSeries - tsrValue = this%parser%GetDouble() - if (tsrValue == DNODATA) cycle tsloop - ! -- multiply value by sfac - tsrValue = tsrValue * this%timeSeries(i)%sfac - call ConstructTimeSeriesRecord(tsRecord, tsrTime, tsrValue) - call AddTimeSeriesRecordToList(this%timeSeries(i)%list, tsRecord) - enddo tsloop - read_tsfile_line = .true. - ! - return - end function read_tsfile_line - - subroutine tsf_da(this) -! ****************************************************************************** -! tsf_da -- deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesFileType), intent(inout) :: this - ! -- local - integer :: i, n - type(TimeSeriesType), pointer :: ts => null() -! ------------------------------------------------------------------------------ - ! - n = this%Count() - do i=1,n - ts => this%GetTimeSeries(i) - if (associated(ts)) then - call ts%da() -! deallocate(ts) - endif - enddo - ! - deallocate(this%timeSeries) - deallocate(this%parser) - ! - return - end subroutine tsf_da - -end module TimeSeriesModule +module TimeSeriesModule + + use KindModule, only: DP, I4B + use BlockParserModule, only: BlockParserType + use ConstantsModule, only: LINELENGTH, UNDEFINED, STEPWISE, LINEAR, & + LINEAREND, LENTIMESERIESNAME, LENHUGELINE, & + DZERO, DONE, DNODATA + use GenericUtilitiesModule, only: IS_SAME + use InputOutputModule, only: GetUnit, openfile, ParseLine, upcase + use ListModule, only: ListType, ListNodeType + use SimModule, only: count_errors, store_error, & + store_error_unit, ustop + use TimeSeriesRecordModule, only: TimeSeriesRecordType, & + ConstructTimeSeriesRecord, & + CastAsTimeSeriesRecordType, & + AddTimeSeriesRecordToList + + private + public :: TimeSeriesType, TimeSeriesFileType, ConstructTimeSeriesFile, & + TimeSeriesContainerType, AddTimeSeriesFileToList, & + GetTimeSeriesFileFromList, CastAsTimeSeriesFileClass, & + SameTimeSeries + + type TimeSeriesType + ! -- Public members + integer(I4B), public :: iMethod = UNDEFINED + character(len=LENTIMESERIESNAME), public :: Name = '' + ! -- Private members + real(DP), private :: sfac = DONE + logical, public :: autoDeallocate = .true. + type(ListType), pointer, private :: list => null() + class(TimeSeriesFileType), pointer, private :: tsfile => null() + contains + ! -- Public procedures + procedure, public :: AddTimeSeriesRecord + procedure, public :: Clear + procedure, public :: FindLatestTime + procedure, public :: get_surrounding_records + procedure, public :: get_surrounding_nodes + procedure, public :: GetCurrentTimeSeriesRecord + procedure, public :: GetNextTimeSeriesRecord + procedure, public :: GetPreviousTimeSeriesRecord + procedure, public :: GetTimeSeriesRecord + procedure, public :: GetValue + procedure, public :: InitializeTimeSeries => initialize_time_series + procedure, public :: InsertTsr + procedure, public :: Reset + ! -- Private procedures + procedure, private :: da => ts_da + procedure, private :: get_average_value + procedure, private :: get_integrated_value + procedure, private :: get_latest_preceding_node + procedure, private :: get_value_at_time + procedure, private :: initialize_time_series + procedure, private :: read_next_record + end type TimeSeriesType + + type TimeSeriesFileType + ! -- Private members + integer(I4B), public :: inunit = 0 + integer(I4B), public :: iout = 0 + integer(I4B), public :: nTimeSeries = 0 + character(len=LINELENGTH), public :: datafile = '' + type(TimeSeriesType), dimension(:), pointer, contiguous, public :: timeSeries => null() + type(BlockParserType), pointer, public :: parser + contains + ! -- Public procedures + procedure, public :: Count + procedure, public :: Initializetsfile + procedure, public :: GetTimeSeries + procedure, public :: da => tsf_da + ! -- Private procedures + procedure, private :: read_tsfile_line + end type TimeSeriesFileType + + type TimeSeriesContainerType + ! -- Public members + type(TimeSeriesType), pointer, public :: timeSeries => null() + end type TimeSeriesContainerType + +contains + + ! -- non-type-bound procedures + + subroutine ConstructTimeSeriesFile(newTimeSeriesFile) +! ****************************************************************************** +! ConstructTimeSeriesFile -- construct ts tsfile +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + type(TimeSeriesFileType), pointer, intent(inout) :: newTimeSeriesFile +! ------------------------------------------------------------------------------ + ! + allocate(newTimeSeriesFile) + allocate(newTimeSeriesFile%parser) + return + end subroutine ConstructTimeSeriesFile + + function CastAsTimeSeriesFileType(obj) result(res) +! ****************************************************************************** +! CastAsTimeSeriesFileType -- Cast an unlimited polymorphic object as +! class(TimeSeriesFileType) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(*), pointer, intent(inout) :: obj + ! -- return + type(TimeSeriesFileType), pointer :: res +! ------------------------------------------------------------------------------ + ! + res => null() + if (.not. associated(obj)) return + ! + select type (obj) + type is (TimeSeriesFileType) + res => obj + end select + return + end function CastAsTimeSeriesFileType + + function CastAsTimeSeriesFileClass(obj) result(res) +! ****************************************************************************** +! CastAsTimeSeriesFileClass -- Cast an unlimited polymorphic object as +! class(TimeSeriesFileType) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(*), pointer, intent(inout) :: obj + ! -- return + type(TimeSeriesFileType), pointer :: res +! ------------------------------------------------------------------------------ + ! + res => null() + if (.not. associated(obj)) return + ! + select type (obj) + class is (TimeSeriesFileType) + res => obj + end select + return + end function CastAsTimeSeriesFileClass + + subroutine AddTimeSeriesFileToList(list, tsfile) +! ****************************************************************************** +! AddTimeSeriesFileToList -- add to list +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + type(ListType), intent(inout) :: list + class(TimeSeriesFileType), pointer, intent(inout) :: tsfile + ! -- local + class(*), pointer :: obj +! ------------------------------------------------------------------------------ + ! + obj => tsfile + call list%Add(obj) + ! + return + end subroutine AddTimeSeriesFileToList + + function GetTimeSeriesFileFromList(list, idx) result (res) +! ****************************************************************************** +! GetTimeSeriesFileFromList -- get from list +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + type(ListType), intent(inout) :: list + integer(I4B), intent(in) :: idx + type(TimeSeriesFileType), pointer :: res + ! -- local + class(*), pointer :: obj +! ------------------------------------------------------------------------------ + ! + obj => list%GetItem(idx) + res => CastAsTimeSeriesFileType(obj) + ! + if (.not. associated(res)) then + res => CastAsTimeSeriesFileClass(obj) + endif + ! + return + end function GetTimeSeriesFileFromList + + function SameTimeSeries(ts1, ts2) result (same) +! ****************************************************************************** +! SameTimeSeries -- Compare two time series; if they are identical, return true. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + type(TimeSeriesType), intent(in) :: ts1 + type(TimeSeriesType), intent(in) :: ts2 + logical :: same + ! -- local + integer :: i, n1, n2 + type(TimeSeriesRecordType), pointer :: tsr1, tsr2 +! ------------------------------------------------------------------------------ + ! + same = .false. + n1 = ts1%list%Count() + n2 = ts2%list%Count() + if (n1 /= n2) return + ! + call ts1%Reset() + call ts2%Reset() + ! + do i=1,n1 + tsr1 => ts1%GetNextTimeSeriesRecord() + tsr2 => ts2%GetNextTimeSeriesRecord() + if (tsr1%tsrTime /= tsr2%tsrTime) return + if (tsr1%tsrValue /= tsr2%tsrValue) return + enddo + ! + same = .true. + ! + return + end function SameTimeSeries + + ! Type-bound procedures of TimeSeriesType + + function GetValue(this, time0, time1) +! ****************************************************************************** +! GetValue -- get ts value +! If iMethod is STEPWISE or LINEAR: +! Return a time-weighted average value for a specified time span. +! If iMethod is LINEAREND: +! Return value at time1. Time0 argument is ignored. +! Units: (ts-value-unit) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + real(DP) :: GetValue + ! -- dummy + class(TimeSeriesType), intent(inout) :: this + real(DP), intent(in) :: time0 + real(DP), intent(in) :: time1 +! ------------------------------------------------------------------------------ + ! + select case (this%iMethod) + case (STEPWISE, LINEAR) + GetValue = this%get_average_value(time0, time1) + case (LINEAREND) + GetValue = this%get_value_at_time(time1) + end select + ! + return + end function GetValue + + subroutine initialize_time_series(this, tsfile, name, autoDeallocate) +! ****************************************************************************** +! initialize_time_series -- initialize time series +! Open time-series file and read options and first time-series record. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesType), intent(inout) :: this + class(TimeSeriesFileType), target :: tsfile + character(len=*), intent(in) :: name + logical, intent(in), optional :: autoDeallocate + ! -- local + character(len=LINELENGTH) :: ermsg + character(len=LENTIMESERIESNAME) :: tsNameTemp +! ------------------------------------------------------------------------------ + ! + ! -- Assign the time-series tsfile, name, and autoDeallocate + this%tsfile => tsfile + ! Store time-series name as all caps + tsNameTemp = name + call UPCASE(tsNameTemp) + this%Name = tsNameTemp + ! + this%iMethod = UNDEFINED + ! + if (present(autoDeallocate)) this%autoDeallocate = autoDeallocate + ! + ! -- allocate the list + allocate(this%list) + ! + ! -- ensure that NAME has been specified + if (this%Name == '') then + ermsg = 'Error: Name not specified for time series.' + call store_error(ermsg) + call ustop() + endif + ! + return + end subroutine initialize_time_series + + subroutine get_surrounding_records(this, time, tsrecEarlier, tsrecLater) +! ****************************************************************************** +! get_surrounding_records -- get surrounding records +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesType), intent(inout) :: this + real(DP), intent(in) :: time + type(TimeSeriesRecordType), pointer, intent(inout) :: tsrecEarlier + type(TimeSeriesRecordType), pointer, intent(inout) :: tsrecLater + ! -- local + real(DP) :: time0, time1 + type(ListNodeType), pointer :: currNode => null() + type(ListNodeType), pointer :: tsNode0 => null() + type(ListNodeType), pointer :: tsNode1 => null() + type(TimeSeriesRecordType), pointer :: tsr => null(), tsrec0 => null() + type(TimeSeriesRecordType), pointer :: tsrec1 => null() + class(*), pointer :: obj => null() +! ------------------------------------------------------------------------------ + ! + tsrecEarlier => null() + tsrecLater => null() + ! + if (associated(this%list%firstNode)) then + currNode => this%list%firstNode + endif + ! + ! -- If the next node is earlier than time of interest, advance along + ! linked list until the next node is later than time of interest. + do + if (associated(currNode)) then + if (associated(currNode%nextNode)) then + obj => currNode%nextNode%GetItem() + tsr => CastAsTimeSeriesRecordType(obj) + if (tsr%tsrTime < time .and. .not. IS_SAME(tsr%tsrTime, time)) then + currNode => currNode%nextNode + else + exit + endif + else + ! -- read another record + if (.not. this%read_next_record()) exit + endif + else + exit + endif + enddo + ! + if (associated(currNode)) then + ! + ! -- find earlier record + tsNode0 => currNode + obj => tsNode0%GetItem() + tsrec0 => CastAsTimeSeriesRecordType(obj) + time0 = tsrec0%tsrTime + do while (time0 > time) + if (associated(tsNode0%prevNode)) then + tsNode0 => tsNode0%prevNode + obj => tsNode0%GetItem() + tsrec0 => CastAsTimeSeriesRecordType(obj) + time0 = tsrec0%tsrTime + else + exit + endif + enddo + ! + ! -- find later record + tsNode1 => currNode + obj => tsNode1%GetItem() + tsrec1 => CastAsTimeSeriesRecordType(obj) + time1 = tsrec1%tsrTime + do while (time1 < time .and. .not. IS_SAME(time1, time)) + if (associated(tsNode1%nextNode)) then + tsNode1 => tsNode1%nextNode + obj => tsNode1%GetItem() + tsrec1 => CastAsTimeSeriesRecordType(obj) + time1 = tsrec1%tsrTime + else + ! -- get next record + if (.not. this%read_next_record()) then + ! -- end of file reached, so exit loop + exit + endif + endif + enddo + ! + endif + ! + if (time0 < time .or. IS_SAME(time0, time)) tsrecEarlier => tsrec0 + if (time1 > time .or. IS_SAME(time1, time)) tsrecLater => tsrec1 + ! + return + end subroutine get_surrounding_records + + subroutine get_surrounding_nodes(this, time, nodeEarlier, nodeLater) +! ****************************************************************************** +! get_surrounding_nodes -- get surrounding nodes +! This subroutine is for working with time series already entirely stored +! in memory -- it does not read data from a file. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesType), intent(inout) :: this + real(DP), intent(in) :: time + type(ListNodeType), pointer, intent(inout) :: nodeEarlier + type(ListNodeType), pointer, intent(inout) :: nodeLater + ! -- local + real(DP) :: time0, time1 + type(ListNodeType), pointer :: currNode => null() + type(ListNodeType), pointer :: tsNode0 => null() + type(ListNodeType), pointer :: tsNode1 => null() + type(TimeSeriesRecordType), pointer :: tsr => null(), tsrec0 => null() + type(TimeSeriesRecordType), pointer :: tsrec1 => null() + type(TimeSeriesRecordType), pointer :: tsrecEarlier + type(TimeSeriesRecordType), pointer :: tsrecLater + class(*), pointer :: obj => null() +! ------------------------------------------------------------------------------ + ! + tsrecEarlier => null() + tsrecLater => null() + nodeEarlier => null() + nodeLater => null() + ! + if (associated(this%list%firstNode)) then + currNode => this%list%firstNode + endif + ! + ! -- If the next node is earlier than time of interest, advance along + ! linked list until the next node is later than time of interest. + do + if (associated(currNode)) then + if (associated(currNode%nextNode)) then + obj => currNode%nextNode%GetItem() + tsr => CastAsTimeSeriesRecordType(obj) + if (tsr%tsrTime < time .and. .not. IS_SAME(tsr%tsrTime, time)) then + currNode => currNode%nextNode + else + exit + endif + else + exit + endif + else + exit + endif + enddo + ! + if (associated(currNode)) then + ! + ! -- find earlier record + tsNode0 => currNode + obj => tsNode0%GetItem() + tsrec0 => CastAsTimeSeriesRecordType(obj) + time0 = tsrec0%tsrTime + do while (time0 > time) + if (associated(tsNode0%prevNode)) then + tsNode0 => tsNode0%prevNode + obj => tsNode0%GetItem() + tsrec0 => CastAsTimeSeriesRecordType(obj) + time0 = tsrec0%tsrTime + else + exit + endif + enddo + ! + ! -- find later record + tsNode1 => currNode + obj => tsNode1%GetItem() + tsrec1 => CastAsTimeSeriesRecordType(obj) + time1 = tsrec1%tsrTime + do while (time1 < time .and. .not. IS_SAME(time1, time)) + if (associated(tsNode1%nextNode)) then + tsNode1 => tsNode1%nextNode + obj => tsNode1%GetItem() + tsrec1 => CastAsTimeSeriesRecordType(obj) + time1 = tsrec1%tsrTime + else + exit + endif + enddo + ! + endif + ! + if (time0 < time .or. IS_SAME(time0, time)) then + tsrecEarlier => tsrec0 + nodeEarlier => tsNode0 + endif + if (time1 > time .or. IS_SAME(time1, time)) then + tsrecLater => tsrec1 + nodeLater => tsNode1 + endif + ! + return + end subroutine get_surrounding_nodes + + logical function read_next_record(this) +! ****************************************************************************** +! read_next_record -- read next record +! Read next time-series record from input file. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesType), intent(inout) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + read_next_record = this%tsfile%read_tsfile_line() + return + ! + end function read_next_record + + function get_value_at_time(this, time) +! ****************************************************************************** +! get_value_at_time -- get value for a time +! Return a value for a specified time, same units as time-series values. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + real(DP) :: get_value_at_time + ! -- dummy + class(TimeSeriesType), intent(inout) :: this + real(DP), intent(in) :: time ! time of interest + ! -- local + integer(I4B) :: ierr + real(DP) :: ratio, time0, time1, timediff, timediffi, val0, val1, & + valdiff + character(len=LINELENGTH) :: errmsg + type(TimeSeriesRecordType), pointer :: tsrEarlier => null() + type(TimeSeriesRecordType), pointer :: tsrLater => null() + ! -- formats + 10 format('Error getting value at time ',g10.3,' for time series "',a,'"') +! ------------------------------------------------------------------------------ + ! + ierr = 0 + call this%get_surrounding_records(time,tsrEarlier,tsrLater) + if (associated(tsrEarlier)) then + if (associated(tsrLater)) then + ! -- values are available for both earlier and later times + if (this%iMethod == STEPWISE) then + get_value_at_time = tsrEarlier%tsrValue + elseif (this%iMethod == LINEAR .or. this%iMethod == LINEAREND) then + ! -- For get_value_at_time, result is the same for either + ! linear method. + ! -- Perform linear interpolation. + time0 = tsrEarlier%tsrTime + time1 = tsrLater%tsrtime + timediff = time1 - time0 + timediffi = time - time0 + if (timediff>0) then + ratio = timediffi/timediff + else + ! -- should not happen if TS does not contain duplicate times + ratio = 0.5d0 + endif + val0 = tsrEarlier%tsrValue + val1 = tsrLater%tsrValue + valdiff = val1 - val0 + get_value_at_time = val0 + (ratio*valdiff) + else + ierr = 1 + endif + else + if (IS_SAME(tsrEarlier%tsrTime, time)) then + get_value_at_time = tsrEarlier%tsrValue + else + ! -- Only earlier time is available, and it is not time of interest; + ! however, if method is STEPWISE, use value for earlier time. + if (this%iMethod == STEPWISE) then + get_value_at_time = tsrEarlier%tsrValue + else + ierr = 1 + endif + endif + endif + else + if (associated(tsrLater)) then + if (IS_SAME(tsrLater%tsrTime, time)) then + get_value_at_time = tsrLater%tsrValue + else + ! -- only later time is available, and it is not time of interest + ierr = 1 + endif + else + ! -- Neither earlier nor later time is available. + ! This should never happen! + ierr = 1 + endif + endif + ! + if (ierr > 0) then + write(errmsg,10)time,trim(this%Name) + call store_error(errmsg) + call ustop() + endif + ! + return + end function get_value_at_time + + function get_integrated_value(this, time0, time1) +! ****************************************************************************** +! get_integrated_value -- get integrated value +! Return an integrated value for a specified time span. +! Units: (ts-value-unit)*time +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + real(DP) :: get_integrated_value + ! -- dummy + class(TimeSeriesType), intent(inout) :: this + real(DP), intent(in) :: time0 + real(DP), intent(in) :: time1 + ! -- local + real(DP) :: area, currTime, nextTime, ratio0, ratio1, t0, t01, t1, & + timediff, value, value0, value1, valuediff + logical :: ldone + character(len=LINELENGTH) :: errmsg + type(ListNodeType), pointer :: tslNodePreceding => null() + type(ListNodeType), pointer :: currNode => null(), nextNode => null() + type(TimeSeriesRecordType), pointer :: currRecord => null() + type(TimeSeriesRecordType), pointer :: nextRecord => null() + class(*), pointer :: currObj => null(), nextObj => null() + ! -- formats + 10 format('Error encountered while performing integration', & + ' for time series "',a,'" for time interval: ',g12.5,' to ',g12.5) +! ------------------------------------------------------------------------------ + ! + value = DZERO + ldone = .false. + t1 = -DONE + call this%get_latest_preceding_node(time0, tslNodePreceding) + if (associated(tslNodePreceding)) then + currNode => tslNodePreceding + do while (.not. ldone) + currObj => currNode%GetItem() + currRecord => CastAsTimeSeriesRecordType(currObj) + currTime = currRecord%tsrTime + if (IS_SAME(currTime, time1)) then + ! Current node time = time1 so should be ldone + ldone = .true. + elseif (currTime < time1) then + if (.not. associated(currNode%nextNode)) then + ! -- try to read the next record + if (.not. this%read_next_record()) then + write(errmsg,10)trim(this%Name),time0,time1 + call store_error(errmsg) + call ustop() + endif + endif + if (associated(currNode%nextNode)) then + nextNode => currNode%nextNode + nextObj => nextNode%GetItem() + nextRecord => CastAsTimeSeriesRecordType(nextObj) + nextTime = nextRecord%tsrTime + ! -- determine lower and upper limits of time span of interest + ! within current interval + if (currTime > time0 .or. IS_SAME(currTime, time0)) then + t0 = currTime + else + t0 = time0 + endif + if (nextTime < time1 .or. IS_SAME(nextTime, time1)) then + t1 = nextTime + else + t1 = time1 + endif + ! -- find area of rectangle or trapezoid delimited by t0 and t1 + t01 = t1 - t0 + select case (this%iMethod) + case (STEPWISE) + ! -- compute area of a rectangle + value0 = currRecord%tsrValue + area = value0 * t01 + case (LINEAR, LINEAREND) + ! -- compute area of a trapezoid + timediff = nextTime - currTime + ratio0 = (t0 - currTime) / timediff + ratio1 = (t1 - currTime) / timediff + valuediff = nextRecord%tsrValue - currRecord%tsrValue + value0 = currRecord%tsrValue + ratio0 * valuediff + value1 = currRecord%tsrValue + ratio1 * valuediff + if (this%iMethod == LINEAR) then + area = 0.5d0 * t01 * (value0 + value1) + elseif (this%iMethod == LINEAREND) then + area = DZERO + value = value1 + endif + end select + ! -- add area to integrated value + value = value + area + endif + endif + ! + ! -- Are we done yet? + if (t1 > time1) then + ldone = .true. + elseif (IS_SAME(t1, time1)) then + ldone = .true. + else + ! -- We are not done yet + if (.not. associated(currNode%nextNode)) then + ! -- Not done and no more data, so try to read the next record + if (.not. this%read_next_record()) then + write(errmsg,10)trim(this%Name),time0,time1 + call store_error(errmsg) + call ustop() + endif + elseif (associated(currNode%nextNode)) then + currNode => currNode%nextNode + endif + endif + enddo + endif + ! + get_integrated_value = value + if (this%autoDeallocate) then + if (associated(tslNodePreceding)) then + if (associated(tslNodePreceding%prevNode))then + call this%list%DeallocateBackward(tslNodePreceding%prevNode) + endif + endif + endif + return + end function get_integrated_value + + function get_average_value(this, time0, time1) +! ****************************************************************************** +! get_average_value -- get average value +! Return a time-weighted average value for a specified time span. +! Units: (ts-value-unit) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + real(DP) :: get_average_value + ! -- dummy + class(TimeSeriesType), intent(inout) :: this + real(DP), intent(in) :: time0 + real(DP), intent(in) :: time1 + ! -- local + real(DP) :: timediff, value, valueIntegrated +! ------------------------------------------------------------------------------ + ! + timediff = time1 - time0 + if (timediff > 0) then + valueIntegrated = this%get_integrated_value(time0, time1) + if (this%iMethod == LINEAREND) then + value = valueIntegrated + else + value = valueIntegrated / timediff + endif + else + ! -- time0 and time1 are the same + value = this%get_value_at_time(time0) + endif + get_average_value = value + ! + return + end function get_average_value + + subroutine get_latest_preceding_node(this, time, tslNode) +! ****************************************************************************** +! get_latest_preceding_node -- get latest prececing node +! Return pointer to ListNodeType object for the node +! representing the latest preceding time in the time series +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesType), intent(inout) :: this + real(DP), intent(in) :: time + type(ListNodeType), pointer, intent(inout) :: tslNode + ! -- local + real(DP) :: time0 + type(ListNodeType), pointer :: currNode => null() + type(ListNodeType), pointer :: tsNode0 => null() + type(TimeSeriesRecordType), pointer :: tsr => null() + type(TimeSeriesRecordType), pointer :: tsrec0 => null() + class(*), pointer :: obj => null() +! ------------------------------------------------------------------------------ + ! + tslNode => null() + if (associated(this%list%firstNode)) then + currNode => this%list%firstNode + else + call store_error('probable programming error in get_latest_preceding_node') + call ustop() + endif + ! + ! -- If the next node is earlier than time of interest, advance along + ! linked list until the next node is later than time of interest. + do + if (associated(currNode)) then + if (associated(currNode%nextNode)) then + obj => currNode%nextNode%GetItem() + tsr => CastAsTimeSeriesRecordType(obj) + if (tsr%tsrTime < time .or. IS_SAME(tsr%tsrTime, time)) then + currNode => currNode%nextNode + else + exit + endif + else + ! -- read another record + if (.not. this%read_next_record()) exit + endif + else + exit + endif + enddo + ! + if (associated(currNode)) then + ! + ! -- find earlier record + tsNode0 => currNode + obj => tsNode0%GetItem() + tsrec0 => CastAsTimeSeriesRecordType(obj) + time0 = tsrec0%tsrTime + do while (time0 > time) + if (associated(tsNode0%prevNode)) then + tsNode0 => tsNode0%prevNode + obj => tsNode0%GetItem() + tsrec0 => CastAsTimeSeriesRecordType(obj) + time0 = tsrec0%tsrTime + else + exit + endif + enddo + endif + ! + if (time0 < time .or. IS_SAME(time0, time)) tslNode => tsNode0 + ! + return + end subroutine get_latest_preceding_node + + subroutine ts_da(this) +! ****************************************************************************** +! ts_da -- deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesType), intent(inout) :: this +! ------------------------------------------------------------------------------ + ! + if (associated(this%list)) then + call this%list%Clear(.true.) + deallocate(this%list) + endif + ! + return + end subroutine ts_da + + subroutine AddTimeSeriesRecord(this, tsr) +! ****************************************************************************** +! AddTimeSeriesRecord -- add ts record +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesType) :: this + type(TimeSeriesRecordType), pointer, intent(inout) :: tsr + ! -- local + class(*), pointer :: obj +! ------------------------------------------------------------------------------ + ! + obj => tsr + call this%list%Add(obj) + ! + return + end subroutine AddTimeSeriesRecord + + function GetCurrentTimeSeriesRecord(this) result (res) +! ****************************************************************************** +! GetCurrentTimeSeriesRecord -- get current ts record +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesType) :: this + ! result + type(TimeSeriesRecordType), pointer :: res + ! -- local + class(*), pointer :: obj +! ------------------------------------------------------------------------------ + ! + obj => null() + res => null() + obj => this%list%GetItem() + if (associated(obj)) then + res => CastAsTimeSeriesRecordType(obj) + endif + ! + return + end function GetCurrentTimeSeriesRecord + + function GetPreviousTimeSeriesRecord(this) result (res) +! ****************************************************************************** +! GetPreviousTimeSeriesRecord -- get previous ts record +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesType) :: this + ! result + type(TimeSeriesRecordType), pointer :: res + ! -- local + class(*), pointer :: obj +! ------------------------------------------------------------------------------ + ! + obj => null() + res => null() + obj => this%list%GetPreviousItem() + if (associated(obj)) then + res => CastAsTimeSeriesRecordType(obj) + endif + ! + return + end function GetPreviousTimeSeriesRecord + + function GetNextTimeSeriesRecord(this) result (res) +! ****************************************************************************** +! GetNextTimeSeriesRecord -- get next ts record +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesType) :: this + ! result + type(TimeSeriesRecordType), pointer :: res + ! -- local + class(*), pointer :: obj +! ------------------------------------------------------------------------------ + ! + obj => null() + res => null() + obj => this%list%GetNextItem() + if (associated(obj)) then + res => CastAsTimeSeriesRecordType(obj) + endif + ! + return + end function GetNextTimeSeriesRecord + + function GetTimeSeriesRecord(this, time, epsi) result (res) +! ****************************************************************************** +! GetTimeSeriesRecord -- get ts record +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesType) :: this + double precision, intent(in) :: time + double precision, intent(in) :: epsi + ! result + type(TimeSeriesRecordType), pointer :: res + ! -- local + type(TimeSeriesRecordType), pointer :: tsr +! ------------------------------------------------------------------------------ + ! + call this%list%Reset() + res => null() + do + tsr => this%GetNextTimeSeriesRecord() + if (associated(tsr)) then + if (IS_SAME(tsr%tsrTime, time)) then + res => tsr + exit + endif + if (tsr%tsrTime > time) exit + else + exit + endif + enddo + ! + return + end function GetTimeSeriesRecord + + subroutine Reset(this) +! ****************************************************************************** +! Reset -- reset +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesType) :: this +! ------------------------------------------------------------------------------ + ! + call this%list%Reset() + ! + return + end subroutine Reset + + subroutine InsertTsr(this, tsr) +! ****************************************************************************** +! InsertTsr -- insert ts record +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesType), intent(inout) :: this + type(TimeSeriesRecordType), pointer, intent(inout) :: tsr + ! -- local + double precision :: badtime, time, time0, time1 + type(TimeSeriesRecordType), pointer :: tsrEarlier, tsrLater + type(ListNodeType), pointer :: nodeEarlier, nodeLater + class(*), pointer :: obj +! ------------------------------------------------------------------------------ + ! + badtime = -9.0d30 + time0 = badtime + time1 = badtime + time = tsr%tsrTime + call this%get_surrounding_nodes(time, nodeEarlier, nodeLater) + ! + if (associated(nodeEarlier)) then + obj => nodeEarlier%GetItem() + tsrEarlier => CastAsTimeSeriesRecordType(obj) + if (associated(tsrEarlier)) then + time0 = tsrEarlier%tsrTime + endif + endif + ! + if (associated(nodeLater)) then + obj => nodeLater%GetItem() + tsrLater => CastAsTimeSeriesRecordType(obj) + if (associated(tsrLater)) then + time1 = tsrLater%tsrTime + endif + endif + ! + if (time0 > badtime) then + ! Time0 is valid + if (time1 > badtime) then + ! Both time0 and time1 are valid + if (time > time0 .and. time < time1) then + ! Insert record between two list nodes + obj => tsr + call this%list%InsertBefore(obj, nodeLater) + else + ! No need to insert a time series record, but if existing record + ! for time of interest has NODATA as tsrValue, replace tsrValue + if (time == time0 .and. tsrEarlier%tsrValue == DNODATA .and. & + tsr%tsrValue /= DNODATA) then + tsrEarlier%tsrValue = tsr%tsrValue + elseif (time == time1 .and. tsrLater%tsrValue == DNODATA .and. & + tsr%tsrValue /= DNODATA) then + tsrLater%tsrValue = tsr%tsrValue + endif + endif + else + ! Time0 is valid and time1 is invalid. Just add tsr to the list. + call this%AddTimeSeriesRecord(tsr) + endif + else + ! Time0 is invalid, so time1 must be for first node in list + if (time1 > badtime) then + ! Time 1 is valid + if (time < time1) then + ! Insert tsr at beginning of list + obj => tsr + call this%list%InsertBefore(obj, nodeLater) + elseif (time == time1) then + ! No need to insert a time series record, but if existing record + ! for time of interest has NODATA as tsrValue, replace tsrValue + if (tsrLater%tsrValue == DNODATA .and. tsr%tsrValue /= DNODATA) then + tsrLater%tsrValue = tsr%tsrValue + endif + endif + else + ! Both time0 and time1 are invalid. Just add tsr to the list. + call this%AddTimeSeriesRecord(tsr) + endif + endif + ! + return + end subroutine InsertTsr + + function FindLatestTime(this) result (endtime) +! ****************************************************************************** +! FindLatestTime -- find latest time +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesType), intent(inout) :: this + ! -- local + integer :: nrecords + double precision :: endtime + type(TimeSeriesRecordType), pointer :: tsr + class(*), pointer :: obj +! ------------------------------------------------------------------------------ + ! + nrecords = this%list%Count() + obj => this%list%GetItem(nrecords) + tsr => CastAsTimeSeriesRecordType(obj) + endtime = tsr%tsrTime + ! + return + end function FindLatestTime + + subroutine Clear(this, destroy) +! ****************************************************************************** +! Clear -- Clear the list of time series records +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesType), intent(inout) :: this + logical, optional, intent(in) :: destroy +! ------------------------------------------------------------------------------ + ! + call this%list%Clear(destroy) + ! + return + end subroutine Clear + +! Type-bound procedures of TimeSeriesFileType + + function Count(this) +! ****************************************************************************** +! Count --count number of time series +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + integer(I4B) :: Count + ! -- dummy + class(TimeSeriesFileType) :: this +! ------------------------------------------------------------------------------ + ! + if (associated(this%timeSeries)) then + Count = size(this%timeSeries) + else + Count = 0 + endif + return + end function Count + + function GetTimeSeries(this, indx) result (res) +! ****************************************************************************** +! GetTimeSeries -- get ts +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesFileType) :: this + integer(I4B), intent(in) :: indx + ! result + type(TimeSeriesType), pointer :: res +! ------------------------------------------------------------------------------ + ! + res => null() + if (indx > 0 .and. indx <= this%nTimeSeries) then + res => this%timeSeries(indx) + endif + return + end function GetTimeSeries + + subroutine Initializetsfile(this, filename, iout, autoDeallocate) +! ****************************************************************************** +! Initializetsfile -- Open time-series tsfile file and read options and first +! record, which may contain data to define multiple time series. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesFileType), target, intent(inout) :: this + character(len=*), intent(in) :: filename + integer(I4B), intent(in) :: iout + logical, optional, intent(in) :: autoDeallocate + ! -- local + integer(I4B) :: iMethod, istatus, j, nwords + integer(I4B) :: ierr, inunit + logical :: autoDeallocateLocal = .true. + logical :: continueread, found, endOfBlock + real(DP) :: sfaclocal + character(len=40) :: keyword, keyvalue + character(len=LINELENGTH) :: ermsg + character(len=LENHUGELINE) :: line + character(len=LENTIMESERIESNAME), allocatable, dimension(:) :: words +! ------------------------------------------------------------------------------ + ! + ! -- Initialize some variables + if (present(autoDeallocate)) autoDeallocateLocal = autoDeallocate + iMethod = UNDEFINED + ! + ! -- Assign members + this%iout = iout + this%datafile = filename + ! + ! -- Open the time-series tsfile input file + this%inunit = GetUnit() + inunit = this%inunit + call openfile(inunit,0,filename,'TS6') + ! + ! -- Initialize block parser + call this%parser%Initialize(this%inunit, this%iout) + ! + ! -- Read the ATTRIBUTES block and count time series + continueread = .false. + ierr = 0 + ! + ! -- get BEGIN line of ATTRIBUTES block + call this%parser%GetBlock('ATTRIBUTES', found, ierr, & + supportOpenClose=.true.) + if (ierr /= 0) then + ! end of file + ermsg = 'End-of-file encountered while searching for' // & + ' ATTRIBUTES in time-series ' // & + 'input file "' // trim(this%datafile) // '"' + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + elseif (.not. found) then + ermsg = 'ATTRIBUTES block not found in time-series ' // & + 'tsfile input file "' // trim(this%datafile) // '"' + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + ! -- parse ATTRIBUTES entries + do + ! -- read a line from input + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + ! + ! -- get the keyword + call this%parser%GetStringCaps(keyword) + ! + ! support either NAME or NAMES as equivalent keywords + if (keyword=='NAMES') keyword = 'NAME' + ! + if (keyword /= 'NAME' .and. keyword /= 'METHODS' .and. keyword /= 'SFACS') then + ! -- get the word following the keyword (the key value) + call this%parser%GetStringCaps(keyvalue) + endif + ! + select case (keyword) + case ('NAME') +! line = line(istart:linelen) + call this%parser%GetRemainingLine(line) + call ParseLine(line, nwords, words, this%parser%iuactive) + this%nTimeSeries = nwords + ! -- Allocate the timeSeries array and initialize each + ! time series. + allocate(this%timeSeries(this%nTimeSeries)) + do j=1,this%nTimeSeries + call this%timeSeries(j)%initialize_time_series(this, words(j), & + autoDeallocateLocal) + enddo + case ('METHOD') + if (this%nTimeSeries == 0) then + ermsg = 'Error: NAME attribute not provided before METHOD in file: ' & + // trim(filename) + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + select case (keyvalue) + case ('STEPWISE') + iMethod = STEPWISE + case ('LINEAR') + iMethod = LINEAR + case ('LINEAREND') + iMethod = LINEAREND + case default + ermsg = 'Unknown interpolation method: "' // trim(keyvalue) // '"' + call store_error(ermsg) + end select + do j=1,this%nTimeSeries + this%timeSeries(j)%iMethod = iMethod + enddo + case ('METHODS') + if (this%nTimeSeries == 0) then + ermsg = 'Error: NAME attribute not provided before METHODS in file: ' & + // trim(filename) + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + call this%parser%GetRemainingLine(line) + call ParseLine(line, nwords, words, this%parser%iuactive) + if (nwords < this%nTimeSeries) then + ermsg = 'Error: METHODS attribute does not list a method for' // & + ' all time series.' + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + do j=1,this%nTimeSeries + call upcase(words(j)) + select case (words(j)) + case ('STEPWISE') + iMethod = STEPWISE + case ('LINEAR') + iMethod = LINEAR + case ('LINEAREND') + iMethod = LINEAREND + case default + ermsg = 'Unknown interpolation method: "' // trim(words(j)) // '"' + call store_error(ermsg) + end select + this%timeSeries(j)%iMethod = iMethod + enddo + case ('SFAC') + if (this%nTimeSeries == 0) then + ermsg = 'Error: NAME attribute not provided before SFAC in file: ' & + // trim(filename) + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + read(keyvalue,*,iostat=istatus)sfaclocal + if (istatus /= 0) then + ermsg = 'Error reading numeric value from: "' // trim(keyvalue) // '"' + call store_error(ermsg) + endif + do j=1,this%nTimeSeries + this%timeSeries(j)%sfac = sfaclocal + enddo + case ('SFACS') + if (this%nTimeSeries == 0) then + ermsg = 'Error: NAME attribute not provided before SFACS in file: ' & + // trim(filename) + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + endif + do j=1,this%nTimeSeries + sfaclocal = this%parser%GetDouble() + this%timeSeries(j)%sfac = sfaclocal + enddo + case ('AUTODEALLOCATE') + do j=1,this%nTimeSeries + this%timeSeries(j)%autoDeallocate = (keyvalue == 'TRUE') + enddo + case default + ermsg = 'Unknown option found in ATTRIBUTES block: "' // & + trim(keyword) // '"' + call store_error(ermsg) + call this%parser%StoreErrorUnit() + call ustop() + end select + enddo + ! + ! -- Get TIMESERIES block + call this%parser%GetBlock('TIMESERIES', found, ierr, & + supportOpenClose=.true.) + ! + ! -- Read the first line of time-series data + if (.not. this%read_tsfile_line()) then + ermsg = 'Error: No time-series data contained in file: ' // & + trim(this%datafile) + call store_error(ermsg) + endif + ! + ! -- Clean up and return + if (allocated(words)) deallocate(words) + ! + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + call ustop() + endif + ! + return + end subroutine Initializetsfile + + logical function read_tsfile_line(this) +! ****************************************************************************** +! read_tsfile_line -- read tsfile line +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesFileType), intent(inout) :: this + ! -- local + real(DP) :: tsrTime, tsrValue + integer(I4B) :: i + logical :: eof, endOfBlock + type(TimeSeriesRecordType), pointer :: tsRecord => null() +! ------------------------------------------------------------------------------ + ! + eof = .false. + read_tsfile_line = .false. + ! + ! -- Get an arbitrary length, non-comment, non-blank line + ! from the input file. + call this%parser%GetNextLine(endOfBlock) + ! + ! -- Get the time + tsrTime = this%parser%GetDouble() + ! + ! -- Construct a new record and append a new node to each time series + tsloop: do i=1,this%nTimeSeries + tsrValue = this%parser%GetDouble() + if (tsrValue == DNODATA) cycle tsloop + ! -- multiply value by sfac + tsrValue = tsrValue * this%timeSeries(i)%sfac + call ConstructTimeSeriesRecord(tsRecord, tsrTime, tsrValue) + call AddTimeSeriesRecordToList(this%timeSeries(i)%list, tsRecord) + enddo tsloop + read_tsfile_line = .true. + ! + return + end function read_tsfile_line + + subroutine tsf_da(this) +! ****************************************************************************** +! tsf_da -- deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesFileType), intent(inout) :: this + ! -- local + integer :: i, n + type(TimeSeriesType), pointer :: ts => null() +! ------------------------------------------------------------------------------ + ! + n = this%Count() + do i=1,n + ts => this%GetTimeSeries(i) + if (associated(ts)) then + call ts%da() +! deallocate(ts) + endif + enddo + ! + deallocate(this%timeSeries) + deallocate(this%parser) + ! + return + end subroutine tsf_da + +end module TimeSeriesModule diff --git a/src/Utilities/TimeSeries/TimeSeriesManager.f90 b/src/Utilities/TimeSeries/TimeSeriesManager.f90 index f0d268608f5..0879d5d471a 100644 --- a/src/Utilities/TimeSeries/TimeSeriesManager.f90 +++ b/src/Utilities/TimeSeries/TimeSeriesManager.f90 @@ -1,747 +1,747 @@ -module TimeSeriesManagerModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, LENPACKAGENAME, MAXCHARLEN, & - LINELENGTH, LENTIMESERIESNAME - use HashTableModule, only: HashTableType - use InputOutputModule, only: same_word, UPCASE - use ListModule, only: ListType - use SimModule, only: store_error, store_error_unit, ustop - use TdisModule, only: delt, kper, kstp, totim, totimc, & - totimsav - use TimeSeriesFileListModule, only: TimeSeriesFileListType - use TimeSeriesLinkModule, only: TimeSeriesLinkType, & - ConstructTimeSeriesLink, & - GetTimeSeriesLinkFromList, & - AddTimeSeriesLinkToList - use TimeSeriesModule, only: TimeSeriesContainerType, & - TimeSeriesFileType, & - TimeSeriesType - - implicit none - - private - public :: TimeSeriesManagerType, read_value_or_time_series, & - read_single_value_or_time_series, tsmanager_cr - - type TimeSeriesManagerType - integer(I4B), public :: iout = 0 ! output unit number - type(TimeSeriesFileListType), pointer, public :: tsfileList => null() ! list of ts files objs - type(ListType), pointer, public :: boundTsLinks => null() ! links to bound and aux - integer(I4B) :: numtsfiles = 0 ! number of ts files - character(len=MAXCHARLEN), allocatable, dimension(:) :: tsfiles ! list of ts files - type(ListType), pointer, private :: auxvarTsLinks => null() ! list of aux links - type(HashTableType), private :: BndTsHashTable ! hash of ts to tsobj - type(TimeSeriesContainerType), allocatable, dimension(:), & - private :: TsContainers - contains - ! -- Public procedures - procedure, public :: tsmanager_df - procedure, public :: ad => tsmgr_ad - procedure, public :: da => tsmgr_da - procedure, public :: add_tsfile - procedure, public :: CountLinks - procedure, public :: GetLink - procedure, public :: Reset - procedure, public :: HashBndTimeSeries - ! -- Private procedures - procedure, private :: get_time_series - procedure, private :: make_link - end type TimeSeriesManagerType - - contains - - subroutine tsmanager_cr(this, iout) -! ****************************************************************************** -! tsmanager_cr -- create the tsmanager -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - type(TimeSeriesManagerType) :: this - integer(I4B), intent(in) :: iout -! ------------------------------------------------------------------------------ - ! - this%iout = iout - allocate(this%boundTsLinks) - allocate(this%auxvarTsLinks) - allocate(this%tsfileList) - allocate(this%tsfiles(1000)) - ! - return - end subroutine tsmanager_cr - - subroutine tsmanager_df(this) -! ****************************************************************************** -! tsmanager_df -- define -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(TimeSeriesManagerType) :: this -! ------------------------------------------------------------------------------ - ! - if (this%numtsfiles > 0) then - call this%HashBndTimeSeries(this%numtsfiles) - endif - ! - ! -- return - return - end subroutine tsmanager_df - - subroutine add_tsfile(this, fname, inunit) -! ****************************************************************************** -! add_tsfile -- add a time series file to this manager -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use SimModule, only: store_error, store_error_unit, ustop - use ArrayHandlersModule, only: ExpandArray - ! -- dummy - class(TimeSeriesManagerType) :: this - character(len=*), intent(in) :: fname - integer(I4B), intent(in) :: inunit - ! -- local - integer(I4B) :: isize - integer(I4B) :: i - class(TimeSeriesFileType), pointer :: tsfile => null() -! ------------------------------------------------------------------------------ - ! - ! -- Check for fname duplicates - if (this%numtsfiles > 0) then - do i = 1, this%numtsfiles - if (this%tsfiles(i) == fname) then - call store_error('Found duplicate time-series file name: ' // trim(fname)) - call store_error_unit(inunit) - call ustop() - endif - enddo - endif - ! - ! -- Save fname - this%numtsfiles = this%numtsfiles + 1 - isize = size(this%tsfiles) - if (this%numtsfiles > isize) then - call ExpandArray(this%tsfiles, 1000) - endif - this%tsfiles(this%numtsfiles) = fname - ! - ! -- - call this%tsfileList%Add(fname, this%iout, tsfile) - ! - return - end subroutine add_tsfile - - subroutine tsmgr_ad(this) -! ****************************************************************************** -! tsmgr_ad -- time step (or subtime step) advance. Call this each time step or -! subtime step. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesManagerType) :: this - ! -- local - type(TimeSeriesLinkType), pointer :: tsLink => null() - type(TimeSeriesType), pointer :: timeseries => null() - integer(I4B) :: i, nlinks, nauxlinks - real(DP) :: begintime, endtime - character(len=LENPACKAGENAME+2) :: pkgID - ! formats - character(len=*),parameter :: fmt5 = & - &"(/,'Time-series controlled values in stress period: ', i0, & - &', time step ', i0, ':')" - 10 format(a,' package: Boundary ',i0,', entry ',i0, ' value from time series "',a,'" = ',g12.5) - 15 format(a,' package: Boundary ',i0,', entry ',i0,' value from time series "',a,'" = ',g12.5,' (',a,')') - 20 format(a,' package: Boundary ',i0,', ',a,' value from time series "',a,'" = ',g12.5) - 25 format(a,' package: Boundary ',i0,', ',a,' value from time series "',a,'" = ',g12.5,' (',a,')') -! ------------------------------------------------------------------------------ - ! - ! -- Initialize time variables - begintime = totimc - endtime = begintime + delt - ! - ! -- Determine number of ts links - nlinks = this%boundtslinks%Count() - nauxlinks = this%auxvartslinks%Count() - ! - ! -- Iterate through auxvartslinks and replace specified - ! elements of auxvar with average value obtained from - ! appropriate time series. Need to do auxvartslinks - ! first because they may be a multiplier column - do i = 1, nauxlinks - tsLink => GetTimeSeriesLinkFromList(this%auxvarTsLinks, i) - timeseries => tsLink%timeSeries - if (i == 1) then - if (tsLink%Iprpak == 1) then - write(this%iout, fmt5) kper, kstp - endif - endif - tsLink%BndElement = timeseries%GetValue(begintime, endtime) - ! - ! -- Write time series values to output file - if (tsLink%Iprpak == 1) then - pkgID = '"' // trim(tsLink%PackageName) // '"' - if (tsLink%Text == '') then - if (tsLink%BndName == '') then - write(this%iout,10)trim(pkgID), tsLink%IRow, tsLink%JCol, & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement - else - write(this%iout,15)trim(pkgID), tsLink%IRow, tsLink%JCol, & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement, trim(tsLink%BndName) - endif - else - if (tsLink%BndName == '') then - write(this%iout,20)trim(pkgID), tsLink%IRow, trim(tsLink%Text), & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement - else - write(this%iout,25)trim(pkgID), tsLink%IRow, trim(tsLink%Text), & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement, trim(tsLink%BndName) - endif - endif - endif - enddo - ! - ! -- Iterate through boundtslinks and replace specified - ! elements of bound with average value obtained from - ! appropriate time series. (For list-type packages) - do i = 1, nlinks - tsLink => GetTimeSeriesLinkFromList(this%boundTsLinks, i) - if (i == 1 .and. nauxlinks == 0) then - if (tsLink%Iprpak == 1) then - write(this%iout, fmt5) kper, kstp - endif - endif - ! this part needs to be different for MAW because MAW does not use - ! bound array for well rate (although rate is stored in - ! this%bound(4,ibnd)), it uses this%mawwells(n)%rate%value - if (tsLink%UseDefaultProc) then - timeseries => tsLink%timeSeries - tsLink%BndElement = timeseries%GetValue(begintime, endtime) - ! - ! -- If multiplier is active and it applies to this element, - ! do the multiplication. This must be done after the auxlinks - ! have been calculated in case iauxmultcol is being used. - if (associated(tsLink%RMultiplier)) then - tsLink%BndElement = tsLink%BndElement * tsLink%RMultiplier - endif - ! - ! -- Write time series values to output files - if (tsLink%Iprpak == 1) then - pkgID = '"' // trim(tsLink%PackageName) // '"' - if (tsLink%Text == '') then - if (tsLink%BndName == '') then - write(this%iout,10)trim(pkgID), tsLink%IRow, tsLink%JCol, & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement - else - write(this%iout,15)trim(pkgID), tsLink%IRow, tsLink%JCol, & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement, trim(tsLink%BndName) - endif - else - if (tsLink%BndName == '') then - write(this%iout,20)trim(pkgID), tsLink%IRow, trim(tsLink%Text), & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement - else - write(this%iout,25)trim(pkgID), tsLink%IRow, trim(tsLink%Text), & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement, trim(tsLink%BndName) - endif - endif - endif - ! - ! -- If conversion from flux to flow is required, multiply by cell area - if (tsLink%ConvertFlux) then - tsLink%BndElement = tsLink%BndElement * tsLink%CellArea - endif - endif - enddo - ! - ! -- Finish with ending line - if (nlinks + nauxlinks > 0) then - if (tsLink%Iprpak == 1) then - write(this%iout,'()') - endif - end if - ! - return - end subroutine tsmgr_ad - - subroutine tsmgr_da(this) -! ****************************************************************************** -! tsmgr_da -- deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesManagerType) :: this - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- Deallocate time-series links in boundTsLinks - call this%boundTsLinks%Clear(.true.) - deallocate(this%boundTsLinks) - ! - ! -- Deallocate time-series links in auxvarTsLinks - call this%auxvarTsLinks%Clear(.true.) - deallocate(this%auxvarTsLinks) - ! - ! -- Deallocate tsfileList - call this%tsfileList%da() - deallocate(this%tsfileList) - ! - ! -- Deallocate the hash table - call this%BndTsHashTable%FreeHash() - ! - deallocate(this%tsfiles) - ! - return - end subroutine tsmgr_da - - subroutine Reset(this, pkgName) -! ****************************************************************************** -! reset -- Call this when a new BEGIN PERIOD block is read for a new stress -! period. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesManagerType) :: this - character(len=*), intent(in) :: pkgName - ! -- local - integer(I4B) :: i, nlinks - type(TimeSeriesLinkType), pointer :: tslink -! ------------------------------------------------------------------------------ - ! Zero out values for time-series controlled stresses. - ! Also deallocate all tslinks too. - ! Then when time series are - ! specified in this or another stress period, - ! a new tslink would be set up. - ! - ! Reassign all linked elements to zero - nlinks = this%boundTsLinks%Count() - do i=1,nlinks - tslink => GetTimeSeriesLinkFromList(this%boundTsLinks, i) - if (associated(tslink)) then - if (tslink%PackageName == pkgName) then - tslink%BndElement = DZERO - endif - endif - enddo - ! - ! Remove links belonging to calling package - nlinks = this%boundTsLinks%Count() - do i=nlinks,1,-1 - tslink => GetTimeSeriesLinkFromList(this%boundTsLinks, i) - if (associated(tslink)) then - if (tslink%PackageName == pkgName) then - call this%boundTsLinks%RemoveNode(i, .true.) - endif - endif - enddo - nlinks = this%auxvarTsLinks%Count() - do i=nlinks,1,-1 - tslink => GetTimeSeriesLinkFromList(this%auxvarTsLinks,i) - if (associated(tslink)) then - if (tslink%PackageName == pkgName) then - call this%auxvarTsLinks%RemoveNode(i, .true.) - endif - endif - enddo - ! - return - end subroutine Reset - - subroutine make_link(this, timeSeries, pkgName, auxOrBnd, bndElem, & - irow, jcol, iprpak, tsLink, text, bndName) -! ****************************************************************************** -! make_link -- -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesManagerType), intent(inout) :: this - type(TimeSeriesType), pointer, intent(inout) :: timeSeries - character(len=*), intent(in) :: pkgName - character(len=3), intent(in) :: auxOrBnd - real(DP), pointer, intent(inout) :: bndElem - integer(I4B), intent(in) :: irow, jcol - integer(I4B), intent(in) :: iprpak - type(TimeSeriesLinkType), pointer, intent(inout) :: tsLink - character(len=*), intent(in) :: text - character(len=*), intent(in) :: bndName - ! -- local -! ------------------------------------------------------------------------------ - ! - tsLink => null() - call ConstructTimeSeriesLink(tsLink, timeSeries, pkgName, & - auxOrBnd, bndElem, irow, jcol, iprpak) - if (associated(tsLink)) then - if (auxOrBnd == 'BND') then - call AddTimeSeriesLinkToList(this%boundTsLinks, tsLink) - elseif (auxOrBnd == 'AUX') then - call AddTimeSeriesLinkToList(this%auxvarTsLinks, tsLink) - else - call ustop('programmer error in make_link') - endif - tsLink%Text = text - tsLink%BndName = bndName - endif - ! - return - end subroutine make_link - - function GetLink(this, auxOrBnd, indx) result(tsLink) -! ****************************************************************************** -! GetLink -- -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesManagerType) :: this - character(len=3), intent(in) :: auxOrBnd - integer(I4B), intent(in) :: indx - type(TimeSeriesLinkType), pointer :: tsLink - ! -- local - type(ListType), pointer :: list -! ------------------------------------------------------------------------------ - ! - list => null() - tsLink => null() - ! - select case (auxOrBnd) - case ('AUX') - list => this%auxvarTsLinks - case ('BND') - list => this%boundTsLinks - end select - ! - if (associated(list)) then - tsLink => GetTimeSeriesLinkFromList(list, indx) - endif - ! - return - end function GetLink - - function CountLinks(this, auxOrBnd) -! ****************************************************************************** -! CountLinks -- -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- return - integer(I4B) :: CountLinks - ! -- dummy - class(TimeSeriesManagerType) :: this - character(len=3), intent(in) :: auxOrBnd -! ------------------------------------------------------------------------------ - ! - CountLinks = 0 - if (auxOrBnd == 'BND') then - CountLinks = this%boundTsLinks%Count() - elseif (auxOrBnd == 'AUX') then - CountLinks = this%auxvarTsLinks%count() - endif - ! - return - end function CountLinks - - function get_time_series(this, name) result (res) -! ****************************************************************************** -! get_time_series -- -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(TimeSeriesManagerType) :: this - character(len=*), intent(in) :: name - ! -- result - type(TimeSeriesType), pointer :: res - ! -- local - integer(I4B) :: indx -! ------------------------------------------------------------------------------ - ! - ! Get index from hash table, get time series from TsContainers, - ! and assign result to time series contained in link. - res => null() - call this%BndTsHashTable%GetHash(name, indx) - if (indx > 0) then - res => this%TsContainers(indx)%timeSeries - endif - ! - return - end function get_time_series - - subroutine HashBndTimeSeries(this, ivecsize) -! ****************************************************************************** -! HashBndTimeSeries -- -! Store all boundary (stress) time series links in -! TsContainers and construct hash table BndTsHashTable. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class (TimeSeriesManagerType), intent(inout) :: this - integer(I4B), intent(in) :: ivecsize - ! -- local - integer(I4B) :: i, j, k, numtsfiles, numts - character(len=LENTIMESERIESNAME) :: name - type(TimeSeriesFileType), pointer :: tsfile => null() -! ------------------------------------------------------------------------------ - ! - ! Initialize the hash table - call this%BndTsHashTable%InitHash(ivecsize) - ! - ! Allocate the TsContainers array to accommodate all time-series links. - numts = this%tsfileList%CountTimeSeries() - allocate(this%TsContainers(numts)) - ! - ! Store a pointer to each time series in the TsContainers array - ! and put its key (time-series name) and index in the hash table. - numtsfiles = this%tsfileList%Counttsfiles() - k = 0 - do i = 1, numtsfiles - tsfile => this%tsfileList%Gettsfile(i) - numts = tsfile%Count() - do j=1,numts - k = k + 1 - this%TsContainers(k)%timeSeries => tsfile%GetTimeSeries(j) - if (associated(this%TsContainers(k)%timeSeries)) then - name = this%TsContainers(k)%timeSeries%Name - call this%BndTsHashTable%PutHash(name, k) - endif - enddo - enddo - ! - return - end subroutine HashBndTimeSeries - - ! -- Non-type-bound procedures - - subroutine read_value_or_time_series(textInput, ii, jj, bndElem, & - pkgName, auxOrBnd, tsManager, iprpak, tsLink) -! ****************************************************************************** -! read_value_or_time_series -- -! Call this subroutine if the time-series link is available or needed. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - character(len=*), intent(in) :: textInput - integer(I4B), intent(in) :: ii - integer(I4B), intent(in) :: jj - real(DP), pointer, intent(inout) :: bndElem - character(len=*), intent(in) :: pkgName - character(len=3), intent(in) :: auxOrBnd - type(TimeSeriesManagerType), intent(inout) :: tsManager - integer(I4B), intent(in) :: iprpak - type(TimeSeriesLinkType), pointer, intent(inout) :: tsLink - ! -- local - type(TimeSeriesType), pointer :: timeseries => null() - type(TimeSeriesLinkType), pointer :: tslTemp => null() - integer(I4B) :: i, istat, nlinks - real(DP) :: r - character(len=LINELENGTH) :: ermsg - character(len=LENTIMESERIESNAME) :: tsNameTemp - logical :: found -! ------------------------------------------------------------------------------ - ! - read (textInput,*,iostat=istat) r - if (istat == 0) then - bndElem = r - else - tsNameTemp = textInput - call UPCASE(tsNameTemp) - ! -- If text is a time-series name, get value - ! from time series. - timeseries => tsManager%get_time_series(tsNameTemp) - ! -- Create a time series link and add it to the package - ! list of time series links used by the array. - if (associated(timeseries)) then - ! -- Assign value from time series to current - ! array element - r = timeseries%GetValue(totimsav, totim) - bndElem = r - ! Look to see if this array element already has a time series - ! linked to it. If not, make a link to it. - nlinks = tsManager%CountLinks(auxOrBnd) - found = .false. - searchlinks: do i=1,nlinks - tslTemp => tsManager%GetLink(auxOrBnd, i) - if (tslTemp%PackageName == pkgName) then - ! -- Check ii, jj against iRow, jCol stored in link - if (tslTemp%IRow==ii .and. tslTemp%JCol==jj) then - ! -- This array element is already linked to a time series. - tsLink => tslTemp - found = .true. - exit searchlinks - endif - endif - enddo searchlinks - if (.not. found) then - ! -- Link was not found. Make one and add it to the list. - call tsManager%make_link(timeseries, pkgName, auxOrBnd, bndElem, & - ii, jj, iprpak, tsLink, '', '') - endif - else - ermsg = 'Error in list input. Expected numeric value or ' // & - 'time-series name, but found: ' // trim(textInput) - call store_error(ermsg) - endif - endif - end subroutine read_value_or_time_series - - subroutine read_single_value_or_time_series(textInput, bndElem, name, endtim,& - pkgName, auxOrBnd, tsManager, & - iprpak, ii, jj, linkText, & - bndName, inunit) -! ****************************************************************************** -! read_single_value_or_time_series -- -! Call this subroutine if the time-series link is NOT available or -! needed and if you need to select the link by its Text member. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - character(len=*), intent(in) :: textInput - real(DP), pointer, intent(inout) :: bndElem - character (len=*), intent(inout) :: name - real(DP), intent(in) :: endtim - character(len=*), intent(in) :: pkgName - character(len=3), intent(in) :: auxOrBnd - type(TimeSeriesManagerType), intent(inout) :: tsManager - integer(I4B), intent(in) :: iprpak - integer(I4B), intent(in) :: ii - integer(I4B), intent(in) :: jj - character(len=*), intent(in) :: linkText - character(len=*), intent(in) :: bndName - integer(I4B), intent(in) :: inunit - ! -- local - integer(I4B) :: i, istat, nlinks - real(DP) :: v - character(len=LINELENGTH) :: ermsg - character(len=LENTIMESERIESNAME) :: tsNameTemp - logical :: found - integer(I4B) :: removeLink - type(TimeSeriesType), pointer :: timeseries => null() - type(TimeSeriesLinkType), pointer :: tslTemp => null() - type(TimeSeriesLinkType), pointer :: tsLink => null() -! ------------------------------------------------------------------------------ - ! - name = '' - read (textInput, *, iostat=istat) v - if (istat == 0) then - ! Numeric value was successfully read. - bndElem = v - ! Look to see if this array element already has a time series - ! linked to it. If so, remove the link. - nlinks = tsManager%CountLinks(auxOrBnd) - found = .false. - removeLink = -1 - csearchlinks: do i=1,nlinks - tslTemp => tsManager%GetLink(auxOrBnd, i) - if (tslTemp%PackageName == pkgName) then - ! -- Check ii against iRow, linkText against Text member of link - if (tslTemp%IRow==ii .and. same_word(tslTemp%Text,linkText)) then - ! -- This array element is already linked to a time series. - found = .true. - removeLink = i - exit csearchlinks - endif - endif - enddo csearchlinks - if (found) then - if (removeLink > 0) then - if (auxOrBnd == 'BND') then - call tsManager%boundTsLinks%RemoveNode(removeLink, .true.) - else if (auxOrBnd == 'AUX') then - call tsManager%auxvarTsLinks%RemoveNode(removeLink, .true.) - end if - end if - end if - else - ! Attempt to read numeric value from textInput failed. - ! Text should be a time-series name. - tsNameTemp = textInput - call UPCASE(tsNameTemp) - ! -- If textInput is a time-series name, get average value - ! from time series. - timeseries => tsManager%get_time_series(tsNameTemp) - ! -- Create a time series link and add it to the package - ! list of time series links used by the array. - if (associated(timeseries)) then - ! -- Assign average value from time series to current - ! array element - v = timeseries%GetValue(totim, endtim) - bndElem = v - name = tsNameTemp - ! Look to see if this array element already has a time series - ! linked to it. If not, make a link to it. - nlinks = tsManager%CountLinks(auxOrBnd) - found = .false. - removeLink = -1 - searchlinks: do i=1,nlinks - tslTemp => tsManager%GetLink(auxOrBnd, i) - if (tslTemp%PackageName == pkgName) then - ! -- Check ii against iRow, linkText against Text member of link - if (tslTemp%IRow==ii .and. same_word(tslTemp%Text,linkText)) then - if (tslTemp%timeseries%name==tsNameTemp) then - ! -- This array element is already linked to a time series. - found = .true. - exit searchlinks - else - if (tslTemp%auxOrBnd == auxOrBnd) then - removeLink = i - end if - end if - endif - endif - enddo searchlinks - if (.not. found) then - if (removeLink > 0) then - if (auxOrBnd == 'BND') then - call tsManager%boundTsLinks%RemoveNode(removeLink, .true.) - else if (auxOrBnd == 'AUX') then - call tsManager%auxvarTsLinks%RemoveNode(removeLink, .true.) - end if - end if - ! -- Link was not found. Make one and add it to the list. - call tsManager%make_link(timeseries, pkgName, auxOrBnd, bndElem, & - ii, jj, iprpak, tsLink, linkText, bndName) - !! -- update array element - !v = timeseries%GetValue(totim, endtim) - !bndElem = v - endif - else - ermsg = 'Error in list input. Expected numeric value or ' // & - 'time-series name, but found: ' // trim(textInput) - call store_error(ermsg) - call store_error_unit(inunit) - call ustop() - end if - end if - return - end subroutine read_single_value_or_time_series - -end module TimeSeriesManagerModule +module TimeSeriesManagerModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, LENPACKAGENAME, MAXCHARLEN, & + LINELENGTH, LENTIMESERIESNAME + use HashTableModule, only: HashTableType + use InputOutputModule, only: same_word, UPCASE + use ListModule, only: ListType + use SimModule, only: store_error, store_error_unit, ustop + use TdisModule, only: delt, kper, kstp, totim, totimc, & + totimsav + use TimeSeriesFileListModule, only: TimeSeriesFileListType + use TimeSeriesLinkModule, only: TimeSeriesLinkType, & + ConstructTimeSeriesLink, & + GetTimeSeriesLinkFromList, & + AddTimeSeriesLinkToList + use TimeSeriesModule, only: TimeSeriesContainerType, & + TimeSeriesFileType, & + TimeSeriesType + + implicit none + + private + public :: TimeSeriesManagerType, read_value_or_time_series, & + read_single_value_or_time_series, tsmanager_cr + + type TimeSeriesManagerType + integer(I4B), public :: iout = 0 ! output unit number + type(TimeSeriesFileListType), pointer, public :: tsfileList => null() ! list of ts files objs + type(ListType), pointer, public :: boundTsLinks => null() ! links to bound and aux + integer(I4B) :: numtsfiles = 0 ! number of ts files + character(len=MAXCHARLEN), allocatable, dimension(:) :: tsfiles ! list of ts files + type(ListType), pointer, private :: auxvarTsLinks => null() ! list of aux links + type(HashTableType), private :: BndTsHashTable ! hash of ts to tsobj + type(TimeSeriesContainerType), allocatable, dimension(:), & + private :: TsContainers + contains + ! -- Public procedures + procedure, public :: tsmanager_df + procedure, public :: ad => tsmgr_ad + procedure, public :: da => tsmgr_da + procedure, public :: add_tsfile + procedure, public :: CountLinks + procedure, public :: GetLink + procedure, public :: Reset + procedure, public :: HashBndTimeSeries + ! -- Private procedures + procedure, private :: get_time_series + procedure, private :: make_link + end type TimeSeriesManagerType + + contains + + subroutine tsmanager_cr(this, iout) +! ****************************************************************************** +! tsmanager_cr -- create the tsmanager +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + type(TimeSeriesManagerType) :: this + integer(I4B), intent(in) :: iout +! ------------------------------------------------------------------------------ + ! + this%iout = iout + allocate(this%boundTsLinks) + allocate(this%auxvarTsLinks) + allocate(this%tsfileList) + allocate(this%tsfiles(1000)) + ! + return + end subroutine tsmanager_cr + + subroutine tsmanager_df(this) +! ****************************************************************************** +! tsmanager_df -- define +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TimeSeriesManagerType) :: this +! ------------------------------------------------------------------------------ + ! + if (this%numtsfiles > 0) then + call this%HashBndTimeSeries(this%numtsfiles) + endif + ! + ! -- return + return + end subroutine tsmanager_df + + subroutine add_tsfile(this, fname, inunit) +! ****************************************************************************** +! add_tsfile -- add a time series file to this manager +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimModule, only: store_error, store_error_unit, ustop + use ArrayHandlersModule, only: ExpandArray + ! -- dummy + class(TimeSeriesManagerType) :: this + character(len=*), intent(in) :: fname + integer(I4B), intent(in) :: inunit + ! -- local + integer(I4B) :: isize + integer(I4B) :: i + class(TimeSeriesFileType), pointer :: tsfile => null() +! ------------------------------------------------------------------------------ + ! + ! -- Check for fname duplicates + if (this%numtsfiles > 0) then + do i = 1, this%numtsfiles + if (this%tsfiles(i) == fname) then + call store_error('Found duplicate time-series file name: ' // trim(fname)) + call store_error_unit(inunit) + call ustop() + endif + enddo + endif + ! + ! -- Save fname + this%numtsfiles = this%numtsfiles + 1 + isize = size(this%tsfiles) + if (this%numtsfiles > isize) then + call ExpandArray(this%tsfiles, 1000) + endif + this%tsfiles(this%numtsfiles) = fname + ! + ! -- + call this%tsfileList%Add(fname, this%iout, tsfile) + ! + return + end subroutine add_tsfile + + subroutine tsmgr_ad(this) +! ****************************************************************************** +! tsmgr_ad -- time step (or subtime step) advance. Call this each time step or +! subtime step. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesManagerType) :: this + ! -- local + type(TimeSeriesLinkType), pointer :: tsLink => null() + type(TimeSeriesType), pointer :: timeseries => null() + integer(I4B) :: i, nlinks, nauxlinks + real(DP) :: begintime, endtime + character(len=LENPACKAGENAME+2) :: pkgID + ! formats + character(len=*),parameter :: fmt5 = & + &"(/,'Time-series controlled values in stress period: ', i0, & + &', time step ', i0, ':')" + 10 format(a,' package: Boundary ',i0,', entry ',i0, ' value from time series "',a,'" = ',g12.5) + 15 format(a,' package: Boundary ',i0,', entry ',i0,' value from time series "',a,'" = ',g12.5,' (',a,')') + 20 format(a,' package: Boundary ',i0,', ',a,' value from time series "',a,'" = ',g12.5) + 25 format(a,' package: Boundary ',i0,', ',a,' value from time series "',a,'" = ',g12.5,' (',a,')') +! ------------------------------------------------------------------------------ + ! + ! -- Initialize time variables + begintime = totimc + endtime = begintime + delt + ! + ! -- Determine number of ts links + nlinks = this%boundtslinks%Count() + nauxlinks = this%auxvartslinks%Count() + ! + ! -- Iterate through auxvartslinks and replace specified + ! elements of auxvar with average value obtained from + ! appropriate time series. Need to do auxvartslinks + ! first because they may be a multiplier column + do i = 1, nauxlinks + tsLink => GetTimeSeriesLinkFromList(this%auxvarTsLinks, i) + timeseries => tsLink%timeSeries + if (i == 1) then + if (tsLink%Iprpak == 1) then + write(this%iout, fmt5) kper, kstp + endif + endif + tsLink%BndElement = timeseries%GetValue(begintime, endtime) + ! + ! -- Write time series values to output file + if (tsLink%Iprpak == 1) then + pkgID = '"' // trim(tsLink%PackageName) // '"' + if (tsLink%Text == '') then + if (tsLink%BndName == '') then + write(this%iout,10)trim(pkgID), tsLink%IRow, tsLink%JCol, & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement + else + write(this%iout,15)trim(pkgID), tsLink%IRow, tsLink%JCol, & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement, trim(tsLink%BndName) + endif + else + if (tsLink%BndName == '') then + write(this%iout,20)trim(pkgID), tsLink%IRow, trim(tsLink%Text), & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement + else + write(this%iout,25)trim(pkgID), tsLink%IRow, trim(tsLink%Text), & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement, trim(tsLink%BndName) + endif + endif + endif + enddo + ! + ! -- Iterate through boundtslinks and replace specified + ! elements of bound with average value obtained from + ! appropriate time series. (For list-type packages) + do i = 1, nlinks + tsLink => GetTimeSeriesLinkFromList(this%boundTsLinks, i) + if (i == 1 .and. nauxlinks == 0) then + if (tsLink%Iprpak == 1) then + write(this%iout, fmt5) kper, kstp + endif + endif + ! this part needs to be different for MAW because MAW does not use + ! bound array for well rate (although rate is stored in + ! this%bound(4,ibnd)), it uses this%mawwells(n)%rate%value + if (tsLink%UseDefaultProc) then + timeseries => tsLink%timeSeries + tsLink%BndElement = timeseries%GetValue(begintime, endtime) + ! + ! -- If multiplier is active and it applies to this element, + ! do the multiplication. This must be done after the auxlinks + ! have been calculated in case iauxmultcol is being used. + if (associated(tsLink%RMultiplier)) then + tsLink%BndElement = tsLink%BndElement * tsLink%RMultiplier + endif + ! + ! -- Write time series values to output files + if (tsLink%Iprpak == 1) then + pkgID = '"' // trim(tsLink%PackageName) // '"' + if (tsLink%Text == '') then + if (tsLink%BndName == '') then + write(this%iout,10)trim(pkgID), tsLink%IRow, tsLink%JCol, & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement + else + write(this%iout,15)trim(pkgID), tsLink%IRow, tsLink%JCol, & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement, trim(tsLink%BndName) + endif + else + if (tsLink%BndName == '') then + write(this%iout,20)trim(pkgID), tsLink%IRow, trim(tsLink%Text), & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement + else + write(this%iout,25)trim(pkgID), tsLink%IRow, trim(tsLink%Text), & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement, trim(tsLink%BndName) + endif + endif + endif + ! + ! -- If conversion from flux to flow is required, multiply by cell area + if (tsLink%ConvertFlux) then + tsLink%BndElement = tsLink%BndElement * tsLink%CellArea + endif + endif + enddo + ! + ! -- Finish with ending line + if (nlinks + nauxlinks > 0) then + if (tsLink%Iprpak == 1) then + write(this%iout,'()') + endif + end if + ! + return + end subroutine tsmgr_ad + + subroutine tsmgr_da(this) +! ****************************************************************************** +! tsmgr_da -- deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesManagerType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Deallocate time-series links in boundTsLinks + call this%boundTsLinks%Clear(.true.) + deallocate(this%boundTsLinks) + ! + ! -- Deallocate time-series links in auxvarTsLinks + call this%auxvarTsLinks%Clear(.true.) + deallocate(this%auxvarTsLinks) + ! + ! -- Deallocate tsfileList + call this%tsfileList%da() + deallocate(this%tsfileList) + ! + ! -- Deallocate the hash table + call this%BndTsHashTable%FreeHash() + ! + deallocate(this%tsfiles) + ! + return + end subroutine tsmgr_da + + subroutine Reset(this, pkgName) +! ****************************************************************************** +! reset -- Call this when a new BEGIN PERIOD block is read for a new stress +! period. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesManagerType) :: this + character(len=*), intent(in) :: pkgName + ! -- local + integer(I4B) :: i, nlinks + type(TimeSeriesLinkType), pointer :: tslink +! ------------------------------------------------------------------------------ + ! Zero out values for time-series controlled stresses. + ! Also deallocate all tslinks too. + ! Then when time series are + ! specified in this or another stress period, + ! a new tslink would be set up. + ! + ! Reassign all linked elements to zero + nlinks = this%boundTsLinks%Count() + do i=1,nlinks + tslink => GetTimeSeriesLinkFromList(this%boundTsLinks, i) + if (associated(tslink)) then + if (tslink%PackageName == pkgName) then + tslink%BndElement = DZERO + endif + endif + enddo + ! + ! Remove links belonging to calling package + nlinks = this%boundTsLinks%Count() + do i=nlinks,1,-1 + tslink => GetTimeSeriesLinkFromList(this%boundTsLinks, i) + if (associated(tslink)) then + if (tslink%PackageName == pkgName) then + call this%boundTsLinks%RemoveNode(i, .true.) + endif + endif + enddo + nlinks = this%auxvarTsLinks%Count() + do i=nlinks,1,-1 + tslink => GetTimeSeriesLinkFromList(this%auxvarTsLinks,i) + if (associated(tslink)) then + if (tslink%PackageName == pkgName) then + call this%auxvarTsLinks%RemoveNode(i, .true.) + endif + endif + enddo + ! + return + end subroutine Reset + + subroutine make_link(this, timeSeries, pkgName, auxOrBnd, bndElem, & + irow, jcol, iprpak, tsLink, text, bndName) +! ****************************************************************************** +! make_link -- +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesManagerType), intent(inout) :: this + type(TimeSeriesType), pointer, intent(inout) :: timeSeries + character(len=*), intent(in) :: pkgName + character(len=3), intent(in) :: auxOrBnd + real(DP), pointer, intent(inout) :: bndElem + integer(I4B), intent(in) :: irow, jcol + integer(I4B), intent(in) :: iprpak + type(TimeSeriesLinkType), pointer, intent(inout) :: tsLink + character(len=*), intent(in) :: text + character(len=*), intent(in) :: bndName + ! -- local +! ------------------------------------------------------------------------------ + ! + tsLink => null() + call ConstructTimeSeriesLink(tsLink, timeSeries, pkgName, & + auxOrBnd, bndElem, irow, jcol, iprpak) + if (associated(tsLink)) then + if (auxOrBnd == 'BND') then + call AddTimeSeriesLinkToList(this%boundTsLinks, tsLink) + elseif (auxOrBnd == 'AUX') then + call AddTimeSeriesLinkToList(this%auxvarTsLinks, tsLink) + else + call ustop('programmer error in make_link') + endif + tsLink%Text = text + tsLink%BndName = bndName + endif + ! + return + end subroutine make_link + + function GetLink(this, auxOrBnd, indx) result(tsLink) +! ****************************************************************************** +! GetLink -- +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesManagerType) :: this + character(len=3), intent(in) :: auxOrBnd + integer(I4B), intent(in) :: indx + type(TimeSeriesLinkType), pointer :: tsLink + ! -- local + type(ListType), pointer :: list +! ------------------------------------------------------------------------------ + ! + list => null() + tsLink => null() + ! + select case (auxOrBnd) + case ('AUX') + list => this%auxvarTsLinks + case ('BND') + list => this%boundTsLinks + end select + ! + if (associated(list)) then + tsLink => GetTimeSeriesLinkFromList(list, indx) + endif + ! + return + end function GetLink + + function CountLinks(this, auxOrBnd) +! ****************************************************************************** +! CountLinks -- +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- return + integer(I4B) :: CountLinks + ! -- dummy + class(TimeSeriesManagerType) :: this + character(len=3), intent(in) :: auxOrBnd +! ------------------------------------------------------------------------------ + ! + CountLinks = 0 + if (auxOrBnd == 'BND') then + CountLinks = this%boundTsLinks%Count() + elseif (auxOrBnd == 'AUX') then + CountLinks = this%auxvarTsLinks%count() + endif + ! + return + end function CountLinks + + function get_time_series(this, name) result (res) +! ****************************************************************************** +! get_time_series -- +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TimeSeriesManagerType) :: this + character(len=*), intent(in) :: name + ! -- result + type(TimeSeriesType), pointer :: res + ! -- local + integer(I4B) :: indx +! ------------------------------------------------------------------------------ + ! + ! Get index from hash table, get time series from TsContainers, + ! and assign result to time series contained in link. + res => null() + call this%BndTsHashTable%GetHash(name, indx) + if (indx > 0) then + res => this%TsContainers(indx)%timeSeries + endif + ! + return + end function get_time_series + + subroutine HashBndTimeSeries(this, ivecsize) +! ****************************************************************************** +! HashBndTimeSeries -- +! Store all boundary (stress) time series links in +! TsContainers and construct hash table BndTsHashTable. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class (TimeSeriesManagerType), intent(inout) :: this + integer(I4B), intent(in) :: ivecsize + ! -- local + integer(I4B) :: i, j, k, numtsfiles, numts + character(len=LENTIMESERIESNAME) :: name + type(TimeSeriesFileType), pointer :: tsfile => null() +! ------------------------------------------------------------------------------ + ! + ! Initialize the hash table + call this%BndTsHashTable%InitHash(ivecsize) + ! + ! Allocate the TsContainers array to accommodate all time-series links. + numts = this%tsfileList%CountTimeSeries() + allocate(this%TsContainers(numts)) + ! + ! Store a pointer to each time series in the TsContainers array + ! and put its key (time-series name) and index in the hash table. + numtsfiles = this%tsfileList%Counttsfiles() + k = 0 + do i = 1, numtsfiles + tsfile => this%tsfileList%Gettsfile(i) + numts = tsfile%Count() + do j=1,numts + k = k + 1 + this%TsContainers(k)%timeSeries => tsfile%GetTimeSeries(j) + if (associated(this%TsContainers(k)%timeSeries)) then + name = this%TsContainers(k)%timeSeries%Name + call this%BndTsHashTable%PutHash(name, k) + endif + enddo + enddo + ! + return + end subroutine HashBndTimeSeries + + ! -- Non-type-bound procedures + + subroutine read_value_or_time_series(textInput, ii, jj, bndElem, & + pkgName, auxOrBnd, tsManager, iprpak, tsLink) +! ****************************************************************************** +! read_value_or_time_series -- +! Call this subroutine if the time-series link is available or needed. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + character(len=*), intent(in) :: textInput + integer(I4B), intent(in) :: ii + integer(I4B), intent(in) :: jj + real(DP), pointer, intent(inout) :: bndElem + character(len=*), intent(in) :: pkgName + character(len=3), intent(in) :: auxOrBnd + type(TimeSeriesManagerType), intent(inout) :: tsManager + integer(I4B), intent(in) :: iprpak + type(TimeSeriesLinkType), pointer, intent(inout) :: tsLink + ! -- local + type(TimeSeriesType), pointer :: timeseries => null() + type(TimeSeriesLinkType), pointer :: tslTemp => null() + integer(I4B) :: i, istat, nlinks + real(DP) :: r + character(len=LINELENGTH) :: ermsg + character(len=LENTIMESERIESNAME) :: tsNameTemp + logical :: found +! ------------------------------------------------------------------------------ + ! + read (textInput,*,iostat=istat) r + if (istat == 0) then + bndElem = r + else + tsNameTemp = textInput + call UPCASE(tsNameTemp) + ! -- If text is a time-series name, get value + ! from time series. + timeseries => tsManager%get_time_series(tsNameTemp) + ! -- Create a time series link and add it to the package + ! list of time series links used by the array. + if (associated(timeseries)) then + ! -- Assign value from time series to current + ! array element + r = timeseries%GetValue(totimsav, totim) + bndElem = r + ! Look to see if this array element already has a time series + ! linked to it. If not, make a link to it. + nlinks = tsManager%CountLinks(auxOrBnd) + found = .false. + searchlinks: do i=1,nlinks + tslTemp => tsManager%GetLink(auxOrBnd, i) + if (tslTemp%PackageName == pkgName) then + ! -- Check ii, jj against iRow, jCol stored in link + if (tslTemp%IRow==ii .and. tslTemp%JCol==jj) then + ! -- This array element is already linked to a time series. + tsLink => tslTemp + found = .true. + exit searchlinks + endif + endif + enddo searchlinks + if (.not. found) then + ! -- Link was not found. Make one and add it to the list. + call tsManager%make_link(timeseries, pkgName, auxOrBnd, bndElem, & + ii, jj, iprpak, tsLink, '', '') + endif + else + ermsg = 'Error in list input. Expected numeric value or ' // & + 'time-series name, but found: ' // trim(textInput) + call store_error(ermsg) + endif + endif + end subroutine read_value_or_time_series + + subroutine read_single_value_or_time_series(textInput, bndElem, name, endtim,& + pkgName, auxOrBnd, tsManager, & + iprpak, ii, jj, linkText, & + bndName, inunit) +! ****************************************************************************** +! read_single_value_or_time_series -- +! Call this subroutine if the time-series link is NOT available or +! needed and if you need to select the link by its Text member. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + character(len=*), intent(in) :: textInput + real(DP), pointer, intent(inout) :: bndElem + character (len=*), intent(inout) :: name + real(DP), intent(in) :: endtim + character(len=*), intent(in) :: pkgName + character(len=3), intent(in) :: auxOrBnd + type(TimeSeriesManagerType), intent(inout) :: tsManager + integer(I4B), intent(in) :: iprpak + integer(I4B), intent(in) :: ii + integer(I4B), intent(in) :: jj + character(len=*), intent(in) :: linkText + character(len=*), intent(in) :: bndName + integer(I4B), intent(in) :: inunit + ! -- local + integer(I4B) :: i, istat, nlinks + real(DP) :: v + character(len=LINELENGTH) :: ermsg + character(len=LENTIMESERIESNAME) :: tsNameTemp + logical :: found + integer(I4B) :: removeLink + type(TimeSeriesType), pointer :: timeseries => null() + type(TimeSeriesLinkType), pointer :: tslTemp => null() + type(TimeSeriesLinkType), pointer :: tsLink => null() +! ------------------------------------------------------------------------------ + ! + name = '' + read (textInput, *, iostat=istat) v + if (istat == 0) then + ! Numeric value was successfully read. + bndElem = v + ! Look to see if this array element already has a time series + ! linked to it. If so, remove the link. + nlinks = tsManager%CountLinks(auxOrBnd) + found = .false. + removeLink = -1 + csearchlinks: do i=1,nlinks + tslTemp => tsManager%GetLink(auxOrBnd, i) + if (tslTemp%PackageName == pkgName) then + ! -- Check ii against iRow, linkText against Text member of link + if (tslTemp%IRow==ii .and. same_word(tslTemp%Text,linkText)) then + ! -- This array element is already linked to a time series. + found = .true. + removeLink = i + exit csearchlinks + endif + endif + enddo csearchlinks + if (found) then + if (removeLink > 0) then + if (auxOrBnd == 'BND') then + call tsManager%boundTsLinks%RemoveNode(removeLink, .true.) + else if (auxOrBnd == 'AUX') then + call tsManager%auxvarTsLinks%RemoveNode(removeLink, .true.) + end if + end if + end if + else + ! Attempt to read numeric value from textInput failed. + ! Text should be a time-series name. + tsNameTemp = textInput + call UPCASE(tsNameTemp) + ! -- If textInput is a time-series name, get average value + ! from time series. + timeseries => tsManager%get_time_series(tsNameTemp) + ! -- Create a time series link and add it to the package + ! list of time series links used by the array. + if (associated(timeseries)) then + ! -- Assign average value from time series to current + ! array element + v = timeseries%GetValue(totim, endtim) + bndElem = v + name = tsNameTemp + ! Look to see if this array element already has a time series + ! linked to it. If not, make a link to it. + nlinks = tsManager%CountLinks(auxOrBnd) + found = .false. + removeLink = -1 + searchlinks: do i=1,nlinks + tslTemp => tsManager%GetLink(auxOrBnd, i) + if (tslTemp%PackageName == pkgName) then + ! -- Check ii against iRow, linkText against Text member of link + if (tslTemp%IRow==ii .and. same_word(tslTemp%Text,linkText)) then + if (tslTemp%timeseries%name==tsNameTemp) then + ! -- This array element is already linked to a time series. + found = .true. + exit searchlinks + else + if (tslTemp%auxOrBnd == auxOrBnd) then + removeLink = i + end if + end if + endif + endif + enddo searchlinks + if (.not. found) then + if (removeLink > 0) then + if (auxOrBnd == 'BND') then + call tsManager%boundTsLinks%RemoveNode(removeLink, .true.) + else if (auxOrBnd == 'AUX') then + call tsManager%auxvarTsLinks%RemoveNode(removeLink, .true.) + end if + end if + ! -- Link was not found. Make one and add it to the list. + call tsManager%make_link(timeseries, pkgName, auxOrBnd, bndElem, & + ii, jj, iprpak, tsLink, linkText, bndName) + !! -- update array element + !v = timeseries%GetValue(totim, endtim) + !bndElem = v + endif + else + ermsg = 'Error in list input. Expected numeric value or ' // & + 'time-series name, but found: ' // trim(textInput) + call store_error(ermsg) + call store_error_unit(inunit) + call ustop() + end if + end if + return + end subroutine read_single_value_or_time_series + +end module TimeSeriesManagerModule diff --git a/src/Utilities/Timer.f90 b/src/Utilities/Timer.f90 index 447037022e4..5e4d33dc44c 100644 --- a/src/Utilities/Timer.f90 +++ b/src/Utilities/Timer.f90 @@ -1,194 +1,194 @@ -module TimerModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH, DZERO - use GenericUtilitiesModule, only: sim_message - implicit none - private - public :: start_time - public :: elapsed_time - public :: code_timer - integer(I4B), dimension(8) :: ibdt - - contains - - subroutine start_time() -! ****************************************************************************** -! Start simulation timer -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - ! -- local - character(len=LINELENGTH) :: line - integer(I4B) :: i - ! -- format - character(len=*), parameter :: fmtdt = & - "(1X,'Run start date and time (yyyy/mm/dd hh:mm:ss): ', & - &I4,'/',I2.2,'/',I2.2,1X,I2,':',I2.2,':',I2.2)" -! ------------------------------------------------------------------------------ - ! - ! -- Get current date and time, assign to IBDT, and write to screen - call date_and_time(values=ibdt) - write(line, fmtdt) (ibdt(i), i = 1, 3), (ibdt(i), i = 5, 7) - call sim_message(line, skipafter=1) - ! - ! -- return - return - end subroutine start_time - - SUBROUTINE elapsed_time(iout, iprtim) -! ****************************************************************************** -! Get end time and calculate elapsed time -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - integer(i4b), intent(in) :: iout - integer(I4B), intent(in) :: iprtim - ! -- local - character(len=LINELENGTH) :: line - INTEGER(I4B) :: IEDT(8), IDPM(12) - integer(I4B) :: NSPD - integer(I4B) :: i - integer(I4B) :: ndays, leap, ibd, ied, mb, me, nm, mc, m - integer(I4B) :: nhours, nmins, nsecs, msecs, nrsecs - real(DP) :: elsec, rsecs - DATA IDPM/31,28,31,30,31,30,31,31,30,31,30,31/ ! Days per month - DATA NSPD/86400/ ! Seconds per day - ! -- format - character(len=*), parameter :: fmtdt = & - "(1X,'Run end date and time (yyyy/mm/dd hh:mm:ss): ', & - &I4,'/',I2.2,'/',I2.2,1X,I2,':',I2.2,':',I2.2)" -! ------------------------------------------------------------------------------ -! -! Get current date and time, assign to IEDT, and write. - CALL DATE_AND_TIME(VALUES=IEDT) - ! - ! -- write elapsed time to stdout - write(line,fmtdt) (IEDT(I),I=1,3),(IEDT(I),I=5,7) - call sim_message(line, skipbefore=1) - ! - ! -- write elapsted time to iout - IF(IPRTIM.GT.0) THEN - call sim_message(line, iunit=iout, skipbefore=1) - END IF -! -! Calculate elapsed time in days and seconds - NDAYS=0 - LEAP=0 - IF (MOD(IEDT(1),4).EQ.0) LEAP = 1 - IBD = IBDT(3) ! BEGIN DAY - IED = IEDT(3) ! END DAY -! FIND DAYS - IF (IBDT(2).NE.IEDT(2)) THEN -! MONTHS DIFFER - MB = IBDT(2) ! BEGIN MONTH - ME = IEDT(2) ! END MONTH - NM = ME-MB+1 ! NUMBER OF MONTHS TO LOOK AT - IF (MB.GT.ME) NM = NM+12 - MC=MB-1 - DO M=1,NM - MC=MC+1 ! MC IS CURRENT MONTH - IF (MC.EQ.13) MC = 1 - IF (MC.EQ.MB) THEN - NDAYS = NDAYS+IDPM(MC)-IBD - IF (MC.EQ.2) NDAYS = NDAYS + LEAP - ELSEIF (MC.EQ.ME) THEN - NDAYS = NDAYS+IED - ELSE - NDAYS = NDAYS+IDPM(MC) - IF (MC.EQ.2) NDAYS = NDAYS + LEAP - ENDIF - ENDDO - ELSEIF (IBD.LT.IED) THEN -! START AND END IN SAME MONTH, ONLY ACCOUNT FOR DAYS - NDAYS = IED-IBD - ENDIF - ELSEC=NDAYS*NSPD -! -! ADD OR SUBTRACT SECONDS - ELSEC = ELSEC+(IEDT(5)-IBDT(5))*3600.0 - ELSEC = ELSEC+(IEDT(6)-IBDT(6))*60.0 - ELSEC = ELSEC+(IEDT(7)-IBDT(7)) - ELSEC = ELSEC+(IEDT(8)-IBDT(8))*0.001 -! -! CONVERT SECONDS TO DAYS, HOURS, MINUTES, AND SECONDS - NDAYS = ELSEC/NSPD - RSECS = MOD(ELSEC, 86400.0_DP) - NHOURS = RSECS/3600.0 - RSECS = MOD(RSECS,3600.0_DP) - NMINS = RSECS/60.0 - RSECS = MOD(RSECS,60.0_DP) - NSECS = RSECS - RSECS = MOD(RSECS,1.0_DP) - MSECS = NINT(RSECS*1000.0) - NRSECS = NSECS - IF (RSECS.GE.0.5) NRSECS=NRSECS+1 -! -! Write elapsed time to screen - IF (NDAYS.GT.0) THEN - WRITE(line, 1010) NDAYS,NHOURS,NMINS,NRSECS - 1010 FORMAT(1X,'Elapsed run time: ',I3,' Days, ',I2,' Hours, ',I2, & - ' Minutes, ',I2,' Seconds') - ELSEIF (NHOURS.GT.0) THEN - WRITE(line, 1020) NHOURS,NMINS,NRSECS - 1020 FORMAT(1X,'Elapsed run time: ',I2,' Hours, ',I2, & - ' Minutes, ',I2,' Seconds') - ELSEIF (NMINS.GT.0) THEN - WRITE(line, 1030) NMINS,NSECS,MSECS - 1030 FORMAT(1X,'Elapsed run time: ',I2,' Minutes, ', & - I2,'.',I3.3,' Seconds') - ELSE - WRITE(line, 1040) NSECS,MSECS - 1040 FORMAT(1X,'Elapsed run time: ',I2,'.',I3.3,' Seconds') - ENDIF - call sim_message(line, skipafter=1) -! -! Write times to file if requested - IF(IPRTIM.GT.0) THEN - IF (NDAYS.GT.0) THEN - WRITE(IOUT,1010) NDAYS,NHOURS,NMINS,NRSECS - ELSEIF (NHOURS.GT.0) THEN - WRITE(IOUT,1020) NHOURS,NMINS,NRSECS - ELSEIF (NMINS.GT.0) THEN - WRITE(IOUT,1030) NMINS,NSECS,MSECS - ELSE - WRITE(IOUT,1040) NSECS,MSECS - ENDIF - ENDIF -! - RETURN - END SUBROUTINE elapsed_time - -! -!-------TIMER FOR SUBROUTINES - SUBROUTINE code_timer(it, t1, ts) -! ****************************************************************************** -! Get end time and calculate elapsed time -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - INTEGER(I4B), INTENT(IN) :: it - REAL(DP), INTENT(INOUT) :: t1 - REAL(DP), INTENT(INOUT) :: ts - ! -- local - REAL(DP) :: dt -! ------------------------------------------------------------------------------ - ! - IF (IT == 0) THEN - call CPU_TIME(t1) - ELSE - call CPU_TIME(dt) - ts = ts + dt - t1 - END IF - ! - ! -- RETURN - RETURN - END SUBROUTINE code_timer - -end module TimerModule +module TimerModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: LINELENGTH, DZERO + use GenericUtilitiesModule, only: sim_message + implicit none + private + public :: start_time + public :: elapsed_time + public :: code_timer + integer(I4B), dimension(8) :: ibdt + + contains + + subroutine start_time() +! ****************************************************************************** +! Start simulation timer +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + ! -- local + character(len=LINELENGTH) :: line + integer(I4B) :: i + ! -- format + character(len=*), parameter :: fmtdt = & + "(1X,'Run start date and time (yyyy/mm/dd hh:mm:ss): ', & + &I4,'/',I2.2,'/',I2.2,1X,I2,':',I2.2,':',I2.2)" +! ------------------------------------------------------------------------------ + ! + ! -- Get current date and time, assign to IBDT, and write to screen + call date_and_time(values=ibdt) + write(line, fmtdt) (ibdt(i), i = 1, 3), (ibdt(i), i = 5, 7) + call sim_message(line, skipafter=1) + ! + ! -- return + return + end subroutine start_time + + SUBROUTINE elapsed_time(iout, iprtim) +! ****************************************************************************** +! Get end time and calculate elapsed time +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + integer(i4b), intent(in) :: iout + integer(I4B), intent(in) :: iprtim + ! -- local + character(len=LINELENGTH) :: line + INTEGER(I4B) :: IEDT(8), IDPM(12) + integer(I4B) :: NSPD + integer(I4B) :: i + integer(I4B) :: ndays, leap, ibd, ied, mb, me, nm, mc, m + integer(I4B) :: nhours, nmins, nsecs, msecs, nrsecs + real(DP) :: elsec, rsecs + DATA IDPM/31,28,31,30,31,30,31,31,30,31,30,31/ ! Days per month + DATA NSPD/86400/ ! Seconds per day + ! -- format + character(len=*), parameter :: fmtdt = & + "(1X,'Run end date and time (yyyy/mm/dd hh:mm:ss): ', & + &I4,'/',I2.2,'/',I2.2,1X,I2,':',I2.2,':',I2.2)" +! ------------------------------------------------------------------------------ +! +! Get current date and time, assign to IEDT, and write. + CALL DATE_AND_TIME(VALUES=IEDT) + ! + ! -- write elapsed time to stdout + write(line,fmtdt) (IEDT(I),I=1,3),(IEDT(I),I=5,7) + call sim_message(line, skipbefore=1) + ! + ! -- write elapsted time to iout + IF(IPRTIM.GT.0) THEN + call sim_message(line, iunit=iout, skipbefore=1) + END IF +! +! Calculate elapsed time in days and seconds + NDAYS=0 + LEAP=0 + IF (MOD(IEDT(1),4).EQ.0) LEAP = 1 + IBD = IBDT(3) ! BEGIN DAY + IED = IEDT(3) ! END DAY +! FIND DAYS + IF (IBDT(2).NE.IEDT(2)) THEN +! MONTHS DIFFER + MB = IBDT(2) ! BEGIN MONTH + ME = IEDT(2) ! END MONTH + NM = ME-MB+1 ! NUMBER OF MONTHS TO LOOK AT + IF (MB.GT.ME) NM = NM+12 + MC=MB-1 + DO M=1,NM + MC=MC+1 ! MC IS CURRENT MONTH + IF (MC.EQ.13) MC = 1 + IF (MC.EQ.MB) THEN + NDAYS = NDAYS+IDPM(MC)-IBD + IF (MC.EQ.2) NDAYS = NDAYS + LEAP + ELSEIF (MC.EQ.ME) THEN + NDAYS = NDAYS+IED + ELSE + NDAYS = NDAYS+IDPM(MC) + IF (MC.EQ.2) NDAYS = NDAYS + LEAP + ENDIF + ENDDO + ELSEIF (IBD.LT.IED) THEN +! START AND END IN SAME MONTH, ONLY ACCOUNT FOR DAYS + NDAYS = IED-IBD + ENDIF + ELSEC=NDAYS*NSPD +! +! ADD OR SUBTRACT SECONDS + ELSEC = ELSEC+(IEDT(5)-IBDT(5))*3600.0 + ELSEC = ELSEC+(IEDT(6)-IBDT(6))*60.0 + ELSEC = ELSEC+(IEDT(7)-IBDT(7)) + ELSEC = ELSEC+(IEDT(8)-IBDT(8))*0.001 +! +! CONVERT SECONDS TO DAYS, HOURS, MINUTES, AND SECONDS + NDAYS = ELSEC/NSPD + RSECS = MOD(ELSEC, 86400.0_DP) + NHOURS = RSECS/3600.0 + RSECS = MOD(RSECS,3600.0_DP) + NMINS = RSECS/60.0 + RSECS = MOD(RSECS,60.0_DP) + NSECS = RSECS + RSECS = MOD(RSECS,1.0_DP) + MSECS = NINT(RSECS*1000.0) + NRSECS = NSECS + IF (RSECS.GE.0.5) NRSECS=NRSECS+1 +! +! Write elapsed time to screen + IF (NDAYS.GT.0) THEN + WRITE(line, 1010) NDAYS,NHOURS,NMINS,NRSECS + 1010 FORMAT(1X,'Elapsed run time: ',I3,' Days, ',I2,' Hours, ',I2, & + ' Minutes, ',I2,' Seconds') + ELSEIF (NHOURS.GT.0) THEN + WRITE(line, 1020) NHOURS,NMINS,NRSECS + 1020 FORMAT(1X,'Elapsed run time: ',I2,' Hours, ',I2, & + ' Minutes, ',I2,' Seconds') + ELSEIF (NMINS.GT.0) THEN + WRITE(line, 1030) NMINS,NSECS,MSECS + 1030 FORMAT(1X,'Elapsed run time: ',I2,' Minutes, ', & + I2,'.',I3.3,' Seconds') + ELSE + WRITE(line, 1040) NSECS,MSECS + 1040 FORMAT(1X,'Elapsed run time: ',I2,'.',I3.3,' Seconds') + ENDIF + call sim_message(line, skipafter=1) +! +! Write times to file if requested + IF(IPRTIM.GT.0) THEN + IF (NDAYS.GT.0) THEN + WRITE(IOUT,1010) NDAYS,NHOURS,NMINS,NRSECS + ELSEIF (NHOURS.GT.0) THEN + WRITE(IOUT,1020) NHOURS,NMINS,NRSECS + ELSEIF (NMINS.GT.0) THEN + WRITE(IOUT,1030) NMINS,NSECS,MSECS + ELSE + WRITE(IOUT,1040) NSECS,MSECS + ENDIF + ENDIF +! + RETURN + END SUBROUTINE elapsed_time + +! +!-------TIMER FOR SUBROUTINES + SUBROUTINE code_timer(it, t1, ts) +! ****************************************************************************** +! Get end time and calculate elapsed time +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + INTEGER(I4B), INTENT(IN) :: it + REAL(DP), INTENT(INOUT) :: t1 + REAL(DP), INTENT(INOUT) :: ts + ! -- local + REAL(DP) :: dt +! ------------------------------------------------------------------------------ + ! + IF (IT == 0) THEN + call CPU_TIME(t1) + ELSE + call CPU_TIME(dt) + ts = ts + dt - t1 + END IF + ! + ! -- RETURN + RETURN + END SUBROUTINE code_timer + +end module TimerModule diff --git a/src/Utilities/comarg.f90 b/src/Utilities/comarg.f90 index 5fdd6645ea6..12313aea901 100644 --- a/src/Utilities/comarg.f90 +++ b/src/Utilities/comarg.f90 @@ -1,258 +1,258 @@ -module CommandArguments +module CommandArguments use KindModule - use ConstantsModule, only: LINELENGTH, LENHUGELINE, & - VSUMMARY, VALL, VDEBUG - use VersionModule, only: VERSION, MFVNAM, IDEVELOPMODE - use CompilerVersion - use SimVariablesModule, only: istdout, isim_level, & - simfile, simlstfile, simstdout - use GenericUtilitiesModule, only: sim_message - use SimModule, only: store_error, ustop, store_error_unit, & - store_error_filename - use InputOutputModule, only: upcase, getunit - ! - implicit none - ! - private - public :: GetCommandLineArguments - ! - contains - - subroutine GetCommandLineArguments() -! ****************************************************************************** -! Write information on command line arguments -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - ! -- local - character(len=LINELENGTH) :: tag - character(len=LINELENGTH) :: uctag - character(len=LENHUGELINE) :: line - character(len=LINELENGTH) :: clevel - character(len=LINELENGTH) :: header - character(len=LINELENGTH) :: errmsg - character(len=LINELENGTH) :: cexe - character(len=80) :: compiler - character(len=20) :: cdate - character(len=17) :: ctyp - logical :: ltyp - logical :: lexist - logical :: lstop - integer(I4B) :: icountcmd - integer(I4B) :: ipos - integer(I4B) :: ilen - integer(I4B) :: iarg -! ------------------------------------------------------------------------------ - ! - ! -- initialize local variables - lstop = .FALSE. - ! - ! -- set mf6 executable name - icountcmd = command_argument_count() - call get_command_argument(0, cexe) - cexe = adjustl(cexe) - ! - ! -- find the program basename, not including the path (this should be - ! mf6.exe, mf6d.exe, etc.) - ipos = index(cexe, '/', back=.TRUE.) - if (ipos == 0) then - ipos = index(cexe, '\', back=.TRUE.) - end if - if (ipos /= 0) then - ipos = ipos + 1 - end if - cexe = cexe(ipos:) - ! - ! -- write header - call get_compile_date(cdate) - write(header, '(a,4(1x,a),a)') & - trim(adjustl(cexe)), '- MODFLOW', & - trim(adjustl(VERSION)), '(compiled', trim(adjustl(cdate)), ')' - ! - ! -- set ctyp - if (IDEVELOPMODE == 1) then - ctyp = 'Release Candidate' - ltyp = .TRUE. - else - ctyp = 'Release' - ltyp = .FALSE. - end if - ! - ! -- check for silent option - do iarg = 1, icountcmd - call get_command_argument(iarg, uctag) - call upcase(uctag) - if (trim(adjustl(uctag)) == '-S' .or. & - trim(adjustl(uctag)) == '-SILENT') then - ! - ! -- get file unit and open mfsim.stdout - istdout = getunit() - open(unit=istdout, file=trim(adjustl(simstdout))) - ! - ! -- exit loop - exit - end if - end do - ! - ! -- Read remaining arguments - iarg = 0 - do - ! - ! -- increment iarg and determine if loop should be terminated - iarg = iarg + 1 - if (iarg > icountcmd) then - exit - end if - ! - ! -- get command line argument - call get_command_argument(iarg, tag) - uctag = tag - call upcase(uctag) - ! - ! -- skip commands without - or -- - ipos = index(uctag, '-') - if (ipos < 1) then - cycle - end if - ! - ! -- parse level string, if necessary - clevel = ' ' - ipos = index(uctag, '--LEVEL=') - if (ipos > 0) then - ipos = index(tag, '=') - ilen = len_trim(tag) - clevel = tag(ipos+1:ilen) - call upcase(clevel) - uctag = tag(1:ipos-1) - call upcase(uctag) - end if - ! - ! -- evaluate the command line argument (uctag) - select case(trim(adjustl(uctag))) - case('-H', '-?', '--HELP') - lstop = .TRUE. - call write_usage(trim(adjustl(header)), trim(adjustl(cexe))) - case('-V', '--VERSION') - lstop = .TRUE. - write(line, '(2a,2(1x,a))') & - trim(adjustl(cexe)), ':', trim(adjustl(VERSION)), ctyp - call sim_message(line) - case('-DEV', '--DEVELOP') - lstop = .TRUE. - write(line, '(2a,g0)') & - trim(adjustl(cexe)), ': develop version ', ltyp - call sim_message(line) - case('-C', '--COMPILER') - lstop = .TRUE. - call get_compiler(compiler) - write(line, '(2a,1x,a)') & - trim(adjustl(cexe)), ':', trim(adjustl(compiler)) - call sim_message(line) - case('-S', '--SILENT') - write(line, '(2a,1x,a)') & - trim(adjustl(cexe)), ':', 'all screen output sent to mfsim.stdout' - call sim_message(line) - case('-L', '--LEVEL') - if (len_trim(clevel) < 1) then - iarg = iarg + 1 - call get_command_argument(iarg, clevel) - call upcase(clevel) - end if - select case(trim(adjustl(clevel))) - case('SUMMARY') - isim_level = VSUMMARY - case('DEBUG') - isim_level = VDEBUG - case default - call write_usage(trim(adjustl(header)), trim(adjustl(cexe))) - write(errmsg, '(2a,1x,a)') & - trim(adjustl(cexe)), ': illegal STDOUT level option -', & - trim(adjustl(clevel)) - call store_error(errmsg) - end select - ! - ! -- write message to stdout - write(line, '(2a,2(1x,a))') & - trim(adjustl(cexe)), ':', 'stdout output level', & - trim(adjustl(clevel)) - call sim_message(line) - case default - lstop = .TRUE. - call write_usage(trim(adjustl(header)), trim(adjustl(cexe))) - write(errmsg, '(2a,1x,a)') & - trim(adjustl(cexe)), ': illegal option -', trim(adjustl(tag)) - call store_error(errmsg) - end select - end do - ! - ! -- check if simfile exists - inquire(file=trim(adjustl(simfile)), exist=lexist) - if (.NOT. lexist) then - lstop = .TRUE. - write(errmsg, '(2a,2(1x,a))') & - trim(adjustl(cexe)), ':', trim(adjustl(simfile)), & - 'is not present in working directory.' - call store_error(errmsg) - end if - ! - ! -- terminate program if lstop - if (lstop) then - call ustop() - end if - ! - ! -- write blank line to stdout - if (icountcmd > 0) then - call sim_message('') - end if - ! - ! -- return - return - end subroutine GetCommandLineArguments - - subroutine write_usage(header, cexe) - ! -- dummy - character(len=*), intent(in) :: header - character(len=*), intent(in) :: cexe - ! -- local - character(len=LINELENGTH) :: line - ! -- format - character(len=*), parameter :: OPTIONSFMT = & - "(/, & - &'Options GNU long option Meaning ',/, & - &' -h, -? --help Show this message',/, & - &' -v --version Display program version information.',/, & - &' -dev --develop Display program develop option mode.',/, & - &' -c --compiler Display compiler information.',/, & - &' -s --silent All STDOUT to mfsim.stdout.',/, & - &' -l --level STDOUT output to screen based on .',/, & - &' =summary Limited output to STDOUT.',/, & - &' =debug Enhanced output to STDOUT.',/, & - &' ',/, & - &'Bug reporting and contributions are welcome from the community. ',/, & - &'Questions can be asked on the issues page[1]. Before creating a new',/, & - &'issue, please take a moment to search and make sure a similar issue',/, & - &'does not already exist. If one does exist, you can comment (most',/, & - &'simply even with just :+1:) to show your support for that issue.',/, & - &' ',/, & - &'[1] https://github.com/MODFLOW-USGS/modflow6/issues',/)" -! ------------------------------------------------------------------------------ - ! - ! -- write command line usage information to the screen - call sim_message(header) - write(line, '(a,1x,a,15x,a,2(1x,a),2a)') & - 'usage:', cexe, 'run MODFLOW', trim(adjustl(MFVNAM)), & - 'using "', trim(adjustl(simfile)), '"' - call sim_message(line) - write(line, '(a,1x,a,1x,a,5x,a)') & - ' or:', cexe, '[options]', & - 'retrieve program information' - call sim_message(line) - call sim_message('', fmt=OPTIONSFMT) - ! - ! -- return - return - end subroutine write_usage - + use ConstantsModule, only: LINELENGTH, LENHUGELINE, & + VSUMMARY, VALL, VDEBUG + use VersionModule, only: VERSION, MFVNAM, IDEVELOPMODE + use CompilerVersion + use SimVariablesModule, only: istdout, isim_level, & + simfile, simlstfile, simstdout + use GenericUtilitiesModule, only: sim_message + use SimModule, only: store_error, ustop, store_error_unit, & + store_error_filename + use InputOutputModule, only: upcase, getunit + ! + implicit none + ! + private + public :: GetCommandLineArguments + ! + contains + + subroutine GetCommandLineArguments() +! ****************************************************************************** +! Write information on command line arguments +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + ! -- local + character(len=LINELENGTH) :: tag + character(len=LINELENGTH) :: uctag + character(len=LENHUGELINE) :: line + character(len=LINELENGTH) :: clevel + character(len=LINELENGTH) :: header + character(len=LINELENGTH) :: errmsg + character(len=LINELENGTH) :: cexe + character(len=80) :: compiler + character(len=20) :: cdate + character(len=17) :: ctyp + logical :: ltyp + logical :: lexist + logical :: lstop + integer(I4B) :: icountcmd + integer(I4B) :: ipos + integer(I4B) :: ilen + integer(I4B) :: iarg +! ------------------------------------------------------------------------------ + ! + ! -- initialize local variables + lstop = .FALSE. + ! + ! -- set mf6 executable name + icountcmd = command_argument_count() + call get_command_argument(0, cexe) + cexe = adjustl(cexe) + ! + ! -- find the program basename, not including the path (this should be + ! mf6.exe, mf6d.exe, etc.) + ipos = index(cexe, '/', back=.TRUE.) + if (ipos == 0) then + ipos = index(cexe, '\', back=.TRUE.) + end if + if (ipos /= 0) then + ipos = ipos + 1 + end if + cexe = cexe(ipos:) + ! + ! -- write header + call get_compile_date(cdate) + write(header, '(a,4(1x,a),a)') & + trim(adjustl(cexe)), '- MODFLOW', & + trim(adjustl(VERSION)), '(compiled', trim(adjustl(cdate)), ')' + ! + ! -- set ctyp + if (IDEVELOPMODE == 1) then + ctyp = 'Release Candidate' + ltyp = .TRUE. + else + ctyp = 'Release' + ltyp = .FALSE. + end if + ! + ! -- check for silent option + do iarg = 1, icountcmd + call get_command_argument(iarg, uctag) + call upcase(uctag) + if (trim(adjustl(uctag)) == '-S' .or. & + trim(adjustl(uctag)) == '-SILENT') then + ! + ! -- get file unit and open mfsim.stdout + istdout = getunit() + open(unit=istdout, file=trim(adjustl(simstdout))) + ! + ! -- exit loop + exit + end if + end do + ! + ! -- Read remaining arguments + iarg = 0 + do + ! + ! -- increment iarg and determine if loop should be terminated + iarg = iarg + 1 + if (iarg > icountcmd) then + exit + end if + ! + ! -- get command line argument + call get_command_argument(iarg, tag) + uctag = tag + call upcase(uctag) + ! + ! -- skip commands without - or -- + ipos = index(uctag, '-') + if (ipos < 1) then + cycle + end if + ! + ! -- parse level string, if necessary + clevel = ' ' + ipos = index(uctag, '--LEVEL=') + if (ipos > 0) then + ipos = index(tag, '=') + ilen = len_trim(tag) + clevel = tag(ipos+1:ilen) + call upcase(clevel) + uctag = tag(1:ipos-1) + call upcase(uctag) + end if + ! + ! -- evaluate the command line argument (uctag) + select case(trim(adjustl(uctag))) + case('-H', '-?', '--HELP') + lstop = .TRUE. + call write_usage(trim(adjustl(header)), trim(adjustl(cexe))) + case('-V', '--VERSION') + lstop = .TRUE. + write(line, '(2a,2(1x,a))') & + trim(adjustl(cexe)), ':', trim(adjustl(VERSION)), ctyp + call sim_message(line) + case('-DEV', '--DEVELOP') + lstop = .TRUE. + write(line, '(2a,g0)') & + trim(adjustl(cexe)), ': develop version ', ltyp + call sim_message(line) + case('-C', '--COMPILER') + lstop = .TRUE. + call get_compiler(compiler) + write(line, '(2a,1x,a)') & + trim(adjustl(cexe)), ':', trim(adjustl(compiler)) + call sim_message(line) + case('-S', '--SILENT') + write(line, '(2a,1x,a)') & + trim(adjustl(cexe)), ':', 'all screen output sent to mfsim.stdout' + call sim_message(line) + case('-L', '--LEVEL') + if (len_trim(clevel) < 1) then + iarg = iarg + 1 + call get_command_argument(iarg, clevel) + call upcase(clevel) + end if + select case(trim(adjustl(clevel))) + case('SUMMARY') + isim_level = VSUMMARY + case('DEBUG') + isim_level = VDEBUG + case default + call write_usage(trim(adjustl(header)), trim(adjustl(cexe))) + write(errmsg, '(2a,1x,a)') & + trim(adjustl(cexe)), ': illegal STDOUT level option -', & + trim(adjustl(clevel)) + call store_error(errmsg) + end select + ! + ! -- write message to stdout + write(line, '(2a,2(1x,a))') & + trim(adjustl(cexe)), ':', 'stdout output level', & + trim(adjustl(clevel)) + call sim_message(line) + case default + lstop = .TRUE. + call write_usage(trim(adjustl(header)), trim(adjustl(cexe))) + write(errmsg, '(2a,1x,a)') & + trim(adjustl(cexe)), ': illegal option -', trim(adjustl(tag)) + call store_error(errmsg) + end select + end do + ! + ! -- check if simfile exists + inquire(file=trim(adjustl(simfile)), exist=lexist) + if (.NOT. lexist) then + lstop = .TRUE. + write(errmsg, '(2a,2(1x,a))') & + trim(adjustl(cexe)), ':', trim(adjustl(simfile)), & + 'is not present in working directory.' + call store_error(errmsg) + end if + ! + ! -- terminate program if lstop + if (lstop) then + call ustop() + end if + ! + ! -- write blank line to stdout + if (icountcmd > 0) then + call sim_message('') + end if + ! + ! -- return + return + end subroutine GetCommandLineArguments + + subroutine write_usage(header, cexe) + ! -- dummy + character(len=*), intent(in) :: header + character(len=*), intent(in) :: cexe + ! -- local + character(len=LINELENGTH) :: line + ! -- format + character(len=*), parameter :: OPTIONSFMT = & + "(/, & + &'Options GNU long option Meaning ',/, & + &' -h, -? --help Show this message',/, & + &' -v --version Display program version information.',/, & + &' -dev --develop Display program develop option mode.',/, & + &' -c --compiler Display compiler information.',/, & + &' -s --silent All STDOUT to mfsim.stdout.',/, & + &' -l --level STDOUT output to screen based on .',/, & + &' =summary Limited output to STDOUT.',/, & + &' =debug Enhanced output to STDOUT.',/, & + &' ',/, & + &'Bug reporting and contributions are welcome from the community. ',/, & + &'Questions can be asked on the issues page[1]. Before creating a new',/, & + &'issue, please take a moment to search and make sure a similar issue',/, & + &'does not already exist. If one does exist, you can comment (most',/, & + &'simply even with just :+1:) to show your support for that issue.',/, & + &' ',/, & + &'[1] https://github.com/MODFLOW-USGS/modflow6/issues',/)" +! ------------------------------------------------------------------------------ + ! + ! -- write command line usage information to the screen + call sim_message(header) + write(line, '(a,1x,a,15x,a,2(1x,a),2a)') & + 'usage:', cexe, 'run MODFLOW', trim(adjustl(MFVNAM)), & + 'using "', trim(adjustl(simfile)), '"' + call sim_message(line) + write(line, '(a,1x,a,1x,a,5x,a)') & + ' or:', cexe, '[options]', & + 'retrieve program information' + call sim_message(line) + call sim_message('', fmt=OPTIONSFMT) + ! + ! -- return + return + end subroutine write_usage + end module CommandArguments \ No newline at end of file diff --git a/src/Utilities/compilerversion.fpp b/src/Utilities/compilerversion.fpp index c176791cad5..961cc9f3048 100644 --- a/src/Utilities/compilerversion.fpp +++ b/src/Utilities/compilerversion.fpp @@ -52,8 +52,8 @@ ! return return - end subroutine get_compiler - + end subroutine get_compiler + subroutine get_compile_date(txt) character(len=20), intent(inout) :: txt @@ -64,10 +64,10 @@ #ifdef __INTEL_COMPILER cdate = __DATE__ // ' ' // __TIME__ #endif - write(txt,'(a)') trim(adjustl(cdate)) + write(txt,'(a)') trim(adjustl(cdate)) ! ! return return - end subroutine get_compile_date + end subroutine get_compile_date end module CompilerVersion \ No newline at end of file diff --git a/src/Utilities/genericutils.f90 b/src/Utilities/genericutils.f90 index c46c158af68..78a99e7fb43 100644 --- a/src/Utilities/genericutils.f90 +++ b/src/Utilities/genericutils.f90 @@ -1,262 +1,262 @@ -module GenericUtilitiesModule - use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, DPREC, DSAME, & - LINELENGTH, LENHUGELINE, VSUMMARY - use SimVariablesModule, only: istdout, isim_level - ! - implicit none - - private - - public :: sim_message - public :: write_centered - public :: is_same - public :: stop_with_error - - contains - - subroutine sim_message(message, iunit, fmt, level, & - skipbefore, skipafter, advance) - ! ****************************************************************************** - ! Print message to user specified iunit or STDOUT based on level. - ! - ! -- Arguments are as follows: - ! message : message to write to iunit - ! iunit (optional) : file unit to write the message to (default=stdout) - ! fmt (optional) : format to write the message (default='(a)') - ! level (optional) : level for the message (default=summary) - ! skipbefore (optional) : number of empty lines before message - ! skipafter (optional) : number of empty lines after message - ! advance (optional) : advancing output (default is .TRUE.) - ! - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - ! -- modules - implicit none - ! -- dummy - character(len=*), intent(in) :: message - integer(I4B), intent(in), optional :: iunit - character(len=*), intent(in), optional :: fmt - integer(I4B), intent(in), optional :: level - integer(I4B), intent(in), optional :: skipbefore - integer(I4B), intent(in), optional :: skipafter - logical, intent(in), optional :: advance - ! -- local - character(len=3) :: cadvance - integer(I4B) :: i - integer(I4B) :: ilen - integer(I4B) :: iu - integer(I4B) :: ilevel - character(len=LENHUGELINE) :: simfmt - character(len=*), parameter :: stdfmt = '(a)' - character(len=*), parameter :: emptyfmt = '()' - ! ------------------------------------------------------------------------------ - ! - ! -- initialize local variables - ilen = len_trim(message) - ! - ! -- process optional dummy variables - if (present(iunit)) then - iu = iunit - else - iu = istdout - end if - if (present(fmt)) then - simfmt = fmt - else - if (ilen > 0) then - simfmt = stdfmt - else - simfmt = emptyfmt - end if - end if - if (present(level)) then - ilevel = level - else - ilevel = VSUMMARY - end if - if (present(advance)) then - if (advance) then - cadvance = 'YES' - else - cadvance = 'NO' - end if - else - cadvance = 'YES' - end if - ! - ! -- write empty line before message - if (present(skipbefore)) then - do i = 1, skipbefore - write(iu, *) - end do - end if - ! - ! -- write message if the level of the message is less than - ! or equal the isim_level for the simulation - if (ilevel <= isim_level) then - if (ilen > 0) then - write(iu, trim(simfmt), advance=cadvance) message(1:ilen) - else - write(iu, trim(simfmt), advance=cadvance) - end if - end if - ! - ! -- write empty line after message - if (present(skipafter)) then - do i = 1, skipafter - write(iu, *) - end do - end if - ! - ! -- return - return - end subroutine sim_message - - subroutine write_centered(text, linelen, iunit) - ! ****************************************************************************** - ! Write text to unit iunit centered in width defined by linelen. Left-pad with - ! blanks as needed. - ! - ! -- Arguments are as follows: - ! text : message to write to iunit - ! linelen : length of line to center text in - ! iunit (optional) : file unit to write text (default stdout) - ! - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - ! -- dummy - character(len=*), intent(in) :: text - integer(I4B), intent(in) :: linelen - integer(I4B), intent(in), optional :: iunit - ! -- local - character(len=LINELENGTH) :: newline - character(len=LINELENGTH) :: textleft - integer(I4B) :: iu - integer(I4B) :: loc1 - integer(I4B) :: loc2 - integer(I4B) :: lentext - integer(I4B) :: nspaces - ! -- code - ! - ! -- process optional parameters - if (present(iunit)) then - iu = iunit - else - iu = istdout - end if - ! - ! -- process text - if (iu > 0) then - textleft = adjustl(text) - lentext = len_trim(textleft) - nspaces = linelen - lentext - loc1 = (nspaces / 2) + 1 - loc2 = loc1 + lentext - 1 - newline = ' ' - newline(loc1:loc2) = textleft - ! - ! -- write processed text to iu - write(iu,'(a)') trim(newline) - end if - ! - ! -- retirn - return - end subroutine write_centered - - function is_same(a, b, eps) result(lvalue) - ! ****************************************************************************** - ! Evaluate if the difference between a and b are less than eps - ! (i.e. a and b are the same). - ! - ! -- Arguments are as follows: - ! a : first number to evaluate - ! b : second number to evaluate - ! eps (optional) : maximum difference between a abd b (default DSAME) - ! - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - ! -- return variable - logical :: lvalue - ! -- dummy arguments - real(DP), intent(in) :: a - real(DP), intent(in) :: b - real(DP), intent(in), optional :: eps - ! -- local definitions - real(DP) :: epsloc - real(DP) :: denom - real(DP) :: rdiff - ! -- parameters - ! -- functions - ! -- code - if (present(eps)) then - epsloc = eps - else - epsloc = DSAME - endif - lvalue = .FALSE. - if (a == b) then - lvalue = .TRUE. - else - if (abs(b) > abs(a)) then - denom = b - else - denom = a - if (abs(denom) == DZERO) then - denom = DPREC - end if - end if - rdiff = abs( (a - b) / denom ) - if (rdiff <= epsloc) then - lvalue = .TRUE. - end if - end if - ! - ! -- return - return - end function is_same - - subroutine stop_with_error(ierr) - ! ****************************************************************************** - ! Stop the program and issue the correct return code - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - integer(I4B), intent(in), optional :: ierr - ! -- local - integer(I4B) :: ireturn_err - !------------------------------------------------------------------------------- - ! - ! -- process optional dummy variables - if (present(ierr)) then - ireturn_err = ierr - else - ireturn_err = 0 - end if - - ! -- return the correct return code - select case (ireturn_err) - case (0) - stop - case (1) - stop 1 - case (2) - stop 2 - case (138) - stop 138 - case default - stop 999 - end select - - end subroutine stop_with_error - +module GenericUtilitiesModule + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, DPREC, DSAME, & + LINELENGTH, LENHUGELINE, VSUMMARY + use SimVariablesModule, only: istdout, isim_level + ! + implicit none + + private + + public :: sim_message + public :: write_centered + public :: is_same + public :: stop_with_error + + contains + + subroutine sim_message(message, iunit, fmt, level, & + skipbefore, skipafter, advance) + ! ****************************************************************************** + ! Print message to user specified iunit or STDOUT based on level. + ! + ! -- Arguments are as follows: + ! message : message to write to iunit + ! iunit (optional) : file unit to write the message to (default=stdout) + ! fmt (optional) : format to write the message (default='(a)') + ! level (optional) : level for the message (default=summary) + ! skipbefore (optional) : number of empty lines before message + ! skipafter (optional) : number of empty lines after message + ! advance (optional) : advancing output (default is .TRUE.) + ! + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + ! -- modules + implicit none + ! -- dummy + character(len=*), intent(in) :: message + integer(I4B), intent(in), optional :: iunit + character(len=*), intent(in), optional :: fmt + integer(I4B), intent(in), optional :: level + integer(I4B), intent(in), optional :: skipbefore + integer(I4B), intent(in), optional :: skipafter + logical, intent(in), optional :: advance + ! -- local + character(len=3) :: cadvance + integer(I4B) :: i + integer(I4B) :: ilen + integer(I4B) :: iu + integer(I4B) :: ilevel + character(len=LENHUGELINE) :: simfmt + character(len=*), parameter :: stdfmt = '(a)' + character(len=*), parameter :: emptyfmt = '()' + ! ------------------------------------------------------------------------------ + ! + ! -- initialize local variables + ilen = len_trim(message) + ! + ! -- process optional dummy variables + if (present(iunit)) then + iu = iunit + else + iu = istdout + end if + if (present(fmt)) then + simfmt = fmt + else + if (ilen > 0) then + simfmt = stdfmt + else + simfmt = emptyfmt + end if + end if + if (present(level)) then + ilevel = level + else + ilevel = VSUMMARY + end if + if (present(advance)) then + if (advance) then + cadvance = 'YES' + else + cadvance = 'NO' + end if + else + cadvance = 'YES' + end if + ! + ! -- write empty line before message + if (present(skipbefore)) then + do i = 1, skipbefore + write(iu, *) + end do + end if + ! + ! -- write message if the level of the message is less than + ! or equal the isim_level for the simulation + if (ilevel <= isim_level) then + if (ilen > 0) then + write(iu, trim(simfmt), advance=cadvance) message(1:ilen) + else + write(iu, trim(simfmt), advance=cadvance) + end if + end if + ! + ! -- write empty line after message + if (present(skipafter)) then + do i = 1, skipafter + write(iu, *) + end do + end if + ! + ! -- return + return + end subroutine sim_message + + subroutine write_centered(text, linelen, iunit) + ! ****************************************************************************** + ! Write text to unit iunit centered in width defined by linelen. Left-pad with + ! blanks as needed. + ! + ! -- Arguments are as follows: + ! text : message to write to iunit + ! linelen : length of line to center text in + ! iunit (optional) : file unit to write text (default stdout) + ! + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + ! -- dummy + character(len=*), intent(in) :: text + integer(I4B), intent(in) :: linelen + integer(I4B), intent(in), optional :: iunit + ! -- local + character(len=LINELENGTH) :: newline + character(len=LINELENGTH) :: textleft + integer(I4B) :: iu + integer(I4B) :: loc1 + integer(I4B) :: loc2 + integer(I4B) :: lentext + integer(I4B) :: nspaces + ! -- code + ! + ! -- process optional parameters + if (present(iunit)) then + iu = iunit + else + iu = istdout + end if + ! + ! -- process text + if (iu > 0) then + textleft = adjustl(text) + lentext = len_trim(textleft) + nspaces = linelen - lentext + loc1 = (nspaces / 2) + 1 + loc2 = loc1 + lentext - 1 + newline = ' ' + newline(loc1:loc2) = textleft + ! + ! -- write processed text to iu + write(iu,'(a)') trim(newline) + end if + ! + ! -- retirn + return + end subroutine write_centered + + function is_same(a, b, eps) result(lvalue) + ! ****************************************************************************** + ! Evaluate if the difference between a and b are less than eps + ! (i.e. a and b are the same). + ! + ! -- Arguments are as follows: + ! a : first number to evaluate + ! b : second number to evaluate + ! eps (optional) : maximum difference between a abd b (default DSAME) + ! + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + ! -- return variable + logical :: lvalue + ! -- dummy arguments + real(DP), intent(in) :: a + real(DP), intent(in) :: b + real(DP), intent(in), optional :: eps + ! -- local definitions + real(DP) :: epsloc + real(DP) :: denom + real(DP) :: rdiff + ! -- parameters + ! -- functions + ! -- code + if (present(eps)) then + epsloc = eps + else + epsloc = DSAME + endif + lvalue = .FALSE. + if (a == b) then + lvalue = .TRUE. + else + if (abs(b) > abs(a)) then + denom = b + else + denom = a + if (abs(denom) == DZERO) then + denom = DPREC + end if + end if + rdiff = abs( (a - b) / denom ) + if (rdiff <= epsloc) then + lvalue = .TRUE. + end if + end if + ! + ! -- return + return + end function is_same + + subroutine stop_with_error(ierr) + ! ****************************************************************************** + ! Stop the program and issue the correct return code + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + integer(I4B), intent(in), optional :: ierr + ! -- local + integer(I4B) :: ireturn_err + !------------------------------------------------------------------------------- + ! + ! -- process optional dummy variables + if (present(ierr)) then + ireturn_err = ierr + else + ireturn_err = 0 + end if + + ! -- return the correct return code + select case (ireturn_err) + case (0) + stop + case (1) + stop 1 + case (2) + stop 2 + case (138) + stop 138 + case default + stop 999 + end select + + end subroutine stop_with_error + end module GenericUtilitiesModule \ No newline at end of file diff --git a/src/Utilities/kind.f90 b/src/Utilities/kind.f90 index cb14a960e8b..43d37c2e6b5 100644 --- a/src/Utilities/kind.f90 +++ b/src/Utilities/kind.f90 @@ -1,39 +1,39 @@ -module KindModule - - implicit none - - public - - integer, parameter :: DP = KIND(1.0D0) ! Precision of all real variables - integer, parameter :: I4B = SELECTED_INT_KIND(8) ! Integer kind - integer, parameter :: I8B = SELECTED_INT_KIND(18) ! Long integer kind - - contains - - subroutine write_kindinfo(iout) -! ****************************************************************************** -! write_kindinfo -- write out information about the kind variables -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - integer(I4B), intent(in) :: iout - real(DP) :: rdum = 0. - integer(I4B) :: idum = 0 -! ------------------------------------------------------------------------------ - ! - write(iout, '(a)') 'Real Variables' - write(iout, '(2x,a,i0)') 'PRECISION: ', precision(rdum) - write(iout, '(2x,a,i0)') 'KIND: ', DP - write(iout, '(2x,a,1pg15.6)') 'TINY (smallest non-zero value): ', tiny(rdum) - write(iout, '(2x,a,1pg15.6)') 'HUGE (largest value): ', huge(rdum) - write(iout, '(a)') 'Integer Variables' - write(iout, '(2x,a,i0)') 'KIND: ', I4B - write(iout, '(2x,a,i0)') 'HUGE (largest value): ', huge(idum) - write(iout, '(2x,a,i0)') 'BIT_SIZE: ', bit_size(idum) - ! - ! -- Return - return - end subroutine write_kindinfo - -end module KindModule +module KindModule + + implicit none + + public + + integer, parameter :: DP = KIND(1.0D0) ! Precision of all real variables + integer, parameter :: I4B = SELECTED_INT_KIND(8) ! Integer kind + integer, parameter :: I8B = SELECTED_INT_KIND(18) ! Long integer kind + + contains + + subroutine write_kindinfo(iout) +! ****************************************************************************** +! write_kindinfo -- write out information about the kind variables +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + integer(I4B), intent(in) :: iout + real(DP) :: rdum = 0. + integer(I4B) :: idum = 0 +! ------------------------------------------------------------------------------ + ! + write(iout, '(a)') 'Real Variables' + write(iout, '(2x,a,i0)') 'PRECISION: ', precision(rdum) + write(iout, '(2x,a,i0)') 'KIND: ', DP + write(iout, '(2x,a,1pg15.6)') 'TINY (smallest non-zero value): ', tiny(rdum) + write(iout, '(2x,a,1pg15.6)') 'HUGE (largest value): ', huge(rdum) + write(iout, '(a)') 'Integer Variables' + write(iout, '(2x,a,i0)') 'KIND: ', I4B + write(iout, '(2x,a,i0)') 'HUGE (largest value): ', huge(idum) + write(iout, '(2x,a,i0)') 'BIT_SIZE: ', bit_size(idum) + ! + ! -- Return + return + end subroutine write_kindinfo + +end module KindModule diff --git a/src/Utilities/sort.f90 b/src/Utilities/sort.f90 index 1463236cf8d..28dc5e9d4dc 100644 --- a/src/Utilities/sort.f90 +++ b/src/Utilities/sort.f90 @@ -6,15 +6,15 @@ module SortModule private public :: qsort, selectn, unique_values - - interface qsort - module procedure qsort_int1d, qsort_dbl1d - end interface - - interface unique_values - module procedure unique_values_int1d, unique_values_dbl1d + + interface qsort + module procedure qsort_int1d, qsort_dbl1d + end interface + + interface unique_values + module procedure unique_values_int1d, unique_values_dbl1d end interface - + contains subroutine qsort_int1d(indx, v, reverse) @@ -152,7 +152,7 @@ subroutine qsort_int1d(indx, v, reverse) ! -- return return end subroutine qsort_int1d - + subroutine qsort_dbl1d(indx, v, reverse) ! ************************************************************************** ! qsort -- quick sort that also includes an index number @@ -288,116 +288,116 @@ subroutine qsort_dbl1d(indx, v, reverse) ! -- return return end subroutine qsort_dbl1d - - subroutine unique_values_int1d(a, b) - ! - dummy arguments - integer(I4B), dimension(:), allocatable, intent(in) :: a - integer(I4B), dimension(:), allocatable, intent(inout) :: b - ! -- local variables - integer(I4B) :: count - integer(I4B) :: n - integer(I4B), dimension(:), allocatable :: indxarr - integer(I4B), dimension(:), allocatable :: tarr - ! -- functions - ! -- code - ! - ! -- allocate tarr and create idxarr - allocate(tarr(size(a))) - allocate(indxarr(size(a))) - ! - ! -- fill tarr with a and create index - do n = 1, size(a) - tarr(n) = a(n) - indxarr(n) = n - end do - ! - ! -- sort a in increasing order - call qsort(indxarr, tarr, reverse=.TRUE.) - ! - ! -- determine the number of unique values - count = 1 - do n = 2, size(tarr) - if (tarr(n) > tarr(n-1)) count = count + 1 - end do - ! - ! -- allocate b for unique values - if (allocated(b)) then - deallocate(b) - end if - allocate(b(count)) - ! - ! -- fill b with unique values - b(1) = tarr(1) - count = 1 - do n = 2, size(a) - if (tarr(n) > b(count)) then - count = count + 1 - b(count) = tarr(n) - end if - end do - ! - ! -- allocate tarr and create idxarr - deallocate(tarr) - deallocate(indxarr) - ! - ! -- return - return - end subroutine unique_values_int1d - - subroutine unique_values_dbl1d(a, b) - ! - dummy arguments - real(DP), dimension(:), allocatable, intent(in) :: a - real(DP), dimension(:), allocatable, intent(inout) :: b - ! -- local variables - integer(I4B) :: count - integer(I4B) :: n - integer(I4B), dimension(:), allocatable :: indxarr - real(DP), dimension(:), allocatable :: tarr - ! -- functions - ! -- code - ! - ! -- allocate tarr and create idxarr - allocate(tarr(size(a))) - allocate(indxarr(size(a))) - ! - ! -- fill tarr with a and create index - do n = 1, size(a) - tarr(n) = a(n) - indxarr(n) = n - end do - ! - ! -- sort a in increasing order - call qsort(indxarr, tarr, reverse=.TRUE.) - ! - ! -- determine the number of unique values - count = 1 - do n = 2, size(tarr) - if (tarr(n) > tarr(n-1)) count = count + 1 - end do - ! - ! -- allocate b for unique values - if (allocated(b)) then - deallocate(b) - end if - allocate(b(count)) - ! - ! -- fill b with unique values - b(1) = tarr(1) - count = 1 - do n = 2, size(a) - if (tarr(n) > b(count)) then - count = count + 1 - b(count) = tarr(n) - end if - end do - ! - ! -- allocate tarr and create idxarr - deallocate(tarr) - deallocate(indxarr) - ! - ! -- return - return - end subroutine unique_values_dbl1d + + subroutine unique_values_int1d(a, b) + ! - dummy arguments + integer(I4B), dimension(:), allocatable, intent(in) :: a + integer(I4B), dimension(:), allocatable, intent(inout) :: b + ! -- local variables + integer(I4B) :: count + integer(I4B) :: n + integer(I4B), dimension(:), allocatable :: indxarr + integer(I4B), dimension(:), allocatable :: tarr + ! -- functions + ! -- code + ! + ! -- allocate tarr and create idxarr + allocate(tarr(size(a))) + allocate(indxarr(size(a))) + ! + ! -- fill tarr with a and create index + do n = 1, size(a) + tarr(n) = a(n) + indxarr(n) = n + end do + ! + ! -- sort a in increasing order + call qsort(indxarr, tarr, reverse=.TRUE.) + ! + ! -- determine the number of unique values + count = 1 + do n = 2, size(tarr) + if (tarr(n) > tarr(n-1)) count = count + 1 + end do + ! + ! -- allocate b for unique values + if (allocated(b)) then + deallocate(b) + end if + allocate(b(count)) + ! + ! -- fill b with unique values + b(1) = tarr(1) + count = 1 + do n = 2, size(a) + if (tarr(n) > b(count)) then + count = count + 1 + b(count) = tarr(n) + end if + end do + ! + ! -- allocate tarr and create idxarr + deallocate(tarr) + deallocate(indxarr) + ! + ! -- return + return + end subroutine unique_values_int1d + + subroutine unique_values_dbl1d(a, b) + ! - dummy arguments + real(DP), dimension(:), allocatable, intent(in) :: a + real(DP), dimension(:), allocatable, intent(inout) :: b + ! -- local variables + integer(I4B) :: count + integer(I4B) :: n + integer(I4B), dimension(:), allocatable :: indxarr + real(DP), dimension(:), allocatable :: tarr + ! -- functions + ! -- code + ! + ! -- allocate tarr and create idxarr + allocate(tarr(size(a))) + allocate(indxarr(size(a))) + ! + ! -- fill tarr with a and create index + do n = 1, size(a) + tarr(n) = a(n) + indxarr(n) = n + end do + ! + ! -- sort a in increasing order + call qsort(indxarr, tarr, reverse=.TRUE.) + ! + ! -- determine the number of unique values + count = 1 + do n = 2, size(tarr) + if (tarr(n) > tarr(n-1)) count = count + 1 + end do + ! + ! -- allocate b for unique values + if (allocated(b)) then + deallocate(b) + end if + allocate(b(count)) + ! + ! -- fill b with unique values + b(1) = tarr(1) + count = 1 + do n = 2, size(a) + if (tarr(n) > b(count)) then + count = count + 1 + b(count) = tarr(n) + end if + end do + ! + ! -- allocate tarr and create idxarr + deallocate(tarr) + deallocate(indxarr) + ! + ! -- return + return + end subroutine unique_values_dbl1d subroutine selectn(indx, v, reverse) ! ************************************************************************** @@ -518,8 +518,8 @@ subroutine iswap(ia, ib) ! ! -- return return - end subroutine iswap - + end subroutine iswap + end module SortModule diff --git a/src/mf6core.f90 b/src/mf6core.f90 index cab92cac262..df9ae4e0074 100644 --- a/src/mf6core.f90 +++ b/src/mf6core.f90 @@ -1,326 +1,326 @@ -module Mf6CoreModule - use KindModule, only: I4B - use ListsModule, only: basesolutionlist, solutiongrouplist, basemodellist, baseexchangelist - use BaseModelModule, only: BaseModelType, GetBaseModelFromList - use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList - use BaseSolutionModule, only: BaseSolutionType, GetBaseSolutionFromList - use SolutionGroupModule, only: SolutionGroupType, GetSolutionGroupFromList - implicit none -contains - - subroutine Mf6Run - ! ****************************************************************************** - ! Main MODFLOW Version 6 program. - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - ! -- modules - - use CommandArguments, only: GetCommandLineArguments - use TdisModule, only: totim, totalsimtime - use KindModule, only: DP - logical :: hasConverged - ! - ! -- parse any command line arguments - call GetCommandLineArguments() - ! - ! initialize simulation - call Mf6Initialize() - ! - ! -- time loop - tsloop: do while (totim < totalsimtime) - - ! perform a time step - hasConverged = Mf6Update() - - ! if not converged, break - if(.not. hasConverged) exit tsloop - - enddo tsloop - ! - ! -- finalize simulation - call Mf6Finalize() - - end subroutine Mf6Run - - subroutine Mf6Initialize() - use SimulationCreateModule, only: simulation_cr - - ! -- print banner and info to screen - call printInfo() - - ! -- create - call simulation_cr() - - ! -- define - call simulation_df() - - ! -- allocate and read - call simulation_ar() - - end subroutine Mf6Initialize - - function Mf6Update() result(hasConverged) - logical :: hasConverged - ! - ! -- prepare timestep - call Mf6PrepareTimestep() - ! - ! -- do timestep - call Mf6DoTimestep() - ! - ! -- after timestep - hasConverged = Mf6FinalizeTimestep() - ! - end function Mf6Update - - subroutine Mf6Finalize() - use, intrinsic :: iso_fortran_env, only: output_unit - use ListsModule, only: lists_da - use MemoryManagerModule, only: mem_usage, mem_da - use TimerModule, only: elapsed_time - use SimVariablesModule, only: iout - use SimulationCreateModule, only: simulation_cr, simulation_da - use TdisModule, only: tdis_tu, tdis_da - use SimModule, only: final_message - integer(I4B) :: im, ic, is, isg - class(SolutionGroupType), pointer :: sgp => null() - class(BaseSolutionType), pointer :: sp => null() - class(BaseModelType), pointer :: mp => null() - class(BaseExchangeType), pointer :: ep => null() - - ! -- FINAL PROCESSING (FP) - ! -- Final processing for each model - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - call mp%model_fp() - enddo - ! - ! -- Final processing for each exchange - do ic = 1, baseexchangelist%Count() - ep => GetBaseExchangeFromList(baseexchangelist, ic) - call ep%exg_fp() - enddo - ! - ! -- Final processing for each solution - do is=1,basesolutionlist%Count() - sp => GetBaseSolutionFromList(basesolutionlist, is) - call sp%sln_fp() - enddo - ! - ! -- DEALLOCATE (DA) - ! -- Deallocate tdis - call tdis_da() - ! - ! -- Deallocate for each model - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - call mp%model_da() - deallocate(mp) - enddo - ! - ! -- Deallocate for each exchange - do ic = 1, baseexchangelist%Count() - ep => GetBaseExchangeFromList(baseexchangelist, ic) - call ep%exg_da() - deallocate(ep) - enddo - ! - ! -- Deallocate for each solution - do is=1,basesolutionlist%Count() - sp => GetBaseSolutionFromList(basesolutionlist, is) - call sp%sln_da() - deallocate(sp) - enddo - ! - ! -- Deallocate solution group and simulation variables - do isg = 1, solutiongrouplist%Count() - sgp => GetSolutionGroupFromList(solutiongrouplist, isg) - call sgp%sgp_da() - deallocate(sgp) - enddo - call simulation_da() - call lists_da() - ! - ! -- Calculate memory usage, elapsed time and terminate - call mem_usage(iout) - call mem_da() - call elapsed_time(iout, 1) - call final_message() - ! - end subroutine Mf6Finalize - - subroutine printInfo() - use CompilerVersion - use VersionModule, only: VERSION, MFVNAM, MFTITLE, FMTDISCLAIMER, & - IDEVELOPMODE - use TimerModule, only: start_time - use GenericUtilitiesModule, only: write_centered, sim_message - character(len=80) :: compiler - - ! -- Write banner to screen (unit stdout) and start timer - call write_centered('MODFLOW'//MFVNAM, 80) - call write_centered(MFTITLE, 80) - call write_centered('VERSION '//VERSION, 80) - ! - ! -- Write if develop mode - if (IDEVELOPMODE == 1) then - call write_centered('***DEVELOP MODE***', 80) - end if - ! - ! -- Write compiler version - call get_compiler(compiler) - call write_centered(' ', 80) - call write_centered(trim(adjustl(compiler)), 80) - ! - ! -- Write disclaimer - call sim_message('', fmt=FMTDISCLAIMER) - ! - ! -- get start time - call start_time() - - end subroutine printInfo - - subroutine simulation_df() - integer(I4B) :: im, ic, is - class(BaseSolutionType), pointer :: sp => null() - class(BaseModelType), pointer :: mp => null() - class(BaseExchangeType), pointer :: ep => null() - - ! -- Define each model - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - call mp%model_df() - enddo - ! - ! -- Define each exchange - do ic = 1, baseexchangelist%Count() - ep => GetBaseExchangeFromList(baseexchangelist, ic) - call ep%exg_df() - enddo - ! - ! -- Define each solution - do is = 1, basesolutionlist%Count() - sp => GetBaseSolutionFromList(basesolutionlist, is) - call sp%sln_df() - enddo - - end subroutine simulation_df - - subroutine simulation_ar() - integer(I4B) :: im, ic, is - class(BaseSolutionType), pointer :: sp => null() - class(BaseModelType), pointer :: mp => null() - class(BaseExchangeType), pointer :: ep => null() - - ! -- Allocate and read each model - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - call mp%model_ar() - enddo - ! - ! -- Allocate and read each exchange - do ic = 1, baseexchangelist%Count() - ep => GetBaseExchangeFromList(baseexchangelist, ic) - call ep%exg_ar() - enddo - ! - ! -- Allocate and read each solution - do is=1,basesolutionlist%Count() - sp => GetBaseSolutionFromList(basesolutionlist, is) - call sp%sln_ar() - enddo - ! - end subroutine simulation_ar - - subroutine Mf6PrepareTimestep() - use KindModule, only: I4B - use TdisModule, only: tdis_tu - use ListsModule, only: basesolutionlist, basemodellist, baseexchangelist - use BaseModelModule, only: BaseModelType, GetBaseModelFromList - use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList - use BaseSolutionModule, only: BaseSolutionType, GetBaseSolutionFromList - use SimModule, only: converge_reset - - integer(I4B) :: im, ic, is - class(BaseSolutionType), pointer :: sp => null() - class(BaseModelType), pointer :: mp => null() - class(BaseExchangeType), pointer :: ep => null() - - ! -- time update - call tdis_tu() - - ! -- Read and prepare each model - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - call mp%model_rp() - enddo - ! - ! -- Read and prepare each exchange - do ic = 1, baseexchangelist%Count() - ep => GetBaseExchangeFromList(baseexchangelist, ic) - call ep%exg_rp() - enddo - ! - ! -- Read and prepare each solution - do is=1,basesolutionlist%Count() - sp => GetBaseSolutionFromList(basesolutionlist, is) - call sp%sln_rp() - enddo - ! - call converge_reset() - - end subroutine Mf6PrepareTimestep - - subroutine Mf6DoTimestep() - use KindModule, only: I4B - use ListsModule, only: solutiongrouplist - use SolutionGroupModule, only: SolutionGroupType, GetSolutionGroupFromList - class(SolutionGroupType), pointer :: sgp => null() - integer(I4B) :: isg - - do isg = 1, solutiongrouplist%Count() - sgp => GetSolutionGroupFromList(solutiongrouplist, isg) - call sgp%sgp_ca() - enddo - - end subroutine Mf6DoTimestep - - function Mf6FinalizeTimestep() result(hasConverged) - use KindModule, only: I4B - use ListsModule, only: basesolutionlist, basemodellist, baseexchangelist - use BaseModelModule, only: BaseModelType, GetBaseModelFromList - use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList - use BaseSolutionModule, only: BaseSolutionType, GetBaseSolutionFromList - use SimModule, only: converge_check - logical :: hasConverged - integer(I4B) :: im, ic, is - class(BaseSolutionType), pointer :: sp => null() - class(BaseModelType), pointer :: mp => null() - class(BaseExchangeType), pointer :: ep => null() - - ! -- Write output for each model - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - call mp%model_ot() - enddo - ! - ! -- Write output for each exchange - do ic = 1, baseexchangelist%Count() - ep => GetBaseExchangeFromList(baseexchangelist, ic) - call ep%exg_ot() - enddo - ! - ! -- Write output for each solution - do is=1,basesolutionlist%Count() - sp => GetBaseSolutionFromList(basesolutionlist, is) - call sp%sln_ot() - enddo - ! - ! -- Check if we're done - call converge_check(hasConverged) - - end function Mf6FinalizeTimestep - -end module Mf6CoreModule +module Mf6CoreModule + use KindModule, only: I4B + use ListsModule, only: basesolutionlist, solutiongrouplist, basemodellist, baseexchangelist + use BaseModelModule, only: BaseModelType, GetBaseModelFromList + use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList + use BaseSolutionModule, only: BaseSolutionType, GetBaseSolutionFromList + use SolutionGroupModule, only: SolutionGroupType, GetSolutionGroupFromList + implicit none +contains + + subroutine Mf6Run + ! ****************************************************************************** + ! Main MODFLOW Version 6 program. + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + ! -- modules + + use CommandArguments, only: GetCommandLineArguments + use TdisModule, only: totim, totalsimtime + use KindModule, only: DP + logical :: hasConverged + ! + ! -- parse any command line arguments + call GetCommandLineArguments() + ! + ! initialize simulation + call Mf6Initialize() + ! + ! -- time loop + tsloop: do while (totim < totalsimtime) + + ! perform a time step + hasConverged = Mf6Update() + + ! if not converged, break + if(.not. hasConverged) exit tsloop + + enddo tsloop + ! + ! -- finalize simulation + call Mf6Finalize() + + end subroutine Mf6Run + + subroutine Mf6Initialize() + use SimulationCreateModule, only: simulation_cr + + ! -- print banner and info to screen + call printInfo() + + ! -- create + call simulation_cr() + + ! -- define + call simulation_df() + + ! -- allocate and read + call simulation_ar() + + end subroutine Mf6Initialize + + function Mf6Update() result(hasConverged) + logical :: hasConverged + ! + ! -- prepare timestep + call Mf6PrepareTimestep() + ! + ! -- do timestep + call Mf6DoTimestep() + ! + ! -- after timestep + hasConverged = Mf6FinalizeTimestep() + ! + end function Mf6Update + + subroutine Mf6Finalize() + use, intrinsic :: iso_fortran_env, only: output_unit + use ListsModule, only: lists_da + use MemoryManagerModule, only: mem_usage, mem_da + use TimerModule, only: elapsed_time + use SimVariablesModule, only: iout + use SimulationCreateModule, only: simulation_cr, simulation_da + use TdisModule, only: tdis_tu, tdis_da + use SimModule, only: final_message + integer(I4B) :: im, ic, is, isg + class(SolutionGroupType), pointer :: sgp => null() + class(BaseSolutionType), pointer :: sp => null() + class(BaseModelType), pointer :: mp => null() + class(BaseExchangeType), pointer :: ep => null() + + ! -- FINAL PROCESSING (FP) + ! -- Final processing for each model + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + call mp%model_fp() + enddo + ! + ! -- Final processing for each exchange + do ic = 1, baseexchangelist%Count() + ep => GetBaseExchangeFromList(baseexchangelist, ic) + call ep%exg_fp() + enddo + ! + ! -- Final processing for each solution + do is=1,basesolutionlist%Count() + sp => GetBaseSolutionFromList(basesolutionlist, is) + call sp%sln_fp() + enddo + ! + ! -- DEALLOCATE (DA) + ! -- Deallocate tdis + call tdis_da() + ! + ! -- Deallocate for each model + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + call mp%model_da() + deallocate(mp) + enddo + ! + ! -- Deallocate for each exchange + do ic = 1, baseexchangelist%Count() + ep => GetBaseExchangeFromList(baseexchangelist, ic) + call ep%exg_da() + deallocate(ep) + enddo + ! + ! -- Deallocate for each solution + do is=1,basesolutionlist%Count() + sp => GetBaseSolutionFromList(basesolutionlist, is) + call sp%sln_da() + deallocate(sp) + enddo + ! + ! -- Deallocate solution group and simulation variables + do isg = 1, solutiongrouplist%Count() + sgp => GetSolutionGroupFromList(solutiongrouplist, isg) + call sgp%sgp_da() + deallocate(sgp) + enddo + call simulation_da() + call lists_da() + ! + ! -- Calculate memory usage, elapsed time and terminate + call mem_usage(iout) + call mem_da() + call elapsed_time(iout, 1) + call final_message() + ! + end subroutine Mf6Finalize + + subroutine printInfo() + use CompilerVersion + use VersionModule, only: VERSION, MFVNAM, MFTITLE, FMTDISCLAIMER, & + IDEVELOPMODE + use TimerModule, only: start_time + use GenericUtilitiesModule, only: write_centered, sim_message + character(len=80) :: compiler + + ! -- Write banner to screen (unit stdout) and start timer + call write_centered('MODFLOW'//MFVNAM, 80) + call write_centered(MFTITLE, 80) + call write_centered('VERSION '//VERSION, 80) + ! + ! -- Write if develop mode + if (IDEVELOPMODE == 1) then + call write_centered('***DEVELOP MODE***', 80) + end if + ! + ! -- Write compiler version + call get_compiler(compiler) + call write_centered(' ', 80) + call write_centered(trim(adjustl(compiler)), 80) + ! + ! -- Write disclaimer + call sim_message('', fmt=FMTDISCLAIMER) + ! + ! -- get start time + call start_time() + + end subroutine printInfo + + subroutine simulation_df() + integer(I4B) :: im, ic, is + class(BaseSolutionType), pointer :: sp => null() + class(BaseModelType), pointer :: mp => null() + class(BaseExchangeType), pointer :: ep => null() + + ! -- Define each model + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + call mp%model_df() + enddo + ! + ! -- Define each exchange + do ic = 1, baseexchangelist%Count() + ep => GetBaseExchangeFromList(baseexchangelist, ic) + call ep%exg_df() + enddo + ! + ! -- Define each solution + do is = 1, basesolutionlist%Count() + sp => GetBaseSolutionFromList(basesolutionlist, is) + call sp%sln_df() + enddo + + end subroutine simulation_df + + subroutine simulation_ar() + integer(I4B) :: im, ic, is + class(BaseSolutionType), pointer :: sp => null() + class(BaseModelType), pointer :: mp => null() + class(BaseExchangeType), pointer :: ep => null() + + ! -- Allocate and read each model + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + call mp%model_ar() + enddo + ! + ! -- Allocate and read each exchange + do ic = 1, baseexchangelist%Count() + ep => GetBaseExchangeFromList(baseexchangelist, ic) + call ep%exg_ar() + enddo + ! + ! -- Allocate and read each solution + do is=1,basesolutionlist%Count() + sp => GetBaseSolutionFromList(basesolutionlist, is) + call sp%sln_ar() + enddo + ! + end subroutine simulation_ar + + subroutine Mf6PrepareTimestep() + use KindModule, only: I4B + use TdisModule, only: tdis_tu + use ListsModule, only: basesolutionlist, basemodellist, baseexchangelist + use BaseModelModule, only: BaseModelType, GetBaseModelFromList + use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList + use BaseSolutionModule, only: BaseSolutionType, GetBaseSolutionFromList + use SimModule, only: converge_reset + + integer(I4B) :: im, ic, is + class(BaseSolutionType), pointer :: sp => null() + class(BaseModelType), pointer :: mp => null() + class(BaseExchangeType), pointer :: ep => null() + + ! -- time update + call tdis_tu() + + ! -- Read and prepare each model + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + call mp%model_rp() + enddo + ! + ! -- Read and prepare each exchange + do ic = 1, baseexchangelist%Count() + ep => GetBaseExchangeFromList(baseexchangelist, ic) + call ep%exg_rp() + enddo + ! + ! -- Read and prepare each solution + do is=1,basesolutionlist%Count() + sp => GetBaseSolutionFromList(basesolutionlist, is) + call sp%sln_rp() + enddo + ! + call converge_reset() + + end subroutine Mf6PrepareTimestep + + subroutine Mf6DoTimestep() + use KindModule, only: I4B + use ListsModule, only: solutiongrouplist + use SolutionGroupModule, only: SolutionGroupType, GetSolutionGroupFromList + class(SolutionGroupType), pointer :: sgp => null() + integer(I4B) :: isg + + do isg = 1, solutiongrouplist%Count() + sgp => GetSolutionGroupFromList(solutiongrouplist, isg) + call sgp%sgp_ca() + enddo + + end subroutine Mf6DoTimestep + + function Mf6FinalizeTimestep() result(hasConverged) + use KindModule, only: I4B + use ListsModule, only: basesolutionlist, basemodellist, baseexchangelist + use BaseModelModule, only: BaseModelType, GetBaseModelFromList + use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList + use BaseSolutionModule, only: BaseSolutionType, GetBaseSolutionFromList + use SimModule, only: converge_check + logical :: hasConverged + integer(I4B) :: im, ic, is + class(BaseSolutionType), pointer :: sp => null() + class(BaseModelType), pointer :: mp => null() + class(BaseExchangeType), pointer :: ep => null() + + ! -- Write output for each model + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + call mp%model_ot() + enddo + ! + ! -- Write output for each exchange + do ic = 1, baseexchangelist%Count() + ep => GetBaseExchangeFromList(baseexchangelist, ic) + call ep%exg_ot() + enddo + ! + ! -- Write output for each solution + do is=1,basesolutionlist%Count() + sp => GetBaseSolutionFromList(basesolutionlist, is) + call sp%sln_ot() + enddo + ! + ! -- Check if we're done + call converge_check(hasConverged) + + end function Mf6FinalizeTimestep + +end module Mf6CoreModule diff --git a/src/mf6lists.f90 b/src/mf6lists.f90 index 8509c128307..0d8de391f4f 100644 --- a/src/mf6lists.f90 +++ b/src/mf6lists.f90 @@ -3,13 +3,13 @@ module ListsModule ! BaseSolutionType, SolutionGroupType, and ! BaseExchangeType for use by any MF6 module. - use KindModule, only: DP, I4B + use KindModule, only: DP, I4B use ListModule, only: ListType - + implicit none private public :: basemodellist, basesolutionlist, solutiongrouplist, & - baseexchangelist + baseexchangelist public :: lists_da ! -- list of all models in simulation @@ -22,24 +22,24 @@ module ListsModule type(ListType) :: solutiongrouplist ! -- list of all exchanges in simulation - type(ListType) :: baseexchangelist - - contains - - subroutine lists_da() -! ****************************************************************************** -! Deallocate the lists -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ -! ------------------------------------------------------------------------------ - ! - call basemodellist%Clear() - call basesolutionlist%Clear() - call solutiongrouplist%Clear() - call baseexchangelist%Clear() - return + type(ListType) :: baseexchangelist + + contains + + subroutine lists_da() +! ****************************************************************************** +! Deallocate the lists +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ + ! + call basemodellist%Clear() + call basesolutionlist%Clear() + call solutiongrouplist%Clear() + call baseexchangelist%Clear() + return end subroutine lists_da end module ListsModule diff --git a/srcbmi/mf6bmi.f90 b/srcbmi/mf6bmi.f90 index 8061c9f3924..f410e26bb3b 100644 --- a/srcbmi/mf6bmi.f90 +++ b/srcbmi/mf6bmi.f90 @@ -9,9 +9,9 @@ module mf6bmi use bmif, only: BMI_SUCCESS, BMI_FAILURE use iso_c_binding, only: c_int, c_char, c_double, C_NULL_CHAR, c_loc, c_ptr use KindModule, only: DP, I4B - use ConstantsModule, only: LENORIGIN, LENVARNAME, LENMODELNAME, MAXCHARLEN - use SimVariablesModule, only: simstdout, istdout - use InputOutputModule, only: getunit + use ConstantsModule, only: LENORIGIN, LENVARNAME, LENMODELNAME, MAXCHARLEN + use SimVariablesModule, only: simstdout, istdout + use InputOutputModule, only: getunit implicit none ! Define global constants @@ -29,14 +29,14 @@ module mf6bmi function bmi_initialize() result(bmi_status) bind(C, name="initialize") !DEC$ ATTRIBUTES DLLEXPORT :: bmi_initialize integer(kind=c_int) :: bmi_status - ! - ! -- set STDOUT to a physical file unit - istdout = getunit() - ! + ! + ! -- set STDOUT to a physical file unit + istdout = getunit() + ! ! -- open stdout file mfsim.stdout - open(unit=istdout, file=simstdout) - ! - ! -- initialize MODFLOW 6 + open(unit=istdout, file=simstdout) + ! + ! -- initialize MODFLOW 6 call Mf6Initialize() bmi_status = BMI_SUCCESS @@ -70,7 +70,7 @@ function bmi_finalize() result(bmi_status) bind(C, name="finalize") ! we don't want a full stop() here, this disables it: iforcestop = 0 - call Mf6Finalize() + call Mf6Finalize() bmi_status = BMI_SUCCESS diff --git a/utils/mf5to6/msvs/mf5to6.sln b/utils/mf5to6/msvs/mf5to6.sln index 7f914964130..0100791fe14 100644 --- a/utils/mf5to6/msvs/mf5to6.sln +++ b/utils/mf5to6/msvs/mf5to6.sln @@ -1,22 +1,22 @@ - -Microsoft Visual Studio Solution File, Format Version 12.00 -# Visual Studio 14 -VisualStudioVersion = 14.0.25420.1 -MinimumVisualStudioVersion = 10.0.40219.1 -Project("{6989167D-11E4-40FE-8C1A-2192A86A7E90}") = "mf5to6", "mf5to6.vfproj", "{EE5F8367-9220-45ED-9B0B-5942AF51229C}" -EndProject -Global - GlobalSection(SolutionConfigurationPlatforms) = preSolution - Debug|x86 = Debug|x86 - Release|x86 = Release|x86 - EndGlobalSection - GlobalSection(ProjectConfigurationPlatforms) = postSolution - {EE5F8367-9220-45ED-9B0B-5942AF51229C}.Debug|x86.ActiveCfg = Debug|Win32 - {EE5F8367-9220-45ED-9B0B-5942AF51229C}.Debug|x86.Build.0 = Debug|Win32 - {EE5F8367-9220-45ED-9B0B-5942AF51229C}.Release|x86.ActiveCfg = Release|Win32 - {EE5F8367-9220-45ED-9B0B-5942AF51229C}.Release|x86.Build.0 = Release|Win32 - EndGlobalSection - GlobalSection(SolutionProperties) = preSolution - HideSolutionNode = FALSE - EndGlobalSection -EndGlobal + +Microsoft Visual Studio Solution File, Format Version 12.00 +# Visual Studio 14 +VisualStudioVersion = 14.0.25420.1 +MinimumVisualStudioVersion = 10.0.40219.1 +Project("{6989167D-11E4-40FE-8C1A-2192A86A7E90}") = "mf5to6", "mf5to6.vfproj", "{EE5F8367-9220-45ED-9B0B-5942AF51229C}" +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|x86 = Debug|x86 + Release|x86 = Release|x86 + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {EE5F8367-9220-45ED-9B0B-5942AF51229C}.Debug|x86.ActiveCfg = Debug|Win32 + {EE5F8367-9220-45ED-9B0B-5942AF51229C}.Debug|x86.Build.0 = Debug|Win32 + {EE5F8367-9220-45ED-9B0B-5942AF51229C}.Release|x86.ActiveCfg = Release|Win32 + {EE5F8367-9220-45ED-9B0B-5942AF51229C}.Release|x86.Build.0 = Release|Win32 + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection +EndGlobal diff --git a/utils/mf5to6/msvs/mf5to6.vfproj b/utils/mf5to6/msvs/mf5to6.vfproj index 4a646a6a76c..5dc7976b665 100644 --- a/utils/mf5to6/msvs/mf5to6.vfproj +++ b/utils/mf5to6/msvs/mf5to6.vfproj @@ -1,187 +1,187 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/utils/mf5to6/src/Lake.f90 b/utils/mf5to6/src/Lake.f90 index f4a4d4d0a04..507682dbc32 100644 --- a/utils/mf5to6/src/Lake.f90 +++ b/utils/mf5to6/src/Lake.f90 @@ -197,8 +197,8 @@ subroutine WriteBathFile(this) call openfile(iu, 0, this%TableFile, 'BATHYMETRY', filstat_opt='REPLACE') ! write(iu,30)'BEGIN DIMENSIONS' - write(iu,40)'NROW',ndim - write(iu,40)'NCOL',3 + write(iu,40)'NROW',ndim + write(iu,40)'NCOL',3 write(iu,30)'END DIMENSIONS' write(iu,1) ! diff --git a/utils/mf5to6/src/MF2005/GwfLakSubs.f b/utils/mf5to6/src/MF2005/GwfLakSubs.f index 6fb5665e370..15214b5978d 100644 --- a/utils/mf5to6/src/MF2005/GwfLakSubs.f +++ b/utils/mf5to6/src/MF2005/GwfLakSubs.f @@ -1,2125 +1,2125 @@ - module GwfLakSubs - - use GWFLAKMODULE, only: SGWF2LAK7PNT - use SimModule, only: store_warning, store_error - private - public :: GWF2LAK7AR, GWF2LAK7RP - - contains - - SUBROUTINE GWF2LAK7AR(IN,IUNITSFR,IUNITGWT,IUNITUZF,NSOL,IGRID) -C -C------USGS VERSION 7.1; JUNE 2006 GWF2LAK7AR; -C------UPDATED FOR MF-2005, FEBRUARY 6, 2012 -C ****************************************************************** -C INITIALIZE POINTER VARIABLES USED BY SFR1 TO SUPPORT LAKE3 AND -C GAGE PACKAGES AND THE GWT PROCESS -C ****************************************************************** -C - USE GWFLAKMODULE - USE GLOBAL, ONLY: IOUT, NCOL, NROW, NLAY, IFREFM, ITRSS, - + NODES - USE GWFSFRMODULE, ONLY: NSS - use utl7module, only: URDCOM, URWORD, U2DINT, U2DREL -C -C ****************************************************************** -C ALLOCATE ARRAY STORAGE FOR LAKES -C ****************************************************************** -C -C ------------------------------------------------------------------ -C SPECIFICATIONS: - CHARACTER (LEN=40):: CARD - CHARACTER*200 line - double precision :: r -C ------------------------------------------------------------------ -Crsr Allocate lake variables used by SFR even if lakes not active so that -C argument lists are defined - ALLOCATE (NLAKES, NLAKESAR,THETA,LAKUNIT) - allocate (NeedLakWaterMover) - NeedLakWaterMover = .false. - NLAKES = 0 - LAKUNIT = IN - NLAKESAR = 1 - THETA = 0.0 -C0--If LAK package is active - IF (IN.GT.0) THEN -Cdep added SURFDEPTH 3/3/2009 - ALLOCATE (ILKCB, NSSITR, SSCNCR, SURFDEPTH) - ALLOCATE (MXLKND, LKNODE, ICMX, NCLS, LWRT, NDV, NTRB) - ALLOCATE (IRDTAB) -C -C1------IDENTIFY PACKAGE AND INITIALIZE LKNODE. - WRITE(IOUT,1) IN - LKNODE=0 -Cdep initialize number of iterations and closure criteria to zero. - DUM = 0.0 - NSSITR = 0 - SSCNCR = 0.0 - SURFDEPTH = 0.0 -! - lloc = 1 - IRDTAB = 0 - NPP = 0 - MXVL = 0 -! Read item 1a - CALL URDCOM(In, IOUT, line) -! Check for alternate option to specifiy stage/vol/area tables. - CALL UPARLSTAL(IN,IOUT,LINE,NPP,MXVL) ! ERB - Pointless, since LAK does not support parameters - lloc = 1 - CALL URWORD(LINE,LLOC,ISTART,ISTOP,1,I,R,IOUT,IN) - IF(LINE(ISTART:ISTOP).EQ.'TABLEINPUT') THEN - IRDTAB = 1 - WRITE(IOUT,32) - 32 FORMAT(1X,I10,' Stage, volume and area relationship specified ', - + 'based on an external tabular input file') - ELSE - BACKSPACE IN - WRITE(IOUT,'(A)') ' Model grid will be used to develop ', - + ' volume and area relationship. ' - ENDIF -C -C2------READ NLAKES, ILKCB. -C -Cdep Revised input statement to read THETA,NSSITR,SSCNCR for -Cdep transient simulations when THETA is negative. - IF(IFREFM.EQ.0) THEN -! Read item 1b - READ(IN,'(2I10)')NLAKES,ILKCB -! Read item 2 and backspace - IF (ITRSS.LE.0) THEN - READ(IN,'(F10.2,I10,F10.2)') THETA,NSSITR,SSCNCR - IF (THETA.LT.0.0) BACKSPACE IN - ELSE - READ(IN,'(F10.2)') THETA - IF (THETA.LT.0.0) BACKSPACE IN - ENDIF - ELSE -! Read item 1b - READ(IN,*) NLAKES,ILKCB -! Read item 2 and backspace - IF (ITRSS.LE.0) THEN - READ(IN,*) THETA,NSSITR,SSCNCR - IF(THETA.LT.0.0) BACKSPACE IN - ELSE - READ(IN,*) THETA - IF(THETA.LT.0.0) BACKSPACE IN - ENDIF - ENDIF - -Cdep Set default values for number of iterations and closure criteria -Cdep for transient simulations when using original version of -Cdep LAKE Package. - IF(THETA.GE.0.0.AND.NSSITR.EQ.0) THEN - NSSITR=100 - SSCNCR=1.0E-05 - ELSEIF(THETA.LT.0.0)THEN - THETA=ABS(THETA) -! Read item 2 - IF(IFREFM.EQ.0) THEN -Cdep fixed format can't read in exponent notation -!rsr, old data sets may not have SURFDEPTH, may need to trap this for some compilers - READ (IN, '(A)') CARD - NUMCHAR = LEN(TRIM(CARD)) - IF ( NUMCHAR>30 ) THEN - READ(CARD,'(F10.2,I10,2F10.5)') DUM,NSSITR,SSCNCR, - + SURFDEPTH - ELSE - READ(CARD,'(F10.2,I10,F10.5)') DUM,NSSITR,SSCNCR - ENDIF - ELSE - READ(IN,*,IOSTAT=IOS) DUM,NSSITR,SSCNCR,SURFDEPTH - IF ( IOS.NE.0 ) SURFDEPTH = 0.0 - ENDIF - ENDIF -Cdep Add check to reset THETA when > 1 or < 0.5. - IF(THETA.GT.1.0) THEN - THETA = 1.0 - ELSEIF(THETA.LT.0.5)THEN - THETA = 0.0 - ENDIF - ENDIF ! goes with IF at comment C0 -C -C -C SET NLAKES ARRAY VARIABLE TO NLAKES IF NLAKES GREATER THAN 0. - IF (NLAKES.GT.0) NLAKESAR = NLAKES - ALLOCATE (VOL(NLAKESAR), STGOLD(NLAKESAR), STGNEW(NLAKESAR)) - ALLOCATE(STGOLD2(NLAKESAR)) - ALLOCATE (VOLOLDD(NLAKESAR)) -! ALLOCATE (VOLOLDD(NLAKESAR), VOLOLD(NLAKES), VOLINIT(NLAKES)) - ALLOCATE (STGITER(NLAKESAR)) - ALLOCATE (LAKSEEP(NCOL,NROW)) - STGNEW = 0.0D0 - STGOLD = 0.0D0 - STGOLD2 = 0.0D0 - STGITER = 0.0D0 - VOLOLDD = 0.0D0 - LAKSEEP = 0.0 -Cdep initialized VOLOLD and VOLINIT 6/4/2009 (VOLOLD is single precision) -! VOLOLD = 0.0 -! VOLINIT = 0.0 - VOL = 0.0 - CALL SGWF2LAK7PSV1(IGRID) - IF (IN.LT.1) RETURN -C -C Lakes are active - ALLOCATE (STAGES(NLAKESAR), CLAKE(NLAKESAR,NSOL)) - STAGES = 0.0 - CLAKE = 0.0 -C Budget variables for GSFLOW - ALLOCATE (TOTGWIN_LAK,TOTGWOT_LAK,TOTDELSTOR_LAK,TOTSTOR_LAK) - ALLOCATE (TOTEVAP_LAK,TOTPPT_LAK,TOTRUNF_LAK,TOTWTHDRW_LAK) - ALLOCATE (TOTSURFIN_LAK,TOTSURFOT_LAK) - TOTGWIN_LAK = 0.0 - TOTGWOT_LAK = 0.0 - TOTDELSTOR_LAK = 0.0 - TOTSTOR_LAK = 0.0 - TOTEVAP_LAK = 0.0 - TOTPPT_LAK = 0.0 - TOTRUNF_LAK = 0.0 - TOTWTHDRW_LAK = 0.0 - TOTSURFIN_LAK = 0.0 - TOTSURFOT_LAK = 0.0 -C -C VALUE OF MXLKND (NUMBER OF LAKE-AQUIFER INTERFACES) IS AN ESTIMATE. -C TO SAVE MEMORY, REDUCE ITS SIZE IF APPROPRIATE. -C IF MXLKND TOO SMALL, ERROR MESSAGE WILL BE PRINTED. - MXLKND=NCOL*NROW*NLAY/2 - IF (NLAKES.LT.1) THEN - WRITE(IOUT,2) - IN=0 - NLAKES = 0 - ELSE - WRITE(IOUT,5) MXLKND,NLAKES - IF (ILKCB.GT.0) WRITE(IOUT,7) ILKCB - IF (ILKCB.LE.0) WRITE(IOUT,9) -Cdep Write THETA, NSSITR, SSCNCR - IF (ITRSS.GT.0) THEN - WRITE(IOUT,22) THETA - WRITE(IOUT,10) NSSITR, SSCNCR - ELSE - WRITE(IOUT,11) THETA, NSSITR, SSCNCR - ENDIF -Cdep Changed default values for NSSITR and SSCNCR and revised -Cdep print statements using format statement 10. -Cdep IF(ITRSS.LE.0.AND.NSSITR.EQ.0) NSSITR = 50 -Cdep IF(ITRSS.LE.0.AND.SSCNCR.EQ.0.0) SSCNCR = 0.01 -Cdep IF(ITRSS.EQ.0) WRITE(IOUT,23) NSSITR, SSCNCR -Cdep IF(ITRSS.LT.0) WRITE(IOUT,24) NSSITR, SSCNCR -C-lfk 1 FORMAT(/1X,'LAK7 -- LAKE PACKAGE, VERSION 7, 2/06/2012', -1 FORMAT(/1X,'LAK7 -- LAKE PACKAGE, VERSION 7, 1/07/2013', - 1' INPUT READ FROM UNIT',I3) -2 FORMAT(1X,' NUMBER OF LAKES=0, ', - 1 ' SO LAKE PACKAGE IS BEING TURNED OFF') -5 FORMAT(1X,'SPACE ALLOCATION FOR',I7,' GRID CELL FACES ADJACENT TO - 1LAKES'/1X,'MAXIMUM NUMBER OF LAKES IS',I3, ' FOR THIS SIMULATION') -7 FORMAT(1X,'CELL-BY-CELL FLOWS WILL BE RECORDED ON UNIT',I5) -9 FORMAT(1X,'CELL-BY-CELL SEEPAGES WILL NOT BE PRINTED OR SAVED') -Cdep added format statement when starting with transient simulation - 10 FORMAT(//1X,'LAKE PACKAGE HAS BEEN MODIFIED TO ITERATIVELY ', - 1 'SOLVE FOR LAKE STAGE DURING TRANSIENT STRESS PERIODS:',/1X, - 2 'MAXIMUM NUMBER OF ITERATIONS (NSSITR) = ',I5,/1X, - 3 'CLOSURE CRITERIA FOR LAKE STAGE (SSCNCR) = ',1PE12.6,/1X, - 4 'DEFAULT VALUES FOR TRANSIENT ONLY SIMULATIONS ARE: ', - 5 'NSSITR = 100 AND SSCNCR = 0.0001',/1X,'VALUES OTHER THAN ', - 6 'DEFAULT CAN BE READ BY SPECIFYING A THETA LESS THAN ZERO ', - 7 'THEN ADDING NSSITR AND SSCNCR PER ORIGINAL INSTRUCTIONS.',/1X, - 8 'NEGATIVE THETA MUST BE LESS THAN ZERO BUT NOT MORE THAN ', - 9 'ONE. THETA IS CONVERTED TO A POSITIVE VALUE.',/1X, - * 'MINIMUM AND MAXIMUM LAKE STAGES FOR TRANSIENT ', - * 'SIMULATIONS ARE SET TO BOTTOM AND TOP ELEVATIONS USED TO ', - * 'COMPUTE LAKE VOLUME, RESPECTIVELY.',//) -Cdep added format statement for steady state only simulations. - 11 FORMAT(//1X,'NEWTON ITERATION METHOD FOR COMPUTING LAKE STAGE ', - 1 'DURING STEADY-STATE STRESS PERIODS HAS BEEN MODIFIED:',/1X, - 2 'SPECIFIED THETA OF ',F6.3,' WILL BE AUTOMATICALLY CHANGED TO ', - 3 '1.0 FOR ALL STEADY STATE STRESS PERIODS.',/1X, - 4 'MAXIMUM NUMBER OF STEADY-STATE ITERATIONS (NSSITR) = ',I5,/1X, - 5 'CLOSURE CRITERIA FOR STEADY-STATE LAKE STAGE (SSCNCR) = ', - 6 1PE12.6,//) -Cdep revised print statement to note that time weighting of theta can -Cdep vary only between 0.5 and 1 for transient simulations -Cdep 22 FORMAT(/1X,'THETA = ',F10.2,' METHOD FOR UPDATING LAKE STAGES IN -Cdep 1ITERATIONS OF THE SOLUTION FOR AQUIFER HEADS.'/20X,'0.0 IS EXPLICI -Cdep 2T, 0.5 IS CENTERED, AND 1.0 IS FULLY IMPLICIT.') - 22 FORMAT(/1X,'THETA = ',F6.3,/1X,'THETA IS THE TIME WEIGHTING ', - *'FACTOR FOR COMPUTING LAKE STAGE DURING TRANSIENT MODFLOW ', - *'TIME STEPS AND ITS DEFINITION HAS BEEN MODIFIED.',/1X,'A THETA ', - *'OF LESS THEN 0.5 IS AUTOMATICALLY SET TO 0 AND LAKE STAGE IS ', - *'EQUAL TO THE STAGE AT THE END OF THE PREVIOUS TIME STEP. ',/1X, - *'TRANSIENT SIMULATIONS OF LAKE STAGE WITH THE CURRENT TIME STEP ', - *'REQUIRES A THETA BETWEEN 0.5 AND 1.0. ',/1X,'VALUES GREATER ', - *'THAN 1.0 ARE AUTOMATICALLY RESET TO 1.0 AND VALUES LESS ', - *'THAN 0.5 ARE RESET TO 0.0.',/1X,'A THETA OF 0.5 REPRESENTS THE ', - *'AVERAGE LAKE STAGE DURING A TIME STEP.',/1X,'A THETA OF 1.0 ', - *'REPRESENTS THE LAKE STAGE AT THE END OF THE TIME STEP.',//) -Cdep 23 FORMAT(/1X,'STEADY-STATE SOLUTION FOR LAKES.' -Cdep 2/1X,'MAXIMUM NUMBER OF ITERATIONS = ',I4,3X, -Cdep 1'CONVERGENCE CRITERION = ',1PE9.2) -Cdep 24 FORMAT(/1X,'COMBINED STEADY-STATE/TRANSIENT SOLUTION FOR LAKES.' -Cdep 2/1X,'MAXIMUM NUMBER OF ITERATIONS = ',I4,3X, -Cdep 1'CONVERGENCE CRITERION = ',1PE9.2) - - ALLOCATE (ILAKE(5,MXLKND), BEDLAK(MXLKND), CNDFCT(MXLKND)) - ALLOCATE (PRCPLK(NLAKES), EVAPLK(NLAKES), WTHDRW(NLAKES)) - ALLOCATE (RNF(NLAKES), CRNF(NLAKES,NSOL), CUMRNF(NLAKES)) - ALLOCATE (CUMUZF(NLAKES)) - ALLOCATE (ISUB(NLAKES,NLAKES), SILLVT(NLAKES,NLAKES)) - ALLOCATE (IRK(2,NLAKES)) - ALLOCATE (CUMPPT(NLAKES), CUMEVP(NLAKES), CUMGWI(NLAKES)) - ALLOCATE (CUMGWO(NLAKES), CUMSWI(NLAKES), CUMSWO(NLAKES)) - ALLOCATE (CUMWDR(NLAKES), CUMFLX(NLAKES)) - ALLOCATE (CAUG(NLAKES,NSOL), CPPT(NLAKES,NSOL)) - ALLOCATE (CLAKINIT(NLAKESAR,NSOL)) - ALLOCATE (ICS(NLAKES),BOTTMS(NLAKES), BGAREA(NLAKES)) - ALLOCATE (SSMN(NLAKES), SSMX(NLAKES)) - ALLOCATE (LKARR1(NCOL,NROW,NLAY), BDLKN1(NCOL,NROW,NLAY)) - ALLOCATE (EVAP(NLAKES), PRECIP(NLAKES), SEEP(NLAKES), - + SEEP3(NLAKES),EVAP3(NLAKES), PRECIP3(NLAKES)) - ALLOCATE (SEEPUZ(NLAKES)) - ALLOCATE (FLWITER(NLAKES),FLWITER3(NLAKES)) - ALLOCATE (SURFA(NLAKES), SURFIN(NLAKES), SURFOT(NLAKES)) - ALLOCATE (SUMCNN(NLAKES), SUMCHN(NLAKES)) - ALLOCATE (NCNCVR(NLAKES), LIMERR(NLAKES), DSRFOT(NLAKES)) -Cdep Allocate arrays that track lake budgets for dry lakes - ALLOCATE (EVAPO(NLAKES),WITHDRW(NLAKES),FLWIN(NLAKES)) - ALLOCATE (GWRATELIM(NLAKES)) - EVAPO = 0.0 - WITHDRW = 0.0D0 - FLWIN = 0.0 - FLWITER = 0.0D0 - FLWITER3 = 0.0D0 - EVAP = 0.0D0 - PRECIP = 0.0D0 - EVAP3 = 0.0D0 - PRECIP3 = 0.0D0 - IF ( IRDTAB.GT.0 ) THEN - ALLOCATE(LAKTAB(NLAKES)) - ELSE - ALLOCATE(LAKTAB(1)) - ENDIF - LAKTAB = 0 -!rsr GWRATLIM= 0.0 -Cdep Allocate space for three arrays used in GAGE Package -C when Solute Transport is active - ALLOCATE (XLAKES(NLAKES,1), XLAKINIT(NLAKES,1)) - ALLOCATE (XLKOLD(NLAKES,1)) -crsr Allocate arrays for BD subroutine - ALLOCATE (LDRY(NODES), FLXINL(NLAKES)) - ALLOCATE (NCNT(NLAKES), NCNST(NLAKES)) - ALLOCATE (SVT(NLAKES), KSUB(NLAKES), STGADJ(NLAKES)) - ALLOCATE (MSUB(NLAKES,NLAKES), MSUB1(NLAKES)) - ALLOCATE (GWIN(NLAKES), GWOUT(NLAKES)) - ALLOCATE (DELH(NLAKES), TDELH(NLAKES)) -Cdep Allocate lake budget error arrays for BD subroutine 6/9/2009 - ALLOCATE (CUMVOL(NLAKES), CMLAKERR(NLAKES)) - ALLOCATE (CUMLKIN(NLAKES), CUMLKOUT(NLAKES)) - ALLOCATE (DELVOL(NLAKES), TSLAKERR(NLAKES)) -Cdep initialized VOLOLD and VOLINIT 6/4/2009 (VOLOLD is single precision) - ALLOCATE (VOLOLD(NLAKES), VOLINIT(NLAKES)) - VOLOLD = 0.0 - VOLINIT = 0.0 - ENDIF -Cdep ALLOCATE SPACE FOR CONNECTION WITH STREAMS - IF (IUNITSFR.LE.0) THEN - NSSAR = 1 - ELSE - NSSAR = NSS - ENDIF -Cdep ALLOCATE SPACE FOR FLOB ARRAY WHEN TRANSPORT ACTIVE. - IF (IUNITGWT.LE.0) THEN - MXLKAR = 1 - ELSE - MXLKAR = MXLKND - ENDIF -Cdep ALLOCATE SPACE FOR OVERLAND FLOW WHEN UNSATURATED FLOW ACTIVE. -! RGN Allocate NUZFAR to nlakes for all cases because of the GAG package 5/28/09 -! IF (IUNITUZF.LE.0) THEN -! NUZFAR = 1 -! ELSE - NUZFAR = NLAKESAR -! ENDIF - - !rsr, what if NLAKES < 1, sanity check - IF (NLAKES<1 ) THEN - print *, 'nlakes dimension problem in lak7', nlakes - stop - ENDIF - - ALLOCATE (ITRB(NLAKES,NSSAR), IDIV(NLAKES,NSSAR)) - ALLOCATE (FLOB(MXLKAR)) - ALLOCATE (OVRLNDRNF(NUZFAR), CUMLNDRNF(NUZFAR)) -Cdep ALLOCATE SPACE FOR DEPTHTABLE, AREATABLE, AND VOLUMETABLE - ALLOCATE (DEPTHTABLE(151,NLAKES), AREATABLE(151,NLAKES)) - ALLOCATE (VOLUMETABLE(151,NLAKES)) - ITRB = 0 - IDIV = 0 - FLOB = 0.0 - OVRLNDRNF = 0.0 - CUMLNDRNF = 0.0 - CUMUZF = 0.0 - DEPTHTABLE = 0.0D0 - AREATABLE = 0.0D0 - VOLUMETABLE = 0.0D0 -Cdep initialized lake budget error arrays 6/9/2009 - CUMVOL = 0.0 - DELVOL = 0.0 - CMLAKERR = 0.0 - TSLAKERR = 0.0 - CUMLKOUT = 0.0 - CUMLKIN = 0.0 -C-----SAVE POINTERS FOR GRID AND RETURN - CALL SGWF2LAK7PSV(IGRID) -C -C11-----RETURN. - RETURN - END SUBROUTINE GWF2LAK7AR -C - SUBROUTINE GWF2LAK7RP(IN,IUNITBCF,IUNITGWT,IUNITLPF,IUNITHUF, - + IUNITSFR,IUNITUZF,IUNITUPW,KKPER,NSOL, - + IOUTS,IGRID) -C -C------USGS VERSION 7.1; JUNE 2006 GWF2LAK7RP -C REVISED FEBRUARY 6, 2012 -C ****************************************************************** -C READ INPUT DATA FOR THE LAKE PACKAGE. -C ------------------------------------------------------------------ -C SPECIFICATIONS: -C ------------------------------------------------------------------ - USE GWFLAKMODULE - USE GLOBAL, ONLY: IOUT, NCOL, NROW, NLAY, IFREFM, IBOUND, - + LBOTM, BOTM, DELR, DELC, ISSFLG - use SimModule, only: ustop - use utl7module, only: U2DINT, U2DREL -C USE GWFSFRMODULE, ONLY: NSS -C ------------------------------------------------------------------ -C FUNCTIONS -C ------------------------------------------------------------------ -!* DOUBLE PRECISION VOLTERP -!* EXTERNAL VOLTERP -C ------------------------------------------------------------------ - CHARACTER*24 ANAME(2) -! CHARACTER*30 LFRMAT -!dep added STGINIT as double precision - DOUBLE PRECISION STGINIT - logical, save :: warned = .false. - character(len=200) :: warning - DATA ANAME(1)/' LAKE ID ARRAY'/ - DATA ANAME(2)/' LAKEBED LEAKANCE ARRAY'/ -C -C ------------------------------------------------------------------ -C------SET POINTERS FOR THE CURRENT GRID. - CALL SGWF2LAK7PNT(IGRID) -C -C1A-----IF MXLKND IS LESS THAN 1, THEN LAKE IS INACTIVE. RETURN. - IF(MXLKND.LT.1) RETURN -C -C1A1----READ INITIAL CONDITIONS FOR ALL LAKES (ONLY READ ONCE) - ISS = ISSFLG(KKPER) - IF (KKPER.EQ.1) THEN - WRITE (IOUT,19) - IF(ISS.NE.0) WRITE (IOUT,20) - IF(ISS.EQ.0) WRITE (IOUT,820) -! Read Item 3 - IF (IUNITGWT.EQ.0) THEN - DO 30 LM=1,NLAKES - IF (IFREFM.EQ.0) THEN - IF ( IRDTAB.GT.0 ) THEN - IF(ISS.NE.0) READ (IN,'(3F10.4,I5)') STAGES(LM), - 1 SSMN(LM),SSMX(LM),LAKTAB(LM) - IF(ISS.EQ.0) READ (IN,'(F10.4,I5)') STAGES(LM), - 2 LAKTAB(LM) - ELSE - IF(ISS.NE.0) READ (IN,'(3F10.4)') STAGES(LM), - 1 SSMN(LM),SSMX(LM) - IF(ISS.EQ.0) READ (IN,'(F10.4)') STAGES(LM) - ENDIF - ELSE - IF ( IRDTAB.GT.0 ) THEN - IF(ISS.NE.0) READ (IN,*)STAGES(LM),SSMN(LM),SSMX(LM), - 1 LAKTAB(LM) - IF(ISS.EQ.0) READ (IN,*) STAGES(LM),LAKTAB(LM) - ELSE - IF(ISS.NE.0) READ (IN,*) STAGES(LM),SSMN(LM),SSMX(LM) - IF(ISS.EQ.0) READ (IN,*) STAGES(LM) - ENDIF - ENDIF - IF(ISS.NE.0) WRITE (IOUT,22) LM,STAGES(LM),SSMN(LM),SSMX(LM) - IF(ISS.EQ.0) WRITE (IOUT,22) LM,STAGES(LM) - 30 CONTINUE - ELSE - WRITE (IOUTS,21) NSOL -! WRITE (LFRMAT,23) NSOL !LFRMAT is not set - DO 35 LM=1,NLAKES - IF (IFREFM.EQ.0) THEN - IF ( IRDTAB.GT.0 ) THEN - IF(ISS.NE.0) READ(IN,'(100F10.4)') STAGES(LM), - 1 SSMN(LM),SSMX(LM),(CLAKE(LM,ISOL),ISOL=1,NSOL), - 2 LAKTAB(LM) - IF(ISS.EQ.0) READ (IN,'(100F10.4)') STAGES(LM), - 1 (CLAKE(LM,ISOL),ISOL=1,NSOL),LAKTAB(LM) - ELSE - IF(ISS.NE.0) READ(IN,'(100F10.4)') STAGES(LM), - 1 SSMN(LM),SSMX(LM),(CLAKE(LM,ISOL),ISOL=1,NSOL) - IF(ISS.EQ.0) READ (IN,'(100F10.4)') STAGES(LM), - 1 (CLAKE(LM,ISOL),ISOL=1,NSOL) - ENDIF - ELSE - IF ( IRDTAB.GT.0 ) THEN - IF(ISS.NE.0) READ (IN,*) STAGES(LM),SSMN(LM), - 1 SSMX(LM),(CLAKE(LM,ISOL),ISOL=1,NSOL), - 2 LAKTAB(LM) - IF(ISS.EQ.0) READ (IN,*) STAGES(LM), - 1 (CLAKE(LM,ISOL),ISOL=1,NSOL),LAKTAB(LM) - ELSE - IF(ISS.NE.0) READ (IN,*) STAGES(LM),SSMN(LM), - 1 SSMX(LM),(CLAKE(LM,ISOL),ISOL=1,NSOL) - IF(ISS.EQ.0) READ (IN,*) STAGES(LM), - 1 (CLAKE(LM,ISOL),ISOL=1,NSOL) - ENDIF - ENDIF - IF(ISS.NE.0) WRITE (IOUT,22) LM,STAGES(LM),SSMN(LM),SSMX(LM) - IF(ISS.EQ.0) WRITE (IOUT,22) LM,STAGES(LM) - 35 WRITE (IOUTS,*) LM,(CLAKE(LM,ISOL),ISOL=1,NSOL) -cgage -C CLAKINIT=CLAKE - ENDIF - ENDIF -C - WRITE (IOUT,'(/)') - WRITE(IOUT,822) - 19 FORMAT(//1X,'LAKE PACKAGE ACTIVE: CALCULATED LAKE STAGE FOR EACH - 1TIME STEP WILL BE STORED IN HNEW ARRAY.') - 20 FORMAT(///1X,'INITIAL LAKE STAGE: LAKE STAGE SS MIN SS M - 1AX'/) - 21 FORMAT (//1X,'INITIAL LAKE CONCENTRATIONS: LAKE CONCENTRATION ( - 1NSOL =',I3,')'/) - 22 FORMAT (22X,I3,3F10.3) - 23 FORMAT ('(31X,I3,3X,1P',I3,'(E12.3))') - 820 FORMAT (/1X,'INITIAL LAKE STAGE: LAKE STAGE'/) - 822 FORMAT(//1X,'If any subsequent steady-state stress periods, min. a - 1nd max. stages for each lake will be read in Record 9a.'//) -C -! RGN 9/25/12 moved this to read lake bathymetry before stress period information. - IF ( KKPER==1 .AND. IRDTAB.GT.0 ) THEN - DO L1=1,NLAKES - WRITE(IOUT,1399) L1 - iunit = LAKTAB(L1) - 1399 FORMAT(//1X,'STAGE/VOLUME RELATION FOR LAKE',I3//6X,'STAGE', - 1 8X,'VOLUME',8X,'AREA'/) - DO INC=1,151 - READ(iunit,*) DEPTHTABLE(INC,L1), VOLUMETABLE(INC,L1), - + AREATABLE(INC,L1) - WRITE(IOUT,1315) DEPTHTABLE(INC,L1), VOLUMETABLE(INC,L1), - + AREATABLE(INC,L1) - ENDDO - ENDDO - ENDIF -C1B-----READ ITMP (FLAG TO REUSE LAKE-GEOMETRY DATA). -! Read Item 4 - IF(IFREFM.EQ.0) THEN - READ(IN,'(3I10)') ITMP, ITMP1, LWRT - ELSE - READ(IN,*) ITMP, ITMP1, LWRT - ENDIF -C -C2A-----IF ITMP < 0 THEN REUSE LAKE CONFIGURATION DATA FROM LAST STRESS -C PERIOD. - IF(ITMP.GE.0) GO TO 50 - WRITE (IOUT,'(/)') - WRITE(IOUT,2) - 2 FORMAT(1H ,'REUSING LAKE CONFIGURATION DATA FROM LAST STRESS PERIO - 1D'/) - GO TO 800 -C -C4------IF THERE ARE NO LAKE NODES THEN RETURN. - 50 LKNODE = 0 - IF(ITMP.EQ.0) GOTO 900 - if (KKPER > 1 .and. .not. warned) then - ! write warning about changing lakes - 55 format('In LAK input, ITMP > 0 for stress period ',i0, - & '. WARNING: LAK8 does not support changing lake configuration', - & ' or leakance during simulation.') - write(warning,55)kkper - call store_warning(warning) - warned = .true. - endif -C -C INITIALIZE BGAREA - DO 60 LK=1,NLAKES - BGAREA(LK)=0.0 - 60 CONTINUE -C -C5------READ INTEGER ARRAYS THAT DEFINE THE POSITIONS OF ALL LAKES IN -C5A EACH MODEL GRID LAYER. THEN READ ARRAYS OF LAKEBED CONDUCTANCES -C5B IN EACH LAYER. -C -C READ ARRAY OF LAKE ID'S, LAYER BY LAYER -C REVISED 11/30/2005 DEP -! Read item 5 - DO 125 K=1,NLAY - KK = K - CALL U2DINT(LKARR1(:,:,KK),ANAME(1),NROW,NCOL,KK,IN,IOUT) - 125 CONTINUE -C -C CHECK THAT ALL ENTRIES ARE VALID LAKE ID NUMBERS OR ZERO -C - DO 130 K=1,NLAY - DO 130 I=1,NCOL - DO 130 J=1,NROW - IF(LKARR1(I,J,K).GT.0.AND.LKARR1(I,J,K).LE.NLAKES) GO TO 130 - LKARR1(I,J,K)=0 - 130 CONTINUE -C -C CHECK IF LAKE CELLS HAVE VALUES OF IBOUND=0; WARN IF INCONSISTENT -C - WRITE (IOUT,'(/)') - DO 132 K=1,NLAY - DO 132 I=1,NCOL - DO 132 J=1,NROW - IF(LKARR1(I,J,K).GT.0.AND.IBOUND(I,J,K).NE.0) THEN - WRITE (IOUT,232) IBOUND(I,J,K),LKARR1(I,J,K),I,J,K - 232 FORMAT (7X,'*** WARNING: IBOUND = ',I2, - 1 ' & LKARR = ',I2,' at CELL I=',I3, - 2 ', J=',I3,', K=',I3,' ***') - ENDIF - 132 CONTINUE -C -C READ ARRAY OF BED LEAKANCES, LAYER BY LAYER -Cdep REVISED 11/30/2005 - WRITE (IOUT,'(/)') -! Read item 6 - DO 135 K=1,NLAY - KK = K - CALL U2DREL(BDLKN1(:,:,KK),ANAME(2),NROW,NCOL,KK,IN,IOUT) - 135 CONTINUE -C - WRITE(IOUT,36) - WRITE(IOUT,4) -36 FORMAT(/7X,'LOCATIONS, LAKE #, INTERFACE TYPE FOR GRID CELLS', - 1 ' ADJACENT TO LAKES:',5X,/ - 3 5X,71('-')) -4 FORMAT(5X,'LAYER #',4X,'ROW #',4X,'COLUMN #',3X,'LAKE #', - 1 2X,'INTERFACE TYPE',2X,'LAKEBED LEAKANCE') -C -C IDENTIFY LAKE BORDER CELLS, ASSIGN CELL TYPE ID'S, COMPUTE AND -C ASSIGN LAKE-AQUIFER INTERFACE CONDUCTANCES. -C - M = 0 - DO 180 I=1,NCOL - DO 180 J=1,NROW - K = 1 - IF(LKARR1(I,J,K).EQ.0) GO TO 150 - IF(NLAY.EQ.1) GO TO 145 -C Keep searching in vertical direction until non-lake cell is found, -C and define interface there ("K" for interface is layer below -C bottom of lake) - DO 140 K=2,NLAY - IF(LKARR1(I,J,K).EQ.0) GO TO 145 - 140 CONTINUE -C Make sure that K=NLAY if lake extends to bottom cell of grid: - K=NLAY -C GO TO 145 -C -C VERTICAL LAKEBED INTERFACE (TYPE 0) DETECTED -C - 145 M = M + 1 - IF(M.LE.MXLKND) GO TO 147 - WRITE(IOUT,149) I,J,K - 149 FORMAT(/1X,'MAXIMUM NUMBER OF GRID CELLS ADJACENT TO LAKES HAS BEE - 1N EXCEEDED WITH CELL ',3I5,' REDEFINE VARIABLE MXLKND TO A LARGER - 2 VALUE IN MODULE GWF2LAK7AR') - CALL USTOP(' ') - 147 ILAKE(1,M) = K - ILAKE(2,M) = J - ILAKE(3,M) = I -Cdep changed if statement August 24, 2009 -Cdep IF(K.GT.1.AND.LKARR1(I,J,K).EQ.0) LID = LKARR1(I,J,K-1) -Cdep IF(LKARR1(I,J,K).NE.0) LID = LKARR1(I,J,K) - IF(K.GT.1) THEN - IF(LKARR1(I,J,K).EQ.0) THEN - LID = LKARR1(I,J,K-1) - ELSE - LID = LKARR1(I,J,K) - ENDIF - ELSEIF (K.EQ.1) THEN - IF(LKARR1(I,J,K).EQ.0) THEN - LID = 0 - ELSE - LID = LKARR1(I,J,K) - ENDIF - ENDIF - ILAKE(4,M) = LID - ILAKE(5,M) = 6 - IF ( K.GT.1 ) THEN !RGN 5/21/12 added IF test - BEDLAK(M) = BDLKN1(I,J,K-1) - ELSE !RGN - BEDLAK(M) = BDLKN1(I,J,K) !RGN - ENDIF !RGN - IF(K.EQ.NLAY.AND.LKARR1(I,J,K).NE.0) BEDLAK(M) = 0.0 - BGAREA(LID) = BGAREA(LID) + DELC(J)*DELR(I) -C-LFK-JAN. 2013 -c-lfk WRITE(IOUT,5) (ILAKE(I1,M),I1=1,5), BEDLAK(M) - WRITE(IOUT,6) (ILAKE(I1,M),I1=1,5), BEDLAK(M) -5 FORMAT(5I10,10X,F10.5) -6 FORMAT(5I10,12X,1PE10.3) -C-LFK - IF(LKARR1(I,J,K).NE.0) GO TO 180 -C -C SEARCH FOR CELL(S) ADJACENT TO LAKE -C - 150 K2 = K - DO 175 K1=K2,NLAY -cgzh fix for 2D-problems - IF(NCOL.EQ.1) GO TO 165 - IF(I.NE.1) GO TO 1151 - IF(LKARR1(I+1,J,K1).EQ.0) GO TO 165 - GO TO 1153 - 1151 IF(I.NE.NCOL) GO TO 1152 - IF(LKARR1(I-1,J,K1).EQ.0) GO TO 165 - GO TO 1153 - 1152 IF(LKARR1(I+1,J,K1).EQ.0.AND.LKARR1(I-1,J,K1).EQ.0) GO TO 165 -C -C CELL(S) LATERALLY ADJACENT TO LAKE IN X-DIRECTION (TYPE 1) DETECTED -C - 1153 DO 160 N=1,2 - IF(N.EQ.2) GO TO 155 - IF(I.EQ.1) GO TO 160 - IF(LKARR1(I-1,J,K1).EQ.0) GO TO 160 - I2 = I-1 - IFACE=1 - GO TO 157 - 155 IF(I.EQ.NCOL) GO TO 160 - IF(LKARR1(I+1,J,K1).EQ.0) GO TO 160 - I2 = I + 1 - IFACE=2 - 157 M = M + 1 - IF(M.LE.MXLKND) GO TO 158 - WRITE(IOUT,149) I,J,K1 - CALL USTOP(' ') - 158 ILAKE(1,M) = K1 - ILAKE(2,M) = J - ILAKE(3,M) = I - ILAKE(4,M) = LKARR1(I2,J,K1) - ILAKE(5,M) = IFACE - BEDLAK(M) = BDLKN1(I,J,K1) - K4 = K1 - 1 - DO 3158 K3=1,K4 - IF(LKARR1(I,J,K3).EQ.0) GO TO 3158 - GO TO 3162 - 3158 CONTINUE - BEDLAK(M) = BDLKN1(I,J,1) - 3162 CONTINUE -c-lfk WRITE(IOUT,5) (ILAKE(I1,M),I1=1,5), BEDLAK(M) -C-LFK-JAN. 2013 -c-lfk WRITE(IOUT,5) (ILAKE(I1,M),I1=1,5), BEDLAK(M) - WRITE(IOUT,6) (ILAKE(I1,M),I1=1,5), BEDLAK(M) -C-LFK - 160 CONTINUE -cgzh fix for 2D-problems - 165 IF(NROW.EQ.1) GO TO 175 - IF(J.NE.1) GO TO 1161 - IF(LKARR1(I,J+1,K1).EQ.0) GO TO 175 - GO TO 1163 - 1161 IF(J.NE.NROW) GO TO 1162 - IF(LKARR1(I,J-1,K1).EQ.0) GO TO 175 - GO TO 1163 - 1162 IF(LKARR1(I,J+1,K1).EQ.0.AND.LKARR1(I,J-1,K1).EQ.0) GO TO 175 -C -C CELL(S) LATERALLY ADJACENT TO LAKE IN Y-DIRECTION (TYPE 2) DETECTED -C - 1163 DO 170 N=1,2 - IF(N.EQ.2) GO TO 172 - IF(J.EQ.1) GO TO 170 - IF(LKARR1(I,J-1,K1).EQ.0) GO TO 170 - J2 = J - 1 - IFACE=4 - GO TO 174 - 172 IF(J.EQ.NROW) GO TO 170 - IF(LKARR1(I,J+1,K1).EQ.0) GO TO 170 - J2 = J + 1 - IFACE=3 - 174 M = M + 1 - IF(M.LE.MXLKND) GO TO 176 - WRITE(IOUT,149) I,J,K1 - CALL USTOP(' ') - 176 ILAKE(1,M) = K1 - ILAKE(2,M) = J - ILAKE(3,M) = I - ILAKE(4,M) = LKARR1(I,J2,K1) - ILAKE(5,M) = IFACE - BEDLAK(M) = BDLKN1(I,J,K1) - K4 = K1 - 1 - DO 4158 K3=1,K4 - IF(LKARR1(I,J,K3).EQ.0) GO TO 4158 - GO TO 4162 - 4158 CONTINUE - BEDLAK(M) = BDLKN1(I,J,1) - 4162 CONTINUE -c-lfk WRITE(IOUT,5) (ILAKE(I1,M),I1=1,5), BEDLAK(M) -C-LFK-JAN. 2013 -c-lfk WRITE(IOUT,5) (ILAKE(I1,M),I1=1,5), BEDLAK(M) - WRITE(IOUT,6) (ILAKE(I1,M),I1=1,5), BEDLAK(M) -C-LFK - 170 CONTINUE - 175 CONTINUE - 180 CONTINUE - WRITE(IOUT,195) M - 195 FORMAT(/5X,'NUMBER OF LAKE-AQUIFER CELL INTERFACES = ',I5) - LKNODE = M -C -C SET LAKE BOTTOM ELEVATIONS - DO 295 LK=1,NLAKES - 295 BOTTMS(LK) = 999999 -C - DO 350 II=1,LKNODE - K = ILAKE(1,II) - J = ILAKE(2,II) - I = ILAKE(3,II) -C Convert ILAKE(5,II): 1 and 2 are type 1, 3 and 4 are type 2, -C 6 is type 0 - NTYP = (ILAKE(5,II)+1)/2 - IF(NTYP.EQ.3) NTYP=0 - IF(NTYP.EQ.0) THEN - LAKE = ILAKE(4,II) -Cdep changed if statement August 24, 2009 -Cdep IF(K.GT.1) BOTLK = BOTM(I,J,LBOTM(K-1)) -Cdep IF(K.EQ.NLAY.AND.LKARR1(I,J,K).GT.0) BOTLK = BOTM(I,J,LBOTM(K)) - IF(K.EQ.1.OR.K.EQ.NLAY.AND.LKARR1(I,J,K).GT.0) THEN - BOTLK = BOTM(I,J,LBOTM(K)) - ELSEIF (K.EQ.0) THEN - BOTLK = BOTM(I,J,LBOTM(1)) - ELSE - BOTLK = BOTM(I,J,LBOTM(K-1)) - ENDIF - IF(BOTLK.LT.BOTTMS(LAKE)) BOTTMS(LAKE) = BOTLK - ENDIF - 350 CONTINUE -C -C-- COMPUTE AND PRINT STAGE/VOLUME TABLES WHEN MORE THAN ONE LAYER -Cdep revised print statement to include stage/area tables -C - IF ( IRDTAB.EQ.0 ) THEN -! IF(NLAY.EQ.1) GO TO 1331 !RGN 5/21/12 - DO 1330 L1=1,NLAKES - WRITE(IOUT,1306) L1 -Cdep revised print statement to include area - 1306 FORMAT(//1X,'STAGE/VOLUME RELATION FOR LAKE',I3//6X,'STAGE', - 1 8X,'VOLUME',8X,'AREA'/) - DO INC=1,151 - AREATABLE(INC,L1) = 0.D0 - ENDDO - EVOL = 0.0 - GTSDPH = 40.0 - TOPMST = BOTTMS(L1)+GTSDPH - TBELV = BOTTMS(L1) - DO 1340 I=1,NCOL - DO 1340 J=1,NROW - IF(LKARR1(I,J,1).NE.L1) GO TO 1340 -Cdep Revised estimate of DTHK to be thickness of top most -C layer 6/09/2009 - IF(BOTM(I,J,0).GT.TOPMST) TOPMST = BOTM(I,J,0) -! DTHK = BOTM(I,J,0) - BOTM(I,J,1) RGN this was causing problems 7/8/11 -! IF (DTHK.LE.GTSDPH) THEN -! TOPMST = BOTM(I,J,1)+DTHK -! ELSE -! TOPMST = BOTM(I,J,1)+GTSDPH -! ENDIF - 1340 CONTINUE - TBNC = (TOPMST-BOTTMS(L1))/150.0 -Cdep Revised looping for computing lake stage, volume, -Cdep and area Apr 2009. -Cdep WRITE(IOUT,1315) TBELV, EVOL - DO INC=1,151 - IF (INC.GT.1) THEN - VOLUMETABLE(INC,L1)=VOLUMETABLE(INC-1,L1) - ENDIF - DO I=1,NCOL - DO J=1,NROW - LAKEFLG = 0 - K = 1 - MOSTBOT: DO WHILE (LAKEFLG.EQ.0) - IF(LKARR1(I,J,K).EQ.L1) THEN - LAKEFLG = K - ENDIF - IF(K.EQ.NLAY)EXIT MOSTBOT - K = K + 1 - ENDDO MOSTBOT - IF(LAKEFLG.GT.0) THEN - K=LAKEFLG - FINDBOT: DO WHILE(LKARR1(I,J,K).GT.0) - K=K+1 - IF(K.EQ.NLAY+1) EXIT - ENDDO FINDBOT - BOTIJ = BOTM(I,J,LBOTM(K-1)) - IF(INC.EQ.1) THEN - IF(TBELV+1.0E-03.GT.BOTIJ) THEN - AREATABLE(INC,L1)=AREATABLE(INC,L1)+DELC(J)*DELR(I) - DEPTHTABLE(INC,L1)=TBELV - ENDIF - ELSE - IF (TBELV-BOTIJ.GT.0.0) THEN - AREATABLE(INC,L1)=AREATABLE(INC,L1)+DELC(J)*DELR(I) - DEPTHTABLE(INC,L1)=TBELV - IF(ABS(TBELV-BOTIJ).GT.1.0E-04) THEN - VOLUMETABLE(INC,L1)=VOLUMETABLE(INC,L1)+ - + (DELC(J)*DELR(I))*TBNC - ENDIF - ENDIF - ENDIF - ENDIF - ENDDO - ENDDO -Cdep PRINT TABLE OF ELEVATION, VOLUME, AND AREA - WRITE(IOUT,1315) DEPTHTABLE(INC,L1), VOLUMETABLE(INC,L1), - + AREATABLE(INC,L1) - TBELV = TBELV + TBNC - ENDDO - 1315 FORMAT(3(1X,1PE13.5)) - WRITE(IOUT,1326) - 1326 FORMAT(120X) -Cdep set minimum and maximum lake stages for transient simulations - IF(ISS.EQ.0) THEN - SSMN(L1)=BOTTMS(L1) - SSMX(L1)=TBELV - ENDIF - 1330 CONTINUE - 1331 CONTINUE - ENDIF - IF(IUNITSFR.LE.0) THEN - NDV=0 - NTRB=0 - ENDIF -C -C -C-- READ LINKAGE PARAMETERS FOR COALESCING LAKES -C -C FOR EACH CONNECTED LAKE SYSTEM, READ LAKE NUMBERS OF CENTER LAKES -C AND ADJOINING LAKES AND SILL ELEVATIONS. ENTER CARD IMAGES -C FOR SUBLAKE SYSTEMS EVEN IF LINKED TO MAIN LAKE SYSTEM. SYSTEMS -C MUST BE ORDERED HIERARCHICALLY. -C - ICMX = 0 - NCLS=0 -! Read item 7 - IF(IFREFM.EQ.0) THEN - READ(IN,'(I5)') NSLMS - ELSE - READ(IN,*) NSLMS - ENDIF - WRITE(IOUT,680) NSLMS - 680 FORMAT(/1X,'NUMBER OF CONNECTED LAKE SYSTEMS IN SIMULATION IS ',I3 - 1) - IF(NSLMS.LE.0) GO TO 760 - DO 700 IS=1,NSLMS -! Read item 8a - IF(IFREFM.EQ.0) THEN - READ(IN,'(16I5)',END=750) IC,(ISUB(IS,I),I=1,IC) - ELSE - READ(IN,*,END=750) IC,(ISUB(IS,I),I=1,IC) - ENDIF - IF(IC.LE.0) GO TO 750 - IF(IC.GT.ICMX) ICMX=IC - ICS(IS)=IC - IC1 = IC - 1 -! Read item 8b - IF(IFREFM.EQ.0) THEN - READ(IN,'(100F10.2)') (SILLVT(IS,I),I=1,IC1) - ELSE - READ(IN,*) (SILLVT(IS,I),I=1,IC1) - ENDIF - WRITE(IOUT,18) IS, ICS(IS), ISUB(IS,1) - 18 FORMAT(/10X,'SYSTEM',I3//2X,'NUMBER OF LAKES IN SYSTEM',I5, - 1 ' CENTER LAKE NUMBER',I5//1X,'SUBLAKE NUMBER',3X, - 2 'SILL ELEVATION'/) - DO 715 JK=2,IC - 715 WRITE(IOUT,717) ISUB(IS,JK), SILLVT(IS,JK-1) - 717 FORMAT(8X,I2,8X,F10.2) - 700 CONTINUE - 750 CONTINUE - NCLS=IS-1 - WRITE(IOUT,751) NCLS - 751 FORMAT(/1X,'READ DATA FOR',I5,' LAKE SYSTEMS'/) - 760 CONTINUE -C -C----- READ LAKE PRECIPITATION, EVAPORATION, RUNOFF, AND WITHDRAWAL RATES. -C IF ITMP1 LT 0, SPECIFICATIONS FROM LAST STRESS PERIOD ARE USED. -C - 800 IF(ITMP1.GE.0) GO TO 801 - WRITE(IOUT,802) - 802 FORMAT(1H0,'REUSING RECH,ET,WITHDRAWAL RATES FROM LAST STRESS PERI - 1OD'/) - GOTO 900 - 801 IF(ISS.NE.0.AND.KKPER.GT.1) WRITE(IOUT,7) -7 FORMAT(/1X,'LAKE',7X,'PRECIP',5X,'EVAP',5X,'RUNOFF', - 2 3X,'WITHDRAW',3X,'BOTTOM',5X,'AREA',5X,'SS MIN',3X,'SS MAX' - 1/90('-')) - IF(ISS.EQ.0.OR.KKPER.EQ.1) WRITE(IOUT,77) - 77 FORMAT(/1X,'LAKE',7X,'PRECIP',5X,'EVAP',5X,'RUNOFF', - 2 3X,'WITHDRAW',3X,'BOTTOM',5X,'AREA',5X,/70('-')) - IF (IUNITGWT.GT.0) WRITE (IOUTS,8) - 8 FORMAT (//1X,'LAKE',4X,'SOLUTE',6X,'CPPT',6X,'CRNF',6X,'CAUG'/) -! Read item 9 - DO 300 LM=1,NLAKES - IF(IFREFM.EQ.0) THEN - IF(ISS.NE.0.AND.KKPER.GT.1) READ(IN,'(6F10.4)') PRCPLK(LM), - 1 EVAPLK(LM),RNF(LM),WTHDRW(LM),SSMN(LM),SSMX(LM) - IF(ISS.EQ.0.OR.KKPER.EQ.1) READ(IN,'(6F10.4)') PRCPLK(LM), - 1 EVAPLK(LM),RNF(LM),WTHDRW(LM) - ELSE - IF(ISS.NE.0.AND.KKPER.GT.1) READ(IN,*) PRCPLK(LM),EVAPLK(LM), - 1 RNF(LM),WTHDRW(LM),SSMN(LM),SSMX(LM) - IF(ISS.EQ.0.OR.KKPER.EQ.1) READ(IN,*) PRCPLK(LM),EVAPLK(LM), - 1 RNF(LM),WTHDRW(LM) - ENDIF - IF(ISS.NE.0.AND.KKPER.GT.1) WRITE(IOUT,9) LM,PRCPLK(LM),EVAPLK(LM) - 1 ,RNF(LM),WTHDRW(LM),BOTTMS(LM),BGAREA(LM),SSMN(LM),SSMX(LM) -9 FORMAT(1X,I3,4X,1P,3E10.3,1X,5E10.3) - IF(ISS.EQ.0.OR.KKPER.EQ.1) WRITE(IOUT,9) LM,PRCPLK(LM),EVAPLK(LM), - 1 RNF(LM),WTHDRW(LM),BOTTMS(LM),BGAREA(LM) - IF(IUNITGWT.LE.0) GO TO 300 -! Read item 9b - DO 850 ISOL=1,NSOL - IF(IFREFM.EQ.0) THEN - IF(WTHDRW(LM).LT.0.0) THEN - READ(IN,'(3F10.4)')CPPT(LM,ISOL),CRNF(LM,ISOL),CAUG(LM,ISOL) - ELSE - READ(IN,'(2F10.4)')CPPT(LM,ISOL),CRNF(LM,ISOL) - ENDIF - ELSE - IF(WTHDRW(LM).LT.0.0) THEN - READ(IN,*) CPPT(LM,ISOL),CRNF(LM,ISOL),CAUG(LM,ISOL) - ELSE - READ(IN,*) CPPT(LM,ISOL),CRNF(LM,ISOL) - ENDIF - ENDIF - IF(WTHDRW(LM).LT.0.0)WRITE(IOUTS,840) LM,ISOL, - + CPPT(LM,ISOL),CRNF(LM,ISOL),CAUG(LM,ISOL) - IF(WTHDRW(LM).GE.0.0) - 1 WRITE(IOUTS,841) LM,ISOL,CPPT(LM,ISOL),CRNF(LM,ISOL) - 840 FORMAT(1X,I3,6X,I3,4X,1P,3E10.2) - 841 FORMAT(1X,I3,6X,I3,4X,1P,2E10.2) - 850 CONTINUE -C WRITE (IOUTS,'(/)') - 300 CONTINUE - WRITE (IOUT,'(/)') -C -C------Define Initial Lake Volume & Initialize Cumulative Budget Terms - IF(KKPER.EQ.1) THEN -!dep revised calculation of initial lake volume July 2009 - STGINIT=0.0D0 - DO 8400 LK=1,NLAKES -!dep 8400 VOL(LK)=0.0 - STGINIT=STAGES(LK) - VOL(LK)=VOLTERP(STGINIT,LK) - VOLINIT(LK)=VOL(LK) - 8400 CONTINUE - DO 8450 LK=1,NLAKES - CUMPPT(LK)=0.0 - CUMEVP(LK)=0.0 - CUMRNF(LK)=0.0 - CUMGWI(LK)=0.0 - CUMGWO(LK)=0.0 - CUMSWI(LK)=0.0 - CUMSWO(LK)=0.0 - CUMWDR(LK)=0.0 - CUMFLX(LK)=0.0 - 8450 CONTINUE - DO 8900 L=1,LKNODE - IL=ILAKE(1,L) - IR=ILAKE(2,L) - IC=ILAKE(3,L) - LAKE=ILAKE(4,L) -C------Convert ILAKE(5,L): 1 and 2 are type 1, 3 and 4 are type 2, -C 6 is type 0 - ITYPE = (ILAKE(5,L)+1)/2 - IF(ITYPE.EQ.3) ITYPE=0 - IF(ITYPE.NE.0) GO TO 8900 - IF(IL.GT.1) BOTLK = BOTM(IC,IR,LBOTM(IL-1)) - IF(IL.EQ.NLAY.AND.LKARR1(IC,IR,IL).GT.0) - 1 BOTLK = BOTM(IC,IR,LBOTM(IL)) - 8900 CONTINUE - ENDIF - - 900 IF (IUNITBCF.GT.0) THEN ! rsr, moved if block from main - CALL SGWF2LAK7BCF7RPS() - ELSEIF (IUNITLPF.GT.0) THEN - CALL SGWF2LAK7LPF7RPS() -! ELSEIF (IUNITHUF.GT.0) THEN -* CALL SGWF2LAK7HUF7RPS() - ELSE IF (IUNITUPW.GT.0) THEN - CALL SGWF2LAK7UPW1RPS() - ELSE -! WRITE (IOUT, *) 'LAK Package requires BCF, LPF, or UPW' - call store_error('LAK Package requires BCF, LPF, or UPW') - CALL USTOP() - ENDIF - IF (IUNITSFR.GT.0) CALL SGWF2LAK7SFR7RPS() -C -C7------RETURN - RETURN - END SUBROUTINE GWF2LAK7RP -C -! SUBROUTINE GWF2LAK7AD(KKPER,KKSTP,IUNITGWT,IGRID) -!C -!C------VERSION 7.1 JUNE 2006 GWF2LAK7AD; REVISED FEBRUARY 6, 2012 -!C -!C ****************************************************************** -!C ADVANCE TO NEXT TIME STEP FOR TRANSIENT LAKE SIMULATION, AND COPY -!C INITIAL LAKE STAGES TO STGOLD FOR STEADY STATE. -!C ****************************************************************** -!C SPECIFICATIONS: -!C ------------------------------------------------------------------ -! USE GWFLAKMODULE, ONLY: NLAKES, LKNODE, FLOB, STAGES, -! + STGNEW, STGOLD, VOLOLDD, VOLOLD, VOLINIT, -! + BOTTMS, IDIV, STGOLD2, NDV -! USE GWFSFRMODULE, ONLY: DLKSTAGE -! USE GLOBAL, ONLY: IOUT -! use SimModule, only: ustop -!C ------------------------------------------------------------------ -!C FUNCTIONS -!C ------------------------------------------------------------------ -!!* DOUBLE PRECISION VOLTERP -!!* EXTERNAL VOLTERP -!C ------------------------------------------------------------------ -!C -!C------SET POINTERS FOR THE CURRENT GRID. -! CALL SGWF2LAK7PNT(IGRID) -!C -!C1 --- COPY INITIAL LAKE STAGES TO STGOLD. -!! RGN COMBINED IF AND ADDED VOLOLDD 4/17/09 -!Cdep initialized VOLINIT and VOLOLD to VOLOLDD 6/4/2009 -! DO I=1,NLAKES -! IF(KKPER.EQ.1.AND.KKSTP.EQ.1) THEN -! STGOLD(I)=STAGES(I) -! VOLOLDD(I)=VOLTERP(STGOLD(I),I) -! VOLOLD(I) = VOLOLDD(I) -! VOLINIT(I) = VOLOLDD(I) -! STGNEW(I)=STAGES(I) -! ELSE -! STGOLD2(I)=STGNEW(I) -! STGOLD(I)=STGNEW(I) -! VOLOLDD(I)=VOLTERP(STGOLD(I),I) -! VOLOLD(I)=VOLOLDD(I) -! ENDIF -!! Moved this code from 7FM 10/19/10 -! DO IDV=1,NDV -! INODE=IDIV(I,IDV) -! IF (INODE.GT.0) THEN -! IF( DLKSTAGE(1,INODE).LT.DBLE(BOTTMS(I))) THEN -! WRITE(IOUT,971)I,BOTTMS(I), -! + DLKSTAGE(1,INODE),INODE -! CALL USTOP(' ') -! ENDIF -! ENDIF -! ENDDO -! ! To hear. -! ENDDO -! 971 FORMAT(' BOTTOM ELEVATION OF LAKE ',I5,' IS ', F10.2, -! + ' AND IS ABOVE OUTLET ELEVATION OF ', F10.2, -! + ' FOR STREAM SEGMENT ',I5,/1X, -! + ' THIS WILL CAUSE PROBLEMS IN COMPUTING LAKE', -! + ' STAGE USING THE NEWTON METHOD. '/1X, -! + ' ELEVATION OF STREAM OUTLET MUST BE GREATER' -! + ' THAN OR EQUAL TO THE LOWEST ELEVATION OF THE', -! + ' LAKE.',/1X,'*****PROGRAM STOPPING'/) -!C2 ----- IF NOT FIRST TIME STEP, OR FIRST STRESS PERIOD, UPDATE -!C STGOLD BY STGNEW. -!! RGN MOVED TO ABOVE. STGOLD SHOULD BE UPDATED EVERY TIME STEP! 4/17/09 -!! IF (KKPER.NE.1.OR.KKSTP.NE.1) THEN -!! DO 30 K=1,NLAKES -!! STGOLD(K)=STGNEW(K) -!! VOLOLD(K)=VOLTERP(STGOLD(K),K)) -!!30 STGOLD2(K)=STGNEW(K) -!! ENDIF -!C -!C-----Initialize FLOB array (stores cell by cell flux between lake and -!C aquifer) -! IF (IUNITGWT.GT.0) THEN -! DO 50 LK=1,LKNODE -! 50 FLOB(LK)=0.0 -! ENDIF -!C -!C3------RETURN -! RETURN -! END SUBROUTINE GWF2LAK7AD -!C -! SUBROUTINE GWF2LAK7ST(NFLG,IGRID) -!C ******************************************************************** -!C SET IBOUND VALUES SO THAT RECHARGE AND EVAPOTRANSPIRATION (ET) WILL -!C BE ASSIGNED CORRECTLY UNDERNEATH DRYING LAKES (NFLG = 0), OR RESET -!C IBOUND AFTER RECHARGE AND ET ARE COMPUTED (NFLG = 1). -!C ******************************************************************** -!C -!C SPECIFICATIONS: -!C -!C----------------------------------------------------------------------- -! USE GWFLAKMODULE, ONLY: LKNODE, ILAKE, STGOLD -! USE GLOBAL, ONLY: IBOUND, LBOTM, BOTM -!C----------------------------------------------------------------------- -!C -!C------SET POINTERS FOR THE CURRENT GRID. -! CALL SGWF2LAK7PNT(IGRID) -! -! IF(LKNODE.EQ.0) RETURN -! DO 10 L=1,LKNODE -!C Convert ILAKE(5,L): 1 and 2 are type 1, 3 and 4 are type 2, 6 is type 0 -! ITYPE = (ILAKE(5,L)+1)/2 -! IF(ITYPE.EQ.3) ITYPE=0 -!C -!C-------ONLY CHANGE IBOUND FOR VERTICALLY ADJACENT NODE FACES -! IF(ITYPE.NE.0) GO TO 10 -! IL = ILAKE(1,L) -! IR = ILAKE(2,L) -! IC = ILAKE(3,L) -!C -!C-------RESET AFTER EXECUTING RECHARGE OR ET ROUTINES -! IF(NFLG.EQ.1) GO TO 8 -!C -!C-------RESET BEFORE EXECUTING RECHARGE OR ET ROUTINES -! IF ( IL.GT.1 ) THEN !RGN 5/21/12 added IF test -! IBOUND(IC,IR,IL-1) = -7 -! ELSE !RGN -! IBOUND(IC,IR,IL) = -7 !RGN -! ENDIF !RGN -!C -!C-------THIS IS THE CORRECT ASSIGNMENT IF PORTION OF LAKE IN COLUMN -!C IS WET. -! LAKE = ILAKE(4,L) -! IF(STGOLD(LAKE).GT.BOTM(IC,IR,LBOTM(IL)-1)) GO TO 10 -!C -!C-------IF PORTION OF LAKE IN NODE IS DRY, LET RECHARGE AND ET BE -!C APPLIED TO THE AQUIFER NODE UNDERNEATH THE LAKE BY SETTING -!C IBOUND EQUAL TO 0. -! 8 IF ( il.GT.1 ) THEN !RGN 5/21/12 added IF test -!! 8 IBOUND(IC,IR,IL-1) = 0 !RGN -! IBOUND(IC,IR,IL-1) = 0 !RGN -! ELSE !RGN -! IBOUND(IC,IR,IL) = 0 !RGN -! ENDIF !RGN -! 10 CONTINUE -!C -!C3------RETURN -! RETURN -! END SUBROUTINE GWF2LAK7ST -C - SUBROUTINE SGWF2LAK7SFR7RPS() -C -C ******************************************************************* -C-- IF STREAMS EXIST, DEFINE CONNECTIONS BETWEEN LAKES AND STREAMS -C ******************************************************************* -C -C ------------------------------------------------------------------- -C SPECIFICATIONS: -C ------------------------------------------------------------------- - USE GWFLAKMODULE, ONLY: NLAKES, NTRB, NDV, ITRB, IDIV, IRK - USE GLOBAL, ONLY: IOUT, NODES - USE GWFSFRMODULE, ONLY: NSS, IDIVAR, IOTSG, SEG, ISEG - use SimModule, only: ustop -C -C-- DOUBLE CHECK SIZE OF IRK (STORED IN BUFF) vs. NLAKES -C - IF ((NLAKES*2).GT.NODES) THEN - WRITE (IOUT,*) '***NLAKES too large for BUFF in Subroutine GWF2 - 1LAK7SFR7RPS*** STOP EXECUTION' - CALL USTOP(' ') - ENDIF -C -C-- INITIALIZE ARRAYS -C - DO 55 LK=1,NLAKES - IRK(1,LK) = 0 - 55 IRK(2,LK) = 0 - NTRB = 0 - NDV = 0 -C -C-- Build arrays to define lake tributary & diversion links ... -C based on stream package input data -C -C--- Stream Inflow to Lakes - DO 100 LSEG=1,NSS - IF(IOTSG(LSEG).LT.0) THEN - LAKE = -IOTSG(LSEG) - IRK(1,LAKE) = IRK(1,LAKE) + 1 - K1 = IRK(1,LAKE) - ITRB(LAKE,K1) = LSEG - IF(IRK(1,LAKE).GT.NTRB) NTRB = IRK(1,LAKE) - ENDIF -C -C--- Stream Outflow from Lakes - IF(IDIVAR(1,LSEG).LT.0) THEN - LAKE = -IDIVAR(1,LSEG) - IRK(2,LAKE) = IRK(2,LAKE) + 1 - K1 = IRK(2,LAKE) - IDIV(LAKE,K1) = LSEG - IF(IRK(2,LAKE).GT.NDV) NDV = IRK(2,LAKE) - ENDIF - 100 CONTINUE -C -C-- PRINT LAKE INFLOW STREAM SEGMENTS. - WRITE(IOUT,10) -10 FORMAT(6X,'LAKE ',4X,'INFLOWING STREAM SEGMENT') - DO 520 IK=1,NLAKES - DO 519 JK=1,NSS - IF(ITRB(IK,JK).LE.0) GO TO 521 - 519 CONTINUE - 521 JK1 = JK - 1 - IF(JK1.GT.0) WRITE(IOUT,15) IK,(ITRB(IK,JK),JK=1,JK1) -15 FORMAT(5X,I5,14X,100I5) - 520 CONTINUE - WRITE(IOUT,103) NTRB -103 FORMAT(/1X,'MAXIMUM NUMBER OF STREAMS INFLOWING TO A', - 1 ' LAKE IS',I5/) -C -C-- PRINT LAKE STREAM OUTFLOW SEGMENT (FROM A LAKE) NUMBERS. -C - WRITE(IOUT,13) -13 FORMAT(6X,'LAKE ',4X,'OUTFLOWING STREAM',' SEGMENT') - DO 600 IK=1,NLAKES - DO 523 JK=1,NSS - IF(IDIV(IK,JK).LE.0) GO TO 527 - 523 CONTINUE - 527 JK1 = JK - 1 - IF(JK1.GT.0) WRITE(IOUT,15) IK,(IDIV(IK,JK),JK=1,JK1) - 600 CONTINUE -C -Cdep-- PRINT WARNING IF OUTFLOWING STREAM IS ASSIGNED ICALC =0. -Cdep ADDED OCTOBER 15, 2004; DAVID PRUDIC - DO ls = 1, NSS - IF (IDIVAR(1,ls).LT.0) THEN - lk = -IDIVAR(1,ls) - IF (ISEG(1,ls).LE.0 .AND. SEG(2,ls).LE.0.0) THEN - WRITE (IOUT, 9007) ls, lk, ISEG(1,ls), SEG(2,ls) - ENDIF - ENDIF - ENDDO - WRITE(IOUT,133) NDV -133 FORMAT(/1X,'MAXIMUM NUMBER OF STREAMS OUTFLOWING', - 1 ' FROM A LAKE IS',I5/) - 9007 FORMAT(/, ' WARNING**** OUTFLOWING STREAM SEGMENT', I6, - + ' FROM LAKE', I6, ' HAS AN ICALC VALUE OF', I6, - + ' AND FLOW INTO THE SEGMENT IS', E12.4, /, - + ' NO OUTFLOW FROM THE LAKE INTO ', - + 'SEGMENT WILL BE SIMULATED', /, - + ' SUGGEST CHANGING ICALC TO ANOTHER OPTION') -C -C-- RETURN - RETURN - END SUBROUTINE SGWF2LAK7SFR7RPS - - SUBROUTINE SGWF2LAK7BCF7RPS() -C -C ****************************************************************** -C COMPUTE VERTICAL CONDUCTANCES AND HORIZONTAL CONDUCTANCES PER UNIT -C THICKNESS FOR LAKES WHEN BCF PACKAGE IS USED -C ****************************************************************** -C -C ------------------------------------------------------------------ -C SPECIFICATIONS: -C ------------------------------------------------------------------ - USE GWFLAKMODULE, ONLY: LKNODE, BEDLAK, LKARR1, ILAKE, CNDFCT - USE GLOBAL, ONLY: NLAY, IOUT, DELR, DELC, LAYHDT,NCOL,NROW - USE GWFBCFMODULE, ONLY: IWDFLG, HY, CVWD, TRPY -C - WRITE(IOUT,108) - 108 FORMAT(//9X,'C',15X,'INTERFACE CONDUCTANCES BETWEEN LAKE AND ', - 1 'AQUIFER CELLS'/ - 2 3X,'L',5X,'O',10X,'(IF TYPE = 6, CONDUCTANCE (L^2/T) IS ', - 3 'BETWEEN AQUIFER CELL AND OVERLYING LAKE CELL.)',/ - 4 3X,'A',5X,'L',2X,'L',2X,'T', - 5 4X,'(IF TYPE = 1 TO 4, CONDUCTANCES ARE PER UNIT SATURATED ', - 6 'THICKNESS (L/T).)'/ - 7 3X,'Y',2X,'R',2X,'U',2X,'A',2X,'Y'/ - 8 3X,'E',2X,'O',2X,'M',2X,'K',2X,'P', - 9 24X,'LAKEBED',6X,'C O N D U C T A N C E S'/3X,'R',2X,'W',2X, - 1 'N',2X,'E', - 2 2X,'E',5X,'DELTA Y',3X,'DELTA X',2X,'LEAKANCE',3X,'LAKEBED',3X, - 3 'AQUIFER',2X,'COMBINED'/1X,79('_')) -C - IWRN = 0 - IWRN1 = 0 - DO 350 II=1,LKNODE - K = ILAKE(1,II) - J = ILAKE(2,II) - I = ILAKE(3,II) - CNDFCT(II) = 0.0 -C Convert ILAKE(5,II): 1 and 2 are type 1, 3 and 4 are type 2, 6 is type 0 - NTYP = (ILAKE(5,II)+1)/2 - IF(NTYP.EQ.3) NTYP=0 - NTYP = NTYP + 1 - IF(NTYP.EQ.1) THEN -C -C Vertical Conductance -C for vertical interface, "K" is layer below bottom of lake -C - CNDFC1=0.0 - IF(K.EQ.NLAY.AND.LKARR1(I,J,K).GT.0) GO TO 315 - IF(BEDLAK(II).LE.0.0) GO TO 315 - IWRN1 = 1 - CNDFC1 = BEDLAK(II)*DELR(I)*DELC(J) - IF (IWDFLG.EQ.0) THEN - CNDFCT(II) = CNDFC1 - ELSE - IF(CVWD(I,J,K-1).LE.0.0.OR.CNDFC1.LE.0.0) GO TO 315 - CNDFCT(II) = 1.0/(0.5/CVWD(I,J,K-1)+1.0/CNDFC1) - ENDIF - 315 IF (IWDFLG.EQ.0) THEN - WRITE(IOUT,7324) (ILAKE(I1,II),I1=1,5),DELC(J),DELR(I), - 1 BEDLAK(II),CNDFC1,CNDFCT(II) -c-lfk - 7324 FORMAT(1X,5I3,2X,1P,4E10.2,10X,E11.3) -C 7324 FORMAT(1X,5I3,2X,1P,4E10.2,10X,E10.2) - ELSE - IF (K.GT.1) THEN - CVWD2= 2.0*CVWD(I,J,K-1) - WRITE(IOUT,7325) (ILAKE(I1,II),I1=1,5),DELC(J),DELR(I), - 1 BEDLAK(II),CNDFC1,CVWD2,CNDFCT(II) - ENDIF -c-lfk - 7325 FORMAT(1X,5I3,2X,1P,5E10.2,E11.3) -c 7325 FORMAT(1X,5I3,2X,1P,6E10.2) - ENDIF - ELSE -C -C Horizontal conductance -C -C HY not read in, thus unavailable. -C -Cdep 348 IF(LAYHDT(K).EQ.0) THEN - IF(LAYHDT(K).EQ.0) THEN - IF(NTYP.EQ.2) CNDFCT(II) = BEDLAK(II)*DELC(J) - IF(NTYP.EQ.3) CNDFCT(II) = BEDLAK(II)*DELR(I) - WRITE(IOUT,7324) (ILAKE(I1,II),I1=1,5),DELC(J),DELR(I), - 1 BEDLAK(II),CNDFCT(II),CNDFCT(II) - IWRN = 1 - ELSE -C -C HY read in, thus available. -C - TT = HY(I,J,K) - IF(NTYP.EQ.2) CNDFC2 = 2.0*TT*DELC(J)/DELR(I) - IF(NTYP.EQ.3) CNDFC2 = 2.0*TRPY(K)*TT*DELR(I)/DELC(J) - IF(NTYP.EQ.2) CNDFC1 = BEDLAK(II)*DELC(J) - IF(NTYP.EQ.3) CNDFC1 = BEDLAK(II)*DELR(I) - IF (CNDFC1.GT.0.0.AND.CNDFC2.GT.0.0) - * CNDFCT(II) = 1.0/(1.0/CNDFC2+1.0/CNDFC1) - WRITE(IOUT,7325) (ILAKE(I1,II),I1=1,5),DELC(J),DELR(I), - 1 BEDLAK(II),CNDFC1,CNDFC2,CNDFCT(II) - ENDIF - ENDIF - 350 CONTINUE -C -C WRITE WARNINGS ON LAKE/AQUIFER CONDUCTANCES, IF NECESSARY - IF(IWRN.EQ.1.OR.IWRN1.EQ.1) WRITE(IOUT,345) - 345 FORMAT(//5X,'NOTE: INFORMATION ABOUT CALCULATED LAKE/AQUIFER C - 1ONDUCTANCES WHEN USING BCF PACKAGE FOLLOWS: '/) - IF(IWRN.EQ.1) WRITE(IOUT,346) - 346 FORMAT(1X,'NODE(S) ADJACENT TO LAKE IN CONFINED LAYER:'/ - 1 1X,'LAKE/AQUIFER CONDUCTANCES BASED SOLELY ON LAKEBED SPECIFIC - 2ATION'/) - IF(IWRN1.EQ.1) WRITE(IOUT,347) - 347 FORMAT(1X,'IF WETDRY FLAG NOT TURNED ON, VERTICAL LEAKANCES AR - 1E NOT SAVED:'/1X,'THEREFORE, LAKE/AQUIFER CONDUCTANCES ARE BASED S - 2OLELY ON LAKEBED SPECIFICATION'/) - IF(IWRN.EQ.1.OR.IWRN1.EQ.1) WRITE(IOUT,'(//)') -C - RETURN - END SUBROUTINE SGWF2LAK7BCF7RPS -C - SUBROUTINE SGWF2LAK7LPF7RPS() -C -C ****************************************************************** -C COMPUTE VERTICAL CONDUCTANCES AND HORIZONTAL CONDUCTANCES PER UNIT -C THICKNESS FOR LAKES WHEN LPF PACKAGE IS USED -C ****************************************************************** -C -C ------------------------------------------------------------------ -C SPECIFICATIONS: -C ------------------------------------------------------------------ - USE GWFLAKMODULE, ONLY: LKNODE, BEDLAK, LKARR1, ILAKE, CNDFCT - USE GLOBAL, ONLY: NLAY, IOUT, LBOTM, LAYCBD, DELR, DELC, - + BOTM - USE GWFLPFMODULE, ONLY: CHANI, LAYVKA, VKA, VKCB, HANI, HK -C - WRITE(IOUT,108) - 108 FORMAT(//9X,'C',15X,'INTERFACE CONDUCTANCES BETWEEN LAKE AND ', - 1 'AQUIFER CELLS'/ - 2 3X,'L',5X,'O',10X,'(IF TYPE = 6, CONDUCTANCE (L^2/T) IS ', - 3 'BETWEEN AQUIFER CELL AND OVERLYING LAKE CELL.)',/ - 4 3X,'A',5X,'L',2X,'L',2X,'T', - 5 4X,'(IF TYPE = 1 TO 4, CONDUCTANCES ARE PER UNIT SATURATED ', - 6 'THICKNESS (L/T).)'/ - 7 3X,'Y',2X,'R',2X,'U',2X,'A',2X,'Y'/ - 8 3X,'E',2X,'O',2X,'M',2X,'K',2X,'P', - 9 24X,'LAKEBED',6X,'C O N D U C T A N C E S'/3X,'R',2X,'W',2X, - 1 'N',2X,'E', - 2 2X,'E',5X,'DELTA Y',3X,'DELTA X',2X,'LEAKANCE',3X,'LAKEBED',3X, - 3 'AQUIFER',2X,'COMBINED'/1X,79('_')) -C - DO 350 II=1,LKNODE - K = ILAKE(1,II) - J = ILAKE(2,II) - I = ILAKE(3,II) - CAQ = 0.0 - CNDFCT(II) = 0.0 -C Convert ILAKE(5,II): 1 and 2 are type 1, 3 and 4 are type 2, 6 is type 0 - NTYP = (ILAKE(5,II)+1)/2 - IF(NTYP.EQ.3) NTYP=0 - NTYP=NTYP + 1 - IF(NTYP.EQ.1) THEN -C -C Vertical Conductance -C for vertical interface, "K" is layer below bottom of lake - CNDFC1=0.0 - IF(K.EQ.NLAY.AND.LKARR1(I,J,K).GT.0) GO TO 315 - IF(BEDLAK(II).LE.0.0) GO TO 315 - CNDFC1 = BEDLAK(II)*DELR(I)*DELC(J) - IF(LAYVKA(K).EQ.0) THEN - VK=VKA(I,J,K) - ELSE - VK=HK(I,J,K)/VKA(I,J,K) - ENDIF -c skip if zero vk - IF(VK.LE.0.0) GO TO 350 - BBOT=BOTM(I,J,LBOTM(K)) - TTOP=BOTM(I,J,LBOTM(K)-1) - CAQ=VK*DELR(I)*DELC(J)/((TTOP-BBOT)*0.5) - IF(LAYCBD(K-1).GT.0) THEN -c skip if zero vkcb - IF(VKCB(I,J,LAYCBD(K-1)).LE.0.0) GO TO 350 - BBOT=BOTM(I,J,LBOTM(K)-1) - TTOP=BOTM(I,J,LBOTM(K-1)) - CCB=VKCB(I,J,LAYCBD(K-1))*DELR(I)*DELC(J)/(TTOP-BBOT) - !include VKCB - CAQ = 1.0/(1.0/CAQ + 1.0/CCB) - ENDIF - CNDFCT(II) = 1.0/(1.0/CAQ+1.0/CNDFC1) - 315 WRITE(IOUT,7325) (ILAKE(I1,II),I1=1,5),DELC(J),DELR(I), - 1 BEDLAK(II),CNDFC1,CAQ,CNDFCT(II) - ELSE -C -C Horizontal conductance -C - TT = HK(I,J,K) -C X-DIRECTION - IF(NTYP.EQ.2) CNDFC2 = 2.0*TT*DELC(J)/DELR(I) -C Y-DIRECTION - IF(NTYP.EQ.3) THEN - IF(CHANI(K).LE.0) THEN - KH=-CHANI(K) - CNDFC2 = 2.0*HANI(I,J,KH)*TT*DELR(I)/DELC(J) - ELSE - CNDFC2 = 2.0*CHANI(K)*TT*DELR(I)/DELC(J) - ENDIF - ENDIF - IF(NTYP.EQ.2) CNDFC1 = BEDLAK(II)*DELC(J) - IF(NTYP.EQ.3) CNDFC1 = BEDLAK(II)*DELR(I) - IF (CNDFC1.GT.0.0.AND.CNDFC2.GT.0.0) - * CNDFCT(II) = 1.0/(1.0/CNDFC2+1.0/CNDFC1) - WRITE(IOUT,7325) (ILAKE(I1,II),I1=1,5),DELC(J),DELR(I), - 1 BEDLAK(II),CNDFC1,CNDFC2,CNDFCT(II) -c-lfk - 7325 FORMAT(1X,5I3,2X,1P,5E10.2,E11.3) -c 7325 FORMAT(1X,5I3,2X,1P,6E10.2) - ENDIF - 350 CONTINUE -C - RETURN - END SUBROUTINE SGWF2LAK7LPF7RPS -C - SUBROUTINE SGWF2LAK7UPW1RPS() -C -C ****************************************************************** -C COMPUTE VERTICAL CONDUCTANCES AND HORIZONTAL CONDUCTANCES PER UNIT -C THICKNESS FOR LAKES WHEN UPW PACKAGE IS USED -C ****************************************************************** -C -C ------------------------------------------------------------------ -C SPECIFICATIONS: -C ------------------------------------------------------------------ - USE GWFLAKMODULE, ONLY: LKNODE, BEDLAK, LKARR1, ILAKE, CNDFCT - USE GLOBAL, ONLY: NLAY, IOUT, LBOTM, LAYCBD, DELR, DELC, - + BOTM - USE GWFUPWMODULE, ONLY: CHANI, LAYVKAUPW, VKAUPW, VKCB, HANI, - + HKUPW -C - WRITE(IOUT,108) - 108 FORMAT(//9X,'C',15X,'INTERFACE CONDUCTANCES BETWEEN LAKE AND ', - 1 'AQUIFER CELLS'/ - 2 3X,'L',5X,'O',10X,'(IF TYPE = 6, CONDUCTANCE (L^2/T) IS ', - 3 'BETWEEN AQUIFER CELL AND OVERLYING LAKE CELL.)',/ - 4 3X,'A',5X,'L',2X,'L',2X,'T', - 5 4X,'(IF TYPE = 1 TO 4, CONDUCTANCES ARE PER UNIT SATURATED ', - 6 'THICKNESS (L/T).)'/ - 7 3X,'Y',2X,'R',2X,'U',2X,'A',2X,'Y'/ - 8 3X,'E',2X,'O',2X,'M',2X,'K',2X,'P', - 9 24X,'LAKEBED',6X,'C O N D U C T A N C E S'/3X,'R',2X,'W',2X, - 1 'N',2X,'E', - 2 2X,'E',5X,'DELTA Y',3X,'DELTA X',2X,'LEAKANCE',3X,'LAKEBED',3X, - 3 'AQUIFER',2X,'COMBINED'/1X,79('_')) -C - DO 350 II=1,LKNODE - K = ILAKE(1,II) - J = ILAKE(2,II) - I = ILAKE(3,II) - CAQ = 0.0 - CNDFCT(II) = 0.0 -C Convert ILAKE(5,II): 1 and 2 are type 1, 3 and 4 are type 2, 6 is type 0 - NTYP = (ILAKE(5,II)+1)/2 - IF(NTYP.EQ.3) NTYP=0 - NTYP=NTYP + 1 - IF(NTYP.EQ.1) THEN -C -C Vertical Conductance -C for vertical interface, "K" is layer below bottom of lake - CNDFC1=0.0 - IF(K.EQ.NLAY.AND.LKARR1(I,J,K).GT.0) GO TO 315 - IF(BEDLAK(II).LE.0.0) GO TO 315 - CNDFC1 = BEDLAK(II)*DELR(I)*DELC(J) - IF(LAYVKAUPW(K).EQ.0) THEN - VK=VKAUPW(I,J,K) - ELSE - VK=HKUPW(I,J,K)/VKAUPW(I,J,K) - END IF -c skip if zero vk - IF(VK.LE.0.0) GO TO 350 - BBOT=BOTM(I,J,LBOTM(K)) - TTOP=BOTM(I,J,LBOTM(K)-1) - CAQ=VK*DELR(I)*DELC(J)/((TTOP-BBOT)*0.5) - IF(LAYCBD(K-1).GT.0) THEN -c skip if zero vkcb - IF(VKCB(I,J,LAYCBD(K)).LE.0.0) GO TO 350 - BBOT=BOTM(I,J,LBOTM(K)-1) - TTOP=BOTM(I,J,LBOTM(K-1)) - CCB=VKCB(I,J,LAYCBD(K-1))*DELR(I)*DELC(J)/(TTOP-BBOT) - !include VKCB - CAQ = 1.0/(1.0/CAQ + 1.0/CCB) - END IF - CNDFCT(II) = 1.0/(1.0/CAQ+1.0/CNDFC1) - 315 WRITE(IOUT,7325) (ILAKE(I1,II),I1=1,5),DELC(J),DELR(I), - 1 BEDLAK(II),CNDFC1,CAQ,CNDFCT(II) - ELSE -C -C Horizontal conductance -C - TT = HKUPW(I,J,K) -C X-DIRECTION - IF(NTYP.EQ.2) CNDFC2 = 2.0*TT*DELC(J)/DELR(I) -C Y-DIRECTION - IF(NTYP.EQ.3) THEN - IF(CHANI(K).LE.0) THEN - KH=-CHANI(K) - CNDFC2 = 2.0*HANI(I,J,KH)*TT*DELR(I)/DELC(J) - ELSE - CNDFC2 = 2.0*CHANI(K)*TT*DELR(I)/DELC(J) - END IF - END IF - IF(NTYP.EQ.2) CNDFC1 = BEDLAK(II)*DELC(J) - IF(NTYP.EQ.3) CNDFC1 = BEDLAK(II)*DELR(I) - IF (CNDFC1.GT.0.0.AND.CNDFC2.GT.0.0) - * CNDFCT(II) = 1.0/(1.0/CNDFC2+1.0/CNDFC1) - WRITE(IOUT,7325) (ILAKE(I1,II),I1=1,5),DELC(J),DELR(I), - 1 BEDLAK(II),CNDFC1,CNDFC2,CNDFCT(II) - 7325 FORMAT(1X,5I3,2X,1P,6E10.2) - END IF - 350 CONTINUE -C - RETURN - END SUBROUTINE SGWF2LAK7UPW1RPS - -Cdep Added function statements to compute derivatives for Newton method -Cdep used in solving lake stage in the FORMULATE SUBROUTINE (LAK7FM). - DOUBLE PRECISION FUNCTION FINTERP (STAGE,LN) -Cdep&rgn FUNCTION LINEARLY INTERPOLATES BETWEEN TWO VALUES -C OF LAKE STAGE TO CACULATE LAKE AREA. -C ADDED 5/16/2006-- changed 12/2007 from "DOUBLE PRECISION FUNCTION" -C to "FUNCTION" - USE GWFLAKMODULE, ONLY: AREATABLE, DEPTHTABLE - IMPLICIT NONE - DOUBLE PRECISION STAGE, AREA, TOLF2, FOLD - DOUBLE PRECISION a1, a2, d1, d2 - INTEGER LN, IFLG, I - TOLF2=1.0E-7 - IF (STAGE.GT.DEPTHTABLE(151,LN))THEN - FINTERP = AREATABLE(151,LN) - RETURN - ENDIF - IFLG = 0 - I = 1 - DO WHILE ( IFLG.EQ.0 ) - a1 = AREATABLE(I,LN) - a2 = AREATABLE(I+1,LN) - d1 = DEPTHTABLE(I,LN) - d2 = DEPTHTABLE(I+1,LN) - FOLD=ABS(STAGE-d1) - IF (FOLD .LE. TOLF2) THEN - AREA=AREATABLE(I,LN) - IFLG = 1 - ELSEIF (STAGE.GT.d1 .AND. STAGE.LT.d2)THEN - AREA=((a2-a1)/(d2-d1))*STAGE+a2-((a2-a1)/(d2-d1))*d2 - IFLG = 1 - ENDIF - I = I + 1 - IF( I.GT.150 ) THEN - IFLG = 1 - AREA = AREATABLE(151,LN) - ENDIF - ENDDO - FINTERP = AREA - RETURN - END FUNCTION FINTERP - -! RGN Added function statements to compute calculate surface area form volume - DOUBLE PRECISION FUNCTION SURFTERP (VOLUME,LN) -C FUNCTION LINEARLY INTERPOLATES BETWEEN TWO VALUES -C OF LAKE VOLUME TO CACULATE LAKE AREA. - USE GWFLAKMODULE, ONLY: AREATABLE, VOLUMETABLE - DOUBLE PRECISION VOLUME - TOLF2=1.0E-7 - IF (VOLUME.GT.VOLUMETABLE(151,LN))THEN - SURFTERP = AREATABLE(151,LN) - RETURN - ENDIF - IFLG = 0 - I = 1 - DO WHILE ( IFLG.EQ.0 ) - FOLD=ABS(VOLUME-VOLUMETABLE(I,LN)) - IF (FOLD .LE. TOLF2) THEN - AREA=AREATABLE(I,LN) - IFLG = 1 - ELSEIF (VOLUME.GT.VOLUMETABLE(I,LN) .AND. VOLUME.LT. - 1 VOLUMETABLE(I+1,LN))THEN - AREA=((AREATABLE(I+1,LN)-AREATABLE(I,LN))/ - 1 (VOLUMETABLE(I+1,LN)- VOLUMETABLE(I,LN)))* - 2 VOLUME+AREATABLE(I+1,LN)-((AREATABLE(I+1,LN)- - 3 AREATABLE(I,LN))/(VOLUMETABLE(I+1,LN)- - 4 VOLUMETABLE(I,LN)))*VOLUMETABLE(I+1,LN) - IFLG = 1 - ENDIF - I = I + 1 - IF( I.GT.150 ) IFLG = 1 - ENDDO - SURFTERP = AREA - RETURN - END FUNCTION SURFTERP -! -! Interpolate lake volume as a function of lake stage -C used in solving lake stage in the FORMULATE SUBROUTINE (LAK7FM). - DOUBLE PRECISION FUNCTION VOLTERP (STAGE,LN) -C FUNCTION LINEARLY INTERPOLATES BETWEEN TWO VALUES -C OF LAKE STAGE TO CACULATE LAKE VOLUME. - USE GWFLAKMODULE, ONLY: VOLUMETABLE, DEPTHTABLE, AREATABLE - IMPLICIT NONE - INTEGER LN, IFLG, I - DOUBLE PRECISION STAGE, VOLUME, TOLF2, FOLD - TOLF2=1.0E-7 - IF (STAGE.GT.DEPTHTABLE(151,LN))THEN - ! bug 5/4/09 changed FINTERP TO VOLUME - VOLTERP = VOLUMETABLE(151,LN)+(STAGE-DEPTHTABLE(151,LN))* - + AREATABLE(151,LN) - RETURN - ENDIF - IFLG = 0 - I = 1 - DO WHILE ( IFLG.EQ.0 ) - FOLD=ABS(STAGE-DEPTHTABLE(I,LN)) - IF (FOLD .LE. TOLF2) THEN - VOLUME=VOLUMETABLE(I,LN) - IFLG = 1 - ELSEIF (STAGE.GT.DEPTHTABLE(I,LN) .AND. STAGE.LT. - 1 DEPTHTABLE(I+1,LN))THEN - VOLUME=((VOLUMETABLE(I+1,LN)-VOLUMETABLE(I,LN))/ - 1 (DEPTHTABLE(I+1,LN)- DEPTHTABLE(I,LN)))* - 2 STAGE+VOLUMETABLE(I+1,LN)-((VOLUMETABLE(I+1,LN)- - 3 VOLUMETABLE(I,LN))/(DEPTHTABLE(I+1,LN)- - 4 DEPTHTABLE(I,LN)))*DEPTHTABLE(I+1,LN) - IFLG = 1 - ENDIF - I = I + 1 - IF( I.GT.150 ) THEN - IFLG = 1 - VOLUME = VOLUMETABLE(151,LN) - ENDIF - ENDDO - VOLTERP = VOLUME - IF ( VOLTERP.LT.TOLF2 ) VOLTERP = TOLF2 - RETURN - END FUNCTION VOLTERP - -! Interpolate lake STAGE as a function of lake VOLUME -C used in solving lake stage in the FORMULATE SUBROUTINE (LAK7FM). - DOUBLE PRECISION FUNCTION STGTERP (VOLUME,LN) -C FUNCTION LINEARLY INTERPOLATES BETWEEN TWO VALUES -C OF LAKE VOLUME TO CACULATE LAKE STAGE. - USE GWFLAKMODULE, ONLY: VOLUMETABLE, DEPTHTABLE,AREATABLE - DOUBLE PRECISION VOLUME, STAGE - TOLF2=1.0E-7 - IF (VOLUME.GT.VOLUMETABLE(151,LN))THEN - STGTERP = DEPTHTABLE(151,LN)+(VOLUME-VOLUMETABLE(151,LN))/ - + AREATABLE(151,LN) - RETURN - ENDIF - IFLG = 0 - I = 1 - DO WHILE ( IFLG.EQ.0 ) - FOLD=ABS(VOLUME-VOLUMETABLE(I,LN)) - IF (FOLD .LE. TOLF2) THEN - STGTERP=DEPTHTABLE(I,LN) - IFLG = 1 - ELSEIF (VOLUME.GT.VOLUMETABLE(I,LN) .AND. VOLUME.LT. - 1 VOLUMETABLE(I+1,LN))THEN - STGTERP=((DEPTHTABLE(I+1,LN)-DEPTHTABLE(I,LN))/ - 1 (VOLUMETABLE(I+1,LN)- VOLUMETABLE(I,LN)))* - 2 VOLUME+DEPTHTABLE(I+1,LN)-((DEPTHTABLE(I+1,LN)- - 3 DEPTHTABLE(I,LN))/(VOLUMETABLE(I+1,LN)- - 4 VOLUMETABLE(I,LN)))*VOLUMETABLE(I+1,LN) - IFLG = 1 - ENDIF - I = I + 1 - IF( I.GT.150 ) THEN - IFLG = 1 - STGTERP= 0.0 - ENDIF - ENDDO - RETURN - END FUNCTION STGTERP - -C------FUNCTION DERIVTERP FOR INTERPOLATING DERIVATIVE OF LAKE OUTFLOW. - DOUBLE PRECISION FUNCTION DERIVTERP (STAGE,LSEG) -Cdep&rgn FUNCTION LINEARLY INTERPOLATES BETWEEN TWO VALUES -C OF LAKE STAGE TO CACULATE LAKE OUTFLOW DERIVATIVE. -C ADDED 5/16/2006-- changed 12/2007 from "DOUBLE PRECISION FUNCTION" -C to "FUNCTION" - USE GWFSFRMODULE, ONLY: DLKOTFLW, DLKSTAGE - DOUBLE PRECISION STAGE, DEROTFLW, FOLD - TOLF2=1.0E-7 - IF (STAGE.GT.DLKSTAGE(200,LSEG))THEN - DERIVTERP = DLKOTFLW(200,LSEG) - RETURN - ENDIF - IFLG = 0 - I = 1 - DO WHILE ( IFLG.EQ.0 ) - FOLD=ABS(STAGE-DLKSTAGE(I,LSEG)) - IF (FOLD .LE. TOLF2) THEN - DEROTFLW=DLKOTFLW(I,LSEG) - IFLG = 1 !rsr, changed ISFLG to IFLG - ELSEIF (STAGE.LT.DLKSTAGE(1,LSEG)) THEN - DEROTFLW=0.0D0 - IFLG = 1 - ELSEIF (STAGE.GT.DLKSTAGE(I,LSEG) .AND. STAGE.LT. - 1 DLKSTAGE(I+1,LSEG))THEN - DEROTFLW=((DLKOTFLW(I+1,LSEG)-DLKOTFLW(I,LSEG))/ - 1 (DLKSTAGE(I+1,LSEG)- DLKSTAGE(I,LSEG)))* - 2 STAGE+DLKOTFLW(I+1,LSEG)-((DLKOTFLW(I+1,LSEG)- - 3 DLKOTFLW(I,LSEG))/(DLKSTAGE(I+1,LSEG)- - 4 DLKSTAGE(I,LSEG)))*DLKSTAGE(I+1,LSEG) - IFLG = 1 - ENDIF - I = I + 1 - IF( I.GT.199) IFLG = 1 - ENDDO - DERIVTERP = DEROTFLW - RETURN - END FUNCTION DERIVTERP - -C------FUNCTION OUTFLWTERP FOR INTERPOLATING DERIVATIVE OF LAKE OUTFLOW. - DOUBLE PRECISION FUNCTION OUTFLWTERP (STAGE,LSEG) -Cdep&rgn FUNCTION LINEARLY INTERPOLATES BETWEEN TWO VALUES -C OF LAKE OUTFLOW STORED IN SLKOTFLW ARRAY. -C ADDED 5/16/2006-- changed 12/2007 from "DOUBLE PRECISION FUNCTION" -C to "FUNCTION" - USE GWFSFRMODULE, ONLY: SLKOTFLW, DLKSTAGE - DOUBLE PRECISION STAGE, OUTFLOW, FOLD - TOLF2=1.0E-9 - IF (STAGE.GT.DLKSTAGE(200,LSEG))THEN - OUTFLWTERP = SLKOTFLW(200,LSEG) - RETURN - ENDIF - IFLG = 0 - I = 1 - DO WHILE ( IFLG.EQ.0 ) - FOLD=DABS(STAGE-DLKSTAGE(I,LSEG)) - IF (FOLD .LE. TOLF2) THEN - OUTFLOW=SLKOTFLW(I,LSEG) - IFLG = 1 - ELSEIF (STAGE.LT.DLKSTAGE(1,LSEG)) THEN - OUTFLOW=0.0D0 - IFLG = 1 - ELSEIF (STAGE.GT.DLKSTAGE(I,LSEG) .AND. STAGE.LT. - 1 DLKSTAGE(I+1,LSEG))THEN - OUTFLOW=((SLKOTFLW(I+1,LSEG)-SLKOTFLW(I,LSEG))/ - 1 (DLKSTAGE(I+1,LSEG)- DLKSTAGE(I,LSEG)))* - 2 STAGE+SLKOTFLW(I+1,LSEG)-((SLKOTFLW(I+1,LSEG)- - 3 SLKOTFLW(I,LSEG))/(DLKSTAGE(I+1,LSEG)- - 4 DLKSTAGE(I,LSEG)))*DLKSTAGE(I+1,LSEG) - IFLG = 1 - ENDIF - I = I + 1 - IF( I.GT.199) IFLG = 1 - ENDDO - OUTFLWTERP = OUTFLOW - RETURN - END FUNCTION OUTFLWTERP -C -C------FUNCTION FXLKOT_TERP FOR SMOOTHING SPECIFIED LAKE OUTFLOWS TO STREAMS. -C - DOUBLE PRECISION FUNCTION FXLKOT_TERP(DSTAGE,Botlake,Splakout,dy) - IMPLICIT NONE - DOUBLE PRECISION DSTAGE,Botlake,Splakout, s, aa, ad, b, x, y, dy - FXLKOT_TERP = 0.0D0 - s = 2.0 - x = DSTAGE-Botlake - aa = -1.0d0/(s**2.0d0) - ad = -2.0D0/(s**2.0d0) - b = 2.0d0/s - y = aa*x**2.0d0 + b*x - dy = (ad*x + b)*Splakout - IF ( x.LE.0.0 ) THEN - y = 0.0D0 - dy = 0.0D0 - ELSEIF ( x-s.GT.-1.0e-14 ) THEN - y = 1.0D0 - dy = 0.0D0 - ENDIF - FXLKOT_TERP = y*Splakout - END FUNCTION FXLKOT_TERP -C - SUBROUTINE GET_FLOBOT(IC, IR, IL, ITYPE, INOFLO,CONDUC, - 1 FLOBOT,FLOBO3,FLOTOUZF,DLSTG,CLOSEZERO,H, - 2 THET1,ISS,LAKE,II,SURFDPTH,AREA,IUNITUZF, - 3 BOTLK,BOTCL,L1) -C -C ****************************************************************** -C CALCULATE SEEPAGE BETWEEN LAKE AND GW CELLS -C ****************************************************************** -C - USE GWFLAKMODULE - USE GLOBAL, ONLY: IBOUND, IOUT, LBOTM, BOTM, NLAY,LAYHDT - USE GWFUZFMODULE, ONLY: IUZFBND,FINF,VKS - IMPLICIT NONE -C ------------------------------------------------------------------ -C SPECIFICATIONS: -C ------------------------------------------------------------------ -C FUNCTIONS -C ----------------------------------------------------------------- -C ----------------------------------------------------------------- -C ARGUMENTS - DOUBLE PRECISION FLOBO3,FLOBOT,CONDUC,H,THET1,CLOSEZERO,DLSTG, - 1 SURFDPTH,AREA,BOTLK,BOTCL,HH - INTEGER ISS, LAKE, II, IC, IR, IL, ITYPE, IUNITUZF, L1 -C ----------------------------------------------------------------- - INTEGER ICHECK, LI, INOFLO - DOUBLE PRECISION FLOBO1,FLOBO2,CONDMX,BOTLKUP, - 1 BOTLKDN,FLOTOUZF,RAMPGW,RAMPSTGO,RAMPSTGN, - 2 RAMPSTGON,HTEMP,HD,THCK,RAMPUP -C -C5C-----INITIALIZE GROUNDWATER SEEPAGE VARIABLES AND CONDUCTANCE FACTOR. - FLOBO1 = 0.0D0 - FLOBO2 = 0.0D0 -C -C6------COMPUTE SEEPAGE INTO OR OUT OF A LAKE BED NODE WHEN ITYPE=0. -C HEAD CANNOT FALL BELOW LAKE BOTTOM - IF (ITYPE.EQ.0) THEN -C -C6B------RAMP CONDUCTANCE ACROSS HORIZONTAL CELL FACE WHEN -C LAKE STAGE AND GROUNDWATER HEAD NEAR LAKEBED. - BOTLKUP = BOTLK + SURFDPTH - BOTLKDN = BOTLK - CONDMX = CONDUC - HH = H - IF ( HH.LT.BOTLKDN ) THEN - HH = BOTLKDN - INOFLO = 1 - ENDIF - IF(SURFDPTH.GT.CLOSEZERO) THEN - RAMPGW = CONDMX-(CONDMX/SURFDPTH)* - + (BOTLKUP-HH) - IF ( RAMPGW-CONDMX.GT.0.0D0 ) RAMPGW = CONDMX - IF ( RAMPGW.LE.0.0D0 ) RAMPGW = 0.0D0 - RAMPSTGO = CONDMX-(CONDMX/SURFDPTH)* - + (BOTLKUP-STGOLD(LAKE)) - IF ( RAMPSTGO-CONDMX.GT.0.0D0 ) RAMPSTGO = CONDMX - IF ( RAMPSTGO.LE.0.0D0 ) RAMPSTGO = 0.0D0 - RAMPSTGN = CONDMX-(CONDMX/SURFDPTH)* - + (BOTLKUP-STGNEW(LAKE)) - IF ( RAMPSTGN-CONDMX.GT.0.0D0 ) RAMPSTGN = CONDMX - IF ( RAMPSTGN.LE.0.0D0 ) RAMPSTGN = 0.0D0 - ELSE - RAMPGW=CONDMX - RAMPSTGO=CONDMX - RAMPSTGN=CONDMX - ENDIF - IF( HH-BOTLKDN.GT.CLOSEZERO ) THEN - HTEMP = HH - ELSE - HTEMP=BOTLKDN - ENDIF -C -C6C------COMPUTE LAKE SEEPAGE FOR STGOLD USING FLOBO1. -C USE UPSTREAM WEIGHTING - IF ( HH.LT.STGOLD(LAKE) ) THEN - RAMPUP = RAMPSTGO - ELSE - RAMPUP = RAMPGW - ENDIF - CONDUC = RAMPUP - IF( STGOLD(LAKE)-BOTLKDN.GT.CLOSEZERO ) THEN - FLOBO1=CONDUC*(STGOLD(LAKE)-HTEMP) - ELSE - FLOBO1=CONDUC*(BOTLKDN-HTEMP) - ENDIF - IF ( IUNITUZF.GT.0 ) THEN - IF ( IUZFBND(IC,IR).GT.0 )THEN - IF (HH-BOTLK.LT.-0.5*SURFDPTH) THEN - IF ( VKS(IC,IR)*AREA-FLOBO1.LT.CLOSEZERO ) - + THEN - FLOBO1 = VKS(IC,IR)*AREA - ENDIF - ENDIF - ENDIF - ENDIF -C -C6D------COMPUTE LAKE SEEPAGE FOR STGNEW USING FLOBO2 AND FLOBO3. -C USE UPSTREAM WEIGHTING - IF ( HH.LT.STGNEW(LAKE) ) THEN - RAMPUP = RAMPSTGN - ELSE - RAMPUP = RAMPGW - ENDIF - CONDUC = RAMPUP - IF( STGNEW(LAKE)-BOTLKDN.GT.CLOSEZERO ) THEN - FLOBO2 = CONDUC*(STGNEW(LAKE)-HTEMP) - FLOBO3 = CONDUC*(STGNEW(LAKE)+DLSTG-HTEMP) - ELSE - FLOBO2 = CONDUC*(BOTLKDN-HTEMP) - FLOBO3 = CONDUC*(BOTLKDN+DLSTG-HTEMP) - ENDIF - IF ( IUNITUZF.GT.0 ) THEN - IF ( IUZFBND(IC,IR).GT.0 )THEN - IF ( HH-BOTLK.LT.-0.5*SURFDPTH ) THEN - IF ( VKS(IC,IR)*AREA-FLOBO2.LT.CLOSEZERO ) - + THEN - FLOBO2 = VKS(IC,IR)*AREA - FLOBO3 = VKS(IC,IR)*AREA - ENDIF - ENDIF - ENDIF - ENDIF -C -C6E------COMPUTE LAKE SEEPAGE (FLOBOT) AS A FRACTION OF FLOBO1 AND -C FLOB02 AND FLOBO3 AS A FRACTION OF FLOBO1 AND FLOBO3. - FLOBOT = THET1*FLOBO2 + (1.0D0-THET1)*FLOBO1 - FLOBO3 = THET1*FLOBO3 + (1.0D0-THET1)*FLOBO1 -! CONDUC = THET1*RAMPSTGN + (1.0D0-THET1)*RAMPSTGO - IF ( IUNITUZF.GT.0 ) THEN - IF ( IUZFBND(IC,IR).GT.0 )THEN - IF ( HH-BOTLK.LT.-0.5*SURFDPTH ) THEN - IF ( FLOBOT/AREA.GT.VKS(IC,IR) ) THEN - FLOBOT = VKS(IC,IR)*AREA - FLOBO3 = FLOTOUZF - ENDIF - FLOTOUZF = FLOBOT - FLOBOT = 0.0D0 - CONDUC = FLOTOUZF/(STGNEW(LAKE)-BOTLK) - FINF(IC,IR)=FLOTOUZF/AREA - ENDIF - ENDIF - ENDIF -C -C7------COMPUTE SEEPAGE INTO OR OUT OF A LAKE WALL NODE -C WHEN ITYPE=1 OR 2. - ELSEIF ( ITYPE.EQ.1.OR.ITYPE.EQ.2 ) THEN - IF( IBOUND(IC,IR,IL).GT.0 ) THEN - HD = H - IF( H.GT.BOTM(IC,IR,LBOTM(IL)-1) ) - 1 HD = BOTM(IC,IR,LBOTM(IL)-1) -C -C7B------CONDUCTANCE ACROSS VERTICAL CELL FACE DEPENDENT ON -C SATURATED THICKNESS. - IF ( LAYHDT(il).GT.0 ) THEN - THCK = HD - BOTCL - ELSE - THCK = BOTM(IC,IR,LBOTM(IL)-1) - BOTCL - ENDIF - IF( THCK.LE.0.0 ) THCK = 0.0 - CONDUC = CONDUC*THCK - IF ( H.LT.BOTM(IC,IR,LBOTM(IL)) ) - + H = BOTM(IC,IR,LBOTM(IL)) -C -C7C------COMPUTE LAKE SEEPAGE FOR STGOLD USING FLOBO1. - IF( STGOLD(LAKE)-BOTCL.GT.CLOSEZERO ) THEN - FLOBO1 = CONDUC*(STGOLD(LAKE)-H) - ELSEIF ( H-BOTCL.GT.CLOSEZERO ) THEN - FLOBO1 = CONDUC*(BOTCL-H) - ENDIF -C -C7D------COMPUTE LAKE SEEPAGE FOR STGNEW USING FLOBO2 AND FLOBO3. - IF( STGNEW(LAKE)-BOTCL.GT.CLOSEZERO )THEN - FLOBO3 = CONDUC*(STGNEW(LAKE)+DLSTG-H) - FLOBO2 = CONDUC*(STGNEW(LAKE)-H) - ELSEIF ( H-BOTCL.GT.CLOSEZERO ) THEN - FLOBO3 = CONDUC*(BOTCL+DLSTG-H) - FLOBO2 = CONDUC*(BOTCL-H) - ELSEIF ( STGNEW(LAKE)+DLSTG.GE.BOTCL )THEN - FLOBO3 = CONDUC*(STGNEW(LAKE)+DLSTG-H) - ENDIF -C -C7E------COMPUTE LAKE SEEPAGE (FLOBOT) AS A FRACTION OF FLOBO1 AND -C FLOB02 AND FLOBO3 AS A FRACTION OF FLOBO1 AND FLOBO3. - FLOBOT = THET1*FLOBO2 + (1.0D0-THET1)*FLOBO1 - FLOBO3 = THET1*FLOBO3 + (1.0D0-THET1)*FLOBO1 - SUMCNN(LAKE) = SUMCNN(LAKE) + CONDUC - ENDIF - ENDIF -C -C8-------SEEPAGE RATES ADDED TO MATRIX AND RESIDUAL TERMS. -C8B------COMPUTE FLWITER AND FLWITER3 DURING FIRST LOOP THROUGH -C CALCULATIONS. NEGATIVE FLOBOT MEANS INTO LAKE - IF ( II==1 ) THEN - IF ( FLOBOT.LT.0.0D0 ) FLWITER(LAKE) = - + FLWITER(LAKE) - FLOBOT - IF ( FLOBO3.LT.0.0D0 ) FLWITER3(LAKE) = - + FLWITER3(LAKE) - FLOBO3 - ENDIF -C8C------COMPUTE FLWITER AND FLOWITER3 DURING SECOND LOOP THROUGH -C CALCULATIONS. - IF ( II==2 ) THEN - IF ( FLOBOT>=FLWITER(LAKE) ) THEN - IF ( FLOBOT.GT.CLOSEZERO ) THEN -! FLOBO2=FLWITER(LAKE) -! FLOBOT = THET1*FLOBO2 + (1.0D0-THET1)*FLOBO1 - FLOBOT = FLWITER(LAKE) - FLWITER(LAKE) = 0.0 - INOFLO = 1 - ENDIF - ELSEIF ( FLOBOT.GT.CLOSEZERO )THEN - FLWITER(LAKE) = FLWITER(LAKE) - FLOBOT - ENDIF - IF ( FLOTOUZF>=FLWITER(LAKE) ) THEN - IF ( FLOTOUZF.GT.CLOSEZERO ) THEN - FLOTOUZF=FLWITER(LAKE) - ! FLOTOUZF = THET1*FLOTOUZF + (1.0D0-THET1)*FLOBO1 - FLWITER(LAKE) = 0.0 - INOFLO = 1 - ENDIF - ELSEIF ( FLOTOUZF.GT.CLOSEZERO )THEN - FLWITER(LAKE) = FLWITER(LAKE) - FLOTOUZF - ENDIF - IF ( FLOBO3>=FLWITER3(LAKE) ) THEN - IF ( FLOBO3.GT.CLOSEZERO ) THEN - FLOBO3=FLWITER3(LAKE) - ! FLOBO3 = THET1*FLOBO3 + (1.0D0-THET1)*FLOBO1 - FLWITER3(LAKE) = 0.0 - INOFLO = 1 - ENDIF - ELSEIF ( FLOBO3.GT.CLOSEZERO )THEN - FLWITER3(LAKE) = FLWITER3(LAKE) - FLOBO3 - ENDIF - ENDIF -C -C6E------COMPUTE LAKE SEEPAGE (FLOBOT) AS A FRACTION OF FLOBO1 AND -C FLOB02 AND FLOBO3 AS A FRACTION OF FLOBO1 AND FLOBO3. - RETURN - END SUBROUTINE GET_FLOBOT -C - end module GwfLakSubs + module GwfLakSubs + + use GWFLAKMODULE, only: SGWF2LAK7PNT + use SimModule, only: store_warning, store_error + private + public :: GWF2LAK7AR, GWF2LAK7RP + + contains + + SUBROUTINE GWF2LAK7AR(IN,IUNITSFR,IUNITGWT,IUNITUZF,NSOL,IGRID) +C +C------USGS VERSION 7.1; JUNE 2006 GWF2LAK7AR; +C------UPDATED FOR MF-2005, FEBRUARY 6, 2012 +C ****************************************************************** +C INITIALIZE POINTER VARIABLES USED BY SFR1 TO SUPPORT LAKE3 AND +C GAGE PACKAGES AND THE GWT PROCESS +C ****************************************************************** +C + USE GWFLAKMODULE + USE GLOBAL, ONLY: IOUT, NCOL, NROW, NLAY, IFREFM, ITRSS, + + NODES + USE GWFSFRMODULE, ONLY: NSS + use utl7module, only: URDCOM, URWORD, U2DINT, U2DREL +C +C ****************************************************************** +C ALLOCATE ARRAY STORAGE FOR LAKES +C ****************************************************************** +C +C ------------------------------------------------------------------ +C SPECIFICATIONS: + CHARACTER (LEN=40):: CARD + CHARACTER*200 line + double precision :: r +C ------------------------------------------------------------------ +Crsr Allocate lake variables used by SFR even if lakes not active so that +C argument lists are defined + ALLOCATE (NLAKES, NLAKESAR,THETA,LAKUNIT) + allocate (NeedLakWaterMover) + NeedLakWaterMover = .false. + NLAKES = 0 + LAKUNIT = IN + NLAKESAR = 1 + THETA = 0.0 +C0--If LAK package is active + IF (IN.GT.0) THEN +Cdep added SURFDEPTH 3/3/2009 + ALLOCATE (ILKCB, NSSITR, SSCNCR, SURFDEPTH) + ALLOCATE (MXLKND, LKNODE, ICMX, NCLS, LWRT, NDV, NTRB) + ALLOCATE (IRDTAB) +C +C1------IDENTIFY PACKAGE AND INITIALIZE LKNODE. + WRITE(IOUT,1) IN + LKNODE=0 +Cdep initialize number of iterations and closure criteria to zero. + DUM = 0.0 + NSSITR = 0 + SSCNCR = 0.0 + SURFDEPTH = 0.0 +! + lloc = 1 + IRDTAB = 0 + NPP = 0 + MXVL = 0 +! Read item 1a + CALL URDCOM(In, IOUT, line) +! Check for alternate option to specifiy stage/vol/area tables. + CALL UPARLSTAL(IN,IOUT,LINE,NPP,MXVL) ! ERB - Pointless, since LAK does not support parameters + lloc = 1 + CALL URWORD(LINE,LLOC,ISTART,ISTOP,1,I,R,IOUT,IN) + IF(LINE(ISTART:ISTOP).EQ.'TABLEINPUT') THEN + IRDTAB = 1 + WRITE(IOUT,32) + 32 FORMAT(1X,I10,' Stage, volume and area relationship specified ', + + 'based on an external tabular input file') + ELSE + BACKSPACE IN + WRITE(IOUT,'(A)') ' Model grid will be used to develop ', + + ' volume and area relationship. ' + ENDIF +C +C2------READ NLAKES, ILKCB. +C +Cdep Revised input statement to read THETA,NSSITR,SSCNCR for +Cdep transient simulations when THETA is negative. + IF(IFREFM.EQ.0) THEN +! Read item 1b + READ(IN,'(2I10)')NLAKES,ILKCB +! Read item 2 and backspace + IF (ITRSS.LE.0) THEN + READ(IN,'(F10.2,I10,F10.2)') THETA,NSSITR,SSCNCR + IF (THETA.LT.0.0) BACKSPACE IN + ELSE + READ(IN,'(F10.2)') THETA + IF (THETA.LT.0.0) BACKSPACE IN + ENDIF + ELSE +! Read item 1b + READ(IN,*) NLAKES,ILKCB +! Read item 2 and backspace + IF (ITRSS.LE.0) THEN + READ(IN,*) THETA,NSSITR,SSCNCR + IF(THETA.LT.0.0) BACKSPACE IN + ELSE + READ(IN,*) THETA + IF(THETA.LT.0.0) BACKSPACE IN + ENDIF + ENDIF + +Cdep Set default values for number of iterations and closure criteria +Cdep for transient simulations when using original version of +Cdep LAKE Package. + IF(THETA.GE.0.0.AND.NSSITR.EQ.0) THEN + NSSITR=100 + SSCNCR=1.0E-05 + ELSEIF(THETA.LT.0.0)THEN + THETA=ABS(THETA) +! Read item 2 + IF(IFREFM.EQ.0) THEN +Cdep fixed format can't read in exponent notation +!rsr, old data sets may not have SURFDEPTH, may need to trap this for some compilers + READ (IN, '(A)') CARD + NUMCHAR = LEN(TRIM(CARD)) + IF ( NUMCHAR>30 ) THEN + READ(CARD,'(F10.2,I10,2F10.5)') DUM,NSSITR,SSCNCR, + + SURFDEPTH + ELSE + READ(CARD,'(F10.2,I10,F10.5)') DUM,NSSITR,SSCNCR + ENDIF + ELSE + READ(IN,*,IOSTAT=IOS) DUM,NSSITR,SSCNCR,SURFDEPTH + IF ( IOS.NE.0 ) SURFDEPTH = 0.0 + ENDIF + ENDIF +Cdep Add check to reset THETA when > 1 or < 0.5. + IF(THETA.GT.1.0) THEN + THETA = 1.0 + ELSEIF(THETA.LT.0.5)THEN + THETA = 0.0 + ENDIF + ENDIF ! goes with IF at comment C0 +C +C +C SET NLAKES ARRAY VARIABLE TO NLAKES IF NLAKES GREATER THAN 0. + IF (NLAKES.GT.0) NLAKESAR = NLAKES + ALLOCATE (VOL(NLAKESAR), STGOLD(NLAKESAR), STGNEW(NLAKESAR)) + ALLOCATE(STGOLD2(NLAKESAR)) + ALLOCATE (VOLOLDD(NLAKESAR)) +! ALLOCATE (VOLOLDD(NLAKESAR), VOLOLD(NLAKES), VOLINIT(NLAKES)) + ALLOCATE (STGITER(NLAKESAR)) + ALLOCATE (LAKSEEP(NCOL,NROW)) + STGNEW = 0.0D0 + STGOLD = 0.0D0 + STGOLD2 = 0.0D0 + STGITER = 0.0D0 + VOLOLDD = 0.0D0 + LAKSEEP = 0.0 +Cdep initialized VOLOLD and VOLINIT 6/4/2009 (VOLOLD is single precision) +! VOLOLD = 0.0 +! VOLINIT = 0.0 + VOL = 0.0 + CALL SGWF2LAK7PSV1(IGRID) + IF (IN.LT.1) RETURN +C +C Lakes are active + ALLOCATE (STAGES(NLAKESAR), CLAKE(NLAKESAR,NSOL)) + STAGES = 0.0 + CLAKE = 0.0 +C Budget variables for GSFLOW + ALLOCATE (TOTGWIN_LAK,TOTGWOT_LAK,TOTDELSTOR_LAK,TOTSTOR_LAK) + ALLOCATE (TOTEVAP_LAK,TOTPPT_LAK,TOTRUNF_LAK,TOTWTHDRW_LAK) + ALLOCATE (TOTSURFIN_LAK,TOTSURFOT_LAK) + TOTGWIN_LAK = 0.0 + TOTGWOT_LAK = 0.0 + TOTDELSTOR_LAK = 0.0 + TOTSTOR_LAK = 0.0 + TOTEVAP_LAK = 0.0 + TOTPPT_LAK = 0.0 + TOTRUNF_LAK = 0.0 + TOTWTHDRW_LAK = 0.0 + TOTSURFIN_LAK = 0.0 + TOTSURFOT_LAK = 0.0 +C +C VALUE OF MXLKND (NUMBER OF LAKE-AQUIFER INTERFACES) IS AN ESTIMATE. +C TO SAVE MEMORY, REDUCE ITS SIZE IF APPROPRIATE. +C IF MXLKND TOO SMALL, ERROR MESSAGE WILL BE PRINTED. + MXLKND=NCOL*NROW*NLAY/2 + IF (NLAKES.LT.1) THEN + WRITE(IOUT,2) + IN=0 + NLAKES = 0 + ELSE + WRITE(IOUT,5) MXLKND,NLAKES + IF (ILKCB.GT.0) WRITE(IOUT,7) ILKCB + IF (ILKCB.LE.0) WRITE(IOUT,9) +Cdep Write THETA, NSSITR, SSCNCR + IF (ITRSS.GT.0) THEN + WRITE(IOUT,22) THETA + WRITE(IOUT,10) NSSITR, SSCNCR + ELSE + WRITE(IOUT,11) THETA, NSSITR, SSCNCR + ENDIF +Cdep Changed default values for NSSITR and SSCNCR and revised +Cdep print statements using format statement 10. +Cdep IF(ITRSS.LE.0.AND.NSSITR.EQ.0) NSSITR = 50 +Cdep IF(ITRSS.LE.0.AND.SSCNCR.EQ.0.0) SSCNCR = 0.01 +Cdep IF(ITRSS.EQ.0) WRITE(IOUT,23) NSSITR, SSCNCR +Cdep IF(ITRSS.LT.0) WRITE(IOUT,24) NSSITR, SSCNCR +C-lfk 1 FORMAT(/1X,'LAK7 -- LAKE PACKAGE, VERSION 7, 2/06/2012', +1 FORMAT(/1X,'LAK7 -- LAKE PACKAGE, VERSION 7, 1/07/2013', + 1' INPUT READ FROM UNIT',I3) +2 FORMAT(1X,' NUMBER OF LAKES=0, ', + 1 ' SO LAKE PACKAGE IS BEING TURNED OFF') +5 FORMAT(1X,'SPACE ALLOCATION FOR',I7,' GRID CELL FACES ADJACENT TO + 1LAKES'/1X,'MAXIMUM NUMBER OF LAKES IS',I3, ' FOR THIS SIMULATION') +7 FORMAT(1X,'CELL-BY-CELL FLOWS WILL BE RECORDED ON UNIT',I5) +9 FORMAT(1X,'CELL-BY-CELL SEEPAGES WILL NOT BE PRINTED OR SAVED') +Cdep added format statement when starting with transient simulation + 10 FORMAT(//1X,'LAKE PACKAGE HAS BEEN MODIFIED TO ITERATIVELY ', + 1 'SOLVE FOR LAKE STAGE DURING TRANSIENT STRESS PERIODS:',/1X, + 2 'MAXIMUM NUMBER OF ITERATIONS (NSSITR) = ',I5,/1X, + 3 'CLOSURE CRITERIA FOR LAKE STAGE (SSCNCR) = ',1PE12.6,/1X, + 4 'DEFAULT VALUES FOR TRANSIENT ONLY SIMULATIONS ARE: ', + 5 'NSSITR = 100 AND SSCNCR = 0.0001',/1X,'VALUES OTHER THAN ', + 6 'DEFAULT CAN BE READ BY SPECIFYING A THETA LESS THAN ZERO ', + 7 'THEN ADDING NSSITR AND SSCNCR PER ORIGINAL INSTRUCTIONS.',/1X, + 8 'NEGATIVE THETA MUST BE LESS THAN ZERO BUT NOT MORE THAN ', + 9 'ONE. THETA IS CONVERTED TO A POSITIVE VALUE.',/1X, + * 'MINIMUM AND MAXIMUM LAKE STAGES FOR TRANSIENT ', + * 'SIMULATIONS ARE SET TO BOTTOM AND TOP ELEVATIONS USED TO ', + * 'COMPUTE LAKE VOLUME, RESPECTIVELY.',//) +Cdep added format statement for steady state only simulations. + 11 FORMAT(//1X,'NEWTON ITERATION METHOD FOR COMPUTING LAKE STAGE ', + 1 'DURING STEADY-STATE STRESS PERIODS HAS BEEN MODIFIED:',/1X, + 2 'SPECIFIED THETA OF ',F6.3,' WILL BE AUTOMATICALLY CHANGED TO ', + 3 '1.0 FOR ALL STEADY STATE STRESS PERIODS.',/1X, + 4 'MAXIMUM NUMBER OF STEADY-STATE ITERATIONS (NSSITR) = ',I5,/1X, + 5 'CLOSURE CRITERIA FOR STEADY-STATE LAKE STAGE (SSCNCR) = ', + 6 1PE12.6,//) +Cdep revised print statement to note that time weighting of theta can +Cdep vary only between 0.5 and 1 for transient simulations +Cdep 22 FORMAT(/1X,'THETA = ',F10.2,' METHOD FOR UPDATING LAKE STAGES IN +Cdep 1ITERATIONS OF THE SOLUTION FOR AQUIFER HEADS.'/20X,'0.0 IS EXPLICI +Cdep 2T, 0.5 IS CENTERED, AND 1.0 IS FULLY IMPLICIT.') + 22 FORMAT(/1X,'THETA = ',F6.3,/1X,'THETA IS THE TIME WEIGHTING ', + *'FACTOR FOR COMPUTING LAKE STAGE DURING TRANSIENT MODFLOW ', + *'TIME STEPS AND ITS DEFINITION HAS BEEN MODIFIED.',/1X,'A THETA ', + *'OF LESS THEN 0.5 IS AUTOMATICALLY SET TO 0 AND LAKE STAGE IS ', + *'EQUAL TO THE STAGE AT THE END OF THE PREVIOUS TIME STEP. ',/1X, + *'TRANSIENT SIMULATIONS OF LAKE STAGE WITH THE CURRENT TIME STEP ', + *'REQUIRES A THETA BETWEEN 0.5 AND 1.0. ',/1X,'VALUES GREATER ', + *'THAN 1.0 ARE AUTOMATICALLY RESET TO 1.0 AND VALUES LESS ', + *'THAN 0.5 ARE RESET TO 0.0.',/1X,'A THETA OF 0.5 REPRESENTS THE ', + *'AVERAGE LAKE STAGE DURING A TIME STEP.',/1X,'A THETA OF 1.0 ', + *'REPRESENTS THE LAKE STAGE AT THE END OF THE TIME STEP.',//) +Cdep 23 FORMAT(/1X,'STEADY-STATE SOLUTION FOR LAKES.' +Cdep 2/1X,'MAXIMUM NUMBER OF ITERATIONS = ',I4,3X, +Cdep 1'CONVERGENCE CRITERION = ',1PE9.2) +Cdep 24 FORMAT(/1X,'COMBINED STEADY-STATE/TRANSIENT SOLUTION FOR LAKES.' +Cdep 2/1X,'MAXIMUM NUMBER OF ITERATIONS = ',I4,3X, +Cdep 1'CONVERGENCE CRITERION = ',1PE9.2) + + ALLOCATE (ILAKE(5,MXLKND), BEDLAK(MXLKND), CNDFCT(MXLKND)) + ALLOCATE (PRCPLK(NLAKES), EVAPLK(NLAKES), WTHDRW(NLAKES)) + ALLOCATE (RNF(NLAKES), CRNF(NLAKES,NSOL), CUMRNF(NLAKES)) + ALLOCATE (CUMUZF(NLAKES)) + ALLOCATE (ISUB(NLAKES,NLAKES), SILLVT(NLAKES,NLAKES)) + ALLOCATE (IRK(2,NLAKES)) + ALLOCATE (CUMPPT(NLAKES), CUMEVP(NLAKES), CUMGWI(NLAKES)) + ALLOCATE (CUMGWO(NLAKES), CUMSWI(NLAKES), CUMSWO(NLAKES)) + ALLOCATE (CUMWDR(NLAKES), CUMFLX(NLAKES)) + ALLOCATE (CAUG(NLAKES,NSOL), CPPT(NLAKES,NSOL)) + ALLOCATE (CLAKINIT(NLAKESAR,NSOL)) + ALLOCATE (ICS(NLAKES),BOTTMS(NLAKES), BGAREA(NLAKES)) + ALLOCATE (SSMN(NLAKES), SSMX(NLAKES)) + ALLOCATE (LKARR1(NCOL,NROW,NLAY), BDLKN1(NCOL,NROW,NLAY)) + ALLOCATE (EVAP(NLAKES), PRECIP(NLAKES), SEEP(NLAKES), + + SEEP3(NLAKES),EVAP3(NLAKES), PRECIP3(NLAKES)) + ALLOCATE (SEEPUZ(NLAKES)) + ALLOCATE (FLWITER(NLAKES),FLWITER3(NLAKES)) + ALLOCATE (SURFA(NLAKES), SURFIN(NLAKES), SURFOT(NLAKES)) + ALLOCATE (SUMCNN(NLAKES), SUMCHN(NLAKES)) + ALLOCATE (NCNCVR(NLAKES), LIMERR(NLAKES), DSRFOT(NLAKES)) +Cdep Allocate arrays that track lake budgets for dry lakes + ALLOCATE (EVAPO(NLAKES),WITHDRW(NLAKES),FLWIN(NLAKES)) + ALLOCATE (GWRATELIM(NLAKES)) + EVAPO = 0.0 + WITHDRW = 0.0D0 + FLWIN = 0.0 + FLWITER = 0.0D0 + FLWITER3 = 0.0D0 + EVAP = 0.0D0 + PRECIP = 0.0D0 + EVAP3 = 0.0D0 + PRECIP3 = 0.0D0 + IF ( IRDTAB.GT.0 ) THEN + ALLOCATE(LAKTAB(NLAKES)) + ELSE + ALLOCATE(LAKTAB(1)) + ENDIF + LAKTAB = 0 +!rsr GWRATLIM= 0.0 +Cdep Allocate space for three arrays used in GAGE Package +C when Solute Transport is active + ALLOCATE (XLAKES(NLAKES,1), XLAKINIT(NLAKES,1)) + ALLOCATE (XLKOLD(NLAKES,1)) +crsr Allocate arrays for BD subroutine + ALLOCATE (LDRY(NODES), FLXINL(NLAKES)) + ALLOCATE (NCNT(NLAKES), NCNST(NLAKES)) + ALLOCATE (SVT(NLAKES), KSUB(NLAKES), STGADJ(NLAKES)) + ALLOCATE (MSUB(NLAKES,NLAKES), MSUB1(NLAKES)) + ALLOCATE (GWIN(NLAKES), GWOUT(NLAKES)) + ALLOCATE (DELH(NLAKES), TDELH(NLAKES)) +Cdep Allocate lake budget error arrays for BD subroutine 6/9/2009 + ALLOCATE (CUMVOL(NLAKES), CMLAKERR(NLAKES)) + ALLOCATE (CUMLKIN(NLAKES), CUMLKOUT(NLAKES)) + ALLOCATE (DELVOL(NLAKES), TSLAKERR(NLAKES)) +Cdep initialized VOLOLD and VOLINIT 6/4/2009 (VOLOLD is single precision) + ALLOCATE (VOLOLD(NLAKES), VOLINIT(NLAKES)) + VOLOLD = 0.0 + VOLINIT = 0.0 + ENDIF +Cdep ALLOCATE SPACE FOR CONNECTION WITH STREAMS + IF (IUNITSFR.LE.0) THEN + NSSAR = 1 + ELSE + NSSAR = NSS + ENDIF +Cdep ALLOCATE SPACE FOR FLOB ARRAY WHEN TRANSPORT ACTIVE. + IF (IUNITGWT.LE.0) THEN + MXLKAR = 1 + ELSE + MXLKAR = MXLKND + ENDIF +Cdep ALLOCATE SPACE FOR OVERLAND FLOW WHEN UNSATURATED FLOW ACTIVE. +! RGN Allocate NUZFAR to nlakes for all cases because of the GAG package 5/28/09 +! IF (IUNITUZF.LE.0) THEN +! NUZFAR = 1 +! ELSE + NUZFAR = NLAKESAR +! ENDIF + + !rsr, what if NLAKES < 1, sanity check + IF (NLAKES<1 ) THEN + print *, 'nlakes dimension problem in lak7', nlakes + stop + ENDIF + + ALLOCATE (ITRB(NLAKES,NSSAR), IDIV(NLAKES,NSSAR)) + ALLOCATE (FLOB(MXLKAR)) + ALLOCATE (OVRLNDRNF(NUZFAR), CUMLNDRNF(NUZFAR)) +Cdep ALLOCATE SPACE FOR DEPTHTABLE, AREATABLE, AND VOLUMETABLE + ALLOCATE (DEPTHTABLE(151,NLAKES), AREATABLE(151,NLAKES)) + ALLOCATE (VOLUMETABLE(151,NLAKES)) + ITRB = 0 + IDIV = 0 + FLOB = 0.0 + OVRLNDRNF = 0.0 + CUMLNDRNF = 0.0 + CUMUZF = 0.0 + DEPTHTABLE = 0.0D0 + AREATABLE = 0.0D0 + VOLUMETABLE = 0.0D0 +Cdep initialized lake budget error arrays 6/9/2009 + CUMVOL = 0.0 + DELVOL = 0.0 + CMLAKERR = 0.0 + TSLAKERR = 0.0 + CUMLKOUT = 0.0 + CUMLKIN = 0.0 +C-----SAVE POINTERS FOR GRID AND RETURN + CALL SGWF2LAK7PSV(IGRID) +C +C11-----RETURN. + RETURN + END SUBROUTINE GWF2LAK7AR +C + SUBROUTINE GWF2LAK7RP(IN,IUNITBCF,IUNITGWT,IUNITLPF,IUNITHUF, + + IUNITSFR,IUNITUZF,IUNITUPW,KKPER,NSOL, + + IOUTS,IGRID) +C +C------USGS VERSION 7.1; JUNE 2006 GWF2LAK7RP +C REVISED FEBRUARY 6, 2012 +C ****************************************************************** +C READ INPUT DATA FOR THE LAKE PACKAGE. +C ------------------------------------------------------------------ +C SPECIFICATIONS: +C ------------------------------------------------------------------ + USE GWFLAKMODULE + USE GLOBAL, ONLY: IOUT, NCOL, NROW, NLAY, IFREFM, IBOUND, + + LBOTM, BOTM, DELR, DELC, ISSFLG + use SimModule, only: ustop + use utl7module, only: U2DINT, U2DREL +C USE GWFSFRMODULE, ONLY: NSS +C ------------------------------------------------------------------ +C FUNCTIONS +C ------------------------------------------------------------------ +!* DOUBLE PRECISION VOLTERP +!* EXTERNAL VOLTERP +C ------------------------------------------------------------------ + CHARACTER*24 ANAME(2) +! CHARACTER*30 LFRMAT +!dep added STGINIT as double precision + DOUBLE PRECISION STGINIT + logical, save :: warned = .false. + character(len=200) :: warning + DATA ANAME(1)/' LAKE ID ARRAY'/ + DATA ANAME(2)/' LAKEBED LEAKANCE ARRAY'/ +C +C ------------------------------------------------------------------ +C------SET POINTERS FOR THE CURRENT GRID. + CALL SGWF2LAK7PNT(IGRID) +C +C1A-----IF MXLKND IS LESS THAN 1, THEN LAKE IS INACTIVE. RETURN. + IF(MXLKND.LT.1) RETURN +C +C1A1----READ INITIAL CONDITIONS FOR ALL LAKES (ONLY READ ONCE) + ISS = ISSFLG(KKPER) + IF (KKPER.EQ.1) THEN + WRITE (IOUT,19) + IF(ISS.NE.0) WRITE (IOUT,20) + IF(ISS.EQ.0) WRITE (IOUT,820) +! Read Item 3 + IF (IUNITGWT.EQ.0) THEN + DO 30 LM=1,NLAKES + IF (IFREFM.EQ.0) THEN + IF ( IRDTAB.GT.0 ) THEN + IF(ISS.NE.0) READ (IN,'(3F10.4,I5)') STAGES(LM), + 1 SSMN(LM),SSMX(LM),LAKTAB(LM) + IF(ISS.EQ.0) READ (IN,'(F10.4,I5)') STAGES(LM), + 2 LAKTAB(LM) + ELSE + IF(ISS.NE.0) READ (IN,'(3F10.4)') STAGES(LM), + 1 SSMN(LM),SSMX(LM) + IF(ISS.EQ.0) READ (IN,'(F10.4)') STAGES(LM) + ENDIF + ELSE + IF ( IRDTAB.GT.0 ) THEN + IF(ISS.NE.0) READ (IN,*)STAGES(LM),SSMN(LM),SSMX(LM), + 1 LAKTAB(LM) + IF(ISS.EQ.0) READ (IN,*) STAGES(LM),LAKTAB(LM) + ELSE + IF(ISS.NE.0) READ (IN,*) STAGES(LM),SSMN(LM),SSMX(LM) + IF(ISS.EQ.0) READ (IN,*) STAGES(LM) + ENDIF + ENDIF + IF(ISS.NE.0) WRITE (IOUT,22) LM,STAGES(LM),SSMN(LM),SSMX(LM) + IF(ISS.EQ.0) WRITE (IOUT,22) LM,STAGES(LM) + 30 CONTINUE + ELSE + WRITE (IOUTS,21) NSOL +! WRITE (LFRMAT,23) NSOL !LFRMAT is not set + DO 35 LM=1,NLAKES + IF (IFREFM.EQ.0) THEN + IF ( IRDTAB.GT.0 ) THEN + IF(ISS.NE.0) READ(IN,'(100F10.4)') STAGES(LM), + 1 SSMN(LM),SSMX(LM),(CLAKE(LM,ISOL),ISOL=1,NSOL), + 2 LAKTAB(LM) + IF(ISS.EQ.0) READ (IN,'(100F10.4)') STAGES(LM), + 1 (CLAKE(LM,ISOL),ISOL=1,NSOL),LAKTAB(LM) + ELSE + IF(ISS.NE.0) READ(IN,'(100F10.4)') STAGES(LM), + 1 SSMN(LM),SSMX(LM),(CLAKE(LM,ISOL),ISOL=1,NSOL) + IF(ISS.EQ.0) READ (IN,'(100F10.4)') STAGES(LM), + 1 (CLAKE(LM,ISOL),ISOL=1,NSOL) + ENDIF + ELSE + IF ( IRDTAB.GT.0 ) THEN + IF(ISS.NE.0) READ (IN,*) STAGES(LM),SSMN(LM), + 1 SSMX(LM),(CLAKE(LM,ISOL),ISOL=1,NSOL), + 2 LAKTAB(LM) + IF(ISS.EQ.0) READ (IN,*) STAGES(LM), + 1 (CLAKE(LM,ISOL),ISOL=1,NSOL),LAKTAB(LM) + ELSE + IF(ISS.NE.0) READ (IN,*) STAGES(LM),SSMN(LM), + 1 SSMX(LM),(CLAKE(LM,ISOL),ISOL=1,NSOL) + IF(ISS.EQ.0) READ (IN,*) STAGES(LM), + 1 (CLAKE(LM,ISOL),ISOL=1,NSOL) + ENDIF + ENDIF + IF(ISS.NE.0) WRITE (IOUT,22) LM,STAGES(LM),SSMN(LM),SSMX(LM) + IF(ISS.EQ.0) WRITE (IOUT,22) LM,STAGES(LM) + 35 WRITE (IOUTS,*) LM,(CLAKE(LM,ISOL),ISOL=1,NSOL) +cgage +C CLAKINIT=CLAKE + ENDIF + ENDIF +C + WRITE (IOUT,'(/)') + WRITE(IOUT,822) + 19 FORMAT(//1X,'LAKE PACKAGE ACTIVE: CALCULATED LAKE STAGE FOR EACH + 1TIME STEP WILL BE STORED IN HNEW ARRAY.') + 20 FORMAT(///1X,'INITIAL LAKE STAGE: LAKE STAGE SS MIN SS M + 1AX'/) + 21 FORMAT (//1X,'INITIAL LAKE CONCENTRATIONS: LAKE CONCENTRATION ( + 1NSOL =',I3,')'/) + 22 FORMAT (22X,I3,3F10.3) + 23 FORMAT ('(31X,I3,3X,1P',I3,'(E12.3))') + 820 FORMAT (/1X,'INITIAL LAKE STAGE: LAKE STAGE'/) + 822 FORMAT(//1X,'If any subsequent steady-state stress periods, min. a + 1nd max. stages for each lake will be read in Record 9a.'//) +C +! RGN 9/25/12 moved this to read lake bathymetry before stress period information. + IF ( KKPER==1 .AND. IRDTAB.GT.0 ) THEN + DO L1=1,NLAKES + WRITE(IOUT,1399) L1 + iunit = LAKTAB(L1) + 1399 FORMAT(//1X,'STAGE/VOLUME RELATION FOR LAKE',I3//6X,'STAGE', + 1 8X,'VOLUME',8X,'AREA'/) + DO INC=1,151 + READ(iunit,*) DEPTHTABLE(INC,L1), VOLUMETABLE(INC,L1), + + AREATABLE(INC,L1) + WRITE(IOUT,1315) DEPTHTABLE(INC,L1), VOLUMETABLE(INC,L1), + + AREATABLE(INC,L1) + ENDDO + ENDDO + ENDIF +C1B-----READ ITMP (FLAG TO REUSE LAKE-GEOMETRY DATA). +! Read Item 4 + IF(IFREFM.EQ.0) THEN + READ(IN,'(3I10)') ITMP, ITMP1, LWRT + ELSE + READ(IN,*) ITMP, ITMP1, LWRT + ENDIF +C +C2A-----IF ITMP < 0 THEN REUSE LAKE CONFIGURATION DATA FROM LAST STRESS +C PERIOD. + IF(ITMP.GE.0) GO TO 50 + WRITE (IOUT,'(/)') + WRITE(IOUT,2) + 2 FORMAT(1H ,'REUSING LAKE CONFIGURATION DATA FROM LAST STRESS PERIO + 1D'/) + GO TO 800 +C +C4------IF THERE ARE NO LAKE NODES THEN RETURN. + 50 LKNODE = 0 + IF(ITMP.EQ.0) GOTO 900 + if (KKPER > 1 .and. .not. warned) then + ! write warning about changing lakes + 55 format('In LAK input, ITMP > 0 for stress period ',i0, + & '. WARNING: LAK8 does not support changing lake configuration', + & ' or leakance during simulation.') + write(warning,55)kkper + call store_warning(warning) + warned = .true. + endif +C +C INITIALIZE BGAREA + DO 60 LK=1,NLAKES + BGAREA(LK)=0.0 + 60 CONTINUE +C +C5------READ INTEGER ARRAYS THAT DEFINE THE POSITIONS OF ALL LAKES IN +C5A EACH MODEL GRID LAYER. THEN READ ARRAYS OF LAKEBED CONDUCTANCES +C5B IN EACH LAYER. +C +C READ ARRAY OF LAKE ID'S, LAYER BY LAYER +C REVISED 11/30/2005 DEP +! Read item 5 + DO 125 K=1,NLAY + KK = K + CALL U2DINT(LKARR1(:,:,KK),ANAME(1),NROW,NCOL,KK,IN,IOUT) + 125 CONTINUE +C +C CHECK THAT ALL ENTRIES ARE VALID LAKE ID NUMBERS OR ZERO +C + DO 130 K=1,NLAY + DO 130 I=1,NCOL + DO 130 J=1,NROW + IF(LKARR1(I,J,K).GT.0.AND.LKARR1(I,J,K).LE.NLAKES) GO TO 130 + LKARR1(I,J,K)=0 + 130 CONTINUE +C +C CHECK IF LAKE CELLS HAVE VALUES OF IBOUND=0; WARN IF INCONSISTENT +C + WRITE (IOUT,'(/)') + DO 132 K=1,NLAY + DO 132 I=1,NCOL + DO 132 J=1,NROW + IF(LKARR1(I,J,K).GT.0.AND.IBOUND(I,J,K).NE.0) THEN + WRITE (IOUT,232) IBOUND(I,J,K),LKARR1(I,J,K),I,J,K + 232 FORMAT (7X,'*** WARNING: IBOUND = ',I2, + 1 ' & LKARR = ',I2,' at CELL I=',I3, + 2 ', J=',I3,', K=',I3,' ***') + ENDIF + 132 CONTINUE +C +C READ ARRAY OF BED LEAKANCES, LAYER BY LAYER +Cdep REVISED 11/30/2005 + WRITE (IOUT,'(/)') +! Read item 6 + DO 135 K=1,NLAY + KK = K + CALL U2DREL(BDLKN1(:,:,KK),ANAME(2),NROW,NCOL,KK,IN,IOUT) + 135 CONTINUE +C + WRITE(IOUT,36) + WRITE(IOUT,4) +36 FORMAT(/7X,'LOCATIONS, LAKE #, INTERFACE TYPE FOR GRID CELLS', + 1 ' ADJACENT TO LAKES:',5X,/ + 3 5X,71('-')) +4 FORMAT(5X,'LAYER #',4X,'ROW #',4X,'COLUMN #',3X,'LAKE #', + 1 2X,'INTERFACE TYPE',2X,'LAKEBED LEAKANCE') +C +C IDENTIFY LAKE BORDER CELLS, ASSIGN CELL TYPE ID'S, COMPUTE AND +C ASSIGN LAKE-AQUIFER INTERFACE CONDUCTANCES. +C + M = 0 + DO 180 I=1,NCOL + DO 180 J=1,NROW + K = 1 + IF(LKARR1(I,J,K).EQ.0) GO TO 150 + IF(NLAY.EQ.1) GO TO 145 +C Keep searching in vertical direction until non-lake cell is found, +C and define interface there ("K" for interface is layer below +C bottom of lake) + DO 140 K=2,NLAY + IF(LKARR1(I,J,K).EQ.0) GO TO 145 + 140 CONTINUE +C Make sure that K=NLAY if lake extends to bottom cell of grid: + K=NLAY +C GO TO 145 +C +C VERTICAL LAKEBED INTERFACE (TYPE 0) DETECTED +C + 145 M = M + 1 + IF(M.LE.MXLKND) GO TO 147 + WRITE(IOUT,149) I,J,K + 149 FORMAT(/1X,'MAXIMUM NUMBER OF GRID CELLS ADJACENT TO LAKES HAS BEE + 1N EXCEEDED WITH CELL ',3I5,' REDEFINE VARIABLE MXLKND TO A LARGER + 2 VALUE IN MODULE GWF2LAK7AR') + CALL USTOP(' ') + 147 ILAKE(1,M) = K + ILAKE(2,M) = J + ILAKE(3,M) = I +Cdep changed if statement August 24, 2009 +Cdep IF(K.GT.1.AND.LKARR1(I,J,K).EQ.0) LID = LKARR1(I,J,K-1) +Cdep IF(LKARR1(I,J,K).NE.0) LID = LKARR1(I,J,K) + IF(K.GT.1) THEN + IF(LKARR1(I,J,K).EQ.0) THEN + LID = LKARR1(I,J,K-1) + ELSE + LID = LKARR1(I,J,K) + ENDIF + ELSEIF (K.EQ.1) THEN + IF(LKARR1(I,J,K).EQ.0) THEN + LID = 0 + ELSE + LID = LKARR1(I,J,K) + ENDIF + ENDIF + ILAKE(4,M) = LID + ILAKE(5,M) = 6 + IF ( K.GT.1 ) THEN !RGN 5/21/12 added IF test + BEDLAK(M) = BDLKN1(I,J,K-1) + ELSE !RGN + BEDLAK(M) = BDLKN1(I,J,K) !RGN + ENDIF !RGN + IF(K.EQ.NLAY.AND.LKARR1(I,J,K).NE.0) BEDLAK(M) = 0.0 + BGAREA(LID) = BGAREA(LID) + DELC(J)*DELR(I) +C-LFK-JAN. 2013 +c-lfk WRITE(IOUT,5) (ILAKE(I1,M),I1=1,5), BEDLAK(M) + WRITE(IOUT,6) (ILAKE(I1,M),I1=1,5), BEDLAK(M) +5 FORMAT(5I10,10X,F10.5) +6 FORMAT(5I10,12X,1PE10.3) +C-LFK + IF(LKARR1(I,J,K).NE.0) GO TO 180 +C +C SEARCH FOR CELL(S) ADJACENT TO LAKE +C + 150 K2 = K + DO 175 K1=K2,NLAY +cgzh fix for 2D-problems + IF(NCOL.EQ.1) GO TO 165 + IF(I.NE.1) GO TO 1151 + IF(LKARR1(I+1,J,K1).EQ.0) GO TO 165 + GO TO 1153 + 1151 IF(I.NE.NCOL) GO TO 1152 + IF(LKARR1(I-1,J,K1).EQ.0) GO TO 165 + GO TO 1153 + 1152 IF(LKARR1(I+1,J,K1).EQ.0.AND.LKARR1(I-1,J,K1).EQ.0) GO TO 165 +C +C CELL(S) LATERALLY ADJACENT TO LAKE IN X-DIRECTION (TYPE 1) DETECTED +C + 1153 DO 160 N=1,2 + IF(N.EQ.2) GO TO 155 + IF(I.EQ.1) GO TO 160 + IF(LKARR1(I-1,J,K1).EQ.0) GO TO 160 + I2 = I-1 + IFACE=1 + GO TO 157 + 155 IF(I.EQ.NCOL) GO TO 160 + IF(LKARR1(I+1,J,K1).EQ.0) GO TO 160 + I2 = I + 1 + IFACE=2 + 157 M = M + 1 + IF(M.LE.MXLKND) GO TO 158 + WRITE(IOUT,149) I,J,K1 + CALL USTOP(' ') + 158 ILAKE(1,M) = K1 + ILAKE(2,M) = J + ILAKE(3,M) = I + ILAKE(4,M) = LKARR1(I2,J,K1) + ILAKE(5,M) = IFACE + BEDLAK(M) = BDLKN1(I,J,K1) + K4 = K1 - 1 + DO 3158 K3=1,K4 + IF(LKARR1(I,J,K3).EQ.0) GO TO 3158 + GO TO 3162 + 3158 CONTINUE + BEDLAK(M) = BDLKN1(I,J,1) + 3162 CONTINUE +c-lfk WRITE(IOUT,5) (ILAKE(I1,M),I1=1,5), BEDLAK(M) +C-LFK-JAN. 2013 +c-lfk WRITE(IOUT,5) (ILAKE(I1,M),I1=1,5), BEDLAK(M) + WRITE(IOUT,6) (ILAKE(I1,M),I1=1,5), BEDLAK(M) +C-LFK + 160 CONTINUE +cgzh fix for 2D-problems + 165 IF(NROW.EQ.1) GO TO 175 + IF(J.NE.1) GO TO 1161 + IF(LKARR1(I,J+1,K1).EQ.0) GO TO 175 + GO TO 1163 + 1161 IF(J.NE.NROW) GO TO 1162 + IF(LKARR1(I,J-1,K1).EQ.0) GO TO 175 + GO TO 1163 + 1162 IF(LKARR1(I,J+1,K1).EQ.0.AND.LKARR1(I,J-1,K1).EQ.0) GO TO 175 +C +C CELL(S) LATERALLY ADJACENT TO LAKE IN Y-DIRECTION (TYPE 2) DETECTED +C + 1163 DO 170 N=1,2 + IF(N.EQ.2) GO TO 172 + IF(J.EQ.1) GO TO 170 + IF(LKARR1(I,J-1,K1).EQ.0) GO TO 170 + J2 = J - 1 + IFACE=4 + GO TO 174 + 172 IF(J.EQ.NROW) GO TO 170 + IF(LKARR1(I,J+1,K1).EQ.0) GO TO 170 + J2 = J + 1 + IFACE=3 + 174 M = M + 1 + IF(M.LE.MXLKND) GO TO 176 + WRITE(IOUT,149) I,J,K1 + CALL USTOP(' ') + 176 ILAKE(1,M) = K1 + ILAKE(2,M) = J + ILAKE(3,M) = I + ILAKE(4,M) = LKARR1(I,J2,K1) + ILAKE(5,M) = IFACE + BEDLAK(M) = BDLKN1(I,J,K1) + K4 = K1 - 1 + DO 4158 K3=1,K4 + IF(LKARR1(I,J,K3).EQ.0) GO TO 4158 + GO TO 4162 + 4158 CONTINUE + BEDLAK(M) = BDLKN1(I,J,1) + 4162 CONTINUE +c-lfk WRITE(IOUT,5) (ILAKE(I1,M),I1=1,5), BEDLAK(M) +C-LFK-JAN. 2013 +c-lfk WRITE(IOUT,5) (ILAKE(I1,M),I1=1,5), BEDLAK(M) + WRITE(IOUT,6) (ILAKE(I1,M),I1=1,5), BEDLAK(M) +C-LFK + 170 CONTINUE + 175 CONTINUE + 180 CONTINUE + WRITE(IOUT,195) M + 195 FORMAT(/5X,'NUMBER OF LAKE-AQUIFER CELL INTERFACES = ',I5) + LKNODE = M +C +C SET LAKE BOTTOM ELEVATIONS + DO 295 LK=1,NLAKES + 295 BOTTMS(LK) = 999999 +C + DO 350 II=1,LKNODE + K = ILAKE(1,II) + J = ILAKE(2,II) + I = ILAKE(3,II) +C Convert ILAKE(5,II): 1 and 2 are type 1, 3 and 4 are type 2, +C 6 is type 0 + NTYP = (ILAKE(5,II)+1)/2 + IF(NTYP.EQ.3) NTYP=0 + IF(NTYP.EQ.0) THEN + LAKE = ILAKE(4,II) +Cdep changed if statement August 24, 2009 +Cdep IF(K.GT.1) BOTLK = BOTM(I,J,LBOTM(K-1)) +Cdep IF(K.EQ.NLAY.AND.LKARR1(I,J,K).GT.0) BOTLK = BOTM(I,J,LBOTM(K)) + IF(K.EQ.1.OR.K.EQ.NLAY.AND.LKARR1(I,J,K).GT.0) THEN + BOTLK = BOTM(I,J,LBOTM(K)) + ELSEIF (K.EQ.0) THEN + BOTLK = BOTM(I,J,LBOTM(1)) + ELSE + BOTLK = BOTM(I,J,LBOTM(K-1)) + ENDIF + IF(BOTLK.LT.BOTTMS(LAKE)) BOTTMS(LAKE) = BOTLK + ENDIF + 350 CONTINUE +C +C-- COMPUTE AND PRINT STAGE/VOLUME TABLES WHEN MORE THAN ONE LAYER +Cdep revised print statement to include stage/area tables +C + IF ( IRDTAB.EQ.0 ) THEN +! IF(NLAY.EQ.1) GO TO 1331 !RGN 5/21/12 + DO 1330 L1=1,NLAKES + WRITE(IOUT,1306) L1 +Cdep revised print statement to include area + 1306 FORMAT(//1X,'STAGE/VOLUME RELATION FOR LAKE',I3//6X,'STAGE', + 1 8X,'VOLUME',8X,'AREA'/) + DO INC=1,151 + AREATABLE(INC,L1) = 0.D0 + ENDDO + EVOL = 0.0 + GTSDPH = 40.0 + TOPMST = BOTTMS(L1)+GTSDPH + TBELV = BOTTMS(L1) + DO 1340 I=1,NCOL + DO 1340 J=1,NROW + IF(LKARR1(I,J,1).NE.L1) GO TO 1340 +Cdep Revised estimate of DTHK to be thickness of top most +C layer 6/09/2009 + IF(BOTM(I,J,0).GT.TOPMST) TOPMST = BOTM(I,J,0) +! DTHK = BOTM(I,J,0) - BOTM(I,J,1) RGN this was causing problems 7/8/11 +! IF (DTHK.LE.GTSDPH) THEN +! TOPMST = BOTM(I,J,1)+DTHK +! ELSE +! TOPMST = BOTM(I,J,1)+GTSDPH +! ENDIF + 1340 CONTINUE + TBNC = (TOPMST-BOTTMS(L1))/150.0 +Cdep Revised looping for computing lake stage, volume, +Cdep and area Apr 2009. +Cdep WRITE(IOUT,1315) TBELV, EVOL + DO INC=1,151 + IF (INC.GT.1) THEN + VOLUMETABLE(INC,L1)=VOLUMETABLE(INC-1,L1) + ENDIF + DO I=1,NCOL + DO J=1,NROW + LAKEFLG = 0 + K = 1 + MOSTBOT: DO WHILE (LAKEFLG.EQ.0) + IF(LKARR1(I,J,K).EQ.L1) THEN + LAKEFLG = K + ENDIF + IF(K.EQ.NLAY)EXIT MOSTBOT + K = K + 1 + ENDDO MOSTBOT + IF(LAKEFLG.GT.0) THEN + K=LAKEFLG + FINDBOT: DO WHILE(LKARR1(I,J,K).GT.0) + K=K+1 + IF(K.EQ.NLAY+1) EXIT + ENDDO FINDBOT + BOTIJ = BOTM(I,J,LBOTM(K-1)) + IF(INC.EQ.1) THEN + IF(TBELV+1.0E-03.GT.BOTIJ) THEN + AREATABLE(INC,L1)=AREATABLE(INC,L1)+DELC(J)*DELR(I) + DEPTHTABLE(INC,L1)=TBELV + ENDIF + ELSE + IF (TBELV-BOTIJ.GT.0.0) THEN + AREATABLE(INC,L1)=AREATABLE(INC,L1)+DELC(J)*DELR(I) + DEPTHTABLE(INC,L1)=TBELV + IF(ABS(TBELV-BOTIJ).GT.1.0E-04) THEN + VOLUMETABLE(INC,L1)=VOLUMETABLE(INC,L1)+ + + (DELC(J)*DELR(I))*TBNC + ENDIF + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO +Cdep PRINT TABLE OF ELEVATION, VOLUME, AND AREA + WRITE(IOUT,1315) DEPTHTABLE(INC,L1), VOLUMETABLE(INC,L1), + + AREATABLE(INC,L1) + TBELV = TBELV + TBNC + ENDDO + 1315 FORMAT(3(1X,1PE13.5)) + WRITE(IOUT,1326) + 1326 FORMAT(120X) +Cdep set minimum and maximum lake stages for transient simulations + IF(ISS.EQ.0) THEN + SSMN(L1)=BOTTMS(L1) + SSMX(L1)=TBELV + ENDIF + 1330 CONTINUE + 1331 CONTINUE + ENDIF + IF(IUNITSFR.LE.0) THEN + NDV=0 + NTRB=0 + ENDIF +C +C +C-- READ LINKAGE PARAMETERS FOR COALESCING LAKES +C +C FOR EACH CONNECTED LAKE SYSTEM, READ LAKE NUMBERS OF CENTER LAKES +C AND ADJOINING LAKES AND SILL ELEVATIONS. ENTER CARD IMAGES +C FOR SUBLAKE SYSTEMS EVEN IF LINKED TO MAIN LAKE SYSTEM. SYSTEMS +C MUST BE ORDERED HIERARCHICALLY. +C + ICMX = 0 + NCLS=0 +! Read item 7 + IF(IFREFM.EQ.0) THEN + READ(IN,'(I5)') NSLMS + ELSE + READ(IN,*) NSLMS + ENDIF + WRITE(IOUT,680) NSLMS + 680 FORMAT(/1X,'NUMBER OF CONNECTED LAKE SYSTEMS IN SIMULATION IS ',I3 + 1) + IF(NSLMS.LE.0) GO TO 760 + DO 700 IS=1,NSLMS +! Read item 8a + IF(IFREFM.EQ.0) THEN + READ(IN,'(16I5)',END=750) IC,(ISUB(IS,I),I=1,IC) + ELSE + READ(IN,*,END=750) IC,(ISUB(IS,I),I=1,IC) + ENDIF + IF(IC.LE.0) GO TO 750 + IF(IC.GT.ICMX) ICMX=IC + ICS(IS)=IC + IC1 = IC - 1 +! Read item 8b + IF(IFREFM.EQ.0) THEN + READ(IN,'(100F10.2)') (SILLVT(IS,I),I=1,IC1) + ELSE + READ(IN,*) (SILLVT(IS,I),I=1,IC1) + ENDIF + WRITE(IOUT,18) IS, ICS(IS), ISUB(IS,1) + 18 FORMAT(/10X,'SYSTEM',I3//2X,'NUMBER OF LAKES IN SYSTEM',I5, + 1 ' CENTER LAKE NUMBER',I5//1X,'SUBLAKE NUMBER',3X, + 2 'SILL ELEVATION'/) + DO 715 JK=2,IC + 715 WRITE(IOUT,717) ISUB(IS,JK), SILLVT(IS,JK-1) + 717 FORMAT(8X,I2,8X,F10.2) + 700 CONTINUE + 750 CONTINUE + NCLS=IS-1 + WRITE(IOUT,751) NCLS + 751 FORMAT(/1X,'READ DATA FOR',I5,' LAKE SYSTEMS'/) + 760 CONTINUE +C +C----- READ LAKE PRECIPITATION, EVAPORATION, RUNOFF, AND WITHDRAWAL RATES. +C IF ITMP1 LT 0, SPECIFICATIONS FROM LAST STRESS PERIOD ARE USED. +C + 800 IF(ITMP1.GE.0) GO TO 801 + WRITE(IOUT,802) + 802 FORMAT(1H0,'REUSING RECH,ET,WITHDRAWAL RATES FROM LAST STRESS PERI + 1OD'/) + GOTO 900 + 801 IF(ISS.NE.0.AND.KKPER.GT.1) WRITE(IOUT,7) +7 FORMAT(/1X,'LAKE',7X,'PRECIP',5X,'EVAP',5X,'RUNOFF', + 2 3X,'WITHDRAW',3X,'BOTTOM',5X,'AREA',5X,'SS MIN',3X,'SS MAX' + 1/90('-')) + IF(ISS.EQ.0.OR.KKPER.EQ.1) WRITE(IOUT,77) + 77 FORMAT(/1X,'LAKE',7X,'PRECIP',5X,'EVAP',5X,'RUNOFF', + 2 3X,'WITHDRAW',3X,'BOTTOM',5X,'AREA',5X,/70('-')) + IF (IUNITGWT.GT.0) WRITE (IOUTS,8) + 8 FORMAT (//1X,'LAKE',4X,'SOLUTE',6X,'CPPT',6X,'CRNF',6X,'CAUG'/) +! Read item 9 + DO 300 LM=1,NLAKES + IF(IFREFM.EQ.0) THEN + IF(ISS.NE.0.AND.KKPER.GT.1) READ(IN,'(6F10.4)') PRCPLK(LM), + 1 EVAPLK(LM),RNF(LM),WTHDRW(LM),SSMN(LM),SSMX(LM) + IF(ISS.EQ.0.OR.KKPER.EQ.1) READ(IN,'(6F10.4)') PRCPLK(LM), + 1 EVAPLK(LM),RNF(LM),WTHDRW(LM) + ELSE + IF(ISS.NE.0.AND.KKPER.GT.1) READ(IN,*) PRCPLK(LM),EVAPLK(LM), + 1 RNF(LM),WTHDRW(LM),SSMN(LM),SSMX(LM) + IF(ISS.EQ.0.OR.KKPER.EQ.1) READ(IN,*) PRCPLK(LM),EVAPLK(LM), + 1 RNF(LM),WTHDRW(LM) + ENDIF + IF(ISS.NE.0.AND.KKPER.GT.1) WRITE(IOUT,9) LM,PRCPLK(LM),EVAPLK(LM) + 1 ,RNF(LM),WTHDRW(LM),BOTTMS(LM),BGAREA(LM),SSMN(LM),SSMX(LM) +9 FORMAT(1X,I3,4X,1P,3E10.3,1X,5E10.3) + IF(ISS.EQ.0.OR.KKPER.EQ.1) WRITE(IOUT,9) LM,PRCPLK(LM),EVAPLK(LM), + 1 RNF(LM),WTHDRW(LM),BOTTMS(LM),BGAREA(LM) + IF(IUNITGWT.LE.0) GO TO 300 +! Read item 9b + DO 850 ISOL=1,NSOL + IF(IFREFM.EQ.0) THEN + IF(WTHDRW(LM).LT.0.0) THEN + READ(IN,'(3F10.4)')CPPT(LM,ISOL),CRNF(LM,ISOL),CAUG(LM,ISOL) + ELSE + READ(IN,'(2F10.4)')CPPT(LM,ISOL),CRNF(LM,ISOL) + ENDIF + ELSE + IF(WTHDRW(LM).LT.0.0) THEN + READ(IN,*) CPPT(LM,ISOL),CRNF(LM,ISOL),CAUG(LM,ISOL) + ELSE + READ(IN,*) CPPT(LM,ISOL),CRNF(LM,ISOL) + ENDIF + ENDIF + IF(WTHDRW(LM).LT.0.0)WRITE(IOUTS,840) LM,ISOL, + + CPPT(LM,ISOL),CRNF(LM,ISOL),CAUG(LM,ISOL) + IF(WTHDRW(LM).GE.0.0) + 1 WRITE(IOUTS,841) LM,ISOL,CPPT(LM,ISOL),CRNF(LM,ISOL) + 840 FORMAT(1X,I3,6X,I3,4X,1P,3E10.2) + 841 FORMAT(1X,I3,6X,I3,4X,1P,2E10.2) + 850 CONTINUE +C WRITE (IOUTS,'(/)') + 300 CONTINUE + WRITE (IOUT,'(/)') +C +C------Define Initial Lake Volume & Initialize Cumulative Budget Terms + IF(KKPER.EQ.1) THEN +!dep revised calculation of initial lake volume July 2009 + STGINIT=0.0D0 + DO 8400 LK=1,NLAKES +!dep 8400 VOL(LK)=0.0 + STGINIT=STAGES(LK) + VOL(LK)=VOLTERP(STGINIT,LK) + VOLINIT(LK)=VOL(LK) + 8400 CONTINUE + DO 8450 LK=1,NLAKES + CUMPPT(LK)=0.0 + CUMEVP(LK)=0.0 + CUMRNF(LK)=0.0 + CUMGWI(LK)=0.0 + CUMGWO(LK)=0.0 + CUMSWI(LK)=0.0 + CUMSWO(LK)=0.0 + CUMWDR(LK)=0.0 + CUMFLX(LK)=0.0 + 8450 CONTINUE + DO 8900 L=1,LKNODE + IL=ILAKE(1,L) + IR=ILAKE(2,L) + IC=ILAKE(3,L) + LAKE=ILAKE(4,L) +C------Convert ILAKE(5,L): 1 and 2 are type 1, 3 and 4 are type 2, +C 6 is type 0 + ITYPE = (ILAKE(5,L)+1)/2 + IF(ITYPE.EQ.3) ITYPE=0 + IF(ITYPE.NE.0) GO TO 8900 + IF(IL.GT.1) BOTLK = BOTM(IC,IR,LBOTM(IL-1)) + IF(IL.EQ.NLAY.AND.LKARR1(IC,IR,IL).GT.0) + 1 BOTLK = BOTM(IC,IR,LBOTM(IL)) + 8900 CONTINUE + ENDIF + + 900 IF (IUNITBCF.GT.0) THEN ! rsr, moved if block from main + CALL SGWF2LAK7BCF7RPS() + ELSEIF (IUNITLPF.GT.0) THEN + CALL SGWF2LAK7LPF7RPS() +! ELSEIF (IUNITHUF.GT.0) THEN +* CALL SGWF2LAK7HUF7RPS() + ELSE IF (IUNITUPW.GT.0) THEN + CALL SGWF2LAK7UPW1RPS() + ELSE +! WRITE (IOUT, *) 'LAK Package requires BCF, LPF, or UPW' + call store_error('LAK Package requires BCF, LPF, or UPW') + CALL USTOP() + ENDIF + IF (IUNITSFR.GT.0) CALL SGWF2LAK7SFR7RPS() +C +C7------RETURN + RETURN + END SUBROUTINE GWF2LAK7RP +C +! SUBROUTINE GWF2LAK7AD(KKPER,KKSTP,IUNITGWT,IGRID) +!C +!C------VERSION 7.1 JUNE 2006 GWF2LAK7AD; REVISED FEBRUARY 6, 2012 +!C +!C ****************************************************************** +!C ADVANCE TO NEXT TIME STEP FOR TRANSIENT LAKE SIMULATION, AND COPY +!C INITIAL LAKE STAGES TO STGOLD FOR STEADY STATE. +!C ****************************************************************** +!C SPECIFICATIONS: +!C ------------------------------------------------------------------ +! USE GWFLAKMODULE, ONLY: NLAKES, LKNODE, FLOB, STAGES, +! + STGNEW, STGOLD, VOLOLDD, VOLOLD, VOLINIT, +! + BOTTMS, IDIV, STGOLD2, NDV +! USE GWFSFRMODULE, ONLY: DLKSTAGE +! USE GLOBAL, ONLY: IOUT +! use SimModule, only: ustop +!C ------------------------------------------------------------------ +!C FUNCTIONS +!C ------------------------------------------------------------------ +!!* DOUBLE PRECISION VOLTERP +!!* EXTERNAL VOLTERP +!C ------------------------------------------------------------------ +!C +!C------SET POINTERS FOR THE CURRENT GRID. +! CALL SGWF2LAK7PNT(IGRID) +!C +!C1 --- COPY INITIAL LAKE STAGES TO STGOLD. +!! RGN COMBINED IF AND ADDED VOLOLDD 4/17/09 +!Cdep initialized VOLINIT and VOLOLD to VOLOLDD 6/4/2009 +! DO I=1,NLAKES +! IF(KKPER.EQ.1.AND.KKSTP.EQ.1) THEN +! STGOLD(I)=STAGES(I) +! VOLOLDD(I)=VOLTERP(STGOLD(I),I) +! VOLOLD(I) = VOLOLDD(I) +! VOLINIT(I) = VOLOLDD(I) +! STGNEW(I)=STAGES(I) +! ELSE +! STGOLD2(I)=STGNEW(I) +! STGOLD(I)=STGNEW(I) +! VOLOLDD(I)=VOLTERP(STGOLD(I),I) +! VOLOLD(I)=VOLOLDD(I) +! ENDIF +!! Moved this code from 7FM 10/19/10 +! DO IDV=1,NDV +! INODE=IDIV(I,IDV) +! IF (INODE.GT.0) THEN +! IF( DLKSTAGE(1,INODE).LT.DBLE(BOTTMS(I))) THEN +! WRITE(IOUT,971)I,BOTTMS(I), +! + DLKSTAGE(1,INODE),INODE +! CALL USTOP(' ') +! ENDIF +! ENDIF +! ENDDO +! ! To hear. +! ENDDO +! 971 FORMAT(' BOTTOM ELEVATION OF LAKE ',I5,' IS ', F10.2, +! + ' AND IS ABOVE OUTLET ELEVATION OF ', F10.2, +! + ' FOR STREAM SEGMENT ',I5,/1X, +! + ' THIS WILL CAUSE PROBLEMS IN COMPUTING LAKE', +! + ' STAGE USING THE NEWTON METHOD. '/1X, +! + ' ELEVATION OF STREAM OUTLET MUST BE GREATER' +! + ' THAN OR EQUAL TO THE LOWEST ELEVATION OF THE', +! + ' LAKE.',/1X,'*****PROGRAM STOPPING'/) +!C2 ----- IF NOT FIRST TIME STEP, OR FIRST STRESS PERIOD, UPDATE +!C STGOLD BY STGNEW. +!! RGN MOVED TO ABOVE. STGOLD SHOULD BE UPDATED EVERY TIME STEP! 4/17/09 +!! IF (KKPER.NE.1.OR.KKSTP.NE.1) THEN +!! DO 30 K=1,NLAKES +!! STGOLD(K)=STGNEW(K) +!! VOLOLD(K)=VOLTERP(STGOLD(K),K)) +!!30 STGOLD2(K)=STGNEW(K) +!! ENDIF +!C +!C-----Initialize FLOB array (stores cell by cell flux between lake and +!C aquifer) +! IF (IUNITGWT.GT.0) THEN +! DO 50 LK=1,LKNODE +! 50 FLOB(LK)=0.0 +! ENDIF +!C +!C3------RETURN +! RETURN +! END SUBROUTINE GWF2LAK7AD +!C +! SUBROUTINE GWF2LAK7ST(NFLG,IGRID) +!C ******************************************************************** +!C SET IBOUND VALUES SO THAT RECHARGE AND EVAPOTRANSPIRATION (ET) WILL +!C BE ASSIGNED CORRECTLY UNDERNEATH DRYING LAKES (NFLG = 0), OR RESET +!C IBOUND AFTER RECHARGE AND ET ARE COMPUTED (NFLG = 1). +!C ******************************************************************** +!C +!C SPECIFICATIONS: +!C +!C----------------------------------------------------------------------- +! USE GWFLAKMODULE, ONLY: LKNODE, ILAKE, STGOLD +! USE GLOBAL, ONLY: IBOUND, LBOTM, BOTM +!C----------------------------------------------------------------------- +!C +!C------SET POINTERS FOR THE CURRENT GRID. +! CALL SGWF2LAK7PNT(IGRID) +! +! IF(LKNODE.EQ.0) RETURN +! DO 10 L=1,LKNODE +!C Convert ILAKE(5,L): 1 and 2 are type 1, 3 and 4 are type 2, 6 is type 0 +! ITYPE = (ILAKE(5,L)+1)/2 +! IF(ITYPE.EQ.3) ITYPE=0 +!C +!C-------ONLY CHANGE IBOUND FOR VERTICALLY ADJACENT NODE FACES +! IF(ITYPE.NE.0) GO TO 10 +! IL = ILAKE(1,L) +! IR = ILAKE(2,L) +! IC = ILAKE(3,L) +!C +!C-------RESET AFTER EXECUTING RECHARGE OR ET ROUTINES +! IF(NFLG.EQ.1) GO TO 8 +!C +!C-------RESET BEFORE EXECUTING RECHARGE OR ET ROUTINES +! IF ( IL.GT.1 ) THEN !RGN 5/21/12 added IF test +! IBOUND(IC,IR,IL-1) = -7 +! ELSE !RGN +! IBOUND(IC,IR,IL) = -7 !RGN +! ENDIF !RGN +!C +!C-------THIS IS THE CORRECT ASSIGNMENT IF PORTION OF LAKE IN COLUMN +!C IS WET. +! LAKE = ILAKE(4,L) +! IF(STGOLD(LAKE).GT.BOTM(IC,IR,LBOTM(IL)-1)) GO TO 10 +!C +!C-------IF PORTION OF LAKE IN NODE IS DRY, LET RECHARGE AND ET BE +!C APPLIED TO THE AQUIFER NODE UNDERNEATH THE LAKE BY SETTING +!C IBOUND EQUAL TO 0. +! 8 IF ( il.GT.1 ) THEN !RGN 5/21/12 added IF test +!! 8 IBOUND(IC,IR,IL-1) = 0 !RGN +! IBOUND(IC,IR,IL-1) = 0 !RGN +! ELSE !RGN +! IBOUND(IC,IR,IL) = 0 !RGN +! ENDIF !RGN +! 10 CONTINUE +!C +!C3------RETURN +! RETURN +! END SUBROUTINE GWF2LAK7ST +C + SUBROUTINE SGWF2LAK7SFR7RPS() +C +C ******************************************************************* +C-- IF STREAMS EXIST, DEFINE CONNECTIONS BETWEEN LAKES AND STREAMS +C ******************************************************************* +C +C ------------------------------------------------------------------- +C SPECIFICATIONS: +C ------------------------------------------------------------------- + USE GWFLAKMODULE, ONLY: NLAKES, NTRB, NDV, ITRB, IDIV, IRK + USE GLOBAL, ONLY: IOUT, NODES + USE GWFSFRMODULE, ONLY: NSS, IDIVAR, IOTSG, SEG, ISEG + use SimModule, only: ustop +C +C-- DOUBLE CHECK SIZE OF IRK (STORED IN BUFF) vs. NLAKES +C + IF ((NLAKES*2).GT.NODES) THEN + WRITE (IOUT,*) '***NLAKES too large for BUFF in Subroutine GWF2 + 1LAK7SFR7RPS*** STOP EXECUTION' + CALL USTOP(' ') + ENDIF +C +C-- INITIALIZE ARRAYS +C + DO 55 LK=1,NLAKES + IRK(1,LK) = 0 + 55 IRK(2,LK) = 0 + NTRB = 0 + NDV = 0 +C +C-- Build arrays to define lake tributary & diversion links ... +C based on stream package input data +C +C--- Stream Inflow to Lakes + DO 100 LSEG=1,NSS + IF(IOTSG(LSEG).LT.0) THEN + LAKE = -IOTSG(LSEG) + IRK(1,LAKE) = IRK(1,LAKE) + 1 + K1 = IRK(1,LAKE) + ITRB(LAKE,K1) = LSEG + IF(IRK(1,LAKE).GT.NTRB) NTRB = IRK(1,LAKE) + ENDIF +C +C--- Stream Outflow from Lakes + IF(IDIVAR(1,LSEG).LT.0) THEN + LAKE = -IDIVAR(1,LSEG) + IRK(2,LAKE) = IRK(2,LAKE) + 1 + K1 = IRK(2,LAKE) + IDIV(LAKE,K1) = LSEG + IF(IRK(2,LAKE).GT.NDV) NDV = IRK(2,LAKE) + ENDIF + 100 CONTINUE +C +C-- PRINT LAKE INFLOW STREAM SEGMENTS. + WRITE(IOUT,10) +10 FORMAT(6X,'LAKE ',4X,'INFLOWING STREAM SEGMENT') + DO 520 IK=1,NLAKES + DO 519 JK=1,NSS + IF(ITRB(IK,JK).LE.0) GO TO 521 + 519 CONTINUE + 521 JK1 = JK - 1 + IF(JK1.GT.0) WRITE(IOUT,15) IK,(ITRB(IK,JK),JK=1,JK1) +15 FORMAT(5X,I5,14X,100I5) + 520 CONTINUE + WRITE(IOUT,103) NTRB +103 FORMAT(/1X,'MAXIMUM NUMBER OF STREAMS INFLOWING TO A', + 1 ' LAKE IS',I5/) +C +C-- PRINT LAKE STREAM OUTFLOW SEGMENT (FROM A LAKE) NUMBERS. +C + WRITE(IOUT,13) +13 FORMAT(6X,'LAKE ',4X,'OUTFLOWING STREAM',' SEGMENT') + DO 600 IK=1,NLAKES + DO 523 JK=1,NSS + IF(IDIV(IK,JK).LE.0) GO TO 527 + 523 CONTINUE + 527 JK1 = JK - 1 + IF(JK1.GT.0) WRITE(IOUT,15) IK,(IDIV(IK,JK),JK=1,JK1) + 600 CONTINUE +C +Cdep-- PRINT WARNING IF OUTFLOWING STREAM IS ASSIGNED ICALC =0. +Cdep ADDED OCTOBER 15, 2004; DAVID PRUDIC + DO ls = 1, NSS + IF (IDIVAR(1,ls).LT.0) THEN + lk = -IDIVAR(1,ls) + IF (ISEG(1,ls).LE.0 .AND. SEG(2,ls).LE.0.0) THEN + WRITE (IOUT, 9007) ls, lk, ISEG(1,ls), SEG(2,ls) + ENDIF + ENDIF + ENDDO + WRITE(IOUT,133) NDV +133 FORMAT(/1X,'MAXIMUM NUMBER OF STREAMS OUTFLOWING', + 1 ' FROM A LAKE IS',I5/) + 9007 FORMAT(/, ' WARNING**** OUTFLOWING STREAM SEGMENT', I6, + + ' FROM LAKE', I6, ' HAS AN ICALC VALUE OF', I6, + + ' AND FLOW INTO THE SEGMENT IS', E12.4, /, + + ' NO OUTFLOW FROM THE LAKE INTO ', + + 'SEGMENT WILL BE SIMULATED', /, + + ' SUGGEST CHANGING ICALC TO ANOTHER OPTION') +C +C-- RETURN + RETURN + END SUBROUTINE SGWF2LAK7SFR7RPS + + SUBROUTINE SGWF2LAK7BCF7RPS() +C +C ****************************************************************** +C COMPUTE VERTICAL CONDUCTANCES AND HORIZONTAL CONDUCTANCES PER UNIT +C THICKNESS FOR LAKES WHEN BCF PACKAGE IS USED +C ****************************************************************** +C +C ------------------------------------------------------------------ +C SPECIFICATIONS: +C ------------------------------------------------------------------ + USE GWFLAKMODULE, ONLY: LKNODE, BEDLAK, LKARR1, ILAKE, CNDFCT + USE GLOBAL, ONLY: NLAY, IOUT, DELR, DELC, LAYHDT,NCOL,NROW + USE GWFBCFMODULE, ONLY: IWDFLG, HY, CVWD, TRPY +C + WRITE(IOUT,108) + 108 FORMAT(//9X,'C',15X,'INTERFACE CONDUCTANCES BETWEEN LAKE AND ', + 1 'AQUIFER CELLS'/ + 2 3X,'L',5X,'O',10X,'(IF TYPE = 6, CONDUCTANCE (L^2/T) IS ', + 3 'BETWEEN AQUIFER CELL AND OVERLYING LAKE CELL.)',/ + 4 3X,'A',5X,'L',2X,'L',2X,'T', + 5 4X,'(IF TYPE = 1 TO 4, CONDUCTANCES ARE PER UNIT SATURATED ', + 6 'THICKNESS (L/T).)'/ + 7 3X,'Y',2X,'R',2X,'U',2X,'A',2X,'Y'/ + 8 3X,'E',2X,'O',2X,'M',2X,'K',2X,'P', + 9 24X,'LAKEBED',6X,'C O N D U C T A N C E S'/3X,'R',2X,'W',2X, + 1 'N',2X,'E', + 2 2X,'E',5X,'DELTA Y',3X,'DELTA X',2X,'LEAKANCE',3X,'LAKEBED',3X, + 3 'AQUIFER',2X,'COMBINED'/1X,79('_')) +C + IWRN = 0 + IWRN1 = 0 + DO 350 II=1,LKNODE + K = ILAKE(1,II) + J = ILAKE(2,II) + I = ILAKE(3,II) + CNDFCT(II) = 0.0 +C Convert ILAKE(5,II): 1 and 2 are type 1, 3 and 4 are type 2, 6 is type 0 + NTYP = (ILAKE(5,II)+1)/2 + IF(NTYP.EQ.3) NTYP=0 + NTYP = NTYP + 1 + IF(NTYP.EQ.1) THEN +C +C Vertical Conductance +C for vertical interface, "K" is layer below bottom of lake +C + CNDFC1=0.0 + IF(K.EQ.NLAY.AND.LKARR1(I,J,K).GT.0) GO TO 315 + IF(BEDLAK(II).LE.0.0) GO TO 315 + IWRN1 = 1 + CNDFC1 = BEDLAK(II)*DELR(I)*DELC(J) + IF (IWDFLG.EQ.0) THEN + CNDFCT(II) = CNDFC1 + ELSE + IF(CVWD(I,J,K-1).LE.0.0.OR.CNDFC1.LE.0.0) GO TO 315 + CNDFCT(II) = 1.0/(0.5/CVWD(I,J,K-1)+1.0/CNDFC1) + ENDIF + 315 IF (IWDFLG.EQ.0) THEN + WRITE(IOUT,7324) (ILAKE(I1,II),I1=1,5),DELC(J),DELR(I), + 1 BEDLAK(II),CNDFC1,CNDFCT(II) +c-lfk + 7324 FORMAT(1X,5I3,2X,1P,4E10.2,10X,E11.3) +C 7324 FORMAT(1X,5I3,2X,1P,4E10.2,10X,E10.2) + ELSE + IF (K.GT.1) THEN + CVWD2= 2.0*CVWD(I,J,K-1) + WRITE(IOUT,7325) (ILAKE(I1,II),I1=1,5),DELC(J),DELR(I), + 1 BEDLAK(II),CNDFC1,CVWD2,CNDFCT(II) + ENDIF +c-lfk + 7325 FORMAT(1X,5I3,2X,1P,5E10.2,E11.3) +c 7325 FORMAT(1X,5I3,2X,1P,6E10.2) + ENDIF + ELSE +C +C Horizontal conductance +C +C HY not read in, thus unavailable. +C +Cdep 348 IF(LAYHDT(K).EQ.0) THEN + IF(LAYHDT(K).EQ.0) THEN + IF(NTYP.EQ.2) CNDFCT(II) = BEDLAK(II)*DELC(J) + IF(NTYP.EQ.3) CNDFCT(II) = BEDLAK(II)*DELR(I) + WRITE(IOUT,7324) (ILAKE(I1,II),I1=1,5),DELC(J),DELR(I), + 1 BEDLAK(II),CNDFCT(II),CNDFCT(II) + IWRN = 1 + ELSE +C +C HY read in, thus available. +C + TT = HY(I,J,K) + IF(NTYP.EQ.2) CNDFC2 = 2.0*TT*DELC(J)/DELR(I) + IF(NTYP.EQ.3) CNDFC2 = 2.0*TRPY(K)*TT*DELR(I)/DELC(J) + IF(NTYP.EQ.2) CNDFC1 = BEDLAK(II)*DELC(J) + IF(NTYP.EQ.3) CNDFC1 = BEDLAK(II)*DELR(I) + IF (CNDFC1.GT.0.0.AND.CNDFC2.GT.0.0) + * CNDFCT(II) = 1.0/(1.0/CNDFC2+1.0/CNDFC1) + WRITE(IOUT,7325) (ILAKE(I1,II),I1=1,5),DELC(J),DELR(I), + 1 BEDLAK(II),CNDFC1,CNDFC2,CNDFCT(II) + ENDIF + ENDIF + 350 CONTINUE +C +C WRITE WARNINGS ON LAKE/AQUIFER CONDUCTANCES, IF NECESSARY + IF(IWRN.EQ.1.OR.IWRN1.EQ.1) WRITE(IOUT,345) + 345 FORMAT(//5X,'NOTE: INFORMATION ABOUT CALCULATED LAKE/AQUIFER C + 1ONDUCTANCES WHEN USING BCF PACKAGE FOLLOWS: '/) + IF(IWRN.EQ.1) WRITE(IOUT,346) + 346 FORMAT(1X,'NODE(S) ADJACENT TO LAKE IN CONFINED LAYER:'/ + 1 1X,'LAKE/AQUIFER CONDUCTANCES BASED SOLELY ON LAKEBED SPECIFIC + 2ATION'/) + IF(IWRN1.EQ.1) WRITE(IOUT,347) + 347 FORMAT(1X,'IF WETDRY FLAG NOT TURNED ON, VERTICAL LEAKANCES AR + 1E NOT SAVED:'/1X,'THEREFORE, LAKE/AQUIFER CONDUCTANCES ARE BASED S + 2OLELY ON LAKEBED SPECIFICATION'/) + IF(IWRN.EQ.1.OR.IWRN1.EQ.1) WRITE(IOUT,'(//)') +C + RETURN + END SUBROUTINE SGWF2LAK7BCF7RPS +C + SUBROUTINE SGWF2LAK7LPF7RPS() +C +C ****************************************************************** +C COMPUTE VERTICAL CONDUCTANCES AND HORIZONTAL CONDUCTANCES PER UNIT +C THICKNESS FOR LAKES WHEN LPF PACKAGE IS USED +C ****************************************************************** +C +C ------------------------------------------------------------------ +C SPECIFICATIONS: +C ------------------------------------------------------------------ + USE GWFLAKMODULE, ONLY: LKNODE, BEDLAK, LKARR1, ILAKE, CNDFCT + USE GLOBAL, ONLY: NLAY, IOUT, LBOTM, LAYCBD, DELR, DELC, + + BOTM + USE GWFLPFMODULE, ONLY: CHANI, LAYVKA, VKA, VKCB, HANI, HK +C + WRITE(IOUT,108) + 108 FORMAT(//9X,'C',15X,'INTERFACE CONDUCTANCES BETWEEN LAKE AND ', + 1 'AQUIFER CELLS'/ + 2 3X,'L',5X,'O',10X,'(IF TYPE = 6, CONDUCTANCE (L^2/T) IS ', + 3 'BETWEEN AQUIFER CELL AND OVERLYING LAKE CELL.)',/ + 4 3X,'A',5X,'L',2X,'L',2X,'T', + 5 4X,'(IF TYPE = 1 TO 4, CONDUCTANCES ARE PER UNIT SATURATED ', + 6 'THICKNESS (L/T).)'/ + 7 3X,'Y',2X,'R',2X,'U',2X,'A',2X,'Y'/ + 8 3X,'E',2X,'O',2X,'M',2X,'K',2X,'P', + 9 24X,'LAKEBED',6X,'C O N D U C T A N C E S'/3X,'R',2X,'W',2X, + 1 'N',2X,'E', + 2 2X,'E',5X,'DELTA Y',3X,'DELTA X',2X,'LEAKANCE',3X,'LAKEBED',3X, + 3 'AQUIFER',2X,'COMBINED'/1X,79('_')) +C + DO 350 II=1,LKNODE + K = ILAKE(1,II) + J = ILAKE(2,II) + I = ILAKE(3,II) + CAQ = 0.0 + CNDFCT(II) = 0.0 +C Convert ILAKE(5,II): 1 and 2 are type 1, 3 and 4 are type 2, 6 is type 0 + NTYP = (ILAKE(5,II)+1)/2 + IF(NTYP.EQ.3) NTYP=0 + NTYP=NTYP + 1 + IF(NTYP.EQ.1) THEN +C +C Vertical Conductance +C for vertical interface, "K" is layer below bottom of lake + CNDFC1=0.0 + IF(K.EQ.NLAY.AND.LKARR1(I,J,K).GT.0) GO TO 315 + IF(BEDLAK(II).LE.0.0) GO TO 315 + CNDFC1 = BEDLAK(II)*DELR(I)*DELC(J) + IF(LAYVKA(K).EQ.0) THEN + VK=VKA(I,J,K) + ELSE + VK=HK(I,J,K)/VKA(I,J,K) + ENDIF +c skip if zero vk + IF(VK.LE.0.0) GO TO 350 + BBOT=BOTM(I,J,LBOTM(K)) + TTOP=BOTM(I,J,LBOTM(K)-1) + CAQ=VK*DELR(I)*DELC(J)/((TTOP-BBOT)*0.5) + IF(LAYCBD(K-1).GT.0) THEN +c skip if zero vkcb + IF(VKCB(I,J,LAYCBD(K-1)).LE.0.0) GO TO 350 + BBOT=BOTM(I,J,LBOTM(K)-1) + TTOP=BOTM(I,J,LBOTM(K-1)) + CCB=VKCB(I,J,LAYCBD(K-1))*DELR(I)*DELC(J)/(TTOP-BBOT) + !include VKCB + CAQ = 1.0/(1.0/CAQ + 1.0/CCB) + ENDIF + CNDFCT(II) = 1.0/(1.0/CAQ+1.0/CNDFC1) + 315 WRITE(IOUT,7325) (ILAKE(I1,II),I1=1,5),DELC(J),DELR(I), + 1 BEDLAK(II),CNDFC1,CAQ,CNDFCT(II) + ELSE +C +C Horizontal conductance +C + TT = HK(I,J,K) +C X-DIRECTION + IF(NTYP.EQ.2) CNDFC2 = 2.0*TT*DELC(J)/DELR(I) +C Y-DIRECTION + IF(NTYP.EQ.3) THEN + IF(CHANI(K).LE.0) THEN + KH=-CHANI(K) + CNDFC2 = 2.0*HANI(I,J,KH)*TT*DELR(I)/DELC(J) + ELSE + CNDFC2 = 2.0*CHANI(K)*TT*DELR(I)/DELC(J) + ENDIF + ENDIF + IF(NTYP.EQ.2) CNDFC1 = BEDLAK(II)*DELC(J) + IF(NTYP.EQ.3) CNDFC1 = BEDLAK(II)*DELR(I) + IF (CNDFC1.GT.0.0.AND.CNDFC2.GT.0.0) + * CNDFCT(II) = 1.0/(1.0/CNDFC2+1.0/CNDFC1) + WRITE(IOUT,7325) (ILAKE(I1,II),I1=1,5),DELC(J),DELR(I), + 1 BEDLAK(II),CNDFC1,CNDFC2,CNDFCT(II) +c-lfk + 7325 FORMAT(1X,5I3,2X,1P,5E10.2,E11.3) +c 7325 FORMAT(1X,5I3,2X,1P,6E10.2) + ENDIF + 350 CONTINUE +C + RETURN + END SUBROUTINE SGWF2LAK7LPF7RPS +C + SUBROUTINE SGWF2LAK7UPW1RPS() +C +C ****************************************************************** +C COMPUTE VERTICAL CONDUCTANCES AND HORIZONTAL CONDUCTANCES PER UNIT +C THICKNESS FOR LAKES WHEN UPW PACKAGE IS USED +C ****************************************************************** +C +C ------------------------------------------------------------------ +C SPECIFICATIONS: +C ------------------------------------------------------------------ + USE GWFLAKMODULE, ONLY: LKNODE, BEDLAK, LKARR1, ILAKE, CNDFCT + USE GLOBAL, ONLY: NLAY, IOUT, LBOTM, LAYCBD, DELR, DELC, + + BOTM + USE GWFUPWMODULE, ONLY: CHANI, LAYVKAUPW, VKAUPW, VKCB, HANI, + + HKUPW +C + WRITE(IOUT,108) + 108 FORMAT(//9X,'C',15X,'INTERFACE CONDUCTANCES BETWEEN LAKE AND ', + 1 'AQUIFER CELLS'/ + 2 3X,'L',5X,'O',10X,'(IF TYPE = 6, CONDUCTANCE (L^2/T) IS ', + 3 'BETWEEN AQUIFER CELL AND OVERLYING LAKE CELL.)',/ + 4 3X,'A',5X,'L',2X,'L',2X,'T', + 5 4X,'(IF TYPE = 1 TO 4, CONDUCTANCES ARE PER UNIT SATURATED ', + 6 'THICKNESS (L/T).)'/ + 7 3X,'Y',2X,'R',2X,'U',2X,'A',2X,'Y'/ + 8 3X,'E',2X,'O',2X,'M',2X,'K',2X,'P', + 9 24X,'LAKEBED',6X,'C O N D U C T A N C E S'/3X,'R',2X,'W',2X, + 1 'N',2X,'E', + 2 2X,'E',5X,'DELTA Y',3X,'DELTA X',2X,'LEAKANCE',3X,'LAKEBED',3X, + 3 'AQUIFER',2X,'COMBINED'/1X,79('_')) +C + DO 350 II=1,LKNODE + K = ILAKE(1,II) + J = ILAKE(2,II) + I = ILAKE(3,II) + CAQ = 0.0 + CNDFCT(II) = 0.0 +C Convert ILAKE(5,II): 1 and 2 are type 1, 3 and 4 are type 2, 6 is type 0 + NTYP = (ILAKE(5,II)+1)/2 + IF(NTYP.EQ.3) NTYP=0 + NTYP=NTYP + 1 + IF(NTYP.EQ.1) THEN +C +C Vertical Conductance +C for vertical interface, "K" is layer below bottom of lake + CNDFC1=0.0 + IF(K.EQ.NLAY.AND.LKARR1(I,J,K).GT.0) GO TO 315 + IF(BEDLAK(II).LE.0.0) GO TO 315 + CNDFC1 = BEDLAK(II)*DELR(I)*DELC(J) + IF(LAYVKAUPW(K).EQ.0) THEN + VK=VKAUPW(I,J,K) + ELSE + VK=HKUPW(I,J,K)/VKAUPW(I,J,K) + END IF +c skip if zero vk + IF(VK.LE.0.0) GO TO 350 + BBOT=BOTM(I,J,LBOTM(K)) + TTOP=BOTM(I,J,LBOTM(K)-1) + CAQ=VK*DELR(I)*DELC(J)/((TTOP-BBOT)*0.5) + IF(LAYCBD(K-1).GT.0) THEN +c skip if zero vkcb + IF(VKCB(I,J,LAYCBD(K)).LE.0.0) GO TO 350 + BBOT=BOTM(I,J,LBOTM(K)-1) + TTOP=BOTM(I,J,LBOTM(K-1)) + CCB=VKCB(I,J,LAYCBD(K-1))*DELR(I)*DELC(J)/(TTOP-BBOT) + !include VKCB + CAQ = 1.0/(1.0/CAQ + 1.0/CCB) + END IF + CNDFCT(II) = 1.0/(1.0/CAQ+1.0/CNDFC1) + 315 WRITE(IOUT,7325) (ILAKE(I1,II),I1=1,5),DELC(J),DELR(I), + 1 BEDLAK(II),CNDFC1,CAQ,CNDFCT(II) + ELSE +C +C Horizontal conductance +C + TT = HKUPW(I,J,K) +C X-DIRECTION + IF(NTYP.EQ.2) CNDFC2 = 2.0*TT*DELC(J)/DELR(I) +C Y-DIRECTION + IF(NTYP.EQ.3) THEN + IF(CHANI(K).LE.0) THEN + KH=-CHANI(K) + CNDFC2 = 2.0*HANI(I,J,KH)*TT*DELR(I)/DELC(J) + ELSE + CNDFC2 = 2.0*CHANI(K)*TT*DELR(I)/DELC(J) + END IF + END IF + IF(NTYP.EQ.2) CNDFC1 = BEDLAK(II)*DELC(J) + IF(NTYP.EQ.3) CNDFC1 = BEDLAK(II)*DELR(I) + IF (CNDFC1.GT.0.0.AND.CNDFC2.GT.0.0) + * CNDFCT(II) = 1.0/(1.0/CNDFC2+1.0/CNDFC1) + WRITE(IOUT,7325) (ILAKE(I1,II),I1=1,5),DELC(J),DELR(I), + 1 BEDLAK(II),CNDFC1,CNDFC2,CNDFCT(II) + 7325 FORMAT(1X,5I3,2X,1P,6E10.2) + END IF + 350 CONTINUE +C + RETURN + END SUBROUTINE SGWF2LAK7UPW1RPS + +Cdep Added function statements to compute derivatives for Newton method +Cdep used in solving lake stage in the FORMULATE SUBROUTINE (LAK7FM). + DOUBLE PRECISION FUNCTION FINTERP (STAGE,LN) +Cdep&rgn FUNCTION LINEARLY INTERPOLATES BETWEEN TWO VALUES +C OF LAKE STAGE TO CACULATE LAKE AREA. +C ADDED 5/16/2006-- changed 12/2007 from "DOUBLE PRECISION FUNCTION" +C to "FUNCTION" + USE GWFLAKMODULE, ONLY: AREATABLE, DEPTHTABLE + IMPLICIT NONE + DOUBLE PRECISION STAGE, AREA, TOLF2, FOLD + DOUBLE PRECISION a1, a2, d1, d2 + INTEGER LN, IFLG, I + TOLF2=1.0E-7 + IF (STAGE.GT.DEPTHTABLE(151,LN))THEN + FINTERP = AREATABLE(151,LN) + RETURN + ENDIF + IFLG = 0 + I = 1 + DO WHILE ( IFLG.EQ.0 ) + a1 = AREATABLE(I,LN) + a2 = AREATABLE(I+1,LN) + d1 = DEPTHTABLE(I,LN) + d2 = DEPTHTABLE(I+1,LN) + FOLD=ABS(STAGE-d1) + IF (FOLD .LE. TOLF2) THEN + AREA=AREATABLE(I,LN) + IFLG = 1 + ELSEIF (STAGE.GT.d1 .AND. STAGE.LT.d2)THEN + AREA=((a2-a1)/(d2-d1))*STAGE+a2-((a2-a1)/(d2-d1))*d2 + IFLG = 1 + ENDIF + I = I + 1 + IF( I.GT.150 ) THEN + IFLG = 1 + AREA = AREATABLE(151,LN) + ENDIF + ENDDO + FINTERP = AREA + RETURN + END FUNCTION FINTERP + +! RGN Added function statements to compute calculate surface area form volume + DOUBLE PRECISION FUNCTION SURFTERP (VOLUME,LN) +C FUNCTION LINEARLY INTERPOLATES BETWEEN TWO VALUES +C OF LAKE VOLUME TO CACULATE LAKE AREA. + USE GWFLAKMODULE, ONLY: AREATABLE, VOLUMETABLE + DOUBLE PRECISION VOLUME + TOLF2=1.0E-7 + IF (VOLUME.GT.VOLUMETABLE(151,LN))THEN + SURFTERP = AREATABLE(151,LN) + RETURN + ENDIF + IFLG = 0 + I = 1 + DO WHILE ( IFLG.EQ.0 ) + FOLD=ABS(VOLUME-VOLUMETABLE(I,LN)) + IF (FOLD .LE. TOLF2) THEN + AREA=AREATABLE(I,LN) + IFLG = 1 + ELSEIF (VOLUME.GT.VOLUMETABLE(I,LN) .AND. VOLUME.LT. + 1 VOLUMETABLE(I+1,LN))THEN + AREA=((AREATABLE(I+1,LN)-AREATABLE(I,LN))/ + 1 (VOLUMETABLE(I+1,LN)- VOLUMETABLE(I,LN)))* + 2 VOLUME+AREATABLE(I+1,LN)-((AREATABLE(I+1,LN)- + 3 AREATABLE(I,LN))/(VOLUMETABLE(I+1,LN)- + 4 VOLUMETABLE(I,LN)))*VOLUMETABLE(I+1,LN) + IFLG = 1 + ENDIF + I = I + 1 + IF( I.GT.150 ) IFLG = 1 + ENDDO + SURFTERP = AREA + RETURN + END FUNCTION SURFTERP +! +! Interpolate lake volume as a function of lake stage +C used in solving lake stage in the FORMULATE SUBROUTINE (LAK7FM). + DOUBLE PRECISION FUNCTION VOLTERP (STAGE,LN) +C FUNCTION LINEARLY INTERPOLATES BETWEEN TWO VALUES +C OF LAKE STAGE TO CACULATE LAKE VOLUME. + USE GWFLAKMODULE, ONLY: VOLUMETABLE, DEPTHTABLE, AREATABLE + IMPLICIT NONE + INTEGER LN, IFLG, I + DOUBLE PRECISION STAGE, VOLUME, TOLF2, FOLD + TOLF2=1.0E-7 + IF (STAGE.GT.DEPTHTABLE(151,LN))THEN + ! bug 5/4/09 changed FINTERP TO VOLUME + VOLTERP = VOLUMETABLE(151,LN)+(STAGE-DEPTHTABLE(151,LN))* + + AREATABLE(151,LN) + RETURN + ENDIF + IFLG = 0 + I = 1 + DO WHILE ( IFLG.EQ.0 ) + FOLD=ABS(STAGE-DEPTHTABLE(I,LN)) + IF (FOLD .LE. TOLF2) THEN + VOLUME=VOLUMETABLE(I,LN) + IFLG = 1 + ELSEIF (STAGE.GT.DEPTHTABLE(I,LN) .AND. STAGE.LT. + 1 DEPTHTABLE(I+1,LN))THEN + VOLUME=((VOLUMETABLE(I+1,LN)-VOLUMETABLE(I,LN))/ + 1 (DEPTHTABLE(I+1,LN)- DEPTHTABLE(I,LN)))* + 2 STAGE+VOLUMETABLE(I+1,LN)-((VOLUMETABLE(I+1,LN)- + 3 VOLUMETABLE(I,LN))/(DEPTHTABLE(I+1,LN)- + 4 DEPTHTABLE(I,LN)))*DEPTHTABLE(I+1,LN) + IFLG = 1 + ENDIF + I = I + 1 + IF( I.GT.150 ) THEN + IFLG = 1 + VOLUME = VOLUMETABLE(151,LN) + ENDIF + ENDDO + VOLTERP = VOLUME + IF ( VOLTERP.LT.TOLF2 ) VOLTERP = TOLF2 + RETURN + END FUNCTION VOLTERP + +! Interpolate lake STAGE as a function of lake VOLUME +C used in solving lake stage in the FORMULATE SUBROUTINE (LAK7FM). + DOUBLE PRECISION FUNCTION STGTERP (VOLUME,LN) +C FUNCTION LINEARLY INTERPOLATES BETWEEN TWO VALUES +C OF LAKE VOLUME TO CACULATE LAKE STAGE. + USE GWFLAKMODULE, ONLY: VOLUMETABLE, DEPTHTABLE,AREATABLE + DOUBLE PRECISION VOLUME, STAGE + TOLF2=1.0E-7 + IF (VOLUME.GT.VOLUMETABLE(151,LN))THEN + STGTERP = DEPTHTABLE(151,LN)+(VOLUME-VOLUMETABLE(151,LN))/ + + AREATABLE(151,LN) + RETURN + ENDIF + IFLG = 0 + I = 1 + DO WHILE ( IFLG.EQ.0 ) + FOLD=ABS(VOLUME-VOLUMETABLE(I,LN)) + IF (FOLD .LE. TOLF2) THEN + STGTERP=DEPTHTABLE(I,LN) + IFLG = 1 + ELSEIF (VOLUME.GT.VOLUMETABLE(I,LN) .AND. VOLUME.LT. + 1 VOLUMETABLE(I+1,LN))THEN + STGTERP=((DEPTHTABLE(I+1,LN)-DEPTHTABLE(I,LN))/ + 1 (VOLUMETABLE(I+1,LN)- VOLUMETABLE(I,LN)))* + 2 VOLUME+DEPTHTABLE(I+1,LN)-((DEPTHTABLE(I+1,LN)- + 3 DEPTHTABLE(I,LN))/(VOLUMETABLE(I+1,LN)- + 4 VOLUMETABLE(I,LN)))*VOLUMETABLE(I+1,LN) + IFLG = 1 + ENDIF + I = I + 1 + IF( I.GT.150 ) THEN + IFLG = 1 + STGTERP= 0.0 + ENDIF + ENDDO + RETURN + END FUNCTION STGTERP + +C------FUNCTION DERIVTERP FOR INTERPOLATING DERIVATIVE OF LAKE OUTFLOW. + DOUBLE PRECISION FUNCTION DERIVTERP (STAGE,LSEG) +Cdep&rgn FUNCTION LINEARLY INTERPOLATES BETWEEN TWO VALUES +C OF LAKE STAGE TO CACULATE LAKE OUTFLOW DERIVATIVE. +C ADDED 5/16/2006-- changed 12/2007 from "DOUBLE PRECISION FUNCTION" +C to "FUNCTION" + USE GWFSFRMODULE, ONLY: DLKOTFLW, DLKSTAGE + DOUBLE PRECISION STAGE, DEROTFLW, FOLD + TOLF2=1.0E-7 + IF (STAGE.GT.DLKSTAGE(200,LSEG))THEN + DERIVTERP = DLKOTFLW(200,LSEG) + RETURN + ENDIF + IFLG = 0 + I = 1 + DO WHILE ( IFLG.EQ.0 ) + FOLD=ABS(STAGE-DLKSTAGE(I,LSEG)) + IF (FOLD .LE. TOLF2) THEN + DEROTFLW=DLKOTFLW(I,LSEG) + IFLG = 1 !rsr, changed ISFLG to IFLG + ELSEIF (STAGE.LT.DLKSTAGE(1,LSEG)) THEN + DEROTFLW=0.0D0 + IFLG = 1 + ELSEIF (STAGE.GT.DLKSTAGE(I,LSEG) .AND. STAGE.LT. + 1 DLKSTAGE(I+1,LSEG))THEN + DEROTFLW=((DLKOTFLW(I+1,LSEG)-DLKOTFLW(I,LSEG))/ + 1 (DLKSTAGE(I+1,LSEG)- DLKSTAGE(I,LSEG)))* + 2 STAGE+DLKOTFLW(I+1,LSEG)-((DLKOTFLW(I+1,LSEG)- + 3 DLKOTFLW(I,LSEG))/(DLKSTAGE(I+1,LSEG)- + 4 DLKSTAGE(I,LSEG)))*DLKSTAGE(I+1,LSEG) + IFLG = 1 + ENDIF + I = I + 1 + IF( I.GT.199) IFLG = 1 + ENDDO + DERIVTERP = DEROTFLW + RETURN + END FUNCTION DERIVTERP + +C------FUNCTION OUTFLWTERP FOR INTERPOLATING DERIVATIVE OF LAKE OUTFLOW. + DOUBLE PRECISION FUNCTION OUTFLWTERP (STAGE,LSEG) +Cdep&rgn FUNCTION LINEARLY INTERPOLATES BETWEEN TWO VALUES +C OF LAKE OUTFLOW STORED IN SLKOTFLW ARRAY. +C ADDED 5/16/2006-- changed 12/2007 from "DOUBLE PRECISION FUNCTION" +C to "FUNCTION" + USE GWFSFRMODULE, ONLY: SLKOTFLW, DLKSTAGE + DOUBLE PRECISION STAGE, OUTFLOW, FOLD + TOLF2=1.0E-9 + IF (STAGE.GT.DLKSTAGE(200,LSEG))THEN + OUTFLWTERP = SLKOTFLW(200,LSEG) + RETURN + ENDIF + IFLG = 0 + I = 1 + DO WHILE ( IFLG.EQ.0 ) + FOLD=DABS(STAGE-DLKSTAGE(I,LSEG)) + IF (FOLD .LE. TOLF2) THEN + OUTFLOW=SLKOTFLW(I,LSEG) + IFLG = 1 + ELSEIF (STAGE.LT.DLKSTAGE(1,LSEG)) THEN + OUTFLOW=0.0D0 + IFLG = 1 + ELSEIF (STAGE.GT.DLKSTAGE(I,LSEG) .AND. STAGE.LT. + 1 DLKSTAGE(I+1,LSEG))THEN + OUTFLOW=((SLKOTFLW(I+1,LSEG)-SLKOTFLW(I,LSEG))/ + 1 (DLKSTAGE(I+1,LSEG)- DLKSTAGE(I,LSEG)))* + 2 STAGE+SLKOTFLW(I+1,LSEG)-((SLKOTFLW(I+1,LSEG)- + 3 SLKOTFLW(I,LSEG))/(DLKSTAGE(I+1,LSEG)- + 4 DLKSTAGE(I,LSEG)))*DLKSTAGE(I+1,LSEG) + IFLG = 1 + ENDIF + I = I + 1 + IF( I.GT.199) IFLG = 1 + ENDDO + OUTFLWTERP = OUTFLOW + RETURN + END FUNCTION OUTFLWTERP +C +C------FUNCTION FXLKOT_TERP FOR SMOOTHING SPECIFIED LAKE OUTFLOWS TO STREAMS. +C + DOUBLE PRECISION FUNCTION FXLKOT_TERP(DSTAGE,Botlake,Splakout,dy) + IMPLICIT NONE + DOUBLE PRECISION DSTAGE,Botlake,Splakout, s, aa, ad, b, x, y, dy + FXLKOT_TERP = 0.0D0 + s = 2.0 + x = DSTAGE-Botlake + aa = -1.0d0/(s**2.0d0) + ad = -2.0D0/(s**2.0d0) + b = 2.0d0/s + y = aa*x**2.0d0 + b*x + dy = (ad*x + b)*Splakout + IF ( x.LE.0.0 ) THEN + y = 0.0D0 + dy = 0.0D0 + ELSEIF ( x-s.GT.-1.0e-14 ) THEN + y = 1.0D0 + dy = 0.0D0 + ENDIF + FXLKOT_TERP = y*Splakout + END FUNCTION FXLKOT_TERP +C + SUBROUTINE GET_FLOBOT(IC, IR, IL, ITYPE, INOFLO,CONDUC, + 1 FLOBOT,FLOBO3,FLOTOUZF,DLSTG,CLOSEZERO,H, + 2 THET1,ISS,LAKE,II,SURFDPTH,AREA,IUNITUZF, + 3 BOTLK,BOTCL,L1) +C +C ****************************************************************** +C CALCULATE SEEPAGE BETWEEN LAKE AND GW CELLS +C ****************************************************************** +C + USE GWFLAKMODULE + USE GLOBAL, ONLY: IBOUND, IOUT, LBOTM, BOTM, NLAY,LAYHDT + USE GWFUZFMODULE, ONLY: IUZFBND,FINF,VKS + IMPLICIT NONE +C ------------------------------------------------------------------ +C SPECIFICATIONS: +C ------------------------------------------------------------------ +C FUNCTIONS +C ----------------------------------------------------------------- +C ----------------------------------------------------------------- +C ARGUMENTS + DOUBLE PRECISION FLOBO3,FLOBOT,CONDUC,H,THET1,CLOSEZERO,DLSTG, + 1 SURFDPTH,AREA,BOTLK,BOTCL,HH + INTEGER ISS, LAKE, II, IC, IR, IL, ITYPE, IUNITUZF, L1 +C ----------------------------------------------------------------- + INTEGER ICHECK, LI, INOFLO + DOUBLE PRECISION FLOBO1,FLOBO2,CONDMX,BOTLKUP, + 1 BOTLKDN,FLOTOUZF,RAMPGW,RAMPSTGO,RAMPSTGN, + 2 RAMPSTGON,HTEMP,HD,THCK,RAMPUP +C +C5C-----INITIALIZE GROUNDWATER SEEPAGE VARIABLES AND CONDUCTANCE FACTOR. + FLOBO1 = 0.0D0 + FLOBO2 = 0.0D0 +C +C6------COMPUTE SEEPAGE INTO OR OUT OF A LAKE BED NODE WHEN ITYPE=0. +C HEAD CANNOT FALL BELOW LAKE BOTTOM + IF (ITYPE.EQ.0) THEN +C +C6B------RAMP CONDUCTANCE ACROSS HORIZONTAL CELL FACE WHEN +C LAKE STAGE AND GROUNDWATER HEAD NEAR LAKEBED. + BOTLKUP = BOTLK + SURFDPTH + BOTLKDN = BOTLK + CONDMX = CONDUC + HH = H + IF ( HH.LT.BOTLKDN ) THEN + HH = BOTLKDN + INOFLO = 1 + ENDIF + IF(SURFDPTH.GT.CLOSEZERO) THEN + RAMPGW = CONDMX-(CONDMX/SURFDPTH)* + + (BOTLKUP-HH) + IF ( RAMPGW-CONDMX.GT.0.0D0 ) RAMPGW = CONDMX + IF ( RAMPGW.LE.0.0D0 ) RAMPGW = 0.0D0 + RAMPSTGO = CONDMX-(CONDMX/SURFDPTH)* + + (BOTLKUP-STGOLD(LAKE)) + IF ( RAMPSTGO-CONDMX.GT.0.0D0 ) RAMPSTGO = CONDMX + IF ( RAMPSTGO.LE.0.0D0 ) RAMPSTGO = 0.0D0 + RAMPSTGN = CONDMX-(CONDMX/SURFDPTH)* + + (BOTLKUP-STGNEW(LAKE)) + IF ( RAMPSTGN-CONDMX.GT.0.0D0 ) RAMPSTGN = CONDMX + IF ( RAMPSTGN.LE.0.0D0 ) RAMPSTGN = 0.0D0 + ELSE + RAMPGW=CONDMX + RAMPSTGO=CONDMX + RAMPSTGN=CONDMX + ENDIF + IF( HH-BOTLKDN.GT.CLOSEZERO ) THEN + HTEMP = HH + ELSE + HTEMP=BOTLKDN + ENDIF +C +C6C------COMPUTE LAKE SEEPAGE FOR STGOLD USING FLOBO1. +C USE UPSTREAM WEIGHTING + IF ( HH.LT.STGOLD(LAKE) ) THEN + RAMPUP = RAMPSTGO + ELSE + RAMPUP = RAMPGW + ENDIF + CONDUC = RAMPUP + IF( STGOLD(LAKE)-BOTLKDN.GT.CLOSEZERO ) THEN + FLOBO1=CONDUC*(STGOLD(LAKE)-HTEMP) + ELSE + FLOBO1=CONDUC*(BOTLKDN-HTEMP) + ENDIF + IF ( IUNITUZF.GT.0 ) THEN + IF ( IUZFBND(IC,IR).GT.0 )THEN + IF (HH-BOTLK.LT.-0.5*SURFDPTH) THEN + IF ( VKS(IC,IR)*AREA-FLOBO1.LT.CLOSEZERO ) + + THEN + FLOBO1 = VKS(IC,IR)*AREA + ENDIF + ENDIF + ENDIF + ENDIF +C +C6D------COMPUTE LAKE SEEPAGE FOR STGNEW USING FLOBO2 AND FLOBO3. +C USE UPSTREAM WEIGHTING + IF ( HH.LT.STGNEW(LAKE) ) THEN + RAMPUP = RAMPSTGN + ELSE + RAMPUP = RAMPGW + ENDIF + CONDUC = RAMPUP + IF( STGNEW(LAKE)-BOTLKDN.GT.CLOSEZERO ) THEN + FLOBO2 = CONDUC*(STGNEW(LAKE)-HTEMP) + FLOBO3 = CONDUC*(STGNEW(LAKE)+DLSTG-HTEMP) + ELSE + FLOBO2 = CONDUC*(BOTLKDN-HTEMP) + FLOBO3 = CONDUC*(BOTLKDN+DLSTG-HTEMP) + ENDIF + IF ( IUNITUZF.GT.0 ) THEN + IF ( IUZFBND(IC,IR).GT.0 )THEN + IF ( HH-BOTLK.LT.-0.5*SURFDPTH ) THEN + IF ( VKS(IC,IR)*AREA-FLOBO2.LT.CLOSEZERO ) + + THEN + FLOBO2 = VKS(IC,IR)*AREA + FLOBO3 = VKS(IC,IR)*AREA + ENDIF + ENDIF + ENDIF + ENDIF +C +C6E------COMPUTE LAKE SEEPAGE (FLOBOT) AS A FRACTION OF FLOBO1 AND +C FLOB02 AND FLOBO3 AS A FRACTION OF FLOBO1 AND FLOBO3. + FLOBOT = THET1*FLOBO2 + (1.0D0-THET1)*FLOBO1 + FLOBO3 = THET1*FLOBO3 + (1.0D0-THET1)*FLOBO1 +! CONDUC = THET1*RAMPSTGN + (1.0D0-THET1)*RAMPSTGO + IF ( IUNITUZF.GT.0 ) THEN + IF ( IUZFBND(IC,IR).GT.0 )THEN + IF ( HH-BOTLK.LT.-0.5*SURFDPTH ) THEN + IF ( FLOBOT/AREA.GT.VKS(IC,IR) ) THEN + FLOBOT = VKS(IC,IR)*AREA + FLOBO3 = FLOTOUZF + ENDIF + FLOTOUZF = FLOBOT + FLOBOT = 0.0D0 + CONDUC = FLOTOUZF/(STGNEW(LAKE)-BOTLK) + FINF(IC,IR)=FLOTOUZF/AREA + ENDIF + ENDIF + ENDIF +C +C7------COMPUTE SEEPAGE INTO OR OUT OF A LAKE WALL NODE +C WHEN ITYPE=1 OR 2. + ELSEIF ( ITYPE.EQ.1.OR.ITYPE.EQ.2 ) THEN + IF( IBOUND(IC,IR,IL).GT.0 ) THEN + HD = H + IF( H.GT.BOTM(IC,IR,LBOTM(IL)-1) ) + 1 HD = BOTM(IC,IR,LBOTM(IL)-1) +C +C7B------CONDUCTANCE ACROSS VERTICAL CELL FACE DEPENDENT ON +C SATURATED THICKNESS. + IF ( LAYHDT(il).GT.0 ) THEN + THCK = HD - BOTCL + ELSE + THCK = BOTM(IC,IR,LBOTM(IL)-1) - BOTCL + ENDIF + IF( THCK.LE.0.0 ) THCK = 0.0 + CONDUC = CONDUC*THCK + IF ( H.LT.BOTM(IC,IR,LBOTM(IL)) ) + + H = BOTM(IC,IR,LBOTM(IL)) +C +C7C------COMPUTE LAKE SEEPAGE FOR STGOLD USING FLOBO1. + IF( STGOLD(LAKE)-BOTCL.GT.CLOSEZERO ) THEN + FLOBO1 = CONDUC*(STGOLD(LAKE)-H) + ELSEIF ( H-BOTCL.GT.CLOSEZERO ) THEN + FLOBO1 = CONDUC*(BOTCL-H) + ENDIF +C +C7D------COMPUTE LAKE SEEPAGE FOR STGNEW USING FLOBO2 AND FLOBO3. + IF( STGNEW(LAKE)-BOTCL.GT.CLOSEZERO )THEN + FLOBO3 = CONDUC*(STGNEW(LAKE)+DLSTG-H) + FLOBO2 = CONDUC*(STGNEW(LAKE)-H) + ELSEIF ( H-BOTCL.GT.CLOSEZERO ) THEN + FLOBO3 = CONDUC*(BOTCL+DLSTG-H) + FLOBO2 = CONDUC*(BOTCL-H) + ELSEIF ( STGNEW(LAKE)+DLSTG.GE.BOTCL )THEN + FLOBO3 = CONDUC*(STGNEW(LAKE)+DLSTG-H) + ENDIF +C +C7E------COMPUTE LAKE SEEPAGE (FLOBOT) AS A FRACTION OF FLOBO1 AND +C FLOB02 AND FLOBO3 AS A FRACTION OF FLOBO1 AND FLOBO3. + FLOBOT = THET1*FLOBO2 + (1.0D0-THET1)*FLOBO1 + FLOBO3 = THET1*FLOBO3 + (1.0D0-THET1)*FLOBO1 + SUMCNN(LAKE) = SUMCNN(LAKE) + CONDUC + ENDIF + ENDIF +C +C8-------SEEPAGE RATES ADDED TO MATRIX AND RESIDUAL TERMS. +C8B------COMPUTE FLWITER AND FLWITER3 DURING FIRST LOOP THROUGH +C CALCULATIONS. NEGATIVE FLOBOT MEANS INTO LAKE + IF ( II==1 ) THEN + IF ( FLOBOT.LT.0.0D0 ) FLWITER(LAKE) = + + FLWITER(LAKE) - FLOBOT + IF ( FLOBO3.LT.0.0D0 ) FLWITER3(LAKE) = + + FLWITER3(LAKE) - FLOBO3 + ENDIF +C8C------COMPUTE FLWITER AND FLOWITER3 DURING SECOND LOOP THROUGH +C CALCULATIONS. + IF ( II==2 ) THEN + IF ( FLOBOT>=FLWITER(LAKE) ) THEN + IF ( FLOBOT.GT.CLOSEZERO ) THEN +! FLOBO2=FLWITER(LAKE) +! FLOBOT = THET1*FLOBO2 + (1.0D0-THET1)*FLOBO1 + FLOBOT = FLWITER(LAKE) + FLWITER(LAKE) = 0.0 + INOFLO = 1 + ENDIF + ELSEIF ( FLOBOT.GT.CLOSEZERO )THEN + FLWITER(LAKE) = FLWITER(LAKE) - FLOBOT + ENDIF + IF ( FLOTOUZF>=FLWITER(LAKE) ) THEN + IF ( FLOTOUZF.GT.CLOSEZERO ) THEN + FLOTOUZF=FLWITER(LAKE) + ! FLOTOUZF = THET1*FLOTOUZF + (1.0D0-THET1)*FLOBO1 + FLWITER(LAKE) = 0.0 + INOFLO = 1 + ENDIF + ELSEIF ( FLOTOUZF.GT.CLOSEZERO )THEN + FLWITER(LAKE) = FLWITER(LAKE) - FLOTOUZF + ENDIF + IF ( FLOBO3>=FLWITER3(LAKE) ) THEN + IF ( FLOBO3.GT.CLOSEZERO ) THEN + FLOBO3=FLWITER3(LAKE) + ! FLOBO3 = THET1*FLOBO3 + (1.0D0-THET1)*FLOBO1 + FLWITER3(LAKE) = 0.0 + INOFLO = 1 + ENDIF + ELSEIF ( FLOBO3.GT.CLOSEZERO )THEN + FLWITER3(LAKE) = FLWITER3(LAKE) - FLOBO3 + ENDIF + ENDIF +C +C6E------COMPUTE LAKE SEEPAGE (FLOBOT) AS A FRACTION OF FLOBO1 AND +C FLOB02 AND FLOBO3 AS A FRACTION OF FLOBO1 AND FLOBO3. + RETURN + END SUBROUTINE GET_FLOBOT +C + end module GwfLakSubs diff --git a/utils/mf5to6/src/Model.f90 b/utils/mf5to6/src/Model.f90 index 479bcf3e4d4..da37a263dcf 100755 --- a/utils/mf5to6/src/Model.f90 +++ b/utils/mf5to6/src/Model.f90 @@ -174,11 +174,11 @@ subroutine Initialize(this, namefile, basename) endif allocate(this%IcWriter) ! - allocate(this%IbChdWriter) + allocate(this%IbChdWriter) this%IbChdWriter%ModelBasename = trim(basename) // '.ib' call this%IbChdWriter%AllocatePointers() ! this%IbChdWriter%PackageName = 'CHD' - this%IbChdWriter%source = 'IBOUND' + this%IbChdWriter%source = 'IBOUND' this%IbChdWriter%PkgObsWriter%Source = 'IBOUND' !allocate(this%IbChdWriter%fileobj) call this%IbChdWriter%fileobj%Initialize() @@ -187,7 +187,7 @@ subroutine Initialize(this, namefile, basename) allocate(this%FhbWriter) !this%FhbWriter%ModelBasename = basename ! this%FhbWriter%PackageName = 'FHB' - allocate(this%FhbWriter%fileobj) + allocate(this%FhbWriter%fileobj) this%FhbWriter%ModelBaseName = basename call this%FhbWriter%fileobj%Initialize() this%FhbWriter%fileobj%PkgName = this%FhbWriter%PackageName @@ -564,8 +564,8 @@ function AddPackage(this, PType) result(PkgWriter) case ('CHD') pw => ChdWriter if (.not. this%ContainsPackageWriterOfType(pw)) then - allocate(ChdWriter) - ChdWriter%ModelBasename = this%BaseName + allocate(ChdWriter) + ChdWriter%ModelBasename = this%BaseName call ChdWriter%AllocatePointers() PkgWriter => ChdWriter PkgWriter%ModelMovers => this%ModelMovers @@ -696,7 +696,7 @@ function AddPackage(this, PType) result(PkgWriter) call SfrWriter%fileobj%Initialize() SfrWriter%PkgType = 'SFR' SfrWriter%Igrid = this%IGrid - write(SfrWriter%PackageName,10)'SFR_',this%IGrid + write(SfrWriter%PackageName,10)'SFR_',this%IGrid PkgWriter => SfrWriter PkgWriter%ModelMovers => this%ModelMovers call this%AddPackageWriter(PkgWriter) @@ -983,8 +983,8 @@ subroutine InitializeIdomain(this) ! dummy class(ModelType), intent(inout) :: this ! local - integer :: i, ilay, j, k, idim1, idim2, idim3, kbot - integer :: kk + integer :: i, ilay, j, k, idim1, idim2, idim3, kbot + integer :: kk double precision :: b character(len=MAXCHARLEN) :: msg logical :: WetdryActive @@ -1061,13 +1061,13 @@ subroutine InitializeIdomain(this) ! Assign Idomain of nodes corresponding to underlying ! quasi-3d unit equal to Idomain of current layer. do i=1,nrow - do j=1,ncol - kk = LBOTM(k) - b = BOTM(j,i,kk) - BOTM(j,i,kk+1) + do j=1,ncol + kk = LBOTM(k) + b = BOTM(j,i,kk) - BOTM(j,i,kk+1) if (b > DZERO) then - this%Idomain(j,i,kk+1) = this%Idomain(j,i,kk) - else - this%Idomain(j,i,kk+1) = -1 + this%Idomain(j,i,kk+1) = this%Idomain(j,i,kk) + else + this%Idomain(j,i,kk+1) = -1 end if enddo enddo diff --git a/utils/mf5to6/src/ModelConverter.f90 b/utils/mf5to6/src/ModelConverter.f90 index 194e5bdf2bd..b7bfb2b77e7 100644 --- a/utils/mf5to6/src/ModelConverter.f90 +++ b/utils/mf5to6/src/ModelConverter.f90 @@ -22,7 +22,7 @@ module ModelConverterModule use GwfLgrSubsModule, only: GWF2LGR2AR use GwfLpfSubs, only: GWF2LPF7AR use HfBSubsNwt, only: GWF2HFB7AR, GWF2HFB7UPW - use InputOutputModule, only: GetUnit, openfile + use InputOutputModule, only: GetUnit, openfile use ListModule, only: ListType use ModelModule, only: ModelType use ModelPackageModule, only: ModelPackageType, ConstructModelPackageType diff --git a/utils/mf5to6/src/MultiLayerObsModule.f90 b/utils/mf5to6/src/MultiLayerObsModule.f90 index a51a3514e3c..5ea57812af2 100644 --- a/utils/mf5to6/src/MultiLayerObsModule.f90 +++ b/utils/mf5to6/src/MultiLayerObsModule.f90 @@ -2,7 +2,7 @@ module MultiLayerObs use ConstantsModule, only: DONE, MAXCHARLEN use ConstantsPHMFModule, only: LENOBSNAMENEW - use GenericUtilitiesModule, only: IS_SAME + use GenericUtilitiesModule, only: IS_SAME use ListModule, only: ListType use SimModule, only: store_error, ustop diff --git a/utils/mf5to6/src/NpfWriter.f90 b/utils/mf5to6/src/NpfWriter.f90 index 5936c0c07dd..2c7854ba6e4 100644 --- a/utils/mf5to6/src/NpfWriter.f90 +++ b/utils/mf5to6/src/NpfWriter.f90 @@ -1,722 +1,722 @@ -module NpfWriterModule - - use ConstantsModule, only: DONE, DZERO, DEM7, DHALF, DTWO - use ConstantsPHMFModule, only: HDRYDEFAULT, HNOFLODEFAULT - use FileListModule, only: FileListType - use FileTypeModule, only: FileType - use FileWriterModule, only: FileWriterType - use GLOBAL, only: ncol, nrow, nlay, ITMUNI, LENUNI, LAYCBD, NCNFBD, BOTM, & - LBOTM, cbcfilename - use GlobalVariablesModule, only: echo - use GWFBCFMODULE, only: LAYCON, WetdryBcf => WETDRY, vcont, TRPY - use GWFLPFMODULE, only: LAYTYP, LAYWET, VKCB, WetdryLpf => WETDRY, HANI - use GWFUPWMODULE, only: LaytypUpw, LaywetUpw => LAYWET, VkcbUpw => VKCB, & - WetdryUpw => WETDRY, HaniUpw => HANI - use InputOutputModule, only: GetUnit, openfile - use SimModule, only: count_errors, store_error, store_note, store_warning, & - ustop - use UtilitiesModule, only: Write2dValues - - type, extends(FileWriterType) :: NpfWriterType - double precision :: Hnoflo = hnoflodefault - double precision :: Hdry = hdrydefault - double precision :: Wetfct = DZERO - double precision :: MinSatThickness = DEM7 - double precision, allocatable, dimension(:,:,:) :: hk - double precision, allocatable, dimension(:,:,:) :: vk - double precision, allocatable, dimension(:,:,:) :: hani - double precision, pointer, dimension(:,:,:) :: WetDry => null() - integer :: Inpfcb = 0 - integer :: Iwetit = 1 - integer :: Ihdwet = 0 - integer :: NumConvertible = 0 - integer, pointer :: Nlaynew => null() - integer, allocatable, dimension(:) :: Icelltype ! dim = nlay - integer, pointer, dimension(:) :: Layptr => null() - logical :: VertFlowCorr = .false. - logical :: ConstantCv = .false. - logical :: CvCorrection = .false. - logical :: Rewet = .false. - logical :: Newton = .false. - logical :: ThickStrt = .false. - logical :: BottomHeadDamping = .false. - logical :: Perched = .false. - logical :: VariableCV = .false. - logical :: Dewatered = .false. - logical :: UseHani = .false. - character(len=3) :: FlowPackage = '' - character(len=11) :: CellAveraging = 'HARMONIC' - type(FileListType), pointer :: Mf2005Files => null() - type(FileListType), pointer :: Mf6Files => null() - contains - procedure :: InitializeFile - procedure :: AllocateArrays - procedure :: WriteFile - procedure, private :: WriteOptions - procedure, private :: assign_vk - end type NpfWriterType - -contains - - subroutine AllocateArrays(this) - implicit none - ! dummy - class(NpfWriterType), intent(inout) :: this - ! - if (.not. allocated(this%Icelltype)) then - allocate(this%Icelltype(nlay)) - allocate(this%hk(ncol,nrow,nlay)) - allocate(this%vk(ncol,nrow,this%Nlaynew)) - endif - this%hk = DZERO - this%vk = DONE - ! - return - end subroutine AllocateArrays - - subroutine InitializeFile(this, fname, ftype, pkgname) - implicit none - ! dummy - class(NpfWriterType), intent(inout) :: this - character(len=*), intent(in) :: fname - character(len=*), intent(in) :: ftype - character(len=*), intent(in), optional :: pkgname - ! local - ! - if (present(pkgname)) then - call this%FileWriterType%InitializeFile(fname, ftype, pkgname) - else - call this%FileWriterType%InitializeFile(fname, ftype) - endif - ! - return - end subroutine InitializeFile - - subroutine WriteFile(this) - implicit none - ! dummy - class(NpfWriterType), intent(inout) :: this - ! local - integer :: i, iprni, iprnr, iu, iwetdry, j, k, knew, & - idim1, idim2, idim3 - character(len=500) :: msg - logical :: constant, vkerr, wettable, writek33 - double precision :: hk, val0, valt - ! formats - 5 format() - 30 format(4x,a,2x,i0) - 40 format(4x,a,2x,g16.9) - 50 format(2x,a) - 60 format(a) - 100 format(a,1x,i0,1x,a,1x,i0,1x,a,1x,g10.3) - ! -! ! Rewetting settings -! if (associated(WetdryBcf)) then -! this%WetDry => WetdryBcf -! elseif (associated(WetdryLpf)) then -! this%WetDry => WetdryLpf -! elseif (associated(WetdryUpw)) then -! this%WetDry => WetdryUpw -! endif - if (this%FlowPackage == 'UPW') then - this%Rewet = .false. - this%WetDry = 0.01d0 - endif - ! - if (echo) then - iprni = 3 - iprnr = 12 - else - iprni = -3 - iprnr = -12 - endif - call this%WriteOptions() - ! - iu = this%fileobj%IUnit - write(iu,5) - write(iu,60)'BEGIN GRIDDATA' - ! - ! Icelltype (0: confined; >0: convertible; <0: see input instruct.) - ! (will be constant for each layer) - write(iu,50)'Icelltype LAYERED' - do k=1,nlay - write(iu,30)'CONSTANT', this%Icelltype(k) - if (LAYCBD(k) /= 0) then - ! Assume quasi-3d unit is not convertible - write(iu,30)'CONSTANT', 0 - endif - enddo - ! - ! HK - write(iu,50)'K LAYERED' - knew = 0 - do k=1,nlay - knew = knew + 1 - constant = .true. - val0 = this%hk(1,1,k) - do i=1,nrow - do j=1,ncol - if (this%hk(j,i,k) /= val0) then - constant = .false. - exit - endif - enddo - enddo - if (constant) then - write(iu,40)'CONSTANT', val0 - else - write(iu,30)'INTERNAL FACTOR 1.0 IPRN ',iprnr - call Write2dValues(iu,NROW,NCOL,this%hk(:,:,k)) - endif - if (LAYCBD(k) /= 0) then - knew = knew + 1 - ! Get a default value for HK - hk = get_q3d_hk() - write(iu,40)'CONSTANT', hk - write(msg,100)'Original quasi-3D unit below layer',k,'is now layer', & - knew,'and has been assigned HK value:',hk - call store_note(msg) - endif - enddo - ! - ! VK (may be problematic when converting from BCF? May need to solve - ! a system of NLAY-1 equations? What about Quasi-3D layers?) - ! -- Don't support BCF when NLAY > 1. For LPF, convert Q-3D layers to - ! active cells. - ! -- Better: For BCF, assign VK = HK for original BCF layers, and assign - ! VK = (default HK)/100 for new layer replacing a quasi-3d unit - if (this%FlowPackage == 'BCF') then - ! Assign all VK values - vkerr = .false. - call this%assign_vk(vkerr) - if (vkerr) then - do k=1,nlay - do i=1,nrow - do j=1,ncol - this%vk(j,i,k) = this%hk(j,i,k) - enddo - enddo - enddo - if (nlay>1) then - msg = 'For conversion of BCF layers to NPF package, definition of' // & - ' vertical hydraulic conductivity (VK) of each layer does' // & - ' not have a unique solution. For each layer, VK has been' // & - ' set to horizontal hydraulic conductivity (HK) of the' // & - ' original layer. These values likely will need to be' // & - ' adjusted by the modeler to approximate the original model.' - call store_note(msg) - if (NCNFBD > 0) then - msg = 'For conversion of BCF quasi-3D unit(s) to NPF package,' // & - ' default values of HK and VK have been assigned. These' // & - ' values likely will need to be adjusted by the modeler' // & - ' to approximate the original model.' - call store_note(msg) - endif - endif - endif - elseif (this%FlowPackage == 'LPF') then - ! Ned todo: is anything needed here? - ! Probably need to populate vk? - elseif (this%FlowPackage == 'UPW') then - ! Anything here? - endif - ! - ! -- Determine if necessary to write K33 - writek33 = .false. - if (nlay > 1) then - layerloop: do k=1,this%Nlaynew - do i=1,nrow - do j=1,ncol - if(this%vk(j,i,k) /= this%hk(j,i,k)) then - writek33 = .true. - exit layerloop - endif - enddo - enddo - enddo layerloop - endif - ! - if (writek33) then - write(iu,50)'K33 LAYERED' - do k=1,this%Nlaynew - constant = .true. - val0 = this%vk(1,1,k) - do i=1,nrow - do j=1,ncol - if (this%vk(j,i,k) /= val0) then - constant = .false. - exit - endif - enddo - enddo - if (constant) then - write(iu,40)'CONSTANT', val0 - else - write(iu,30)'INTERNAL FACTOR 1.0 IPRN ',iprnr - call Write2dValues(iu,NROW,NCOL,this%vk(:,:,k)) - endif - enddo - endif - ! - ! WETDRY - if (this%Rewet) then - write(iu,50)'WETDRY LAYERED' - iwetdry = 0 ! index to WETDRY array - do k=1,nlay - ! Determine if this layer is wettable - wettable = .false. - select case (this%FlowPackage) - case ('LPF') - if (LAYTYP(k) /= 0 .and. LAYWET(k) /= 0) then - wettable = .true. - endif - case ('UPW') - if (LAYTYPUPW(k) /= 0) then ! .and. LaywetUpw(k) /= 0) then - wettable = .true. - endif - case ('BCF') - if (LAYCON(k) == 1 .or. LAYCON(k) == 3) then - wettable = .true. - endif - end select - ! - ! If this layer is wettable, need nonzero Wetdry values - if (wettable) then - ! determine if laywet for this layer is constant - constant = .true. - val0 = this%WetDry(1,1,1) - idim1 = size(this%WetDry,1) - idim2 = size(this%WetDry,2) - idim3 = size(this%WetDry,3) - if (idim1 == ncol .and. idim2 == nrow .and. idim3 == nlay) then - val0 = this%WetDry(1,1,k) - do i=1,nrow - do j=1,ncol - if (this%WetDry(j,i,k) /= val0) then - constant = .false. - exit - endif - enddo - enddo - endif - if (constant) then - write(iu,40)'CONSTANT', val0 - else - write(iu,30)'INTERNAL FACTOR 1.0 IPRN ',iprnr - call Write2dValues(iu,NROW,NCOL,this%WetDry(:,:,k)) - endif - else - ! Layer is not wettable in LPF, but needs to be assigned Wetdry = 0 in NPF - write(iu,40)'CONSTANT', DZERO - endif - if (LAYCBD(k) /= 0) then - ! Need to write WETDRY array for quasi-3d unit. - ! Quasi-3d confining bed would not be rewettable, so use Wetdry = 0 - write(iu,40)'CONSTANT', DZERO - endif - enddo - endif - ! - ! HANI -- convert to K22 - if (this%UseHani) then - write(iu,50)'K22 LAYERED' - knew = 0 - do k=1,nlay - knew = knew + 1 - constant = .true. - val0 = this%hani(1,1,k) * this%hk(1,1,k) - do i=1,nrow - do j=1,ncol - valt = this%hani(j,i,k) * this%hk(j,i,k) - if (valt /= val0) then - constant = .false. - exit - endif - enddo - enddo - if (constant) then - write(iu,40)'CONSTANT', val0 - else - ! calculate k22 - do i=1,nrow - do j=1,ncol - this%hani(j,i,k) = this%hani(j,i,k) * this%hk(j,i,k) - end do - end do - write(iu,30)'INTERNAL FACTOR 1.0 IPRN ',iprnr - call Write2dValues(iu,NROW,NCOL,this%hani(:,:,k)) - endif - if (LAYCBD(k) /= 0) then - knew = knew + 1 - ! Assign a default value for HANI - write(iu,40)'CONSTANT', 1.0d0 - write(msg,100)'Original quasi-3D unit below layer',k,'is now layer', & - knew,'and has been assigned HANI value:',1.0d0 - call store_note(msg) - endif - enddo - endif - ! - ! ANGLEX (presumably not needed) - ! - write(iu,60)'END GRIDDATA' - ! - return - end subroutine WriteFile - - subroutine WriteOptions(this) - implicit none - ! dummy - class(NpfWriterType), intent(inout) :: this - ! local - integer :: icbc, iu - type(FileType), pointer :: cbcfil - ! formats - 5 format() - 10 format('BEGIN Options') - 20 format(2x,a,2x,a) - 30 format(2x,a,2x,i0) - 40 format(2x,a,2x,g16.9) - 50 format(2x,a) - 60 format(a) - 70 format(2x,a,2x,a,2x,g16.9,2x,a,2x,i0,2x,a,2x,i0) - 100 format('END Options') - ! - if (this%Newton) then - this%Perched = .false. - this%VariableCV = .false. - this%Dewatered = .false. - this%BottomHeadDamping = .true. - endif - ! - iu = this%fileobj%IUnit - ! Write BEGIN Options - write(iu,5) - write(iu,10) - ! - ! Options related to vertical flow correction - if (this%Perched) then - write(iu,50)'PERCHED' - endif - if (this%VariableCV) then - if (this%Dewatered) then - write(iu,20)'VARIABLECV', 'DEWATERED' - else - write(iu,50)'VARIABLECV' - endif - endif - ! - ! SAVE_FLOWS - cbcfil => null() - if (this%Inpfcb/=0) then - icbc = this%Inpfcb - if (icbc > 0) then - cbcfil => this%Mf6Files%GetFileByUnit(icbc) - if (associated(cbcfil)) then - if (cbcfilename == '') then - cbcfilename = cbcfil%FName - endif - if (cbcfilename .ne. '') then - write(iu,20)'SAVE_FLOWS', trim(cbcfilename) - endif -! write(iu,50)'SAVE_FLOWS' - endif - endif - endif - !! - !! HNOFLO - !if (this%Hnoflo/=hnoflodefault) then - ! write(line,40)'HNOFLO', this%Hnoflo - ! write(iu,60) trim(line) - !endif - !! - !! HDRY - !if (this%Hdry/=hdrydefault) then - ! write(line,40)'HDRY', this%Hdry - ! write(iu,60) trim(line) - !endif - ! - ! CELL_AVERAGING - if (this%CellAveraging /= 'HARMONIC') then - write(iu,20)'ALTERNATIVE_CELL_AVERAGING', trim(this%CellAveraging) - endif - ! - ! CONSTANTCV - if (this%ConstantCv) write(iu,50)'CONSTANTCV' - ! - ! CVCORRECTION - if (this%CvCorrection) write(iu,50)'CVCORRECTION' - ! - ! REWET options - if (this%Rewet) then - write(iu,70) 'REWET', 'WETFCT', this%Wetfct, 'IWETIT', this%Iwetit, & - 'IHDWET', this%Ihdwet - !write(iu,50)'REWET' - !if (this%Wetfct/=DZERO) then - ! write(line,40)'WETFCT',this%Wetfct - ! write(iu,60) trim(line) - !endif - !if (this%Iwetit>1) then - ! write(line,30)'IWETIT',this%Iwetit - ! write(iu,60) trim(line) - !endif - !if (this%Ihdwet/=0) write(iu,30)'IHDWET', this%Ihdwet - endif - !! - !if (.not. this%Newton) then - ! write(iu,50)'NO_NEWTON' - !endif - ! -! if (this%BottomHeadDamping) then -! write(iu,50)'BOTTOM_HEAD_DAMPENING' -! endif - ! - ! Write END Options - write(iu,100) - ! - return - end subroutine WriteOptions - - double precision function get_q3d_hk() result(hk) - ! Based on ITMUNI, LENUNI, and Domenico & Schwartz, return a - ! reasonable, small value for horizontal hydraulic conductivity, - ! to be used in active cells that will replace a quasi-3D - ! confining unit. - implicit none - ! local - ! -- hkms is a typical, small horizontal - ! hydraulic conductivity in meters and seconds. - double precision :: converter, hkms - character(len=300) :: msg - character(len=10) :: strng - ! format - 10 format(g10.3) - ! - ! -- Start with a small HK value characteristic of shale - ! or unfractured igneous or metamorphic rock - ! (Domenico and Schwartz, 1990) - hkms = 1.0e-13 - ! - ! -- Convert to model units specified in BAS input - if (ITMUNI < 1 .or. ITMUNI > 5) then - msg = 'Error: ITMUNI is undefined in Discretization Package input. ' // & - 'A valid value needs to be assigned so that HK can be ' // & - 'assigned for layer(s) representing former quasi-3D unit(s).' - call store_error(msg) - endif - if (LENUNI < 1 .or. LENUNI > 3) then - msg = 'Error: LENUNI is undefined in Discretization Package input. ' // & - 'A valid value needs to be assigned so that HK can be ' // & - 'assigned for layer(s) representing former quasi-3D unit(s).' - call store_error(msg) - endif - if (count_errors() > 0) call ustop() - ! - ! -- Define time conversion - select case (ITMUNI) - case (1) - ! seconds -- no time conversion needed - converter = DONE - case (2) - ! minutes - converter = 60.0d0 - case (3) - ! hours - converter = 60.0d0 * 60.0d0 - case (4) - ! days - converter = 60.0d0 * 60.0d0 * 24.0d0 - case (5) - ! years - converter = 60.0d0 * 60.0d0 * 24.0d0 * 365.25d0 - end select - ! - ! -- Define length conversion - select case (LENUNI) - case (1) - ! feet - converter = converter / 0.3048d0 - case (2) - ! meters -- no length conversion needed - case (3) - ! centimeters - converter = converter * 100.0d0 - end select - ! - ! -- Perform conversion - hk = hkms * converter - ! -- Round the value to about 3 significant figures - write(strng,10)hk - read(strng,*)hk - ! - return - end function get_q3d_hk - - ! - ! Functions to assign VK based on Vcont and cell thicknesses from BCF - ! - - subroutine assign_vk(this, vkerr) - ! Assign VK array for all layers when BCF is used and NLAY > 1, - ! based on vcont arrays and cell thicknesses. - implicit none - ! dummy - class(NpfWriterType) :: this - logical, intent(inout) :: vkerr - ! local - integer :: i, j, k, knew - double precision :: thk, thkp1, thq, vktemp - double precision :: topk, botk, botq, botkp1 - double precision, parameter :: vkbig = 1.0d20 - character(len=1000) :: msg - ! - if (.not. associated(vcont)) return - vkerr = .false. - knew = 0 - bigloop: do k=1,nlay-1 - knew = knew + 1 - if (LAYCBD(k) == 0) then - ! No quasi-3d unit underlies layer k - if (k == 1) then - ! Assign VK for layers 1 and 2 - do i=1,NROW - do j=1,NCOL - if (k == 1) then - topk = BOTM(j,i,0) - else - topk = BOTM(j,i,LBOTM(k-1)) - endif - botk = BOTM(j,i,LBOTM(k)) - botkp1 = BOTM(j,i,LBOTM(k)+1) - thk = topk - botk - thkp1 = botk - botkp1 - vktemp = vk_noq3d(vcont(j,i,k), thk, thkp1) - this%vk(j,i,knew) = vktemp - this%vk(j,i,knew+1) = vktemp - enddo - enddo - else - ! VK for current layer has already been assigned. - ! Assign VK for next layer. - do i=1,NROW - do j=1,NCOL - topk = BOTM(j,i,LBOTM(k-1)) - botk = BOTM(j,i,LBOTM(k)) - botkp1 = BOTM(j,i,LBOTM(k)+1) - thk = topk - botk - thkp1 = botk - botkp1 - this%vk(j,i,knew+1) = vkkp1(vcont(j,i,k), thk, thkp1, & - this%vk(j,i,knew), vkerr) - if (vkerr) exit bigloop - enddo - enddo - endif - else - ! A quasi-3d unit underlies layer k - if (k == 1) then - ! Assign VK for layers 1, 2, and 3 - do i=1,NROW - do j=1,NCOL - topk = BOTM(j,i,LBOTM(k)-1) - botk = BOTM(j,i,LBOTM(k)) - botq = BOTM(j,i,LBOTM(k)+1) - botkp1 = BOTM(j,i,LBOTM(k+1)) - thk = topk - botk - thq = botk - botq - thkp1 = botq - botkp1 - this%vk(j,i,knew) = vkbig - this%vk(j,i,knew+1) = vcont(j,i,k) * thq - this%vk(j,i,knew+2) = vkbig - enddo - enddo - else - ! VK for current layer has already been assigned. - ! Assign VK for quasi-3d unit and next layer. - do i=1,NROW - do j=1,NCOL - topk = BOTM(j,i,LBOTM(k)-1) - botk = BOTM(j,i,LBOTM(k)) - botq = BOTM(j,i,LBOTM(k)+1) - botkp1 = BOTM(j,i,LBOTM(k+1)) - thk = topk - botk - thq = botk - botq - thkp1 = botq - botkp1 - vktemp = vkcj(vcont(j,i,k), thk, thkp1, thq, & - this%vk(j,i,knew), vkerr) - this%vk(j,i,knew+1) = vktemp - this%vk(j,i,knew+2) = vktemp - enddo - enddo - endif - ! Increment knew - knew = knew + 1 - endif - enddo bigloop - if (vkerr) then - msg = 'Unable to assign physically meaningful VK values that' & - // ' produce specified Vcont values.' - call store_warning(msg) - ! Ned todo: write and call a routine to assign placeholder values for - ! VK arrays. - else - msg = 'VK values that are equivalent to specified Vcont values' & - // ' have been assigned. However, these values may or' & - // ' may not be reasonable.' - call store_note(msg) - endif - ! - return - end subroutine assign_vk - - double precision function vk_noq3d(vcnt, thk, thkp1) - ! For case without quasi-3d unit, vkk and vkkp1 unknown. - ! Assume vkk = vkkp1 = vk. Solve for vk. - implicit none - ! dummy - double precision, intent(in) :: vcnt, thk, thkp1 - ! - vk_noq3d = vcnt*DHALF*(thk + thkp1) - return - end function vk_noq3d - - double precision function vkkp1(vcnt, thk, thkp1, vkk, vkerr) - ! For case without quasi-3d unit, vkk known. - ! Solve for vkkp1. - implicit none - ! dummy - double precision, intent(in) :: vcnt, thk, thkp1, vkk - logical, intent(inout) :: vkerr - ! local - double precision :: denom - ! - denom = (DONE/vcnt - DHALF*thk/vkk) - if (denom <= DZERO) then - vkerr = .true. - vkkp1 = -9999.0d0 - else - vkkp1 = DHALF*thkp1/denom - endif - return - end function vkkp1 - - double precision function vkcj(vcnt, thk, thkp1, thq, vkk, vkerr) - ! For case with quasi-3d unit, vkk known. - ! Assume VKCB = vkkp1 = vkcj. Solve for vkcj. - implicit none - ! dummy - double precision, intent(in) :: vcnt, thk, thkp1, thq, vkk - logical, intent(inout) :: vkerr - ! local - double precision :: denom - ! - denom = DONE/vcnt - DHALF*thk/vkk - if (denom <= DZERO) then - vkerr = .true. - vkcj = -9999.0d0 - else - vkcj = (thq + DHALF*thkp1) / denom - endif - return - end function vkcj - -end module NpfWriterModule +module NpfWriterModule + + use ConstantsModule, only: DONE, DZERO, DEM7, DHALF, DTWO + use ConstantsPHMFModule, only: HDRYDEFAULT, HNOFLODEFAULT + use FileListModule, only: FileListType + use FileTypeModule, only: FileType + use FileWriterModule, only: FileWriterType + use GLOBAL, only: ncol, nrow, nlay, ITMUNI, LENUNI, LAYCBD, NCNFBD, BOTM, & + LBOTM, cbcfilename + use GlobalVariablesModule, only: echo + use GWFBCFMODULE, only: LAYCON, WetdryBcf => WETDRY, vcont, TRPY + use GWFLPFMODULE, only: LAYTYP, LAYWET, VKCB, WetdryLpf => WETDRY, HANI + use GWFUPWMODULE, only: LaytypUpw, LaywetUpw => LAYWET, VkcbUpw => VKCB, & + WetdryUpw => WETDRY, HaniUpw => HANI + use InputOutputModule, only: GetUnit, openfile + use SimModule, only: count_errors, store_error, store_note, store_warning, & + ustop + use UtilitiesModule, only: Write2dValues + + type, extends(FileWriterType) :: NpfWriterType + double precision :: Hnoflo = hnoflodefault + double precision :: Hdry = hdrydefault + double precision :: Wetfct = DZERO + double precision :: MinSatThickness = DEM7 + double precision, allocatable, dimension(:,:,:) :: hk + double precision, allocatable, dimension(:,:,:) :: vk + double precision, allocatable, dimension(:,:,:) :: hani + double precision, pointer, dimension(:,:,:) :: WetDry => null() + integer :: Inpfcb = 0 + integer :: Iwetit = 1 + integer :: Ihdwet = 0 + integer :: NumConvertible = 0 + integer, pointer :: Nlaynew => null() + integer, allocatable, dimension(:) :: Icelltype ! dim = nlay + integer, pointer, dimension(:) :: Layptr => null() + logical :: VertFlowCorr = .false. + logical :: ConstantCv = .false. + logical :: CvCorrection = .false. + logical :: Rewet = .false. + logical :: Newton = .false. + logical :: ThickStrt = .false. + logical :: BottomHeadDamping = .false. + logical :: Perched = .false. + logical :: VariableCV = .false. + logical :: Dewatered = .false. + logical :: UseHani = .false. + character(len=3) :: FlowPackage = '' + character(len=11) :: CellAveraging = 'HARMONIC' + type(FileListType), pointer :: Mf2005Files => null() + type(FileListType), pointer :: Mf6Files => null() + contains + procedure :: InitializeFile + procedure :: AllocateArrays + procedure :: WriteFile + procedure, private :: WriteOptions + procedure, private :: assign_vk + end type NpfWriterType + +contains + + subroutine AllocateArrays(this) + implicit none + ! dummy + class(NpfWriterType), intent(inout) :: this + ! + if (.not. allocated(this%Icelltype)) then + allocate(this%Icelltype(nlay)) + allocate(this%hk(ncol,nrow,nlay)) + allocate(this%vk(ncol,nrow,this%Nlaynew)) + endif + this%hk = DZERO + this%vk = DONE + ! + return + end subroutine AllocateArrays + + subroutine InitializeFile(this, fname, ftype, pkgname) + implicit none + ! dummy + class(NpfWriterType), intent(inout) :: this + character(len=*), intent(in) :: fname + character(len=*), intent(in) :: ftype + character(len=*), intent(in), optional :: pkgname + ! local + ! + if (present(pkgname)) then + call this%FileWriterType%InitializeFile(fname, ftype, pkgname) + else + call this%FileWriterType%InitializeFile(fname, ftype) + endif + ! + return + end subroutine InitializeFile + + subroutine WriteFile(this) + implicit none + ! dummy + class(NpfWriterType), intent(inout) :: this + ! local + integer :: i, iprni, iprnr, iu, iwetdry, j, k, knew, & + idim1, idim2, idim3 + character(len=500) :: msg + logical :: constant, vkerr, wettable, writek33 + double precision :: hk, val0, valt + ! formats + 5 format() + 30 format(4x,a,2x,i0) + 40 format(4x,a,2x,g16.9) + 50 format(2x,a) + 60 format(a) + 100 format(a,1x,i0,1x,a,1x,i0,1x,a,1x,g10.3) + ! +! ! Rewetting settings +! if (associated(WetdryBcf)) then +! this%WetDry => WetdryBcf +! elseif (associated(WetdryLpf)) then +! this%WetDry => WetdryLpf +! elseif (associated(WetdryUpw)) then +! this%WetDry => WetdryUpw +! endif + if (this%FlowPackage == 'UPW') then + this%Rewet = .false. + this%WetDry = 0.01d0 + endif + ! + if (echo) then + iprni = 3 + iprnr = 12 + else + iprni = -3 + iprnr = -12 + endif + call this%WriteOptions() + ! + iu = this%fileobj%IUnit + write(iu,5) + write(iu,60)'BEGIN GRIDDATA' + ! + ! Icelltype (0: confined; >0: convertible; <0: see input instruct.) + ! (will be constant for each layer) + write(iu,50)'Icelltype LAYERED' + do k=1,nlay + write(iu,30)'CONSTANT', this%Icelltype(k) + if (LAYCBD(k) /= 0) then + ! Assume quasi-3d unit is not convertible + write(iu,30)'CONSTANT', 0 + endif + enddo + ! + ! HK + write(iu,50)'K LAYERED' + knew = 0 + do k=1,nlay + knew = knew + 1 + constant = .true. + val0 = this%hk(1,1,k) + do i=1,nrow + do j=1,ncol + if (this%hk(j,i,k) /= val0) then + constant = .false. + exit + endif + enddo + enddo + if (constant) then + write(iu,40)'CONSTANT', val0 + else + write(iu,30)'INTERNAL FACTOR 1.0 IPRN ',iprnr + call Write2dValues(iu,NROW,NCOL,this%hk(:,:,k)) + endif + if (LAYCBD(k) /= 0) then + knew = knew + 1 + ! Get a default value for HK + hk = get_q3d_hk() + write(iu,40)'CONSTANT', hk + write(msg,100)'Original quasi-3D unit below layer',k,'is now layer', & + knew,'and has been assigned HK value:',hk + call store_note(msg) + endif + enddo + ! + ! VK (may be problematic when converting from BCF? May need to solve + ! a system of NLAY-1 equations? What about Quasi-3D layers?) + ! -- Don't support BCF when NLAY > 1. For LPF, convert Q-3D layers to + ! active cells. + ! -- Better: For BCF, assign VK = HK for original BCF layers, and assign + ! VK = (default HK)/100 for new layer replacing a quasi-3d unit + if (this%FlowPackage == 'BCF') then + ! Assign all VK values + vkerr = .false. + call this%assign_vk(vkerr) + if (vkerr) then + do k=1,nlay + do i=1,nrow + do j=1,ncol + this%vk(j,i,k) = this%hk(j,i,k) + enddo + enddo + enddo + if (nlay>1) then + msg = 'For conversion of BCF layers to NPF package, definition of' // & + ' vertical hydraulic conductivity (VK) of each layer does' // & + ' not have a unique solution. For each layer, VK has been' // & + ' set to horizontal hydraulic conductivity (HK) of the' // & + ' original layer. These values likely will need to be' // & + ' adjusted by the modeler to approximate the original model.' + call store_note(msg) + if (NCNFBD > 0) then + msg = 'For conversion of BCF quasi-3D unit(s) to NPF package,' // & + ' default values of HK and VK have been assigned. These' // & + ' values likely will need to be adjusted by the modeler' // & + ' to approximate the original model.' + call store_note(msg) + endif + endif + endif + elseif (this%FlowPackage == 'LPF') then + ! Ned todo: is anything needed here? + ! Probably need to populate vk? + elseif (this%FlowPackage == 'UPW') then + ! Anything here? + endif + ! + ! -- Determine if necessary to write K33 + writek33 = .false. + if (nlay > 1) then + layerloop: do k=1,this%Nlaynew + do i=1,nrow + do j=1,ncol + if(this%vk(j,i,k) /= this%hk(j,i,k)) then + writek33 = .true. + exit layerloop + endif + enddo + enddo + enddo layerloop + endif + ! + if (writek33) then + write(iu,50)'K33 LAYERED' + do k=1,this%Nlaynew + constant = .true. + val0 = this%vk(1,1,k) + do i=1,nrow + do j=1,ncol + if (this%vk(j,i,k) /= val0) then + constant = .false. + exit + endif + enddo + enddo + if (constant) then + write(iu,40)'CONSTANT', val0 + else + write(iu,30)'INTERNAL FACTOR 1.0 IPRN ',iprnr + call Write2dValues(iu,NROW,NCOL,this%vk(:,:,k)) + endif + enddo + endif + ! + ! WETDRY + if (this%Rewet) then + write(iu,50)'WETDRY LAYERED' + iwetdry = 0 ! index to WETDRY array + do k=1,nlay + ! Determine if this layer is wettable + wettable = .false. + select case (this%FlowPackage) + case ('LPF') + if (LAYTYP(k) /= 0 .and. LAYWET(k) /= 0) then + wettable = .true. + endif + case ('UPW') + if (LAYTYPUPW(k) /= 0) then ! .and. LaywetUpw(k) /= 0) then + wettable = .true. + endif + case ('BCF') + if (LAYCON(k) == 1 .or. LAYCON(k) == 3) then + wettable = .true. + endif + end select + ! + ! If this layer is wettable, need nonzero Wetdry values + if (wettable) then + ! determine if laywet for this layer is constant + constant = .true. + val0 = this%WetDry(1,1,1) + idim1 = size(this%WetDry,1) + idim2 = size(this%WetDry,2) + idim3 = size(this%WetDry,3) + if (idim1 == ncol .and. idim2 == nrow .and. idim3 == nlay) then + val0 = this%WetDry(1,1,k) + do i=1,nrow + do j=1,ncol + if (this%WetDry(j,i,k) /= val0) then + constant = .false. + exit + endif + enddo + enddo + endif + if (constant) then + write(iu,40)'CONSTANT', val0 + else + write(iu,30)'INTERNAL FACTOR 1.0 IPRN ',iprnr + call Write2dValues(iu,NROW,NCOL,this%WetDry(:,:,k)) + endif + else + ! Layer is not wettable in LPF, but needs to be assigned Wetdry = 0 in NPF + write(iu,40)'CONSTANT', DZERO + endif + if (LAYCBD(k) /= 0) then + ! Need to write WETDRY array for quasi-3d unit. + ! Quasi-3d confining bed would not be rewettable, so use Wetdry = 0 + write(iu,40)'CONSTANT', DZERO + endif + enddo + endif + ! + ! HANI -- convert to K22 + if (this%UseHani) then + write(iu,50)'K22 LAYERED' + knew = 0 + do k=1,nlay + knew = knew + 1 + constant = .true. + val0 = this%hani(1,1,k) * this%hk(1,1,k) + do i=1,nrow + do j=1,ncol + valt = this%hani(j,i,k) * this%hk(j,i,k) + if (valt /= val0) then + constant = .false. + exit + endif + enddo + enddo + if (constant) then + write(iu,40)'CONSTANT', val0 + else + ! calculate k22 + do i=1,nrow + do j=1,ncol + this%hani(j,i,k) = this%hani(j,i,k) * this%hk(j,i,k) + end do + end do + write(iu,30)'INTERNAL FACTOR 1.0 IPRN ',iprnr + call Write2dValues(iu,NROW,NCOL,this%hani(:,:,k)) + endif + if (LAYCBD(k) /= 0) then + knew = knew + 1 + ! Assign a default value for HANI + write(iu,40)'CONSTANT', 1.0d0 + write(msg,100)'Original quasi-3D unit below layer',k,'is now layer', & + knew,'and has been assigned HANI value:',1.0d0 + call store_note(msg) + endif + enddo + endif + ! + ! ANGLEX (presumably not needed) + ! + write(iu,60)'END GRIDDATA' + ! + return + end subroutine WriteFile + + subroutine WriteOptions(this) + implicit none + ! dummy + class(NpfWriterType), intent(inout) :: this + ! local + integer :: icbc, iu + type(FileType), pointer :: cbcfil + ! formats + 5 format() + 10 format('BEGIN Options') + 20 format(2x,a,2x,a) + 30 format(2x,a,2x,i0) + 40 format(2x,a,2x,g16.9) + 50 format(2x,a) + 60 format(a) + 70 format(2x,a,2x,a,2x,g16.9,2x,a,2x,i0,2x,a,2x,i0) + 100 format('END Options') + ! + if (this%Newton) then + this%Perched = .false. + this%VariableCV = .false. + this%Dewatered = .false. + this%BottomHeadDamping = .true. + endif + ! + iu = this%fileobj%IUnit + ! Write BEGIN Options + write(iu,5) + write(iu,10) + ! + ! Options related to vertical flow correction + if (this%Perched) then + write(iu,50)'PERCHED' + endif + if (this%VariableCV) then + if (this%Dewatered) then + write(iu,20)'VARIABLECV', 'DEWATERED' + else + write(iu,50)'VARIABLECV' + endif + endif + ! + ! SAVE_FLOWS + cbcfil => null() + if (this%Inpfcb/=0) then + icbc = this%Inpfcb + if (icbc > 0) then + cbcfil => this%Mf6Files%GetFileByUnit(icbc) + if (associated(cbcfil)) then + if (cbcfilename == '') then + cbcfilename = cbcfil%FName + endif + if (cbcfilename .ne. '') then + write(iu,20)'SAVE_FLOWS', trim(cbcfilename) + endif +! write(iu,50)'SAVE_FLOWS' + endif + endif + endif + !! + !! HNOFLO + !if (this%Hnoflo/=hnoflodefault) then + ! write(line,40)'HNOFLO', this%Hnoflo + ! write(iu,60) trim(line) + !endif + !! + !! HDRY + !if (this%Hdry/=hdrydefault) then + ! write(line,40)'HDRY', this%Hdry + ! write(iu,60) trim(line) + !endif + ! + ! CELL_AVERAGING + if (this%CellAveraging /= 'HARMONIC') then + write(iu,20)'ALTERNATIVE_CELL_AVERAGING', trim(this%CellAveraging) + endif + ! + ! CONSTANTCV + if (this%ConstantCv) write(iu,50)'CONSTANTCV' + ! + ! CVCORRECTION + if (this%CvCorrection) write(iu,50)'CVCORRECTION' + ! + ! REWET options + if (this%Rewet) then + write(iu,70) 'REWET', 'WETFCT', this%Wetfct, 'IWETIT', this%Iwetit, & + 'IHDWET', this%Ihdwet + !write(iu,50)'REWET' + !if (this%Wetfct/=DZERO) then + ! write(line,40)'WETFCT',this%Wetfct + ! write(iu,60) trim(line) + !endif + !if (this%Iwetit>1) then + ! write(line,30)'IWETIT',this%Iwetit + ! write(iu,60) trim(line) + !endif + !if (this%Ihdwet/=0) write(iu,30)'IHDWET', this%Ihdwet + endif + !! + !if (.not. this%Newton) then + ! write(iu,50)'NO_NEWTON' + !endif + ! +! if (this%BottomHeadDamping) then +! write(iu,50)'BOTTOM_HEAD_DAMPENING' +! endif + ! + ! Write END Options + write(iu,100) + ! + return + end subroutine WriteOptions + + double precision function get_q3d_hk() result(hk) + ! Based on ITMUNI, LENUNI, and Domenico & Schwartz, return a + ! reasonable, small value for horizontal hydraulic conductivity, + ! to be used in active cells that will replace a quasi-3D + ! confining unit. + implicit none + ! local + ! -- hkms is a typical, small horizontal + ! hydraulic conductivity in meters and seconds. + double precision :: converter, hkms + character(len=300) :: msg + character(len=10) :: strng + ! format + 10 format(g10.3) + ! + ! -- Start with a small HK value characteristic of shale + ! or unfractured igneous or metamorphic rock + ! (Domenico and Schwartz, 1990) + hkms = 1.0e-13 + ! + ! -- Convert to model units specified in BAS input + if (ITMUNI < 1 .or. ITMUNI > 5) then + msg = 'Error: ITMUNI is undefined in Discretization Package input. ' // & + 'A valid value needs to be assigned so that HK can be ' // & + 'assigned for layer(s) representing former quasi-3D unit(s).' + call store_error(msg) + endif + if (LENUNI < 1 .or. LENUNI > 3) then + msg = 'Error: LENUNI is undefined in Discretization Package input. ' // & + 'A valid value needs to be assigned so that HK can be ' // & + 'assigned for layer(s) representing former quasi-3D unit(s).' + call store_error(msg) + endif + if (count_errors() > 0) call ustop() + ! + ! -- Define time conversion + select case (ITMUNI) + case (1) + ! seconds -- no time conversion needed + converter = DONE + case (2) + ! minutes + converter = 60.0d0 + case (3) + ! hours + converter = 60.0d0 * 60.0d0 + case (4) + ! days + converter = 60.0d0 * 60.0d0 * 24.0d0 + case (5) + ! years + converter = 60.0d0 * 60.0d0 * 24.0d0 * 365.25d0 + end select + ! + ! -- Define length conversion + select case (LENUNI) + case (1) + ! feet + converter = converter / 0.3048d0 + case (2) + ! meters -- no length conversion needed + case (3) + ! centimeters + converter = converter * 100.0d0 + end select + ! + ! -- Perform conversion + hk = hkms * converter + ! -- Round the value to about 3 significant figures + write(strng,10)hk + read(strng,*)hk + ! + return + end function get_q3d_hk + + ! + ! Functions to assign VK based on Vcont and cell thicknesses from BCF + ! + + subroutine assign_vk(this, vkerr) + ! Assign VK array for all layers when BCF is used and NLAY > 1, + ! based on vcont arrays and cell thicknesses. + implicit none + ! dummy + class(NpfWriterType) :: this + logical, intent(inout) :: vkerr + ! local + integer :: i, j, k, knew + double precision :: thk, thkp1, thq, vktemp + double precision :: topk, botk, botq, botkp1 + double precision, parameter :: vkbig = 1.0d20 + character(len=1000) :: msg + ! + if (.not. associated(vcont)) return + vkerr = .false. + knew = 0 + bigloop: do k=1,nlay-1 + knew = knew + 1 + if (LAYCBD(k) == 0) then + ! No quasi-3d unit underlies layer k + if (k == 1) then + ! Assign VK for layers 1 and 2 + do i=1,NROW + do j=1,NCOL + if (k == 1) then + topk = BOTM(j,i,0) + else + topk = BOTM(j,i,LBOTM(k-1)) + endif + botk = BOTM(j,i,LBOTM(k)) + botkp1 = BOTM(j,i,LBOTM(k)+1) + thk = topk - botk + thkp1 = botk - botkp1 + vktemp = vk_noq3d(vcont(j,i,k), thk, thkp1) + this%vk(j,i,knew) = vktemp + this%vk(j,i,knew+1) = vktemp + enddo + enddo + else + ! VK for current layer has already been assigned. + ! Assign VK for next layer. + do i=1,NROW + do j=1,NCOL + topk = BOTM(j,i,LBOTM(k-1)) + botk = BOTM(j,i,LBOTM(k)) + botkp1 = BOTM(j,i,LBOTM(k)+1) + thk = topk - botk + thkp1 = botk - botkp1 + this%vk(j,i,knew+1) = vkkp1(vcont(j,i,k), thk, thkp1, & + this%vk(j,i,knew), vkerr) + if (vkerr) exit bigloop + enddo + enddo + endif + else + ! A quasi-3d unit underlies layer k + if (k == 1) then + ! Assign VK for layers 1, 2, and 3 + do i=1,NROW + do j=1,NCOL + topk = BOTM(j,i,LBOTM(k)-1) + botk = BOTM(j,i,LBOTM(k)) + botq = BOTM(j,i,LBOTM(k)+1) + botkp1 = BOTM(j,i,LBOTM(k+1)) + thk = topk - botk + thq = botk - botq + thkp1 = botq - botkp1 + this%vk(j,i,knew) = vkbig + this%vk(j,i,knew+1) = vcont(j,i,k) * thq + this%vk(j,i,knew+2) = vkbig + enddo + enddo + else + ! VK for current layer has already been assigned. + ! Assign VK for quasi-3d unit and next layer. + do i=1,NROW + do j=1,NCOL + topk = BOTM(j,i,LBOTM(k)-1) + botk = BOTM(j,i,LBOTM(k)) + botq = BOTM(j,i,LBOTM(k)+1) + botkp1 = BOTM(j,i,LBOTM(k+1)) + thk = topk - botk + thq = botk - botq + thkp1 = botq - botkp1 + vktemp = vkcj(vcont(j,i,k), thk, thkp1, thq, & + this%vk(j,i,knew), vkerr) + this%vk(j,i,knew+1) = vktemp + this%vk(j,i,knew+2) = vktemp + enddo + enddo + endif + ! Increment knew + knew = knew + 1 + endif + enddo bigloop + if (vkerr) then + msg = 'Unable to assign physically meaningful VK values that' & + // ' produce specified Vcont values.' + call store_warning(msg) + ! Ned todo: write and call a routine to assign placeholder values for + ! VK arrays. + else + msg = 'VK values that are equivalent to specified Vcont values' & + // ' have been assigned. However, these values may or' & + // ' may not be reasonable.' + call store_note(msg) + endif + ! + return + end subroutine assign_vk + + double precision function vk_noq3d(vcnt, thk, thkp1) + ! For case without quasi-3d unit, vkk and vkkp1 unknown. + ! Assume vkk = vkkp1 = vk. Solve for vk. + implicit none + ! dummy + double precision, intent(in) :: vcnt, thk, thkp1 + ! + vk_noq3d = vcnt*DHALF*(thk + thkp1) + return + end function vk_noq3d + + double precision function vkkp1(vcnt, thk, thkp1, vkk, vkerr) + ! For case without quasi-3d unit, vkk known. + ! Solve for vkkp1. + implicit none + ! dummy + double precision, intent(in) :: vcnt, thk, thkp1, vkk + logical, intent(inout) :: vkerr + ! local + double precision :: denom + ! + denom = (DONE/vcnt - DHALF*thk/vkk) + if (denom <= DZERO) then + vkerr = .true. + vkkp1 = -9999.0d0 + else + vkkp1 = DHALF*thkp1/denom + endif + return + end function vkkp1 + + double precision function vkcj(vcnt, thk, thkp1, thq, vkk, vkerr) + ! For case with quasi-3d unit, vkk known. + ! Assume VKCB = vkkp1 = vkcj. Solve for vkcj. + implicit none + ! dummy + double precision, intent(in) :: vcnt, thk, thkp1, thq, vkk + logical, intent(inout) :: vkerr + ! local + double precision :: denom + ! + denom = DONE/vcnt - DHALF*thk/vkk + if (denom <= DZERO) then + vkerr = .true. + vkcj = -9999.0d0 + else + vkcj = (thq + DHALF*thkp1) / denom + endif + return + end function vkcj + +end module NpfWriterModule diff --git a/utils/mf5to6/src/Preproc/Global.f90 b/utils/mf5to6/src/Preproc/Global.f90 index 2caacedec5c..00f87694f99 100644 --- a/utils/mf5to6/src/Preproc/Global.f90 +++ b/utils/mf5to6/src/Preproc/Global.f90 @@ -1,5 +1,5 @@ MODULE GLOBAL - use ConstantsModule, only: MAXCHARLEN + use ConstantsModule, only: MAXCHARLEN ! scalars INTEGER, SAVE, POINTER :: NCOL, NROW, NLAY, NPER, NBOTM, NCNFBD INTEGER, SAVE, POINTER :: ITMUNI, LENUNI, IXSEC, ITRSS, INBAS @@ -34,20 +34,20 @@ MODULE GLOBAL TYPE GLOBALTYPE ! scalars - INTEGER, POINTER :: NCOL => null() - INTEGER, POINTER :: NROW => null() - INTEGER, POINTER :: NLAY => null() - INTEGER, POINTER :: NPER => null() - INTEGER, POINTER :: NBOTM => null() + INTEGER, POINTER :: NCOL => null() + INTEGER, POINTER :: NROW => null() + INTEGER, POINTER :: NLAY => null() + INTEGER, POINTER :: NPER => null() + INTEGER, POINTER :: NBOTM => null() INTEGER, POINTER :: NCNFBD => null() - INTEGER, POINTER :: ITMUNI => null() - INTEGER, POINTER :: LENUNI => null() - INTEGER, POINTER :: IXSEC => null() - INTEGER, POINTER :: ITRSS => null() + INTEGER, POINTER :: ITMUNI => null() + INTEGER, POINTER :: LENUNI => null() + INTEGER, POINTER :: IXSEC => null() + INTEGER, POINTER :: ITRSS => null() INTEGER, POINTER :: INBAS => null() - INTEGER, POINTER :: IFREFM => null() - INTEGER, POINTER :: NODES => null() - INTEGER, POINTER :: IOUT => null() + INTEGER, POINTER :: IFREFM => null() + INTEGER, POINTER :: NODES => null() + INTEGER, POINTER :: IOUT => null() INTEGER, POINTER :: MXITER => null() double precision, pointer :: constantdelr => null() double precision, pointer :: constantdelc => null() diff --git a/utils/mf5to6/src/Preproc/GlobalVariables.f90 b/utils/mf5to6/src/Preproc/GlobalVariables.f90 index 2b5cb82b10f..f1b98867b06 100644 --- a/utils/mf5to6/src/Preproc/GlobalVariables.f90 +++ b/utils/mf5to6/src/Preproc/GlobalVariables.f90 @@ -1,6 +1,6 @@ module GlobalVariablesModule - use ConstantsModule, only: MAXCHARLEN + use ConstantsModule, only: MAXCHARLEN use VersionModule, only: VERSION use OpenSpecModule, only: ACCESS, ACTION, FORM diff --git a/utils/mf5to6/src/Preproc/ObsBlock.f90 b/utils/mf5to6/src/Preproc/ObsBlock.f90 index 0d744a6e98e..fd16060af5b 100644 --- a/utils/mf5to6/src/Preproc/ObsBlock.f90 +++ b/utils/mf5to6/src/Preproc/ObsBlock.f90 @@ -3,7 +3,7 @@ module ObsBlockModule use BlockParserModule, only: BlockParserType use ConstantsModule, only: DONE, DZERO, & LINELENGTH, MAXCHARLEN - use GenericUtilitiesModule, only: IS_SAME + use GenericUtilitiesModule, only: IS_SAME use ConstantsPHMFModule, only: CONTINUOUS, SINGLE, LENOBSNAMENEW use DnmDis3dModule, only: Dis3dType use GlobalVariablesPHMFModule, only: verbose diff --git a/utils/mf5to6/src/Preproc/SimListVariables.f90 b/utils/mf5to6/src/Preproc/SimListVariables.f90 index 9e0a23c387d..5fd22c0b316 100644 --- a/utils/mf5to6/src/Preproc/SimListVariables.f90 +++ b/utils/mf5to6/src/Preproc/SimListVariables.f90 @@ -1,7 +1,7 @@ module SimListVariablesModule use ListModule, only: ListType - - implicit none + + implicit none private public :: ModelPacks, SimMovers diff --git a/utils/mf5to6/src/UzfPackageWriter.f90 b/utils/mf5to6/src/UzfPackageWriter.f90 index 543e489e030..9af8443f883 100755 --- a/utils/mf5to6/src/UzfPackageWriter.f90 +++ b/utils/mf5to6/src/UzfPackageWriter.f90 @@ -1,747 +1,747 @@ -module UzfPackageWriterModule - - use ConstantsModule, only: DONE, DZERO, LINELENGTH, & - MAXCHARLEN, LENMODELNAME, LENPACKAGENAME - use ConstantsPHMFModule, only: FCINPUT, FCUNKNOWN, LENCTYPE - use FileTypeModule, only: FileType - use GLOBAL, only: NPER, IUNIT, NCOL, NROW, NLAY, IOUT, ISSFLG, IBOUND - use GWFBASMODULE, only: FindHighestActiveLayer, SGWF2BAS7PNT - use GWFLAKMODULE, only: SGWF2LAK7PNT, NeedLakWaterMover - use GWFSFRMODULE, only: SGWF2SFR7PNT, NeedSfrWaterMover - use GwfUzfModule, only: NeedUzfWaterMover, IUZFBND, SGWF2UZF1PNT, SURFDEP, & - IRUNBND, NTRAIL, NSETS, VKS, THTI, THTR, THTS, & - EPS, IUZFCB1, IUZFCB2, NUZTOP, PETRATE, ROOTDPTH, & - WCWILT, FINF, IRUNFLG - use GwfUzfSubs, only: GWF2UZF1AR, GWF2UZF1RP - use LineListModule, only: LineListType - use ListModule, only: ListType - use ModelPackageModule, only: ModelPackageType, GetModelPack - use MoverModule, only: MoverType, ConstructWaterMover, AddMoverToList, & - GetMoverFromList - use MvrPackageWriterModule, only: MvrPackageWriterType - use PackageWriterModule, only: PackageWriterType - use SfrPackageWriterModule, only: SfrPackageWriterType, & - GetSfrPackageWriterByIgrid - use SfrReachModule, only: SfrReachType - use SfrSegmentModule, only: SfrSegmentType - use SimModule, only: store_error, ustop - - implicit none - - private - public :: AllUzfPkgWriters, UzfPackageWriterType - - type(ListType) :: AllUzfPkgWriters - - type, extends(PackageWriterType) :: UzfPackageWriterType - type(MvrPackageWriterType), pointer :: MvrWriter => null() - type(SfrPackageWriterType), pointer :: SfrWriter => null() - logical :: simulate_et = .true. ! simulate ET in UZ - logical :: linear_gwet = .true. ! original ET fomulation of mf2005 - logical :: square_gwet = .false. - logical :: simulate_gwseep = .false. - logical :: unsat_etwc = .false. - logical :: unsat_etae = .false. - logical :: multilayer = .false. - integer :: nuzfcells = 0 - integer :: nuztop = 0 - integer :: kdim = 0 - double precision :: surfdep = DZERO ! one value per sim in UZF1; one per cell in UZF8 - integer, allocatable, dimension(:,:,:) :: IUzfNum - contains - ! Public procedures - procedure, public :: BuildModelMovers - procedure, public :: MyType - procedure, public :: ProcessAllocate - procedure, public :: ProcessStressLoop - procedure, public :: WriteDimensions - procedure, public :: WriteOptions - procedure, public :: WriteStressPeriodListData - ! Private procedures - procedure, private :: CountRunoffLakes - procedure, private :: CountRunoffSegs - procedure, private :: PopulateIUzfNum - procedure, private :: process_options - procedure, private :: UzfCount - procedure, private :: WriteDataBlock - end type UzfPackageWriterType - -contains - - subroutine ProcessAllocate(this, igrid) - implicit none - ! dummy - class(UzfPackageWriterType) :: this - integer, intent(in) :: igrid - ! local - integer :: krunLak, krunSfr - character(len=MAXCHARLEN) :: ermsg, fname - ! format - 12 format(a,'_',i0) - ! - this%Active = .true. - this%Igrid = igrid - call this%AllocatePointers() - this%DefaultBudgetText = 'UZF CELLS' - this%ipr = 1 - this%IuOrig = IUNIT(55) ! Specific to UZF package - this%OrigPkg = 'UZF' - this%PkgType = 'UZF' - write(this%PackageName,12)trim(this%PkgType),igrid - this%fileobj%FCode = FCINPUT - this%fileobj%FType = 'UZF6' - this%fileobj%PkgName = this%PackageName - fname = trim(this%ModelBasename) // '.uzf' - call this%FileWriterType%InitializeFile(fname, this%fileobj%FType, & - this%PackageName) - this%IunitBcf = iunit(1) - this%IunitGwt = iunit(15) - this%IunitLpf = iunit(23) - this%IunitHuf = iunit(37) - this%IunitSfr = iunit(44) - this%IunitUzf = iunit(55) - this%IunitUpw = iunit(62) - call GWF2UZF1AR(this%IuOrig, this%IunitBcf, this%IunitLpf, & - this%IunitUpw, igrid) - ! - this%nuztop = NUZTOP - call this%PopulateIUzfNum() - if (IRUNFLG > 0) then - krunLak = this%CountRunoffLakes() - krunSfr = this%CountRunoffSegs() - if (krunLak > 0) then - this%NeedWaterMover = .true. - if (.not. associated(NeedLakWaterMover)) then - ermsg = 'UZF needs information from LAK package, which has not' // & - ' been read yet. Please edit name file so that LAK precedes UZF.' - call store_error(ermsg) - call ustop() - endif - NeedLakWaterMover = .true. - endif - if (krunSfr > 0) then - this%NeedWaterMover = .true. - if (.not. associated(NeedSfrWaterMover)) then - ermsg = 'UZF needs information from SFR package, which has not' // & - ' been read yet. Please edit name file so that SFR precedes UZF.' - call store_error(ermsg) - call ustop() - endif - NeedSfrWaterMover = .true. - endif - endif - ! - if (.not. this%Active) then - this%fileobj%FCode = FCUNKNOWN - return - endif - ! - if (IUZFCB1 > 0) then - this%ICbc => IUZFCB1 - elseif (IUZFCB2 > 0) then - this%ICbc => IUZFCB2 - else - this%ICbc => IUZFCB1 - endif - ! - return - end subroutine ProcessAllocate - - subroutine PopulateIUzfNum(this) - ! IUzfNum will contain UZF cell ID number where UZF is active, 0 elsewhere - ! dummy - class(UzfPackageWriterType) :: this - ! local - integer :: i, j, k, kk, ki, kl - ! - kk = 0 - if (this%nuztop == 1 .or. this%nuztop == 2) then - this%kdim = 1 - elseif (this%nuztop == 3) then +module UzfPackageWriterModule + + use ConstantsModule, only: DONE, DZERO, LINELENGTH, & + MAXCHARLEN, LENMODELNAME, LENPACKAGENAME + use ConstantsPHMFModule, only: FCINPUT, FCUNKNOWN, LENCTYPE + use FileTypeModule, only: FileType + use GLOBAL, only: NPER, IUNIT, NCOL, NROW, NLAY, IOUT, ISSFLG, IBOUND + use GWFBASMODULE, only: FindHighestActiveLayer, SGWF2BAS7PNT + use GWFLAKMODULE, only: SGWF2LAK7PNT, NeedLakWaterMover + use GWFSFRMODULE, only: SGWF2SFR7PNT, NeedSfrWaterMover + use GwfUzfModule, only: NeedUzfWaterMover, IUZFBND, SGWF2UZF1PNT, SURFDEP, & + IRUNBND, NTRAIL, NSETS, VKS, THTI, THTR, THTS, & + EPS, IUZFCB1, IUZFCB2, NUZTOP, PETRATE, ROOTDPTH, & + WCWILT, FINF, IRUNFLG + use GwfUzfSubs, only: GWF2UZF1AR, GWF2UZF1RP + use LineListModule, only: LineListType + use ListModule, only: ListType + use ModelPackageModule, only: ModelPackageType, GetModelPack + use MoverModule, only: MoverType, ConstructWaterMover, AddMoverToList, & + GetMoverFromList + use MvrPackageWriterModule, only: MvrPackageWriterType + use PackageWriterModule, only: PackageWriterType + use SfrPackageWriterModule, only: SfrPackageWriterType, & + GetSfrPackageWriterByIgrid + use SfrReachModule, only: SfrReachType + use SfrSegmentModule, only: SfrSegmentType + use SimModule, only: store_error, ustop + + implicit none + + private + public :: AllUzfPkgWriters, UzfPackageWriterType + + type(ListType) :: AllUzfPkgWriters + + type, extends(PackageWriterType) :: UzfPackageWriterType + type(MvrPackageWriterType), pointer :: MvrWriter => null() + type(SfrPackageWriterType), pointer :: SfrWriter => null() + logical :: simulate_et = .true. ! simulate ET in UZ + logical :: linear_gwet = .true. ! original ET fomulation of mf2005 + logical :: square_gwet = .false. + logical :: simulate_gwseep = .false. + logical :: unsat_etwc = .false. + logical :: unsat_etae = .false. + logical :: multilayer = .false. + integer :: nuzfcells = 0 + integer :: nuztop = 0 + integer :: kdim = 0 + double precision :: surfdep = DZERO ! one value per sim in UZF1; one per cell in UZF8 + integer, allocatable, dimension(:,:,:) :: IUzfNum + contains + ! Public procedures + procedure, public :: BuildModelMovers + procedure, public :: MyType + procedure, public :: ProcessAllocate + procedure, public :: ProcessStressLoop + procedure, public :: WriteDimensions + procedure, public :: WriteOptions + procedure, public :: WriteStressPeriodListData + ! Private procedures + procedure, private :: CountRunoffLakes + procedure, private :: CountRunoffSegs + procedure, private :: PopulateIUzfNum + procedure, private :: process_options + procedure, private :: UzfCount + procedure, private :: WriteDataBlock + end type UzfPackageWriterType + +contains + + subroutine ProcessAllocate(this, igrid) + implicit none + ! dummy + class(UzfPackageWriterType) :: this + integer, intent(in) :: igrid + ! local + integer :: krunLak, krunSfr + character(len=MAXCHARLEN) :: ermsg, fname + ! format + 12 format(a,'_',i0) + ! + this%Active = .true. + this%Igrid = igrid + call this%AllocatePointers() + this%DefaultBudgetText = 'UZF CELLS' + this%ipr = 1 + this%IuOrig = IUNIT(55) ! Specific to UZF package + this%OrigPkg = 'UZF' + this%PkgType = 'UZF' + write(this%PackageName,12)trim(this%PkgType),igrid + this%fileobj%FCode = FCINPUT + this%fileobj%FType = 'UZF6' + this%fileobj%PkgName = this%PackageName + fname = trim(this%ModelBasename) // '.uzf' + call this%FileWriterType%InitializeFile(fname, this%fileobj%FType, & + this%PackageName) + this%IunitBcf = iunit(1) + this%IunitGwt = iunit(15) + this%IunitLpf = iunit(23) + this%IunitHuf = iunit(37) + this%IunitSfr = iunit(44) + this%IunitUzf = iunit(55) + this%IunitUpw = iunit(62) + call GWF2UZF1AR(this%IuOrig, this%IunitBcf, this%IunitLpf, & + this%IunitUpw, igrid) + ! + this%nuztop = NUZTOP + call this%PopulateIUzfNum() + if (IRUNFLG > 0) then + krunLak = this%CountRunoffLakes() + krunSfr = this%CountRunoffSegs() + if (krunLak > 0) then + this%NeedWaterMover = .true. + if (.not. associated(NeedLakWaterMover)) then + ermsg = 'UZF needs information from LAK package, which has not' // & + ' been read yet. Please edit name file so that LAK precedes UZF.' + call store_error(ermsg) + call ustop() + endif + NeedLakWaterMover = .true. + endif + if (krunSfr > 0) then + this%NeedWaterMover = .true. + if (.not. associated(NeedSfrWaterMover)) then + ermsg = 'UZF needs information from SFR package, which has not' // & + ' been read yet. Please edit name file so that SFR precedes UZF.' + call store_error(ermsg) + call ustop() + endif + NeedSfrWaterMover = .true. + endif + endif + ! + if (.not. this%Active) then + this%fileobj%FCode = FCUNKNOWN + return + endif + ! + if (IUZFCB1 > 0) then + this%ICbc => IUZFCB1 + elseif (IUZFCB2 > 0) then + this%ICbc => IUZFCB2 + else + this%ICbc => IUZFCB1 + endif + ! + return + end subroutine ProcessAllocate + + subroutine PopulateIUzfNum(this) + ! IUzfNum will contain UZF cell ID number where UZF is active, 0 elsewhere + ! dummy + class(UzfPackageWriterType) :: this + ! local + integer :: i, j, k, kk, ki, kl + ! + kk = 0 + if (this%nuztop == 1 .or. this%nuztop == 2) then + this%kdim = 1 + elseif (this%nuztop == 3) then this%kdim = NLAY - endif - allocate(this%IUzfNum(NCOL,NROW,this%kdim)) - kloop: do kl=1,this%kdim - rowloop: do i=1,NROW - colloop: do j=1,NCOL - this%IUzfNum(j,i,kl) = 0 - if (IUZFBND(j,i) <= 0) cycle colloop - select case (NUZTOP) - case (1) - k = 1 - ki = 1 - case (2) - k = IUZFBND(j,i) - ki = 1 - case (3) - if (IBOUND(j,i,kl) > 0) then - k = kl - ki = kl - else + endif + allocate(this%IUzfNum(NCOL,NROW,this%kdim)) + kloop: do kl=1,this%kdim + rowloop: do i=1,NROW + colloop: do j=1,NCOL + this%IUzfNum(j,i,kl) = 0 + if (IUZFBND(j,i) <= 0) cycle colloop + select case (NUZTOP) + case (1) + k = 1 + ki = 1 + case (2) + k = IUZFBND(j,i) + ki = 1 + case (3) + if (IBOUND(j,i,kl) > 0) then + k = kl + ki = kl + else k = 0 - endif - !k = FindHighestActiveLayer(i,j) - end select - if (k <= 0) cycle colloop - if (IBOUND(j,i,k) <= 0) cycle colloop - kk = kk + 1 - this%IUzfNum(j,i,ki) = kk - enddo colloop - enddo rowloop - enddo kloop - ! - return - end subroutine PopulateIUzfNum - - subroutine WriteOptions(this) - ! Overrides PackageWriterType%WriteOptions - implicit none - class(UzfPackageWriterType) :: this - ! local - integer :: i, iu - ! formats - 5 format() - 10 format(2x,a,2x,G15.8) - 20 format(2x,a,2x,a) - 50 format(2x,a) - 60 format(a) - ! - call this%process_options() - if (.not. this%Active) return - ! - iu = this%fileobj%IUnit - ! Write BEGIN Options - write(iu,5) - write(iu,60)'BEGIN Options' - ! - ! Aux variable names - if (this%NAux > 0) then - do i=1,this%NAux - write(iu,20) 'AUXILIARY', trim(this%Aux(i)) - enddo - endif - ! - if (this%ipr==1) then - write(iu,50)'PRINT_INPUT' - endif - ! - write(iu,50)'PRINT_FLOWS' - if (associated(this%ICbc)) then - if (this%ICbc > 0) then - write(iu,50)'SAVE_FLOWS' - endif - endif - ! - if (this%simulate_et) then - write(iu,50)'SIMULATE_ET' - endif - ! - if (this%linear_gwet) then - write(iu,50)'LINEAR_GWET' - endif - ! - if (this%simulate_gwseep) then - write(iu,50)'SIMULATE_GWSEEP' - endif - ! - !if (this%multilayer) then - ! write(iu,50)'MULTILAYER' - !endif - ! - if (this%NeedWaterMover) then - write(iu,50)'MOVER' - endif - ! - ! Write END Options - write(iu,60)'END Options' - ! - return - end subroutine WriteOptions - - subroutine process_options(this) - implicit none - ! dummy - class(UzfPackageWriterType) :: this - ! local - integer :: irl, irs - ! format - ! - this%MaxActiveBnd = this%UzfCount() - ! - this%SurfDep = SURFDEP - ! - irl = this%CountRunoffLakes() - irs = this%CountRunoffSegs() - if (irl > 0 .or. irs > 0) then - this%simulate_gwseep = .true. - endif - ! - if (NUZTOP == 2 .or. NUZTOP == 3) then - ! 2 -- Recharge to and discharge from layer specified in IUZFBND - ! 3 -- Recharge to and discharge from highest active cell - ! in each vertical column - !this%multilayer = .true. - endif - ! - return - end subroutine process_options - - subroutine WriteDimensions(this) - implicit none - class(UzfPackageWriterType) :: this - ! local - integer :: iu - ! formats - 5 format() - 30 format(2x,a,2x,i0) - 60 format(a) - ! - if (.not. this%NeedDimensionsBlock) return - ! - this%MaxActiveBnd = this%UzfCount() - ! - iu = this%fileobj%IUnit - ! Write BEGIN Dimensions - write(iu,5) - write(iu,60)'BEGIN Dimensions' - ! - write(iu,30)'NUZFCELLS', this%MaxActiveBnd - write(iu,30)'NTRAILWAVES', NTRAIL - write(iu,30)'NWAVESETS', NSETS - ! - ! Write END Dimensions - write(iu,60)'END Dimensions' - ! - return - end subroutine WriteDimensions - - subroutine ProcessStressLoop(this, igrid) - implicit none - ! dummy - class(UzfPackageWriterType) :: this - integer, intent(in) :: igrid - ! local - integer :: kper - logical :: currentA, forceWrite - character(len=12) :: sstrOption, lastSstrOption - ! formats - 10 format(' Processing UZF package input...') - 20 format(/,'Processing UZF package for stress period ',i0) - ! - ! Write Options and Dimensions blocks - if (.not. this%Active) return - ! - ! Check to see if UZF specifies potential for flow between UZF and any - ! lakes and streams. If so, water mover(s) will be needed. - call SGWF2LAK7PNT(this%Igrid) - call SGWF2SFR7PNT(this%Igrid) - call SGWF2UZF1PNT(this%Igrid) - ! - ! Write the options block - call this%WriteOptions() - ! - ! Initially, current block is BlockA; alternate each stress period - this%CurrentBlock => this%BlockA - this%PreviousBlock => this%BlockB - currentA = .true. - ! - lastSstrOption = '' -! sstrOption = 'TRANSIENT' - forceWrite = .true. - do kper=1,nper -!! Following Rich's example, use TRANSIENT always -- Not sure about this -! select case (ISSFLG(kper)) -! case (0) -! sstrOption = 'TRANSIENT' -! case (1) -! sstrOption = 'STEADY-STATE' -! end select - sstrOption = '' -! -! UZF requires block every stress period, so this logic is commented out. -! Just let forceWrite = true every stress period. -! if (sstrOption == lastSstrOption) then -! forceWrite = .false. -! else -! forceWrite = .true. -! endif - if (kper==1) write(*,10) - write(iout,20)kper - ! Read MF2005 input for current stress period - call GWF2UZF1RP(this%IuOrig, kper, this%IunitSfr, this%Igrid) - if (.not. this%Active) then - this%fileobj%FCode = FCUNKNOWN - return - endif - ! - if (kper==1) then - ! Write Dimensions block - call this%WriteDimensions() - ! Write Data block - call this%WriteDataBlock() - endif - ! - ! Write MF6 input for current stress period to a LineList - call this%CurrentBlock%Clear(.true.) - call this%WriteStressPeriodListData(this%CurrentBlock) - ! Write block to MF6 input file if needed - call this%WriteBlockIfNeeded(kper, sstrOption, forceWrite) - ! - ! switcheroo - if (currentA) then - this%CurrentBlock => this%BlockB - this%PreviousBlock => this%BlockA - currentA = .false. - else - this%CurrentBlock => this%BlockA - this%PreviousBlock => this%BlockB - currentA = .true. - endif - lastSstrOption = sstrOption - enddo - ! - call this%BlockA%Clear(.true.) - call this%BlockB%Clear(.true.) - ! - return - end subroutine ProcessStressLoop - - subroutine WriteStressPeriodListData(this, lineList) - ! Overrides PackageWriterType%WriteStressPeriodListData - implicit none - ! dummy - class(UzfPackageWriterType) :: this - type(LineListType), pointer :: lineList - ! local - character(len=MAXCHARLEN) :: line - integer :: i, iu, j, kk, kl, kha - ! formats - 5 format('#',4x,'iuzno',6x,'finf',13x,'pet',12x,'extdp',12x,'extwc',12x, & - ' ha ',12x,'hroot',12x,'rootact') - 10 format(2x,a,2x,i0,2x,a) - 20 format(4x,i0,7(2x,g15.8)) - ! - if (.not. this%Active) return - call SGWF2BAS7PNT(this%Igrid) - call SGWF2UZF1PNT(this%Igrid) - ! - iu = this%fileobj%IUnit - ! - ! Write uzfid finf pet extdp extwc ha hroot rootact - write(line,5) - call lineList%AddLine(line) - kloop: do kl=1,this%kdim - rowloop: do i=1,NROW - colloop: do j=1,NCOL - kk = this%IUzfNum(j,i,kl) - if (kk == 0) cycle colloop - ! Find highest active layer for this row,column location - kha = FindHighestActiveLayer(i,j) - if (this%nuztop == 3 .and. kha /= kl) cycle colloop - ! DZEROes at end are for ha, hroot, and rootact. - write(line,20)kk, FINF(j,i), PETRATE(j,i), ROOTDPTH(j,i), & - WCWILT(j,i), DZERO, DZERO, DZERO - call lineList%AddLine(line) - enddo colloop - enddo rowloop - enddo kloop - ! - return - end subroutine WriteStressPeriodListData - - subroutine WriteDataBlock(this) - ! dummy - class(UzfPackageWriterType) :: this - ! local - integer :: iuzno, i, j, iu, k, landflag, vertcon - integer :: kl, kha - double precision :: vk, thr, ths, thi, ep - ! formats - 5 format() - 20 format('# iuzno cellid landflag vertcon surfdep',9x,'vks',14x,'thtr',13x, & - 'thts',13x,'thti',14x,'eps') - 30 format(2x,i0, 5(2x,i0), 6(2x,g15.8)) - 60 format(a) - ! - call SGWF2BAS7PNT(this%igrid) - call SGWF2UZF1PNT(this%Igrid) - landflag = 1 - vertcon = 0 - ! - ! Write BEGIN Data - iu = this%fileobj%IUnit - write(iu,5) - write(iu,60)'BEGIN PACKAGEDATA' - write(iu,20) - ! - ! For each active UZF cell, need to write: - ! layer row column landflag vertcon surfdep vks thtr thts thti eps - iuzno = 1 - kloop: do kl=1,this%kdim - rowloop: do i=1,NROW - colloop: do j=1,NCOL - if (this%IUzfNum(j,i,kl) > 0) then - ! this is an active UZF cell - ! Get layer index - select case (NUZTOP) - case (1) - ! Recharge to and discharge from only the top model layer - k = 1 - case (2) - ! Recharge to and discharge from layer specified in IUZFBND - k = IUZFBND(j,i) - case (3) - ! Find highest active layer for this row,column location - kha = FindHighestActiveLayer(i,j) - ! Recharge to and discharge from highest active cell - ! in each vertical column - k = kl - if (kl == kha) then - landflag = 1 - else + endif + !k = FindHighestActiveLayer(i,j) + end select + if (k <= 0) cycle colloop + if (IBOUND(j,i,k) <= 0) cycle colloop + kk = kk + 1 + this%IUzfNum(j,i,ki) = kk + enddo colloop + enddo rowloop + enddo kloop + ! + return + end subroutine PopulateIUzfNum + + subroutine WriteOptions(this) + ! Overrides PackageWriterType%WriteOptions + implicit none + class(UzfPackageWriterType) :: this + ! local + integer :: i, iu + ! formats + 5 format() + 10 format(2x,a,2x,G15.8) + 20 format(2x,a,2x,a) + 50 format(2x,a) + 60 format(a) + ! + call this%process_options() + if (.not. this%Active) return + ! + iu = this%fileobj%IUnit + ! Write BEGIN Options + write(iu,5) + write(iu,60)'BEGIN Options' + ! + ! Aux variable names + if (this%NAux > 0) then + do i=1,this%NAux + write(iu,20) 'AUXILIARY', trim(this%Aux(i)) + enddo + endif + ! + if (this%ipr==1) then + write(iu,50)'PRINT_INPUT' + endif + ! + write(iu,50)'PRINT_FLOWS' + if (associated(this%ICbc)) then + if (this%ICbc > 0) then + write(iu,50)'SAVE_FLOWS' + endif + endif + ! + if (this%simulate_et) then + write(iu,50)'SIMULATE_ET' + endif + ! + if (this%linear_gwet) then + write(iu,50)'LINEAR_GWET' + endif + ! + if (this%simulate_gwseep) then + write(iu,50)'SIMULATE_GWSEEP' + endif + ! + !if (this%multilayer) then + ! write(iu,50)'MULTILAYER' + !endif + ! + if (this%NeedWaterMover) then + write(iu,50)'MOVER' + endif + ! + ! Write END Options + write(iu,60)'END Options' + ! + return + end subroutine WriteOptions + + subroutine process_options(this) + implicit none + ! dummy + class(UzfPackageWriterType) :: this + ! local + integer :: irl, irs + ! format + ! + this%MaxActiveBnd = this%UzfCount() + ! + this%SurfDep = SURFDEP + ! + irl = this%CountRunoffLakes() + irs = this%CountRunoffSegs() + if (irl > 0 .or. irs > 0) then + this%simulate_gwseep = .true. + endif + ! + if (NUZTOP == 2 .or. NUZTOP == 3) then + ! 2 -- Recharge to and discharge from layer specified in IUZFBND + ! 3 -- Recharge to and discharge from highest active cell + ! in each vertical column + !this%multilayer = .true. + endif + ! + return + end subroutine process_options + + subroutine WriteDimensions(this) + implicit none + class(UzfPackageWriterType) :: this + ! local + integer :: iu + ! formats + 5 format() + 30 format(2x,a,2x,i0) + 60 format(a) + ! + if (.not. this%NeedDimensionsBlock) return + ! + this%MaxActiveBnd = this%UzfCount() + ! + iu = this%fileobj%IUnit + ! Write BEGIN Dimensions + write(iu,5) + write(iu,60)'BEGIN Dimensions' + ! + write(iu,30)'NUZFCELLS', this%MaxActiveBnd + write(iu,30)'NTRAILWAVES', NTRAIL + write(iu,30)'NWAVESETS', NSETS + ! + ! Write END Dimensions + write(iu,60)'END Dimensions' + ! + return + end subroutine WriteDimensions + + subroutine ProcessStressLoop(this, igrid) + implicit none + ! dummy + class(UzfPackageWriterType) :: this + integer, intent(in) :: igrid + ! local + integer :: kper + logical :: currentA, forceWrite + character(len=12) :: sstrOption, lastSstrOption + ! formats + 10 format(' Processing UZF package input...') + 20 format(/,'Processing UZF package for stress period ',i0) + ! + ! Write Options and Dimensions blocks + if (.not. this%Active) return + ! + ! Check to see if UZF specifies potential for flow between UZF and any + ! lakes and streams. If so, water mover(s) will be needed. + call SGWF2LAK7PNT(this%Igrid) + call SGWF2SFR7PNT(this%Igrid) + call SGWF2UZF1PNT(this%Igrid) + ! + ! Write the options block + call this%WriteOptions() + ! + ! Initially, current block is BlockA; alternate each stress period + this%CurrentBlock => this%BlockA + this%PreviousBlock => this%BlockB + currentA = .true. + ! + lastSstrOption = '' +! sstrOption = 'TRANSIENT' + forceWrite = .true. + do kper=1,nper +!! Following Rich's example, use TRANSIENT always -- Not sure about this +! select case (ISSFLG(kper)) +! case (0) +! sstrOption = 'TRANSIENT' +! case (1) +! sstrOption = 'STEADY-STATE' +! end select + sstrOption = '' +! +! UZF requires block every stress period, so this logic is commented out. +! Just let forceWrite = true every stress period. +! if (sstrOption == lastSstrOption) then +! forceWrite = .false. +! else +! forceWrite = .true. +! endif + if (kper==1) write(*,10) + write(iout,20)kper + ! Read MF2005 input for current stress period + call GWF2UZF1RP(this%IuOrig, kper, this%IunitSfr, this%Igrid) + if (.not. this%Active) then + this%fileobj%FCode = FCUNKNOWN + return + endif + ! + if (kper==1) then + ! Write Dimensions block + call this%WriteDimensions() + ! Write Data block + call this%WriteDataBlock() + endif + ! + ! Write MF6 input for current stress period to a LineList + call this%CurrentBlock%Clear(.true.) + call this%WriteStressPeriodListData(this%CurrentBlock) + ! Write block to MF6 input file if needed + call this%WriteBlockIfNeeded(kper, sstrOption, forceWrite) + ! + ! switcheroo + if (currentA) then + this%CurrentBlock => this%BlockB + this%PreviousBlock => this%BlockA + currentA = .false. + else + this%CurrentBlock => this%BlockA + this%PreviousBlock => this%BlockB + currentA = .true. + endif + lastSstrOption = sstrOption + enddo + ! + call this%BlockA%Clear(.true.) + call this%BlockB%Clear(.true.) + ! + return + end subroutine ProcessStressLoop + + subroutine WriteStressPeriodListData(this, lineList) + ! Overrides PackageWriterType%WriteStressPeriodListData + implicit none + ! dummy + class(UzfPackageWriterType) :: this + type(LineListType), pointer :: lineList + ! local + character(len=MAXCHARLEN) :: line + integer :: i, iu, j, kk, kl, kha + ! formats + 5 format('#',4x,'iuzno',6x,'finf',13x,'pet',12x,'extdp',12x,'extwc',12x, & + ' ha ',12x,'hroot',12x,'rootact') + 10 format(2x,a,2x,i0,2x,a) + 20 format(4x,i0,7(2x,g15.8)) + ! + if (.not. this%Active) return + call SGWF2BAS7PNT(this%Igrid) + call SGWF2UZF1PNT(this%Igrid) + ! + iu = this%fileobj%IUnit + ! + ! Write uzfid finf pet extdp extwc ha hroot rootact + write(line,5) + call lineList%AddLine(line) + kloop: do kl=1,this%kdim + rowloop: do i=1,NROW + colloop: do j=1,NCOL + kk = this%IUzfNum(j,i,kl) + if (kk == 0) cycle colloop + ! Find highest active layer for this row,column location + kha = FindHighestActiveLayer(i,j) + if (this%nuztop == 3 .and. kha /= kl) cycle colloop + ! DZEROes at end are for ha, hroot, and rootact. + write(line,20)kk, FINF(j,i), PETRATE(j,i), ROOTDPTH(j,i), & + WCWILT(j,i), DZERO, DZERO, DZERO + call lineList%AddLine(line) + enddo colloop + enddo rowloop + enddo kloop + ! + return + end subroutine WriteStressPeriodListData + + subroutine WriteDataBlock(this) + ! dummy + class(UzfPackageWriterType) :: this + ! local + integer :: iuzno, i, j, iu, k, landflag, vertcon + integer :: kl, kha + double precision :: vk, thr, ths, thi, ep + ! formats + 5 format() + 20 format('# iuzno cellid landflag vertcon surfdep',9x,'vks',14x,'thtr',13x, & + 'thts',13x,'thti',14x,'eps') + 30 format(2x,i0, 5(2x,i0), 6(2x,g15.8)) + 60 format(a) + ! + call SGWF2BAS7PNT(this%igrid) + call SGWF2UZF1PNT(this%Igrid) + landflag = 1 + vertcon = 0 + ! + ! Write BEGIN Data + iu = this%fileobj%IUnit + write(iu,5) + write(iu,60)'BEGIN PACKAGEDATA' + write(iu,20) + ! + ! For each active UZF cell, need to write: + ! layer row column landflag vertcon surfdep vks thtr thts thti eps + iuzno = 1 + kloop: do kl=1,this%kdim + rowloop: do i=1,NROW + colloop: do j=1,NCOL + if (this%IUzfNum(j,i,kl) > 0) then + ! this is an active UZF cell + ! Get layer index + select case (NUZTOP) + case (1) + ! Recharge to and discharge from only the top model layer + k = 1 + case (2) + ! Recharge to and discharge from layer specified in IUZFBND + k = IUZFBND(j,i) + case (3) + ! Find highest active layer for this row,column location + kha = FindHighestActiveLayer(i,j) + ! Recharge to and discharge from highest active cell + ! in each vertical column + k = kl + if (kl == kha) then + landflag = 1 + else landflag = 0 - endif - end select - if (k == 0) cycle colloop - vk = VKS(j,i) - thr = THTR(j,i) - ths = THTS(j,i) - thi = THTI(j,i) - ep = EPS(j,i) - write(iu,30) iuzno, k, i, j, landflag, vertcon, SURFDEP, vk, thr, ths, thi, ep - iuzno = iuzno + 1 - endif - enddo colloop - enddo rowloop - enddo kloop - ! - write(iu,60)'END PACKAGEDATA' - ! - return - end subroutine WriteDataBlock - - function MyType(this) result (ctype) - ! dummy - class(UzfPackageWriterType) :: this - character(len=LENCTYPE) :: ctype - ! - ctype = 'UzfPackageWriterType' - ! - return - end function MyType - - integer function UzfCount(this) - ! dummy - class(UzfPackageWriterType) :: this - ! local - integer :: i, j, k, kk, kl - ! - call SGWF2UZF1PNT(this%Igrid) - call SGWF2BAS7PNT(this%Igrid) - kk = 0 - kloop: do kl=1,this%kdim - rowloop: do i=1,NROW - colloop: do j=1,NCOL - if (this%IUzfNum(j,i,kl) /= 0) then - k = FindHighestActiveLayer(i, j) - if (k == 0) cycle colloop - kk = kk + 1 - endif - enddo colloop - enddo rowloop - enddo kloop - ! - UzfCount = kk - ! - return - end function UzfCount - - integer function CountRunoffLakes(this) - ! dummy - class(UzfPackageWriterType) :: this - ! local - integer :: i, j, kk, kl - ! - call SGWF2UZF1PNT(this%Igrid) - kk = 0 - rowloop: do i=1,NROW - colloop: do j=1,NCOL - kloop: do kl=1,this%kdim - if (this%IUzfNum(j,i,kl) == 0) cycle kloop - if (IRUNBND(j,i) < 0) then - kk = kk + 1 - exit kloop - endif - enddo kloop - enddo colloop - enddo rowloop - ! - CountRunoffLakes = kk - ! - return - end function CountRunoffLakes - - integer function CountRunoffSegs(this) - ! dummy - class(UzfPackageWriterType) :: this - ! local - integer :: i, j, kk, kl - ! - call SGWF2UZF1PNT(this%Igrid) - kk = 0 - rowloop: do i=1,NROW - colloop: do j=1,NCOL - kloop: do kl=1,this%kdim - if (this%IUzfNum(j,i,kl) == 0) cycle kloop - if (IRUNBND(j,i) > 0) then - kk = kk + 1 - exit kloop - endif - enddo kloop - enddo colloop - enddo rowloop - ! - CountRunoffSegs = kk - ! - return - end function CountRunoffSegs - - subroutine BuildModelMovers(this) - ! Define a water mover for each outlet in this%Outlets - implicit none - ! dummy - class(UzfPackageWriterType) :: this - ! local - integer :: i, j, kl - integer :: igridProv, igridRcvr, idProv, idRec, isegnum - type(MoverType), pointer :: newMover => null() - type(SfrSegmentType), pointer :: seg => null() - type(SfrReachType), pointer :: reach => null() - character(len=MAXCHARLEN) :: ermsg - character(len=9) :: mvrType - character(len=LENPACKAGENAME) :: provPkgName, recLakPkgName, & - recSfrPkgName - character(len=LENMODELNAME) :: provModelName, recModelName - logical :: needSfrWriter - ! formats - 10 format(a,i0) - 20 format('SFR package for IGRID = ',i0,' not found. Please reorder', & - ' name file entries so that SFR file precedes UZF file.') - ! - if (.not. this%NeedWaterMover) return - ! - mvrType = 'FACTOR' - provPkgName = this%PackageName - provModelName = this%ModelPack%ModelName - recModelName = provModelName - igridProv = this%Igrid - igridRcvr = igridProv - write(recLakPkgName,10)'LAK_',this%Igrid - write(recSfrPkgName,10)'SFR_',this%Igrid - ! - ! Need access to SfrPackageWriter for this grid if any IRUNBND > 0 - needSfrWriter = .false. - outerloop: do i=1,NROW - innerloop: do j=1,NCOL - if (IRUNBND(j,i) > 0) then - needSfrWriter = .true. - exit outerloop - endif - enddo innerloop - enddo outerloop - if (needSfrWriter) then - ! Get SfrPackageWriter for this igrid - this%SfrWriter => GetSfrPackageWriterByIgrid(this%Igrid) - if (.not. associated(this%SfrWriter)) then - write(ermsg,20)this%Igrid - call store_error(ermsg) - call ustop() - endif - endif - ! - ! Cycle through grid and build movers as needed - rowloop: do i=1,NROW - colloop: do j=1,NCOL - kloop: do kl=1,this%kdim - if (this%IUzfNum(j,i,kl) == 0) cycle colloop - if (IRUNBND(j,i) < 0) then - ! Construct a UZF -> LAK water mover for this cell - idProv = this%IUzfNum(j,i,kl) ! UZF cell ID number is the provider ID - idRec = ABS(IRUNBND(j,i)) ! Lake number is the receiver ID - call ConstructWaterMover(newMover, mvrType, provModelName, & - recModelName, provPkgName, recLakPkgName, idProv, idRec, & - igridProv, igridRcvr, 'UZF', 'LAK', DONE) - elseif (IRUNBND(j,i) > 0) then - ! Construct a UZF -> SFR water mover for this cell - idProv = this%IUzfNum(j,i,kl) ! UZF cell ID number is the provider ID - ! Reach number will be the receiver ID. First find segment number. - isegnum = IRUNBND(j,i) - ! Get reach number of first reach in this segment from SFR - seg => this%SfrWriter%GetSegment(isegnum) ! Get segment indicated in IRUNBND - reach => seg%GetReach(1) ! Get first reach in this segment - idRec = reach%rnopkg ! Get reach number in package - call ConstructWaterMover(newMover, mvrType, provModelName, & - recModelName, provPkgName, recSfrPkgName, idProv, idRec, & - igridProv, igridRcvr, 'UZF', 'SFR', DONE) - endif - call this%AddMover(newMover) - enddo kloop - enddo colloop - enddo rowloop - ! - return - end subroutine BuildModelMovers - -end module UzfPackageWriterModule - -module uzfjunk -! Variables and arrays of UZF1 (SZ = saturated zone; LS = land surface) -! -! Read by GWF2UZF1AR: -! ITHTRFLG = 1 when SPECIFYTHTR is used (THTR will be read for 1st transient SP) -! ITHTIFLG = 1 when SPECIFYTHTI is used (THTI will be read for 1st SP) -! Iseepsupress = 1 when NOSURFLEAK is used (surface leakage not simulated) -! NUZTOP - similar to NRCHOP, signifies where recharge/discharge is simulated. -! : 1 - RECHARGE IN UZF TO TOP LAYER ONLY -! : 2 - RECHARGE IN UZF TO SPECIFIED NODE IN EACH VERTICAL COLUMN -! : 3 - RECHARGE IN UZF TO HIGHEST ACTIVE NODE IN EACH VERTICAL COLUMN -! IUZFOPT: 0 - flow will not be routed through the UZ, goes directly to SZ. -! 1 - vertical K will be specified in UZF1 input using array VKS. -! 2 - vertical K will be specified in either BCF or LPF input. -! IRUNFLG: 0 - GW discharge to LS is removed from model. -! > 0 - GW discharge goes to LAK3 or SFR2. -! IETFLG: 0 - ET will not be simulated. -! not 0 - ET will be simulated. -! IUZFCB1 = IUZFB11 - >0 is unit # for writing unformatted cell-by-cell recharge, ET, discharge using UBUDSV -! IUZFCB2 = IUZFB22 - >0 is unit # for writing unformatted cell-by-cell recharge, ET, discharge using UBDSV3 -! NTRAIL (default = 1) - # trailing waves -! NSETS (default = 1) - # wave sets -! NUZGAG - # cells for printing detailed information -! SURFDEP - average undulation depth within a finite-difference cell -! IUZFBND(ncol,nrow) - defines cells where recharge and discharge will be simulated -! NUMACTIVE - # cells connected to stream segments -! IRUNBND(ncol,nrow) - stream segment (>0) or lake number (<0) that can receive discharge or excess infiltration. -! VKS(ncol,nrow) - sat'd vertical K of UZ -! EPS(ncol,nrow) - Brooks-Corey epsilon -! THTS(ncol,nrow) - saturated water content of UZ -! THTR(ncol,nrow) - residual water content -! THTI(ncol,nrow) - initial water content -! IUZLIST(1,) - row index for cell where detailed information is printed -! (2,) - column index for cell where detailed information is printed -! (3,) - unit # of output file; or, if <0, output is summed over all model cells -! (4,) - flag for type of expanded listing -! -! Read (or calculated) by GWF2UZF1RP: -! NUZF - Flag for reading infiltration rates; if <0, use rates from previous SP -! FINF(ncol,nrow) - infiltration rates -! EXCESPP(ncol,nrow) - excess infiltration greater than VKS -! RECHSAVE(ncol,nrow) - FINF used for SFR interaction somehow -! NUZF - Flag for reading ET demand rates; if <0, use rates from previous SP -! PETRATE(ncol,nrow) - ET demand rates -! NUZF - Flag for reading ET extinction depths -! ROOTDPTH(ncol,nrow) - ET extinction depths -! NUZF - Flag for reading extinction water contents -! WCWILT - Extinction water contents -! -end module uzfjunk - + endif + end select + if (k == 0) cycle colloop + vk = VKS(j,i) + thr = THTR(j,i) + ths = THTS(j,i) + thi = THTI(j,i) + ep = EPS(j,i) + write(iu,30) iuzno, k, i, j, landflag, vertcon, SURFDEP, vk, thr, ths, thi, ep + iuzno = iuzno + 1 + endif + enddo colloop + enddo rowloop + enddo kloop + ! + write(iu,60)'END PACKAGEDATA' + ! + return + end subroutine WriteDataBlock + + function MyType(this) result (ctype) + ! dummy + class(UzfPackageWriterType) :: this + character(len=LENCTYPE) :: ctype + ! + ctype = 'UzfPackageWriterType' + ! + return + end function MyType + + integer function UzfCount(this) + ! dummy + class(UzfPackageWriterType) :: this + ! local + integer :: i, j, k, kk, kl + ! + call SGWF2UZF1PNT(this%Igrid) + call SGWF2BAS7PNT(this%Igrid) + kk = 0 + kloop: do kl=1,this%kdim + rowloop: do i=1,NROW + colloop: do j=1,NCOL + if (this%IUzfNum(j,i,kl) /= 0) then + k = FindHighestActiveLayer(i, j) + if (k == 0) cycle colloop + kk = kk + 1 + endif + enddo colloop + enddo rowloop + enddo kloop + ! + UzfCount = kk + ! + return + end function UzfCount + + integer function CountRunoffLakes(this) + ! dummy + class(UzfPackageWriterType) :: this + ! local + integer :: i, j, kk, kl + ! + call SGWF2UZF1PNT(this%Igrid) + kk = 0 + rowloop: do i=1,NROW + colloop: do j=1,NCOL + kloop: do kl=1,this%kdim + if (this%IUzfNum(j,i,kl) == 0) cycle kloop + if (IRUNBND(j,i) < 0) then + kk = kk + 1 + exit kloop + endif + enddo kloop + enddo colloop + enddo rowloop + ! + CountRunoffLakes = kk + ! + return + end function CountRunoffLakes + + integer function CountRunoffSegs(this) + ! dummy + class(UzfPackageWriterType) :: this + ! local + integer :: i, j, kk, kl + ! + call SGWF2UZF1PNT(this%Igrid) + kk = 0 + rowloop: do i=1,NROW + colloop: do j=1,NCOL + kloop: do kl=1,this%kdim + if (this%IUzfNum(j,i,kl) == 0) cycle kloop + if (IRUNBND(j,i) > 0) then + kk = kk + 1 + exit kloop + endif + enddo kloop + enddo colloop + enddo rowloop + ! + CountRunoffSegs = kk + ! + return + end function CountRunoffSegs + + subroutine BuildModelMovers(this) + ! Define a water mover for each outlet in this%Outlets + implicit none + ! dummy + class(UzfPackageWriterType) :: this + ! local + integer :: i, j, kl + integer :: igridProv, igridRcvr, idProv, idRec, isegnum + type(MoverType), pointer :: newMover => null() + type(SfrSegmentType), pointer :: seg => null() + type(SfrReachType), pointer :: reach => null() + character(len=MAXCHARLEN) :: ermsg + character(len=9) :: mvrType + character(len=LENPACKAGENAME) :: provPkgName, recLakPkgName, & + recSfrPkgName + character(len=LENMODELNAME) :: provModelName, recModelName + logical :: needSfrWriter + ! formats + 10 format(a,i0) + 20 format('SFR package for IGRID = ',i0,' not found. Please reorder', & + ' name file entries so that SFR file precedes UZF file.') + ! + if (.not. this%NeedWaterMover) return + ! + mvrType = 'FACTOR' + provPkgName = this%PackageName + provModelName = this%ModelPack%ModelName + recModelName = provModelName + igridProv = this%Igrid + igridRcvr = igridProv + write(recLakPkgName,10)'LAK_',this%Igrid + write(recSfrPkgName,10)'SFR_',this%Igrid + ! + ! Need access to SfrPackageWriter for this grid if any IRUNBND > 0 + needSfrWriter = .false. + outerloop: do i=1,NROW + innerloop: do j=1,NCOL + if (IRUNBND(j,i) > 0) then + needSfrWriter = .true. + exit outerloop + endif + enddo innerloop + enddo outerloop + if (needSfrWriter) then + ! Get SfrPackageWriter for this igrid + this%SfrWriter => GetSfrPackageWriterByIgrid(this%Igrid) + if (.not. associated(this%SfrWriter)) then + write(ermsg,20)this%Igrid + call store_error(ermsg) + call ustop() + endif + endif + ! + ! Cycle through grid and build movers as needed + rowloop: do i=1,NROW + colloop: do j=1,NCOL + kloop: do kl=1,this%kdim + if (this%IUzfNum(j,i,kl) == 0) cycle colloop + if (IRUNBND(j,i) < 0) then + ! Construct a UZF -> LAK water mover for this cell + idProv = this%IUzfNum(j,i,kl) ! UZF cell ID number is the provider ID + idRec = ABS(IRUNBND(j,i)) ! Lake number is the receiver ID + call ConstructWaterMover(newMover, mvrType, provModelName, & + recModelName, provPkgName, recLakPkgName, idProv, idRec, & + igridProv, igridRcvr, 'UZF', 'LAK', DONE) + elseif (IRUNBND(j,i) > 0) then + ! Construct a UZF -> SFR water mover for this cell + idProv = this%IUzfNum(j,i,kl) ! UZF cell ID number is the provider ID + ! Reach number will be the receiver ID. First find segment number. + isegnum = IRUNBND(j,i) + ! Get reach number of first reach in this segment from SFR + seg => this%SfrWriter%GetSegment(isegnum) ! Get segment indicated in IRUNBND + reach => seg%GetReach(1) ! Get first reach in this segment + idRec = reach%rnopkg ! Get reach number in package + call ConstructWaterMover(newMover, mvrType, provModelName, & + recModelName, provPkgName, recSfrPkgName, idProv, idRec, & + igridProv, igridRcvr, 'UZF', 'SFR', DONE) + endif + call this%AddMover(newMover) + enddo kloop + enddo colloop + enddo rowloop + ! + return + end subroutine BuildModelMovers + +end module UzfPackageWriterModule + +module uzfjunk +! Variables and arrays of UZF1 (SZ = saturated zone; LS = land surface) +! +! Read by GWF2UZF1AR: +! ITHTRFLG = 1 when SPECIFYTHTR is used (THTR will be read for 1st transient SP) +! ITHTIFLG = 1 when SPECIFYTHTI is used (THTI will be read for 1st SP) +! Iseepsupress = 1 when NOSURFLEAK is used (surface leakage not simulated) +! NUZTOP - similar to NRCHOP, signifies where recharge/discharge is simulated. +! : 1 - RECHARGE IN UZF TO TOP LAYER ONLY +! : 2 - RECHARGE IN UZF TO SPECIFIED NODE IN EACH VERTICAL COLUMN +! : 3 - RECHARGE IN UZF TO HIGHEST ACTIVE NODE IN EACH VERTICAL COLUMN +! IUZFOPT: 0 - flow will not be routed through the UZ, goes directly to SZ. +! 1 - vertical K will be specified in UZF1 input using array VKS. +! 2 - vertical K will be specified in either BCF or LPF input. +! IRUNFLG: 0 - GW discharge to LS is removed from model. +! > 0 - GW discharge goes to LAK3 or SFR2. +! IETFLG: 0 - ET will not be simulated. +! not 0 - ET will be simulated. +! IUZFCB1 = IUZFB11 - >0 is unit # for writing unformatted cell-by-cell recharge, ET, discharge using UBUDSV +! IUZFCB2 = IUZFB22 - >0 is unit # for writing unformatted cell-by-cell recharge, ET, discharge using UBDSV3 +! NTRAIL (default = 1) - # trailing waves +! NSETS (default = 1) - # wave sets +! NUZGAG - # cells for printing detailed information +! SURFDEP - average undulation depth within a finite-difference cell +! IUZFBND(ncol,nrow) - defines cells where recharge and discharge will be simulated +! NUMACTIVE - # cells connected to stream segments +! IRUNBND(ncol,nrow) - stream segment (>0) or lake number (<0) that can receive discharge or excess infiltration. +! VKS(ncol,nrow) - sat'd vertical K of UZ +! EPS(ncol,nrow) - Brooks-Corey epsilon +! THTS(ncol,nrow) - saturated water content of UZ +! THTR(ncol,nrow) - residual water content +! THTI(ncol,nrow) - initial water content +! IUZLIST(1,) - row index for cell where detailed information is printed +! (2,) - column index for cell where detailed information is printed +! (3,) - unit # of output file; or, if <0, output is summed over all model cells +! (4,) - flag for type of expanded listing +! +! Read (or calculated) by GWF2UZF1RP: +! NUZF - Flag for reading infiltration rates; if <0, use rates from previous SP +! FINF(ncol,nrow) - infiltration rates +! EXCESPP(ncol,nrow) - excess infiltration greater than VKS +! RECHSAVE(ncol,nrow) - FINF used for SFR interaction somehow +! NUZF - Flag for reading ET demand rates; if <0, use rates from previous SP +! PETRATE(ncol,nrow) - ET demand rates +! NUZF - Flag for reading ET extinction depths +! ROOTDPTH(ncol,nrow) - ET extinction depths +! NUZF - Flag for reading extinction water contents +! WCWILT - Extinction water contents +! +end module uzfjunk + diff --git a/utils/zonebudget/msvs/zonebudget.sln b/utils/zonebudget/msvs/zonebudget.sln index 1cbc466a727..0da07f68a2c 100644 --- a/utils/zonebudget/msvs/zonebudget.sln +++ b/utils/zonebudget/msvs/zonebudget.sln @@ -1,22 +1,22 @@ - -Microsoft Visual Studio Solution File, Format Version 12.00 -# Visual Studio 2013 -VisualStudioVersion = 12.0.30723.0 -MinimumVisualStudioVersion = 10.0.40219.1 -Project("{6989167D-11E4-40FE-8C1A-2192A86A7E90}") = "zonebudget", "zonebudget.vfproj", "{E7756A4E-003C-4D3D-B618-CC2BE6D20B04}" -EndProject -Global - GlobalSection(SolutionConfigurationPlatforms) = preSolution - Debug|Win32 = Debug|Win32 - Release|Win32 = Release|Win32 - EndGlobalSection - GlobalSection(ProjectConfigurationPlatforms) = postSolution - {E7756A4E-003C-4D3D-B618-CC2BE6D20B04}.Debug|Win32.ActiveCfg = Debug|Win32 - {E7756A4E-003C-4D3D-B618-CC2BE6D20B04}.Debug|Win32.Build.0 = Debug|Win32 - {E7756A4E-003C-4D3D-B618-CC2BE6D20B04}.Release|Win32.ActiveCfg = Release|Win32 - {E7756A4E-003C-4D3D-B618-CC2BE6D20B04}.Release|Win32.Build.0 = Release|Win32 - EndGlobalSection - GlobalSection(SolutionProperties) = preSolution - HideSolutionNode = FALSE - EndGlobalSection -EndGlobal + +Microsoft Visual Studio Solution File, Format Version 12.00 +# Visual Studio 2013 +VisualStudioVersion = 12.0.30723.0 +MinimumVisualStudioVersion = 10.0.40219.1 +Project("{6989167D-11E4-40FE-8C1A-2192A86A7E90}") = "zonebudget", "zonebudget.vfproj", "{E7756A4E-003C-4D3D-B618-CC2BE6D20B04}" +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|Win32 = Debug|Win32 + Release|Win32 = Release|Win32 + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {E7756A4E-003C-4D3D-B618-CC2BE6D20B04}.Debug|Win32.ActiveCfg = Debug|Win32 + {E7756A4E-003C-4D3D-B618-CC2BE6D20B04}.Debug|Win32.Build.0 = Debug|Win32 + {E7756A4E-003C-4D3D-B618-CC2BE6D20B04}.Release|Win32.ActiveCfg = Release|Win32 + {E7756A4E-003C-4D3D-B618-CC2BE6D20B04}.Release|Win32.Build.0 = Release|Win32 + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection +EndGlobal diff --git a/utils/zonebudget/msvs/zonebudget.vfproj b/utils/zonebudget/msvs/zonebudget.vfproj index 0aa1c2ee065..62ca3587830 100644 --- a/utils/zonebudget/msvs/zonebudget.vfproj +++ b/utils/zonebudget/msvs/zonebudget.vfproj @@ -1,49 +1,49 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/utils/zonebudget/pymake/extrafiles.txt b/utils/zonebudget/pymake/extrafiles.txt index cdd86b719d1..5a2daedbf15 100644 --- a/utils/zonebudget/pymake/extrafiles.txt +++ b/utils/zonebudget/pymake/extrafiles.txt @@ -1,14 +1,14 @@ -../../../src/Utilities/ArrayHandlers.f90 -../../../src/Utilities/ArrayReaders.f90 -../../../src/Utilities/BlockParser.f90 -../../../src/Utilities/Budget.f90 -../../../src/Utilities/Constants.f90 -../../../src/Utilities/genericutils.f90 -../../../src/Utilities/InputOutput.f90 -../../../src/Utilities/kind.f90 -../../../src/Utilities/OpenSpec.f90 -../../../src/Utilities/sort.f90 -../../../src/Utilities/Sim.f90 -../../../src/Utilities/SimVariables.f90 -../../../src/Utilities/version.f90 - +../../../src/Utilities/ArrayHandlers.f90 +../../../src/Utilities/ArrayReaders.f90 +../../../src/Utilities/BlockParser.f90 +../../../src/Utilities/Budget.f90 +../../../src/Utilities/Constants.f90 +../../../src/Utilities/genericutils.f90 +../../../src/Utilities/InputOutput.f90 +../../../src/Utilities/kind.f90 +../../../src/Utilities/OpenSpec.f90 +../../../src/Utilities/sort.f90 +../../../src/Utilities/Sim.f90 +../../../src/Utilities/SimVariables.f90 +../../../src/Utilities/version.f90 + diff --git a/utils/zonebudget/src/budgetdata.f90 b/utils/zonebudget/src/budgetdata.f90 index 584b25e77df..3d79a54c97c 100644 --- a/utils/zonebudget/src/budgetdata.f90 +++ b/utils/zonebudget/src/budgetdata.f90 @@ -1,202 +1,202 @@ -module BudgetDataModule - +module BudgetDataModule + use KindModule - use SimModule, only: store_error, store_error_unit, ustop - use ConstantsModule, only: LINELENGTH - implicit none - - private - public :: budgetdata_init - public :: budgetdata_read - public :: budgetdata_finalize - public :: budtxt, ia, ja, flowja, nodesrc, nodedst, flowdata, & - dstpackagename, nbudterms, kstp, kper, delt, totim, & - srcmodelname, dstmodelname, hasimeth1flowja - - logical :: hasimeth1flowja = .false. - integer(I4B) :: inunit - integer(I4B) :: nbudterms = 0 - integer(I4B) :: kstp - integer(I4B) :: kper - character(len=16) :: budtxt - integer(I4B) :: nval - integer(I4B) :: idum1 - integer(I4B) :: idum2 - integer(I4B) :: imeth - real(DP) :: delt - real(DP) :: pertim - real(DP) :: totim - character(len=16) :: srcmodelname - character(len=16) :: srcpackagename - integer(I4B) :: ndat - character(len=16), dimension(:), allocatable :: auxtxt - integer(I4B) :: nlist - integer(I4B), allocatable, dimension(:) :: ia - integer(I4B), allocatable, dimension(:) :: ja - real(DP), dimension(:), allocatable :: flowja - integer(I4B), dimension(:), allocatable :: nodesrc - integer(I4B), dimension(:), allocatable :: nodedst - real(DP), dimension(:, :), allocatable :: flowdata - character(len=16) :: dstmodelname - character(len=16) :: dstpackagename - - contains - - subroutine budgetdata_init(iu, iout, ncrbud) -! ****************************************************************************** -! budgetdata_init -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - integer(I4B), intent(in) :: iu - integer(I4B), intent(in) :: iout - integer(I4B), intent(out) :: ncrbud - ! -- local - integer(I4B) :: icount, kstp_last, kper_last - logical :: success -! ------------------------------------------------------------------------------ - inunit = iu - icount = 0 - ncrbud = 0 - ! - ! -- Read the first budget data record to set kstp_last, kstp_last - call budgetdata_read(success) - kstp_last = kstp - kper_last = kper - rewind(inunit) - ! - ! -- Determine number of budget terms within a time step - write(iout, '(a)') 'Reading budget file to determine number of terms per time step.' - icount = 1 - do - call budgetdata_read(success, iout) - if (.not. success) exit - if (kstp_last /= kstp .or. kper_last /= kper) exit - icount = icount + 1 - nbudterms = nbudterms + 1 - if (trim(adjustl(budtxt)) == 'FLOW-JA-FACE' .and. & - srcmodelname == dstmodelname) then - if(allocated(nodesrc)) ncrbud = maxval(nodesrc) - endif - enddo - rewind(inunit) - write(iout, '(a, i0, a)') 'Detected ', nbudterms, ' unique flow terms in budget file.' - ! - ! -- return - return - end subroutine budgetdata_init - - subroutine budgetdata_read(success, iout_opt) -! ****************************************************************************** -! budgetdata_read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - logical, intent(out) :: success - integer(I4B), intent(in), optional :: iout_opt - ! -- local - integer(I4B) :: i, n, iostat, iout - character(len=LINELENGTH) :: errmsg -! ------------------------------------------------------------------------------ - ! - if (present(iout_opt)) then - iout = iout_opt - else - iout = 0 - endif - ! - kstp = 0 - kper = 0 - budtxt = '' - nval = 0 - idum1 = 0 - idum2 = 0 - srcmodelname = '' - srcpackagename = '' - dstmodelname = '' - dstpackagename = '' - - success = .true. - read(inunit, iostat=iostat) kstp, kper, budtxt, nval, idum1, idum2 - if (iostat /= 0) then - success = .false. - return - endif - read(inunit) imeth, delt, pertim, totim - if(imeth == 1) then - if (trim(adjustl(budtxt)) == 'FLOW-JA-FACE') then - if(allocated(flowja)) deallocate(flowja) - allocate(flowja(nval)) - read(inunit) flowja - hasimeth1flowja = .true. - else - nval = nval * idum1 * abs(idum2) - if(allocated(flowdata)) deallocate(flowdata) - allocate(flowdata(1, nval)) - if(allocated(nodesrc)) deallocate(nodesrc) - allocate(nodesrc(nval)) - read(inunit) flowdata - do i = 1, nval - nodesrc(i) = i - enddo - endif - elseif (imeth == 6) then - ! -- method code 6 - read(inunit) srcmodelname - read(inunit) srcpackagename - read(inunit) dstmodelname - read(inunit) dstpackagename - read(inunit) ndat - if(allocated(auxtxt)) deallocate(auxtxt) - allocate(auxtxt(ndat-1)) - read(inunit) auxtxt - read(inunit) nlist - if(allocated(nodesrc)) deallocate(nodesrc) - allocate(nodesrc(nlist)) - if(allocated(nodedst)) deallocate(nodedst) - allocate(nodedst(nlist)) - if(allocated(flowdata)) deallocate(flowdata) - allocate(flowdata(ndat, nlist)) - read(inunit) (nodesrc(n), nodedst(n), (flowdata(i,n), i = 1, ndat), n = 1, nlist) - else - write(errmsg, '(a, a)') 'ERROR READING: ', trim(budtxt) - call store_error(errmsg) - write(errmsg, '(a, i0)') 'INVALID METHOD CODE DETECTED: ', imeth - call store_error(errmsg) - call store_error_unit(inunit) - call ustop() - endif - if (iout > 0) then - write(iout, '(1pg15.6, a, 1x, a)') totim, budtxt, dstpackagename - endif - ! - ! -- return - return - end subroutine budgetdata_read - - subroutine budgetdata_finalize() -! ****************************************************************************** -! budgetdata_finalize -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ -! ------------------------------------------------------------------------------ - close(inunit) - if(allocated(auxtxt)) deallocate(auxtxt) - if(allocated(ia)) deallocate(ia) - if(allocated(ja)) deallocate(ja) - if(allocated(flowja)) deallocate(flowja) - if(allocated(nodesrc)) deallocate(nodesrc) - if(allocated(nodedst)) deallocate(nodedst) - if(allocated(flowdata)) deallocate(flowdata) - ! - ! -- return - return - end subroutine budgetdata_finalize - -end module BudgetDataModule + use SimModule, only: store_error, store_error_unit, ustop + use ConstantsModule, only: LINELENGTH + implicit none + + private + public :: budgetdata_init + public :: budgetdata_read + public :: budgetdata_finalize + public :: budtxt, ia, ja, flowja, nodesrc, nodedst, flowdata, & + dstpackagename, nbudterms, kstp, kper, delt, totim, & + srcmodelname, dstmodelname, hasimeth1flowja + + logical :: hasimeth1flowja = .false. + integer(I4B) :: inunit + integer(I4B) :: nbudterms = 0 + integer(I4B) :: kstp + integer(I4B) :: kper + character(len=16) :: budtxt + integer(I4B) :: nval + integer(I4B) :: idum1 + integer(I4B) :: idum2 + integer(I4B) :: imeth + real(DP) :: delt + real(DP) :: pertim + real(DP) :: totim + character(len=16) :: srcmodelname + character(len=16) :: srcpackagename + integer(I4B) :: ndat + character(len=16), dimension(:), allocatable :: auxtxt + integer(I4B) :: nlist + integer(I4B), allocatable, dimension(:) :: ia + integer(I4B), allocatable, dimension(:) :: ja + real(DP), dimension(:), allocatable :: flowja + integer(I4B), dimension(:), allocatable :: nodesrc + integer(I4B), dimension(:), allocatable :: nodedst + real(DP), dimension(:, :), allocatable :: flowdata + character(len=16) :: dstmodelname + character(len=16) :: dstpackagename + + contains + + subroutine budgetdata_init(iu, iout, ncrbud) +! ****************************************************************************** +! budgetdata_init +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + integer(I4B), intent(in) :: iu + integer(I4B), intent(in) :: iout + integer(I4B), intent(out) :: ncrbud + ! -- local + integer(I4B) :: icount, kstp_last, kper_last + logical :: success +! ------------------------------------------------------------------------------ + inunit = iu + icount = 0 + ncrbud = 0 + ! + ! -- Read the first budget data record to set kstp_last, kstp_last + call budgetdata_read(success) + kstp_last = kstp + kper_last = kper + rewind(inunit) + ! + ! -- Determine number of budget terms within a time step + write(iout, '(a)') 'Reading budget file to determine number of terms per time step.' + icount = 1 + do + call budgetdata_read(success, iout) + if (.not. success) exit + if (kstp_last /= kstp .or. kper_last /= kper) exit + icount = icount + 1 + nbudterms = nbudterms + 1 + if (trim(adjustl(budtxt)) == 'FLOW-JA-FACE' .and. & + srcmodelname == dstmodelname) then + if(allocated(nodesrc)) ncrbud = maxval(nodesrc) + endif + enddo + rewind(inunit) + write(iout, '(a, i0, a)') 'Detected ', nbudterms, ' unique flow terms in budget file.' + ! + ! -- return + return + end subroutine budgetdata_init + + subroutine budgetdata_read(success, iout_opt) +! ****************************************************************************** +! budgetdata_read +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + logical, intent(out) :: success + integer(I4B), intent(in), optional :: iout_opt + ! -- local + integer(I4B) :: i, n, iostat, iout + character(len=LINELENGTH) :: errmsg +! ------------------------------------------------------------------------------ + ! + if (present(iout_opt)) then + iout = iout_opt + else + iout = 0 + endif + ! + kstp = 0 + kper = 0 + budtxt = '' + nval = 0 + idum1 = 0 + idum2 = 0 + srcmodelname = '' + srcpackagename = '' + dstmodelname = '' + dstpackagename = '' + + success = .true. + read(inunit, iostat=iostat) kstp, kper, budtxt, nval, idum1, idum2 + if (iostat /= 0) then + success = .false. + return + endif + read(inunit) imeth, delt, pertim, totim + if(imeth == 1) then + if (trim(adjustl(budtxt)) == 'FLOW-JA-FACE') then + if(allocated(flowja)) deallocate(flowja) + allocate(flowja(nval)) + read(inunit) flowja + hasimeth1flowja = .true. + else + nval = nval * idum1 * abs(idum2) + if(allocated(flowdata)) deallocate(flowdata) + allocate(flowdata(1, nval)) + if(allocated(nodesrc)) deallocate(nodesrc) + allocate(nodesrc(nval)) + read(inunit) flowdata + do i = 1, nval + nodesrc(i) = i + enddo + endif + elseif (imeth == 6) then + ! -- method code 6 + read(inunit) srcmodelname + read(inunit) srcpackagename + read(inunit) dstmodelname + read(inunit) dstpackagename + read(inunit) ndat + if(allocated(auxtxt)) deallocate(auxtxt) + allocate(auxtxt(ndat-1)) + read(inunit) auxtxt + read(inunit) nlist + if(allocated(nodesrc)) deallocate(nodesrc) + allocate(nodesrc(nlist)) + if(allocated(nodedst)) deallocate(nodedst) + allocate(nodedst(nlist)) + if(allocated(flowdata)) deallocate(flowdata) + allocate(flowdata(ndat, nlist)) + read(inunit) (nodesrc(n), nodedst(n), (flowdata(i,n), i = 1, ndat), n = 1, nlist) + else + write(errmsg, '(a, a)') 'ERROR READING: ', trim(budtxt) + call store_error(errmsg) + write(errmsg, '(a, i0)') 'INVALID METHOD CODE DETECTED: ', imeth + call store_error(errmsg) + call store_error_unit(inunit) + call ustop() + endif + if (iout > 0) then + write(iout, '(1pg15.6, a, 1x, a)') totim, budtxt, dstpackagename + endif + ! + ! -- return + return + end subroutine budgetdata_read + + subroutine budgetdata_finalize() +! ****************************************************************************** +! budgetdata_finalize +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ + close(inunit) + if(allocated(auxtxt)) deallocate(auxtxt) + if(allocated(ia)) deallocate(ia) + if(allocated(ja)) deallocate(ja) + if(allocated(flowja)) deallocate(flowja) + if(allocated(nodesrc)) deallocate(nodesrc) + if(allocated(nodedst)) deallocate(nodedst) + if(allocated(flowdata)) deallocate(flowdata) + ! + ! -- return + return + end subroutine budgetdata_finalize + +end module BudgetDataModule diff --git a/utils/zonebudget/src/grb.f90 b/utils/zonebudget/src/grb.f90 index 51960f13daf..d257fb25305 100644 --- a/utils/zonebudget/src/grb.f90 +++ b/utils/zonebudget/src/grb.f90 @@ -1,167 +1,167 @@ -module GrbModule - +module GrbModule + use KindModule - use SimVariablesModule, only: iout - use SimModule, only: store_error, store_error_unit, ustop - implicit none - private - public :: read_grb - - contains - - subroutine read_grb(inunit, ia, ja, mshape) -! ****************************************************************************** -! read_grb -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use InputOutputModule, only: urword - ! -- dummy - integer(I4B), intent(in) :: inunit - integer(I4B), allocatable, dimension(:), intent(out) :: ia - integer(I4B), allocatable, dimension(:), intent(out) :: ja - integer(I4B), allocatable, dimension(:), intent(out) :: mshape - ! -- local - character(len=50) :: hdrtxt - integer(I4B) :: lloc, istart, istop - character(len=50) :: dataname - character(len=50) :: datatype - integer(I4B) :: ntxt, lentxt, ndim, i, j, n, nval - integer(I4B) :: nja, ncells - real(DP) :: r, d - character(len=:), allocatable :: line - character(len=:), allocatable :: dfntxt - integer(I4B), dimension(:), allocatable :: ishape - integer(I4B), dimension(:), allocatable :: itmp - real(DP), dimension(:), allocatable :: dtmp -! ------------------------------------------------------------------------------ - ! - ! -- message - write(iout, '(/,a)') 'Processing Binary Grid File' - ! -- grid keyword - read(inunit) hdrtxt - lloc = 1 - call urword(hdrtxt, lloc, istart, istop, 0, i, r, iout, inunit) - if ( hdrtxt(istart:istop) /= 'GRID') then - call store_error('GRB FILE MUST BEGIN WITH WORD GRID. FOUND: ' // hdrtxt(istart:istop)) - call store_error_unit(inunit) - call ustop() - endif - ! - ! -- grid type, allocate mshape accordingly - call urword(hdrtxt, lloc, istart, istop, 0, i, r, iout, inunit) - if (hdrtxt(istart:istop) == 'DIS') then - write(iout, '(2x, a)') 'Detected regular MODFLOW grid (DIS)' - allocate(mshape(3)) - elseif (hdrtxt(istart:istop) == 'DISV') then - write(iout, '(2x, a)') 'Detected Discretization by Vertices grid (DISV)' - allocate(mshape(2)) - elseif (hdrtxt(istart:istop) == 'DISU') then - write(iout, '(2x, a)') 'Detected unstructured grid (DISU)' - allocate(mshape(1)) - else - call store_error('UNKNOWN GRID TYPE IN GRB FILE: ' // hdrtxt(istart:istop)) - call store_error_unit(inunit) - call ustop() - endif - mshape(:) = 0 - ! - ! -- version - read(inunit) hdrtxt - write(iout, '(2x, a, a)') 'Detected ', trim(hdrtxt(1:49)) - ! - ! -- ntxt - read(inunit) hdrtxt - write(iout, '(2x, a, a)') 'Detected ', trim(hdrtxt(1:49)) - lloc=1 - call urword(hdrtxt, lloc, istart, istop, 0, i, r, iout, inunit) - call urword(hdrtxt, lloc, istart, istop, 2, ntxt, r, iout, inunit) - - ! -- lentxt - read(inunit) hdrtxt - write(iout, '(2x, a, a)') 'Detected ', trim(hdrtxt(1:49)) - lloc=1 - call urword(hdrtxt, lloc, istart, istop, 0, i, r, iout, inunit) - call urword(hdrtxt, lloc, istart, istop, 2, lentxt, r, iout, inunit) - ! - ! -- read txt definitions - allocate(character(len=lentxt)::line) - allocate(character(len=lentxt*ntxt)::dfntxt) - read(inunit) dfntxt - ! -- read each data record - do n = 1, lentxt*ntxt, lentxt - line = dfntxt(n:n+lentxt-1) - lloc = 1 - call urword(line, lloc, istart, istop, 0, i, r, iout, inunit) - dataname = line(istart:istop) - call urword(line, lloc, istart, istop, 0, i, r, iout, inunit) - datatype = line(istart:istop) - call urword(line, lloc, istart, istop, 0, i, r, iout, inunit) - call urword(line, lloc, istart, istop, 2, ndim, r, iout, inunit) - allocate(ishape(ndim)) - do j = 1, ndim - call urword(line, lloc, istart, istop, 2, ishape(j), r, iout, inunit) - enddo - select case (trim(datatype)) - case('INTEGER') - if(ndim == 0)then - read(inunit) i - write(iout, '(2x, a, a, a, i0)') 'Detected ', trim(dataname), ' = ', i - if(trim(dataname) == 'NLAY') mshape(1) = i - if(trim(dataname) == 'NROW') mshape(2) = i - if(trim(dataname) == 'NCOL') mshape(3) = i - if(trim(dataname) == 'NCPL') mshape(2) = i - if(trim(dataname) == 'NJA') nja = i - if(trim(dataname) == 'NCELLS') ncells = i - if(trim(dataname) == 'NODES') then - ncells = i - mshape(1) = i - endif - else - write(iout, '(2x, a, a)') 'Detected integer array ', trim(dataname) - nval = 1 - do j = 1, ndim - nval = nval * ishape(j) - enddo - allocate(itmp(nval)) - read(inunit) itmp - if(trim(dataname) == 'IA') then - allocate (ia(ncells + 1)) - ia = itmp - elseif(trim(dataname) == 'JA') then - allocate (ja(nja)) - ja = itmp - endif - deallocate(itmp) - endif - case('DOUBLE') - if(ndim == 0)then - read(inunit) d - write(iout, '(2x, a, a, a, G0)') 'Detected ', trim(dataname), ' = ', d - else - write(iout, '(2x, a, a)') 'Detected double array ', trim(dataname) - nval = 1 - do j = 1, ndim - nval = nval * ishape(j) - enddo - allocate(dtmp(nval)) - read(inunit) dtmp - deallocate(dtmp) - endif - end select - deallocate(ishape) - enddo - close(inunit) - write(iout, '(a)') 'Done processing Binary Grid File' - ! - ! -- deallocate local storage - deallocate(line) - deallocate(dfntxt) - ! - ! -- return - return - end subroutine read_grb - -end module GrbModule + use SimVariablesModule, only: iout + use SimModule, only: store_error, store_error_unit, ustop + implicit none + private + public :: read_grb + + contains + + subroutine read_grb(inunit, ia, ja, mshape) +! ****************************************************************************** +! read_grb +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use InputOutputModule, only: urword + ! -- dummy + integer(I4B), intent(in) :: inunit + integer(I4B), allocatable, dimension(:), intent(out) :: ia + integer(I4B), allocatable, dimension(:), intent(out) :: ja + integer(I4B), allocatable, dimension(:), intent(out) :: mshape + ! -- local + character(len=50) :: hdrtxt + integer(I4B) :: lloc, istart, istop + character(len=50) :: dataname + character(len=50) :: datatype + integer(I4B) :: ntxt, lentxt, ndim, i, j, n, nval + integer(I4B) :: nja, ncells + real(DP) :: r, d + character(len=:), allocatable :: line + character(len=:), allocatable :: dfntxt + integer(I4B), dimension(:), allocatable :: ishape + integer(I4B), dimension(:), allocatable :: itmp + real(DP), dimension(:), allocatable :: dtmp +! ------------------------------------------------------------------------------ + ! + ! -- message + write(iout, '(/,a)') 'Processing Binary Grid File' + ! -- grid keyword + read(inunit) hdrtxt + lloc = 1 + call urword(hdrtxt, lloc, istart, istop, 0, i, r, iout, inunit) + if ( hdrtxt(istart:istop) /= 'GRID') then + call store_error('GRB FILE MUST BEGIN WITH WORD GRID. FOUND: ' // hdrtxt(istart:istop)) + call store_error_unit(inunit) + call ustop() + endif + ! + ! -- grid type, allocate mshape accordingly + call urword(hdrtxt, lloc, istart, istop, 0, i, r, iout, inunit) + if (hdrtxt(istart:istop) == 'DIS') then + write(iout, '(2x, a)') 'Detected regular MODFLOW grid (DIS)' + allocate(mshape(3)) + elseif (hdrtxt(istart:istop) == 'DISV') then + write(iout, '(2x, a)') 'Detected Discretization by Vertices grid (DISV)' + allocate(mshape(2)) + elseif (hdrtxt(istart:istop) == 'DISU') then + write(iout, '(2x, a)') 'Detected unstructured grid (DISU)' + allocate(mshape(1)) + else + call store_error('UNKNOWN GRID TYPE IN GRB FILE: ' // hdrtxt(istart:istop)) + call store_error_unit(inunit) + call ustop() + endif + mshape(:) = 0 + ! + ! -- version + read(inunit) hdrtxt + write(iout, '(2x, a, a)') 'Detected ', trim(hdrtxt(1:49)) + ! + ! -- ntxt + read(inunit) hdrtxt + write(iout, '(2x, a, a)') 'Detected ', trim(hdrtxt(1:49)) + lloc=1 + call urword(hdrtxt, lloc, istart, istop, 0, i, r, iout, inunit) + call urword(hdrtxt, lloc, istart, istop, 2, ntxt, r, iout, inunit) + + ! -- lentxt + read(inunit) hdrtxt + write(iout, '(2x, a, a)') 'Detected ', trim(hdrtxt(1:49)) + lloc=1 + call urword(hdrtxt, lloc, istart, istop, 0, i, r, iout, inunit) + call urword(hdrtxt, lloc, istart, istop, 2, lentxt, r, iout, inunit) + ! + ! -- read txt definitions + allocate(character(len=lentxt)::line) + allocate(character(len=lentxt*ntxt)::dfntxt) + read(inunit) dfntxt + ! -- read each data record + do n = 1, lentxt*ntxt, lentxt + line = dfntxt(n:n+lentxt-1) + lloc = 1 + call urword(line, lloc, istart, istop, 0, i, r, iout, inunit) + dataname = line(istart:istop) + call urword(line, lloc, istart, istop, 0, i, r, iout, inunit) + datatype = line(istart:istop) + call urword(line, lloc, istart, istop, 0, i, r, iout, inunit) + call urword(line, lloc, istart, istop, 2, ndim, r, iout, inunit) + allocate(ishape(ndim)) + do j = 1, ndim + call urword(line, lloc, istart, istop, 2, ishape(j), r, iout, inunit) + enddo + select case (trim(datatype)) + case('INTEGER') + if(ndim == 0)then + read(inunit) i + write(iout, '(2x, a, a, a, i0)') 'Detected ', trim(dataname), ' = ', i + if(trim(dataname) == 'NLAY') mshape(1) = i + if(trim(dataname) == 'NROW') mshape(2) = i + if(trim(dataname) == 'NCOL') mshape(3) = i + if(trim(dataname) == 'NCPL') mshape(2) = i + if(trim(dataname) == 'NJA') nja = i + if(trim(dataname) == 'NCELLS') ncells = i + if(trim(dataname) == 'NODES') then + ncells = i + mshape(1) = i + endif + else + write(iout, '(2x, a, a)') 'Detected integer array ', trim(dataname) + nval = 1 + do j = 1, ndim + nval = nval * ishape(j) + enddo + allocate(itmp(nval)) + read(inunit) itmp + if(trim(dataname) == 'IA') then + allocate (ia(ncells + 1)) + ia = itmp + elseif(trim(dataname) == 'JA') then + allocate (ja(nja)) + ja = itmp + endif + deallocate(itmp) + endif + case('DOUBLE') + if(ndim == 0)then + read(inunit) d + write(iout, '(2x, a, a, a, G0)') 'Detected ', trim(dataname), ' = ', d + else + write(iout, '(2x, a, a)') 'Detected double array ', trim(dataname) + nval = 1 + do j = 1, ndim + nval = nval * ishape(j) + enddo + allocate(dtmp(nval)) + read(inunit) dtmp + deallocate(dtmp) + endif + end select + deallocate(ishape) + enddo + close(inunit) + write(iout, '(a)') 'Done processing Binary Grid File' + ! + ! -- deallocate local storage + deallocate(line) + deallocate(dfntxt) + ! + ! -- return + return + end subroutine read_grb + +end module GrbModule diff --git a/utils/zonebudget/src/zbud6.f90 b/utils/zonebudget/src/zbud6.f90 index 6f0522b35e4..94be1892b2d 100644 --- a/utils/zonebudget/src/zbud6.f90 +++ b/utils/zonebudget/src/zbud6.f90 @@ -1,385 +1,385 @@ -program zonbudmf6 +program zonbudmf6 use KindModule - use SimModule, only: ustop - use ConstantsModule, only: LINELENGTH, LENHUGELINE - use VersionModule, only: VERSION - use SimVariablesModule, only: iout - use GenericUtilitiesModule, only: sim_message, write_centered - use InputOutputModule, only: openfile - - implicit none - - character(len=10), parameter :: mfvnam=' Version 6' - character(len=LINELENGTH) :: line - character(len=LENHUGELINE) :: fnam, flst, fcsv - integer(I4B) :: iunit_lst = 20 - integer(I4B) :: iunit_csv = 21 - integer(I4B) :: iunit_nam = 22 - integer(I4B) :: iunit_bud = 23 - integer(I4B) :: iunit_zon = 24 - integer(I4B) :: iunit_grb = 25 - logical :: exists - - ! -- Write title to screen - call write_centered('ZONEBUDGET'//mfvnam, 80) - call write_centered('U.S. GEOLOGICAL SURVEY', 80) - call write_centered('VERSION '//VERSION, 80) - ! - ! -- Find name of zone budget name file and lst file - fnam = 'zbud.nam' - call parse_command_line(fnam, flst, fcsv) - inquire(file=fnam, exist=exists) - if (.not. exists) then - write(line,'(a)') 'ERROR. Name file not found.' - call sim_message(line, skipbefore=1) - write(line,'(a)') 'Looking for: ' // trim(fnam) - call sim_message(line) - call ustop() - endif - ! - ! -- Open list file and write title - iout = iunit_lst - call openfile(iunit_lst, 0, flst, 'LIST', filstat_opt='REPLACE') - call write_centered('ZONEBUDGET'//mfvnam, 80, iunit=iout) - call write_centered('U.S. GEOLOGICAL SURVEY', 80, iunit=iout) - call write_centered('VERSION '//VERSION, 80, iunit=iout) - ! - ! -- Open name file, read name file, and open csv file - call openfile(iunit_nam, iout, fnam, 'NAM') - call read_namefile(iunit_nam, iunit_bud, iunit_zon, iunit_grb) - call openfile(iunit_csv, iout, fcsv, 'CSV', filstat_opt='REPLACE') - ! - ! -- Process the budget file and write output - call process_budget(iunit_csv, iunit_bud, iunit_zon, iunit_grb) - ! - ! -- close output files - write(iunit_lst, '(/, a)') 'Normal Termination' - close(iunit_lst) - close(iunit_csv) - write(line,'(a)') 'Normal Termination' - call sim_message(line, skipbefore=1) - ! - ! -- end of program -end program zonbudmf6 - -subroutine read_namefile(iunit_nam, iunit_bud, iunit_zon, iunit_grb) -! ****************************************************************************** -! read_namefile -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules + use SimModule, only: ustop + use ConstantsModule, only: LINELENGTH, LENHUGELINE + use VersionModule, only: VERSION + use SimVariablesModule, only: iout + use GenericUtilitiesModule, only: sim_message, write_centered + use InputOutputModule, only: openfile + + implicit none + + character(len=10), parameter :: mfvnam=' Version 6' + character(len=LINELENGTH) :: line + character(len=LENHUGELINE) :: fnam, flst, fcsv + integer(I4B) :: iunit_lst = 20 + integer(I4B) :: iunit_csv = 21 + integer(I4B) :: iunit_nam = 22 + integer(I4B) :: iunit_bud = 23 + integer(I4B) :: iunit_zon = 24 + integer(I4B) :: iunit_grb = 25 + logical :: exists + + ! -- Write title to screen + call write_centered('ZONEBUDGET'//mfvnam, 80) + call write_centered('U.S. GEOLOGICAL SURVEY', 80) + call write_centered('VERSION '//VERSION, 80) + ! + ! -- Find name of zone budget name file and lst file + fnam = 'zbud.nam' + call parse_command_line(fnam, flst, fcsv) + inquire(file=fnam, exist=exists) + if (.not. exists) then + write(line,'(a)') 'ERROR. Name file not found.' + call sim_message(line, skipbefore=1) + write(line,'(a)') 'Looking for: ' // trim(fnam) + call sim_message(line) + call ustop() + endif + ! + ! -- Open list file and write title + iout = iunit_lst + call openfile(iunit_lst, 0, flst, 'LIST', filstat_opt='REPLACE') + call write_centered('ZONEBUDGET'//mfvnam, 80, iunit=iout) + call write_centered('U.S. GEOLOGICAL SURVEY', 80, iunit=iout) + call write_centered('VERSION '//VERSION, 80, iunit=iout) + ! + ! -- Open name file, read name file, and open csv file + call openfile(iunit_nam, iout, fnam, 'NAM') + call read_namefile(iunit_nam, iunit_bud, iunit_zon, iunit_grb) + call openfile(iunit_csv, iout, fcsv, 'CSV', filstat_opt='REPLACE') + ! + ! -- Process the budget file and write output + call process_budget(iunit_csv, iunit_bud, iunit_zon, iunit_grb) + ! + ! -- close output files + write(iunit_lst, '(/, a)') 'Normal Termination' + close(iunit_lst) + close(iunit_csv) + write(line,'(a)') 'Normal Termination' + call sim_message(line, skipbefore=1) + ! + ! -- end of program +end program zonbudmf6 + +subroutine read_namefile(iunit_nam, iunit_bud, iunit_zon, iunit_grb) +! ****************************************************************************** +! read_namefile +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules use KindModule - use SimVariablesModule, only: iout - use SimModule, only: store_error, ustop - use ConstantsModule, only: LENHUGELINE, LINELENGTH - use InputOutputModule, only: openfile - use OpenSpecModule, only: form, access - use BlockParserModule, only: BlockParserType - implicit none - ! -- dummy - integer, intent(in) :: iunit_nam - integer, intent(in) :: iunit_bud - integer, intent(in) :: iunit_zon - integer, intent(inout) :: iunit_grb - ! -- local - type(BlockParserType) :: parser - integer(I4B) :: ierr, iu - logical :: isfound, endOfBlock - character(len=LINELENGTH) :: keyword, errmsg - character(len=LENHUGELINE) :: filename - character(len=20) :: fm, acc -! ------------------------------------------------------------------------------ - ! - call parser%Initialize(iunit_nam, iout) - call parser%GetBlock('ZONEBUDGET', isfound, ierr) - if(isfound) then - do - call parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call parser%GetStringCaps(keyword) - fm = 'FORMATTED' - acc = 'SEQUENTIAL' - select case (keyword) - case ('BUD') - iu = iunit_bud - fm = form - acc = access - call parser%GetString(filename) - case ('ZON') - iu = iunit_zon - call parser%GetString(filename) - case ('GRB') - iu = iunit_grb - fm = form - acc = access - call parser%GetString(filename) - case default - write(errmsg,'(4x,a,a)')'ERROR. UNKNOWN ZONEBUDGET ENTRY: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - end select - call openfile(iu, iout, trim(filename), trim(keyword), fm, acc) - end do - else - write(errmsg,'(1x,a)')'ERROR. REQUIRED ZONEBUDGET BLOCK NOT FOUND.' - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- close name file - close(iunit_nam) - ! - ! -- return - return -end subroutine read_namefile - -subroutine process_budget(iunit_csv, iunit_bud, iunit_zon, iunit_grb) -! ****************************************************************************** -! process_budget -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules + use SimVariablesModule, only: iout + use SimModule, only: store_error, ustop + use ConstantsModule, only: LENHUGELINE, LINELENGTH + use InputOutputModule, only: openfile + use OpenSpecModule, only: form, access + use BlockParserModule, only: BlockParserType + implicit none + ! -- dummy + integer, intent(in) :: iunit_nam + integer, intent(in) :: iunit_bud + integer, intent(in) :: iunit_zon + integer, intent(inout) :: iunit_grb + ! -- local + type(BlockParserType) :: parser + integer(I4B) :: ierr, iu + logical :: isfound, endOfBlock + character(len=LINELENGTH) :: keyword, errmsg + character(len=LENHUGELINE) :: filename + character(len=20) :: fm, acc +! ------------------------------------------------------------------------------ + ! + call parser%Initialize(iunit_nam, iout) + call parser%GetBlock('ZONEBUDGET', isfound, ierr) + if(isfound) then + do + call parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call parser%GetStringCaps(keyword) + fm = 'FORMATTED' + acc = 'SEQUENTIAL' + select case (keyword) + case ('BUD') + iu = iunit_bud + fm = form + acc = access + call parser%GetString(filename) + case ('ZON') + iu = iunit_zon + call parser%GetString(filename) + case ('GRB') + iu = iunit_grb + fm = form + acc = access + call parser%GetString(filename) + case default + write(errmsg,'(4x,a,a)')'ERROR. UNKNOWN ZONEBUDGET ENTRY: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + end select + call openfile(iu, iout, trim(filename), trim(keyword), fm, acc) + end do + else + write(errmsg,'(1x,a)')'ERROR. REQUIRED ZONEBUDGET BLOCK NOT FOUND.' + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- close name file + close(iunit_nam) + ! + ! -- return + return +end subroutine read_namefile + +subroutine process_budget(iunit_csv, iunit_bud, iunit_zon, iunit_grb) +! ****************************************************************************** +! process_budget +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules use KindModule - use ConstantsModule, only: LINELENGTH - use SimVariablesModule, only: iout - use GenericUtilitiesModule, only: sim_message - use SimModule, only: store_error, ustop - use BudgetDataModule, only: budgetdata_init, budgetdata_read, & - budgetdata_finalize, & - ia, ja, budtxt, nbudterms, & - nodesrc, nodedst, flowdata, flowja, kper, kstp, & - delt, totim, dstpackagename, hasimeth1flowja, & - srcmodelname, dstmodelname - use ZoneModule, only: zone_init, clear_accumulators, & - flowja_accumulate, flowiaja_accumulate, & - flow_accumulate, & - flowch_setich, flowch_accumulate, & - zone_finalize, nmznfl, vbvl, vbznfl, maxzone - use ZoneOutputModule, only: zoneoutput_init, zoneoutput_write, & - zoneoutput_finalize - use GrbModule, only: read_grb - implicit none - ! -- dummy - integer, intent(in) :: iunit_csv - integer, intent(in) :: iunit_bud - integer, intent(in) :: iunit_zon - integer, intent(in) :: iunit_grb - ! -- local - character(len=1) :: cdot - character(len=16), dimension(:), allocatable :: budtxtarray - character(len=16), dimension(:), allocatable :: packagenamearray - integer, dimension(:), allocatable :: internalflow - integer, allocatable, dimension(:) :: mshape - integer(I4B) :: ibudterm - integer(I4B) :: itime = 1 - integer(I4B) :: ncrgrb - integer(I4B) :: ncrbud = 0 - integer(I4B) :: ncr - logical :: opengrb - logical :: success - logical :: hasiaja = .false. - logical :: foundchd = .false. - character(len=LINELENGTH) :: errmsg -! ------------------------------------------------------------------------------ - ! - ! -- initialize local variables - cdot = '.' - ! - ! -- Initialize budget data - call budgetdata_init(iunit_bud, iout, ncrbud) - ! - ! -- Check to see if GRB is required, and read it if necessary - ncrgrb = 0 - if (hasimeth1flowja) then - inquire(unit=iunit_grb, opened=opengrb) - if (opengrb) then - hasiaja = .true. - call read_grb(iunit_grb, ia, ja, mshape) - ncrgrb = size(ia) - 1 - else - errmsg = 'BUDGET FILE HAS "FLOW-JA-FACE" RECORD BUT NO GRB FILE SPECIFIED.' - call store_error(errmsg) - errmsg = 'ADD GRB ENTRY TO ZONE BUDGET NAME FILE.' - call store_error(errmsg) - call ustop() - endif - else - inquire(unit=iunit_grb, opened=opengrb) - if (opengrb) then - errmsg = 'BINARY GRID FILE IS PRESENT, BUT BUDGET FILE DOES NOT HAVE & - &"FLOW-JA-FACE" RECORD IN THE IMETH=1 FORMAT. CHECK TO MAKE SURE & - &FLOWS ARE SAVED TO THE BUDGET FILE' - call store_error(errmsg) - call ustop() - endif - ! - ! -- At this point, must be a budget file from an advanced package without - ! the IMETH=1 flow-ja-face record. - allocate(mshape(1)) - mshape(1) = ncrgrb - endif - ! - ! -- Read the zone file to get number of cells/reaches - ncr = ncrgrb - call zone_init(iunit_zon, nbudterms, ncr, mshape) - ! - ! -- Initialize zone and zoneoutput modules - !call zone_init(iunit_zon, nbudterms, ncr) - call zoneoutput_init(iout, iunit_csv, maxzone, nbudterms) - allocate(budtxtarray(nbudterms)) - allocate(packagenamearray(nbudterms)) - allocate(internalflow(nbudterms)) - ! - ! -- time loop - timeloop: do - ! - ! -- Clear budget accumulators and loop through budget terms - call clear_accumulators() - write(iout, '(/, a)') 'Reading records from budget file' - do ibudterm = 1, nbudterms - ! - ! -- read data - call budgetdata_read(success, iout) - if (.not. success) then - write(iout, '(a)') 'Done reading records. Exiting time loop.' - exit timeloop - endif - ! - ! -- write message and check - call sim_message(cdot, advance=.FALSE.) - if (itime == 1) then - budtxtarray(ibudterm) = budtxt - packagenamearray(ibudterm) = dstpackagename - if (trim(adjustl(budtxt)) == 'FLOW-JA-FACE' .and. & - srcmodelname == dstmodelname) then - internalflow(ibudterm) = 1 - else - internalflow(ibudterm) = 0 - endif - else - if (budtxt /= budtxtarray(ibudterm) .or. & - dstpackagename /= packagenamearray(ibudterm)) then - errmsg = 'Expecting ' // trim(packagenamearray(itime)) // '-' // & - trim(budtxtarray(itime)) // ' but found ' // trim(dstpackagename) & - // '-' // trim(budtxt) - call store_error(errmsg) - call ustop() - endif - endif - ! - ! -- Accumulate flow terms (or set ich for constant heads) - if (internalflow(ibudterm) == 1) then - if (hasiaja) then - call flowiaja_accumulate(ia, ja, flowja) - else - call flowja_accumulate(nodesrc, nodedst, flowdata) - endif - else - if(trim(adjustl(budtxt)) == 'CONSTANT HEAD') then - call flowch_setich(ibudterm, nodesrc) - foundchd = .true. - else - call flow_accumulate(ibudterm, nodesrc, flowdata) - endif - endif - ! - enddo - write(iout, '(a)') 'Done reading records from budget file' - ! - ! -- Now that all constant heads read, can process budgets for them - if(hasiaja .and. foundchd) then - call flowch_accumulate(ia, ja, flowja) - endif - ! - ! -- Write information for this time - call zoneoutput_write(itime, kstp, kper, delt, totim, nbudterms, nmznfl, & - vbvl, vbznfl, packagenamearray, budtxtarray, & - internalflow) - itime = itime + 1 - - enddo timeloop - ! - ! -- Finalize - call sim_message(cdot) - call budgetdata_finalize() - call zoneoutput_finalize() - call zone_finalize() - ! - ! -- return - return -end subroutine process_budget - - subroutine parse_command_line(fnam, flst, fcsv) -! ****************************************************************************** -! Parse command line arguments -! Assign zone budget name file as first argument. -! Assign file names for list and csv files based on root name of name file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules + use ConstantsModule, only: LINELENGTH + use SimVariablesModule, only: iout + use GenericUtilitiesModule, only: sim_message + use SimModule, only: store_error, ustop + use BudgetDataModule, only: budgetdata_init, budgetdata_read, & + budgetdata_finalize, & + ia, ja, budtxt, nbudterms, & + nodesrc, nodedst, flowdata, flowja, kper, kstp, & + delt, totim, dstpackagename, hasimeth1flowja, & + srcmodelname, dstmodelname + use ZoneModule, only: zone_init, clear_accumulators, & + flowja_accumulate, flowiaja_accumulate, & + flow_accumulate, & + flowch_setich, flowch_accumulate, & + zone_finalize, nmznfl, vbvl, vbznfl, maxzone + use ZoneOutputModule, only: zoneoutput_init, zoneoutput_write, & + zoneoutput_finalize + use GrbModule, only: read_grb + implicit none + ! -- dummy + integer, intent(in) :: iunit_csv + integer, intent(in) :: iunit_bud + integer, intent(in) :: iunit_zon + integer, intent(in) :: iunit_grb + ! -- local + character(len=1) :: cdot + character(len=16), dimension(:), allocatable :: budtxtarray + character(len=16), dimension(:), allocatable :: packagenamearray + integer, dimension(:), allocatable :: internalflow + integer, allocatable, dimension(:) :: mshape + integer(I4B) :: ibudterm + integer(I4B) :: itime = 1 + integer(I4B) :: ncrgrb + integer(I4B) :: ncrbud = 0 + integer(I4B) :: ncr + logical :: opengrb + logical :: success + logical :: hasiaja = .false. + logical :: foundchd = .false. + character(len=LINELENGTH) :: errmsg +! ------------------------------------------------------------------------------ + ! + ! -- initialize local variables + cdot = '.' + ! + ! -- Initialize budget data + call budgetdata_init(iunit_bud, iout, ncrbud) + ! + ! -- Check to see if GRB is required, and read it if necessary + ncrgrb = 0 + if (hasimeth1flowja) then + inquire(unit=iunit_grb, opened=opengrb) + if (opengrb) then + hasiaja = .true. + call read_grb(iunit_grb, ia, ja, mshape) + ncrgrb = size(ia) - 1 + else + errmsg = 'BUDGET FILE HAS "FLOW-JA-FACE" RECORD BUT NO GRB FILE SPECIFIED.' + call store_error(errmsg) + errmsg = 'ADD GRB ENTRY TO ZONE BUDGET NAME FILE.' + call store_error(errmsg) + call ustop() + endif + else + inquire(unit=iunit_grb, opened=opengrb) + if (opengrb) then + errmsg = 'BINARY GRID FILE IS PRESENT, BUT BUDGET FILE DOES NOT HAVE & + &"FLOW-JA-FACE" RECORD IN THE IMETH=1 FORMAT. CHECK TO MAKE SURE & + &FLOWS ARE SAVED TO THE BUDGET FILE' + call store_error(errmsg) + call ustop() + endif + ! + ! -- At this point, must be a budget file from an advanced package without + ! the IMETH=1 flow-ja-face record. + allocate(mshape(1)) + mshape(1) = ncrgrb + endif + ! + ! -- Read the zone file to get number of cells/reaches + ncr = ncrgrb + call zone_init(iunit_zon, nbudterms, ncr, mshape) + ! + ! -- Initialize zone and zoneoutput modules + !call zone_init(iunit_zon, nbudterms, ncr) + call zoneoutput_init(iout, iunit_csv, maxzone, nbudterms) + allocate(budtxtarray(nbudterms)) + allocate(packagenamearray(nbudterms)) + allocate(internalflow(nbudterms)) + ! + ! -- time loop + timeloop: do + ! + ! -- Clear budget accumulators and loop through budget terms + call clear_accumulators() + write(iout, '(/, a)') 'Reading records from budget file' + do ibudterm = 1, nbudterms + ! + ! -- read data + call budgetdata_read(success, iout) + if (.not. success) then + write(iout, '(a)') 'Done reading records. Exiting time loop.' + exit timeloop + endif + ! + ! -- write message and check + call sim_message(cdot, advance=.FALSE.) + if (itime == 1) then + budtxtarray(ibudterm) = budtxt + packagenamearray(ibudterm) = dstpackagename + if (trim(adjustl(budtxt)) == 'FLOW-JA-FACE' .and. & + srcmodelname == dstmodelname) then + internalflow(ibudterm) = 1 + else + internalflow(ibudterm) = 0 + endif + else + if (budtxt /= budtxtarray(ibudterm) .or. & + dstpackagename /= packagenamearray(ibudterm)) then + errmsg = 'Expecting ' // trim(packagenamearray(itime)) // '-' // & + trim(budtxtarray(itime)) // ' but found ' // trim(dstpackagename) & + // '-' // trim(budtxt) + call store_error(errmsg) + call ustop() + endif + endif + ! + ! -- Accumulate flow terms (or set ich for constant heads) + if (internalflow(ibudterm) == 1) then + if (hasiaja) then + call flowiaja_accumulate(ia, ja, flowja) + else + call flowja_accumulate(nodesrc, nodedst, flowdata) + endif + else + if(trim(adjustl(budtxt)) == 'CONSTANT HEAD') then + call flowch_setich(ibudterm, nodesrc) + foundchd = .true. + else + call flow_accumulate(ibudterm, nodesrc, flowdata) + endif + endif + ! + enddo + write(iout, '(a)') 'Done reading records from budget file' + ! + ! -- Now that all constant heads read, can process budgets for them + if(hasiaja .and. foundchd) then + call flowch_accumulate(ia, ja, flowja) + endif + ! + ! -- Write information for this time + call zoneoutput_write(itime, kstp, kper, delt, totim, nbudterms, nmznfl, & + vbvl, vbznfl, packagenamearray, budtxtarray, & + internalflow) + itime = itime + 1 + + enddo timeloop + ! + ! -- Finalize + call sim_message(cdot) + call budgetdata_finalize() + call zoneoutput_finalize() + call zone_finalize() + ! + ! -- return + return +end subroutine process_budget + + subroutine parse_command_line(fnam, flst, fcsv) +! ****************************************************************************** +! Parse command line arguments +! Assign zone budget name file as first argument. +! Assign file names for list and csv files based on root name of name file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules use KindModule - use InputOutputModule, only: urword - use ConstantsModule, only: LENHUGELINE - implicit none - ! -- dummy - character(len=*), intent(inout) :: fnam - character(len=*), intent(inout) :: flst - character(len=*), intent(inout) :: fcsv - ! -- local - character(len=LENHUGELINE) :: line - integer(I4B) :: inunit = 0 - integer(I4B) :: ilen - integer(I4B) :: istat - integer(I4B) :: lloc - integer(I4B) :: istart - integer(I4B) :: istop - integer(I4B) :: ival - integer(I4B) :: i - real(DP) :: rval -! ------------------------------------------------------------------------------ - ! - ! -- Get the command line string - call GET_COMMAND(line, ilen, istat) - ! - ! -- This will read zonebudget executable - lloc = 1 - call urword(line, lloc, istart, istop, 0, ival, rval, 0, inunit) - ! - ! -- This will read first argument (zone budget name file) - call urword(line, lloc, istart, istop, 0, ival, rval, 0, inunit) - if (istart < len(line)) fnam = line(istart:istop) - ! - ! -- Set lst and csv file names by replacing fnam suffix with .lst - istart = 0 - istop = len_trim(fnam) - do i = istop, 1, -1 - if (fnam(i:i) == '.') then - istart = i - exit - endif - enddo - if (istart == 0) istart = istop + 1 - ! - ! -- Create flst name - flst = fnam(1:istart) - istop = istart + 3 - flst(istart:istop) = '.lst' - ! - ! -- Create fcsv name - fcsv = fnam(1:istart) - istop = istart + 3 - fcsv(istart:istop) = '.csv' - ! - ! -- Return - return - end subroutine parse_command_line - + use InputOutputModule, only: urword + use ConstantsModule, only: LENHUGELINE + implicit none + ! -- dummy + character(len=*), intent(inout) :: fnam + character(len=*), intent(inout) :: flst + character(len=*), intent(inout) :: fcsv + ! -- local + character(len=LENHUGELINE) :: line + integer(I4B) :: inunit = 0 + integer(I4B) :: ilen + integer(I4B) :: istat + integer(I4B) :: lloc + integer(I4B) :: istart + integer(I4B) :: istop + integer(I4B) :: ival + integer(I4B) :: i + real(DP) :: rval +! ------------------------------------------------------------------------------ + ! + ! -- Get the command line string + call GET_COMMAND(line, ilen, istat) + ! + ! -- This will read zonebudget executable + lloc = 1 + call urword(line, lloc, istart, istop, 0, ival, rval, 0, inunit) + ! + ! -- This will read first argument (zone budget name file) + call urword(line, lloc, istart, istop, 0, ival, rval, 0, inunit) + if (istart < len(line)) fnam = line(istart:istop) + ! + ! -- Set lst and csv file names by replacing fnam suffix with .lst + istart = 0 + istop = len_trim(fnam) + do i = istop, 1, -1 + if (fnam(i:i) == '.') then + istart = i + exit + endif + enddo + if (istart == 0) istart = istop + 1 + ! + ! -- Create flst name + flst = fnam(1:istart) + istop = istart + 3 + flst(istart:istop) = '.lst' + ! + ! -- Create fcsv name + fcsv = fnam(1:istart) + istop = istart + 3 + fcsv(istart:istop) = '.csv' + ! + ! -- Return + return + end subroutine parse_command_line + diff --git a/utils/zonebudget/src/zone.f90 b/utils/zonebudget/src/zone.f90 index 052949bedcc..38f2d06a3d4 100644 --- a/utils/zonebudget/src/zone.f90 +++ b/utils/zonebudget/src/zone.f90 @@ -1,506 +1,506 @@ -module ZoneModule - +module ZoneModule + use KindModule - use SimVariablesModule, only: iout - use SimModule, only: store_error, store_error_unit, ustop - use ConstantsModule, only: LINELENGTH, DEP20 - use BlockParserModule, only: BlockParserType - use SortModule, only: unique_values - - implicit none - private - public :: zone_init - public :: clear_accumulators - public :: flowja_accumulate - public :: flowiaja_accumulate - public :: flow_accumulate - public :: flowch_setich - public :: flowch_accumulate - public :: zone_finalize - public :: maxzone - public :: iuniqzone - public :: nmznfl, vbvl, vbznfl - - integer(I4B) :: ncells - integer(I4B) :: maxzone - integer(I4B), dimension(:), allocatable :: izoneuser - integer(I4B), dimension(:), allocatable :: iuniqzone - integer(I4B), dimension(:), allocatable :: izone - integer(I4B), dimension(:), allocatable :: ich - integer(I4B), dimension(:, :), allocatable :: nmznfl - real(DP), dimension(:, :, :), allocatable :: vbznfl - real(DP), dimension(:, :, :), allocatable :: vbvl - character(len=LINELENGTH) :: errmsg, keyword - - contains - - subroutine zone_init(inunit, nbudterms, ncr, mshape) -! ****************************************************************************** -! zone_init -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - use ArrayReadersModule, only: ReadArray - type(BlockParserType) :: parser - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: nbudterms - integer(I4B), intent(inout) :: ncr - integer(I4B), dimension(:), intent(in) :: mshape - integer(I4B) :: nlay, ncpl, istart, istop, k - character(len=24) :: aname = ' IZONE' - integer(I4B) :: ierr - integer(I4B) :: i - integer(I4B) :: n - integer(I4B) :: iminval - integer(I4B) :: imaxval - integer(I4B), dimension(:), allocatable :: izonecount - logical :: isfound, endOfBlock -! ------------------------------------------------------------------------------ - ! - ! -- Read DIMENSIONS block, set NCELLS - call parser%Initialize(inunit, iout) - call parser%GetBlock('DIMENSIONS', isfound, ierr) - if(isfound) then - write(iout,'(/, a)') 'Processing zone dimensions' - do - call parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call parser%GetStringCaps(keyword) - select case (keyword) - case ('NCELLS') - ncells = parser%GetInteger() - write(iout,'(4x,a,i0)') 'NCELLS = ', ncells - case default - write(errmsg,'(4x,a,a)')'ERROR. UNKNOWN DIMENSIONS ENTRY: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - end select - end do - write(iout,'(a)') 'End processing zone dimensions' - else - write(errmsg,'(1x,a)')'ERROR. REQUIRED ZONE DIMENSIONS BLOCK NOT FOUND.' - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- Validate size and allocate arrays - if (ncr > 0) then - if (ncells /= ncr) then - write(errmsg, '(a,i0)') 'GRB FILE INDICATES NUMBER OF CELLS OR ' // & - 'REACHES IS ', ncr - call store_error(errmsg) - write(errmsg, '(a,i0)') 'INSTEAD ZONE ARRAY SPECIFIED AS SIZE ', ncells - call store_error(errmsg) - write(errmsg, '(a,i0)') 'CHANGE SIZE OF ZONE ARRAY TO ', ncr - call store_error(errmsg) - call store_error_unit(inunit) - call ustop() - endif - else - ! -- Number of cells/reaches not available in grb or no grb specified - ! Setting ncr to ncells - ncr = ncells - endif - allocate(izoneuser(ncells)) - allocate(izone(ncells)) - allocate(ich(ncells)) - ! - ! -- get griddata block - call parser%GetBlock('GRIDDATA', isfound, ierr) - if(isfound) then - write(iout,'(/, a)') 'Processing zone griddata' - do - call parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call parser%GetStringCaps(keyword) - select case (keyword) - case ('IZONE') - call parser%GetStringCaps(keyword) - if (keyword .EQ. 'LAYERED') then - if (size(mshape) > 1) then - nlay = mshape(1) - else - write(errmsg,'(4x,a)') 'ERROR. LAYERED INPUT NOT SUPPORTED & - &FOR IZONE. LAYERED INPUT CAN ONLY BE USED FOR IZONE & - &WHEN A BINARY GRID FILE IS PROVIDED AND THE MODEL IS LAYERED' - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - endif - ncpl = ncells / nlay - write(iout, '(4x, a, i0)') 'LAYERED detected. Using NLAY = ', nlay - write(iout, '(4x, a, i0, a)') 'Reading ', ncpl, ' values per layer' - istart = 1 - istop = ncpl - do k = 1, nlay - call ReadArray(inunit, izoneuser(istart:istop), aname, 1, ncpl, iout, k) - istart = istop + 1 - istop = istart + ncpl - 1 - enddo - else - call ReadArray(inunit, izoneuser, aname, 1, ncells, iout, 0) - endif - case default - write(errmsg,'(4x,a,a)')'ERROR. UNKNOWN ZONE GRIDDATA TAG: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() - call ustop() - end select - end do - else - call store_error('ERROR. REQUIRED GRIDDATA BLOCK NOT FOUND.') - call parser%StoreErrorUnit() - call ustop() - end if - ! - ! -- Write messages - close(inunit) - ! - ! -- Find max and min values - iminval = HUGE(iminval) - imaxval = -HUGE(imaxval) - do n = 1, size(izoneuser) - izone(n) = izoneuser(n) - if (izoneuser(n) /= 0) then - if (izoneuser(n) < iminval) then - iminval = izoneuser(n) - end if - if (izoneuser(n) > imaxval) then - imaxval = izoneuser(n) - end if - end if - end do - ! - ! -- write minimum and maximum zone numbers - write(iout, '(/, 4x, a, i0)') 'Successfully read zone array with NCELLS = ', ncells - write(iout, '(4x, a, i0)') 'Minimum user-specified zone number is ', iminval - write(iout, '(4x, a, i0)') 'Maximum user-specified zone number is ', imaxval - ! - ! -- find unique zones - call unique_values(izone, iuniqzone) - ! - ! -- pop off a zero zone value - call pop_zero_zone(iuniqzone) - ! - ! -- set max zone number - maxzone = size(iuniqzone) - ! - ! -- allocate and initialize izonecount - allocate(izonecount(0:maxzone)) - do i = 0, maxzone - izonecount(i) = 0 - end do - ! - ! -- fill izonemap with uniqzone number - do n = 1, size(izone) - if (izoneuser(n) == 0) then - izone(n) = 0 - izonecount(0) = izonecount(0) + 1 - else - do i = 1, maxzone - if (izoneuser(n) == iuniqzone(i)) then - izone(n) = i - izonecount(i) = izonecount(i) + 1 - exit - end if - end do - end if - end do - ! - ! -- write zone mapping - write(iout, '(//,4x,3(a20,1x))') 'USER ZONE', 'ZONE NUMBER', 'CELL COUNT' - write(iout, '(4x,62("-"))') - write(iout, '(4x,3(i20,1x))') 0, 0, izonecount(0) - do i = 1, maxzone - write(iout, '(4x,3(i20,1x))') iuniqzone(i), i, izonecount(i) - end do - write(iout, '(4x,62("-"),/)') - - ! - !maxzone = maxval(izone) - write(iout,'(a)') 'End processing zone griddata' - ! - ! -- nmznfl is map showing connections between two zones. If 1, then - ! there is flow between zones, and zone to zone flow will be written. - allocate(nmznfl(0:maxzone, 0:maxzone)) - allocate(vbznfl(2, 0:maxzone, 0:maxzone)) - allocate(vbvl(2, 0:maxzone, nbudterms)) - ! - ! -- deallocate local variables - deallocate(izonecount) - ! - ! -- close the zone file - close(inunit) - ! - ! -- return - return - end subroutine zone_init - - subroutine clear_accumulators() -! ****************************************************************************** -! clear_accumulators -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ -! ------------------------------------------------------------------------------ - ich(:) = 0 - nmznfl(:, :) = 0 - vbvl(:, :, :) = 0.d0 - vbznfl(:, :, :) = 0.d0 - ! - ! -- return - return - end subroutine clear_accumulators - - subroutine flowja_accumulate(nodesrc, nodedst, flowdata) -! ****************************************************************************** -! flowja_accumulate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - integer(I4B), dimension(:), intent(in) :: nodesrc - integer(I4B), dimension(:), intent(in) :: nodedst - real(DP), dimension(:, :), intent(in) :: flowdata - ! -- local - integer(I4B) :: i, n, m, iz1, iz2 - real(DP) :: q -! ------------------------------------------------------------------------------ - ! - ! -- add up flowja terms - do i = 1, size(nodesrc) - n = nodesrc(i) - m = nodedst(i) - q = flowdata(1, i) - iz1 = izone(n) - iz2 = izone(m) - nmznfl(iz1, iz2) = 1 - if (q < 0.d0) then - vbznfl(2, iz1, iz2) = vbznfl(2, iz1, iz2) - q - else - vbznfl(1, iz1, iz2) = vbznfl(1, iz1, iz2) + q - endif - enddo - ! - ! -- return - return - end subroutine flowja_accumulate - - subroutine flowiaja_accumulate(ia, ja, flowja) -! ****************************************************************************** -! flowiaja_accumulate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: ja - real(DP), dimension(:), intent(in) :: flowja - ! -- local - integer(I4B) :: ipos, n, m, iz1, iz2 - real(DP) :: q -! ------------------------------------------------------------------------------ - ! - ! -- add up flowja terms - do n = 1, ncells - do ipos = ia(n), ia(n + 1) - 1 - m = ja(ipos) - if (n == m) cycle - q = flowja(ipos) - iz1 = izone(n) - iz2 = izone(m) - nmznfl(iz1, iz2) = 1 - if (q < 0.d0) then - vbznfl(2, iz1, iz2) = vbznfl(2, iz1, iz2) - q - else - vbznfl(1, iz1, iz2) = vbznfl(1, iz1, iz2) + q - endif - enddo - enddo - ! - ! -- return - return - end subroutine flowiaja_accumulate - - subroutine flow_accumulate(ibudterm, nodesrc, flowdata) -! ****************************************************************************** -! flow_accumulate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - integer(I4B), intent(in) :: ibudterm - integer(I4B), dimension(:), intent(in) :: nodesrc - real(DP), dimension(:, :), intent(in) :: flowdata - ! -- local - integer(I4B) :: i, n, iz1 - real(DP) :: q -! ------------------------------------------------------------------------------ - ! - ! -- accumulate flow terms - do i = 1, size(nodesrc) - n = nodesrc(i) - q = flowdata(1, i) - iz1 = izone(n) - if (q < 0.d0) then - vbvl(2, iz1, ibudterm) = vbvl(2, iz1, ibudterm) - q - else - vbvl(1, iz1, ibudterm) = vbvl(1, iz1, ibudterm) + q - endif - enddo - ! - ! -- return - return - end subroutine flow_accumulate - - subroutine flowch_setich(ibudterm, nodesrc) -! ****************************************************************************** -! Set ICH equal to ibudterm for all constant head cells -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - integer(I4B), intent(in) :: ibudterm - integer(I4B), dimension(:), intent(in) :: nodesrc - ! -- local - integer(I4B) :: i, n -! ------------------------------------------------------------------------------ - ! - ! -- accumulate flow terms - do i = 1, size(nodesrc) - n = nodesrc(i) - ich(n) = ibudterm - enddo - ! - ! -- return - return - end subroutine flowch_setich - - subroutine flowch_accumulate(ia, ja, flowja) -! ****************************************************************************** -! flowiaja_accumulate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - integer(I4B), dimension(:), intent(in) :: ia - integer(I4B), dimension(:), intent(in) :: ja - real(DP), dimension(:), intent(in) :: flowja - ! -- local - integer(I4B) :: ipos, n, m, iz, ibudterm - real(DP) :: q -! ------------------------------------------------------------------------------ - ! - ! -- add up flowja terms - do n = 1, ncells - do ipos = ia(n), ia(n + 1) - 1 - ! - ! -- skip if cell is not constant head - ibudterm = ich(n) - if (ibudterm == 0) cycle - ! - ! -- skip if adjacent cell is a constant head cell - m = ja(ipos) - if (n == m) cycle - if (ich(m) > 0) cycle - ! - ! -- accumulate constant head flows - q = flowja(ipos) - iz = izone(n) - if (q < 0.d0) then - vbvl(2, iz, ibudterm) = vbvl(2, iz, ibudterm) - q - else - vbvl(1, iz, ibudterm) = vbvl(1, iz, ibudterm) + q - endif - enddo - enddo - ! - ! -- return - return - end subroutine flowch_accumulate - - subroutine pop_zero_zone(ia) - ! -- dummy arguments - integer(I4B), dimension(:), allocatable, intent(inout) :: ia - ! -- local variables - integer(I4B) :: i - integer(I4B) :: n - integer(I4B) :: nlen - integer(I4B) :: ipop - integer(I4B), dimension(:), allocatable :: ib -! ------------------------------------------------------------------------------ - nlen = size(ia) - ipop = 0 - ! - ! -- determine if there is a zero value in the integer attay - do i = 1, nlen - if (ia(i) == 0) then - ipop = i - exit - end if - end do - ! - ! -- remove zero value from ia - if (ipop /= 0) then - ! - ! -- allocate ib - allocate(ib(nlen-1)) - ! - ! -- fill itmp with everything in ia except 0 - n = 1 - do i = 1, nlen - if (i == ipop) then - cycle - end if - ib(n) = ia(i) - n = n + 1 - end do - ! - ! -- deallocate ia - deallocate(ia) - ! - ! -- allocate ia and fill with ib - allocate(ia(size(ib))) - do i = 1, size(ib) - ia(i) = ib(i) - end do - ! - ! -- deallocate ib - deallocate(ib) - end if - ! - ! -- return - return - end subroutine pop_zero_zone - - subroutine zone_finalize() -! ****************************************************************************** -! zone_finalize -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ -! ------------------------------------------------------------------------------ - deallocate(izone) - deallocate(ich) - deallocate(nmznfl) - deallocate(vbznfl) - deallocate(vbvl) - ! - ! -- return - return - end subroutine zone_finalize - -end module ZoneModule - + use SimVariablesModule, only: iout + use SimModule, only: store_error, store_error_unit, ustop + use ConstantsModule, only: LINELENGTH, DEP20 + use BlockParserModule, only: BlockParserType + use SortModule, only: unique_values + + implicit none + private + public :: zone_init + public :: clear_accumulators + public :: flowja_accumulate + public :: flowiaja_accumulate + public :: flow_accumulate + public :: flowch_setich + public :: flowch_accumulate + public :: zone_finalize + public :: maxzone + public :: iuniqzone + public :: nmznfl, vbvl, vbznfl + + integer(I4B) :: ncells + integer(I4B) :: maxzone + integer(I4B), dimension(:), allocatable :: izoneuser + integer(I4B), dimension(:), allocatable :: iuniqzone + integer(I4B), dimension(:), allocatable :: izone + integer(I4B), dimension(:), allocatable :: ich + integer(I4B), dimension(:, :), allocatable :: nmznfl + real(DP), dimension(:, :, :), allocatable :: vbznfl + real(DP), dimension(:, :, :), allocatable :: vbvl + character(len=LINELENGTH) :: errmsg, keyword + + contains + + subroutine zone_init(inunit, nbudterms, ncr, mshape) +! ****************************************************************************** +! zone_init +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ArrayReadersModule, only: ReadArray + type(BlockParserType) :: parser + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: nbudterms + integer(I4B), intent(inout) :: ncr + integer(I4B), dimension(:), intent(in) :: mshape + integer(I4B) :: nlay, ncpl, istart, istop, k + character(len=24) :: aname = ' IZONE' + integer(I4B) :: ierr + integer(I4B) :: i + integer(I4B) :: n + integer(I4B) :: iminval + integer(I4B) :: imaxval + integer(I4B), dimension(:), allocatable :: izonecount + logical :: isfound, endOfBlock +! ------------------------------------------------------------------------------ + ! + ! -- Read DIMENSIONS block, set NCELLS + call parser%Initialize(inunit, iout) + call parser%GetBlock('DIMENSIONS', isfound, ierr) + if(isfound) then + write(iout,'(/, a)') 'Processing zone dimensions' + do + call parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call parser%GetStringCaps(keyword) + select case (keyword) + case ('NCELLS') + ncells = parser%GetInteger() + write(iout,'(4x,a,i0)') 'NCELLS = ', ncells + case default + write(errmsg,'(4x,a,a)')'ERROR. UNKNOWN DIMENSIONS ENTRY: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + end select + end do + write(iout,'(a)') 'End processing zone dimensions' + else + write(errmsg,'(1x,a)')'ERROR. REQUIRED ZONE DIMENSIONS BLOCK NOT FOUND.' + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- Validate size and allocate arrays + if (ncr > 0) then + if (ncells /= ncr) then + write(errmsg, '(a,i0)') 'GRB FILE INDICATES NUMBER OF CELLS OR ' // & + 'REACHES IS ', ncr + call store_error(errmsg) + write(errmsg, '(a,i0)') 'INSTEAD ZONE ARRAY SPECIFIED AS SIZE ', ncells + call store_error(errmsg) + write(errmsg, '(a,i0)') 'CHANGE SIZE OF ZONE ARRAY TO ', ncr + call store_error(errmsg) + call store_error_unit(inunit) + call ustop() + endif + else + ! -- Number of cells/reaches not available in grb or no grb specified + ! Setting ncr to ncells + ncr = ncells + endif + allocate(izoneuser(ncells)) + allocate(izone(ncells)) + allocate(ich(ncells)) + ! + ! -- get griddata block + call parser%GetBlock('GRIDDATA', isfound, ierr) + if(isfound) then + write(iout,'(/, a)') 'Processing zone griddata' + do + call parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call parser%GetStringCaps(keyword) + select case (keyword) + case ('IZONE') + call parser%GetStringCaps(keyword) + if (keyword .EQ. 'LAYERED') then + if (size(mshape) > 1) then + nlay = mshape(1) + else + write(errmsg,'(4x,a)') 'ERROR. LAYERED INPUT NOT SUPPORTED & + &FOR IZONE. LAYERED INPUT CAN ONLY BE USED FOR IZONE & + &WHEN A BINARY GRID FILE IS PROVIDED AND THE MODEL IS LAYERED' + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + endif + ncpl = ncells / nlay + write(iout, '(4x, a, i0)') 'LAYERED detected. Using NLAY = ', nlay + write(iout, '(4x, a, i0, a)') 'Reading ', ncpl, ' values per layer' + istart = 1 + istop = ncpl + do k = 1, nlay + call ReadArray(inunit, izoneuser(istart:istop), aname, 1, ncpl, iout, k) + istart = istop + 1 + istop = istart + ncpl - 1 + enddo + else + call ReadArray(inunit, izoneuser, aname, 1, ncells, iout, 0) + endif + case default + write(errmsg,'(4x,a,a)')'ERROR. UNKNOWN ZONE GRIDDATA TAG: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() + call ustop() + end select + end do + else + call store_error('ERROR. REQUIRED GRIDDATA BLOCK NOT FOUND.') + call parser%StoreErrorUnit() + call ustop() + end if + ! + ! -- Write messages + close(inunit) + ! + ! -- Find max and min values + iminval = HUGE(iminval) + imaxval = -HUGE(imaxval) + do n = 1, size(izoneuser) + izone(n) = izoneuser(n) + if (izoneuser(n) /= 0) then + if (izoneuser(n) < iminval) then + iminval = izoneuser(n) + end if + if (izoneuser(n) > imaxval) then + imaxval = izoneuser(n) + end if + end if + end do + ! + ! -- write minimum and maximum zone numbers + write(iout, '(/, 4x, a, i0)') 'Successfully read zone array with NCELLS = ', ncells + write(iout, '(4x, a, i0)') 'Minimum user-specified zone number is ', iminval + write(iout, '(4x, a, i0)') 'Maximum user-specified zone number is ', imaxval + ! + ! -- find unique zones + call unique_values(izone, iuniqzone) + ! + ! -- pop off a zero zone value + call pop_zero_zone(iuniqzone) + ! + ! -- set max zone number + maxzone = size(iuniqzone) + ! + ! -- allocate and initialize izonecount + allocate(izonecount(0:maxzone)) + do i = 0, maxzone + izonecount(i) = 0 + end do + ! + ! -- fill izonemap with uniqzone number + do n = 1, size(izone) + if (izoneuser(n) == 0) then + izone(n) = 0 + izonecount(0) = izonecount(0) + 1 + else + do i = 1, maxzone + if (izoneuser(n) == iuniqzone(i)) then + izone(n) = i + izonecount(i) = izonecount(i) + 1 + exit + end if + end do + end if + end do + ! + ! -- write zone mapping + write(iout, '(//,4x,3(a20,1x))') 'USER ZONE', 'ZONE NUMBER', 'CELL COUNT' + write(iout, '(4x,62("-"))') + write(iout, '(4x,3(i20,1x))') 0, 0, izonecount(0) + do i = 1, maxzone + write(iout, '(4x,3(i20,1x))') iuniqzone(i), i, izonecount(i) + end do + write(iout, '(4x,62("-"),/)') + + ! + !maxzone = maxval(izone) + write(iout,'(a)') 'End processing zone griddata' + ! + ! -- nmznfl is map showing connections between two zones. If 1, then + ! there is flow between zones, and zone to zone flow will be written. + allocate(nmznfl(0:maxzone, 0:maxzone)) + allocate(vbznfl(2, 0:maxzone, 0:maxzone)) + allocate(vbvl(2, 0:maxzone, nbudterms)) + ! + ! -- deallocate local variables + deallocate(izonecount) + ! + ! -- close the zone file + close(inunit) + ! + ! -- return + return + end subroutine zone_init + + subroutine clear_accumulators() +! ****************************************************************************** +! clear_accumulators +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ + ich(:) = 0 + nmznfl(:, :) = 0 + vbvl(:, :, :) = 0.d0 + vbznfl(:, :, :) = 0.d0 + ! + ! -- return + return + end subroutine clear_accumulators + + subroutine flowja_accumulate(nodesrc, nodedst, flowdata) +! ****************************************************************************** +! flowja_accumulate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + integer(I4B), dimension(:), intent(in) :: nodesrc + integer(I4B), dimension(:), intent(in) :: nodedst + real(DP), dimension(:, :), intent(in) :: flowdata + ! -- local + integer(I4B) :: i, n, m, iz1, iz2 + real(DP) :: q +! ------------------------------------------------------------------------------ + ! + ! -- add up flowja terms + do i = 1, size(nodesrc) + n = nodesrc(i) + m = nodedst(i) + q = flowdata(1, i) + iz1 = izone(n) + iz2 = izone(m) + nmznfl(iz1, iz2) = 1 + if (q < 0.d0) then + vbznfl(2, iz1, iz2) = vbznfl(2, iz1, iz2) - q + else + vbznfl(1, iz1, iz2) = vbznfl(1, iz1, iz2) + q + endif + enddo + ! + ! -- return + return + end subroutine flowja_accumulate + + subroutine flowiaja_accumulate(ia, ja, flowja) +! ****************************************************************************** +! flowiaja_accumulate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: ja + real(DP), dimension(:), intent(in) :: flowja + ! -- local + integer(I4B) :: ipos, n, m, iz1, iz2 + real(DP) :: q +! ------------------------------------------------------------------------------ + ! + ! -- add up flowja terms + do n = 1, ncells + do ipos = ia(n), ia(n + 1) - 1 + m = ja(ipos) + if (n == m) cycle + q = flowja(ipos) + iz1 = izone(n) + iz2 = izone(m) + nmznfl(iz1, iz2) = 1 + if (q < 0.d0) then + vbznfl(2, iz1, iz2) = vbznfl(2, iz1, iz2) - q + else + vbznfl(1, iz1, iz2) = vbznfl(1, iz1, iz2) + q + endif + enddo + enddo + ! + ! -- return + return + end subroutine flowiaja_accumulate + + subroutine flow_accumulate(ibudterm, nodesrc, flowdata) +! ****************************************************************************** +! flow_accumulate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + integer(I4B), intent(in) :: ibudterm + integer(I4B), dimension(:), intent(in) :: nodesrc + real(DP), dimension(:, :), intent(in) :: flowdata + ! -- local + integer(I4B) :: i, n, iz1 + real(DP) :: q +! ------------------------------------------------------------------------------ + ! + ! -- accumulate flow terms + do i = 1, size(nodesrc) + n = nodesrc(i) + q = flowdata(1, i) + iz1 = izone(n) + if (q < 0.d0) then + vbvl(2, iz1, ibudterm) = vbvl(2, iz1, ibudterm) - q + else + vbvl(1, iz1, ibudterm) = vbvl(1, iz1, ibudterm) + q + endif + enddo + ! + ! -- return + return + end subroutine flow_accumulate + + subroutine flowch_setich(ibudterm, nodesrc) +! ****************************************************************************** +! Set ICH equal to ibudterm for all constant head cells +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + integer(I4B), intent(in) :: ibudterm + integer(I4B), dimension(:), intent(in) :: nodesrc + ! -- local + integer(I4B) :: i, n +! ------------------------------------------------------------------------------ + ! + ! -- accumulate flow terms + do i = 1, size(nodesrc) + n = nodesrc(i) + ich(n) = ibudterm + enddo + ! + ! -- return + return + end subroutine flowch_setich + + subroutine flowch_accumulate(ia, ja, flowja) +! ****************************************************************************** +! flowiaja_accumulate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: ja + real(DP), dimension(:), intent(in) :: flowja + ! -- local + integer(I4B) :: ipos, n, m, iz, ibudterm + real(DP) :: q +! ------------------------------------------------------------------------------ + ! + ! -- add up flowja terms + do n = 1, ncells + do ipos = ia(n), ia(n + 1) - 1 + ! + ! -- skip if cell is not constant head + ibudterm = ich(n) + if (ibudterm == 0) cycle + ! + ! -- skip if adjacent cell is a constant head cell + m = ja(ipos) + if (n == m) cycle + if (ich(m) > 0) cycle + ! + ! -- accumulate constant head flows + q = flowja(ipos) + iz = izone(n) + if (q < 0.d0) then + vbvl(2, iz, ibudterm) = vbvl(2, iz, ibudterm) - q + else + vbvl(1, iz, ibudterm) = vbvl(1, iz, ibudterm) + q + endif + enddo + enddo + ! + ! -- return + return + end subroutine flowch_accumulate + + subroutine pop_zero_zone(ia) + ! -- dummy arguments + integer(I4B), dimension(:), allocatable, intent(inout) :: ia + ! -- local variables + integer(I4B) :: i + integer(I4B) :: n + integer(I4B) :: nlen + integer(I4B) :: ipop + integer(I4B), dimension(:), allocatable :: ib +! ------------------------------------------------------------------------------ + nlen = size(ia) + ipop = 0 + ! + ! -- determine if there is a zero value in the integer attay + do i = 1, nlen + if (ia(i) == 0) then + ipop = i + exit + end if + end do + ! + ! -- remove zero value from ia + if (ipop /= 0) then + ! + ! -- allocate ib + allocate(ib(nlen-1)) + ! + ! -- fill itmp with everything in ia except 0 + n = 1 + do i = 1, nlen + if (i == ipop) then + cycle + end if + ib(n) = ia(i) + n = n + 1 + end do + ! + ! -- deallocate ia + deallocate(ia) + ! + ! -- allocate ia and fill with ib + allocate(ia(size(ib))) + do i = 1, size(ib) + ia(i) = ib(i) + end do + ! + ! -- deallocate ib + deallocate(ib) + end if + ! + ! -- return + return + end subroutine pop_zero_zone + + subroutine zone_finalize() +! ****************************************************************************** +! zone_finalize +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ + deallocate(izone) + deallocate(ich) + deallocate(nmznfl) + deallocate(vbznfl) + deallocate(vbvl) + ! + ! -- return + return + end subroutine zone_finalize + +end module ZoneModule + diff --git a/utils/zonebudget/src/zoneoutput.f90 b/utils/zonebudget/src/zoneoutput.f90 index fa3a87aae6b..e7b7d71e64f 100644 --- a/utils/zonebudget/src/zoneoutput.f90 +++ b/utils/zonebudget/src/zoneoutput.f90 @@ -1,244 +1,244 @@ -module ZoneOutputModule - +module ZoneOutputModule + use KindModule - use ConstantsModule, only: LINELENGTH - use BudgetModule, only: BudgetType, budget_cr - use ZoneModule, only: iuniqzone - implicit none - private - public :: zoneoutput_init - public :: zoneoutput_write - public :: zoneoutput_finalize - - integer(I4B) :: iout - integer(I4B) :: ioutcsv = 0 - type(BudgetType), dimension(:), allocatable :: budobj - - contains - - subroutine zoneoutput_init(iunit_out, iunit_csv, maxzone, nbudterms) -! ****************************************************************************** -! zoneoutput_init -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - integer(I4B), intent(in) :: iunit_out - integer(I4B), intent(in) :: iunit_csv - integer(I4B), intent(in) :: maxzone - integer(I4B), intent(in) :: nbudterms - ! -- local - integer(I4B) :: izone - character(len=LINELENGTH) :: bdzone -! ------------------------------------------------------------------------------ - iout = iunit_out - ioutcsv = iunit_csv - ! - ! -- Create the budget objects to that budget tables can be - ! written to list file. - allocate(budobj(maxzone)) - do izone = 1, maxzone - call budobj(izone)%allocate_scalars('ZONEBUDGET') - write(bdzone, '(a,i0)') 'ZONE ', iuniqzone(izone) - call budobj(izone)%budget_df(nbudterms + maxzone, & - labeltitle='PACKAGE/MODEL', bdzone=bdzone) - enddo - ! - ! -- Return - return - end subroutine zoneoutput_init - - subroutine zoneoutput_write(itime, kstp, kper, delt, totim, nbudterms, & - nmznfl, vbvl, vbznfl, packagenamearray, & - budtxtarray, internalflow) -! ****************************************************************************** -! zoneoutput_write -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ZoneModule, only: maxzone, iuniqzone - ! -- dummy - integer(I4B), intent(in) :: itime - integer(I4B), intent(in) :: kstp - integer(I4B), intent(in) :: kper - real(DP), intent(in) :: delt - real(DP), intent(in) :: totim - integer(I4B), intent(in) :: nbudterms - integer(I4B), dimension(0:maxzone, 0:maxzone), intent(in) :: nmznfl - real(DP), dimension(2, 0:maxzone, nbudterms), intent(in) :: vbvl - real(DP), dimension(2, 0:maxzone, 0:maxzone), intent(in) :: vbznfl - character(len=16), dimension(:), intent(in) :: packagenamearray - character(len=16), dimension(:), intent(in) :: budtxtarray - integer(I4B), dimension(:), intent(in) :: internalflow - ! -- local - character(len=500) :: txt - integer(I4B) :: ibudterm, izone, iinout, iz2, j - integer(I4B) :: izv - real(DP) :: val, rin, rout - character(len=16), dimension(:), allocatable :: spntmp -! ------------------------------------------------------------------------------ - ! - ! -- If this is the first time, then write the CSV header, but skip - ! FLOW-JA-FACE as that is only used for zone to zone flow. - if (itime == 1) then - ! - ! -- Because there can be more than one package of the same type, need - ! to add package name to CSV titles, but only if necessary. Put - ! packagename into spntmp if there are multiple butxt entries of the - ! same type. - allocate(spntmp(nbudterms)) - spntmp(:) = '' - do ibudterm = 1, nbudterms - do j = 1, nbudterms - if (j == ibudterm) cycle - if (budtxtarray(ibudterm) == budtxtarray(j)) then - spntmp(ibudterm) = packagenamearray(ibudterm) - endif - enddo - enddo - ! - ! -- Write time and zone informatio to CSV header - write(ioutcsv, '(a)', advance='no') 'totim,' - write(ioutcsv, '(a)', advance='no') 'kstp,' - write(ioutcsv, '(a)', advance='no') 'kper,' - write(ioutcsv, '(a)', advance='no') 'zone,' - do ibudterm = 1, nbudterms - if (internalflow(ibudterm) == 1) cycle - txt = '' - if (spntmp(ibudterm) /= '') then - txt = trim(adjustl(spntmp(ibudterm))) // '-' - endif - write(txt, '(a, a, a)') trim(txt), & - trim(adjustl(budtxtarray(ibudterm))), & - '-IN,' - write(ioutcsv, '(a)', advance='no') trim(txt) - enddo - ! - ! -- Write budget terms to CSV header - do ibudterm = 1, nbudterms - if (internalflow(ibudterm) == 1) cycle - txt = '' - if (spntmp(ibudterm) /= '') then - txt = trim(adjustl(spntmp(ibudterm))) // '-' - endif - write(txt, '(a, a, a)') trim(txt), & - trim(adjustl(budtxtarray(ibudterm))), & - '-OUT,' - write(ioutcsv, '(a)', advance='no') trim(txt) - enddo - ! - ! -- Write zone to zone flow names to CSV header - do izone = 0, maxzone - if (izone == 0) then - izv = izone - else - izv = iuniqzone(izone) - end if - write(ioutcsv, '(a, i0)', advance='no') 'FROM ZONE ', izv - write(ioutcsv, '(a)', advance='no') ',' - enddo - do izone = 0, maxzone - if (izone == 0) then - izv = izone - else - izv = iuniqzone(izone) - end if - write(ioutcsv, '(a, i0)', advance='no') 'TO ZONE ', izv - if (izone < maxzone) write(ioutcsv, '(a)', advance='no') ',' - enddo - write(ioutcsv, *) - endif - ! - ! -- Write a line of CSV entries for each zone - zoneloop: do izone = 1, maxzone - ! - ! -- Time and zone information - write(txt, '(G0)') totim - write(ioutcsv, '(a)', advance='no') trim(adjustl(txt)) // ',' - write(txt, '(i0)') kstp - write(ioutcsv, '(a)', advance='no') trim(adjustl(txt)) // ',' - write(txt, '(i0)') kper - write(ioutcsv, '(a)', advance='no') trim(adjustl(txt)) // ',' - write(txt, '(i0)') iuniqzone(izone) - write(ioutcsv, '(a)', advance='no') trim(adjustl(txt)) // ',' - ! - ! -- CSV budget ins and outs - do iinout = 1, 2 - do ibudterm = 1, nbudterms - if (internalflow(ibudterm) == 1) cycle - write(txt, '(G0)') vbvl(iinout, izone, ibudterm) - write(ioutcsv, '(a)', advance='no') trim(adjustl(txt)) - write(ioutcsv, '(a)', advance='no') ',' - enddo - enddo - ! - ! -- CSV file zone to zone flow in and out - do iz2 = 0, maxzone - val = vbznfl(1, izone, iz2) - if (izone == iz2) val = 0.d0 - write(txt, '(G0)') val - write(ioutcsv, '(a)', advance='no') trim(adjustl(txt)) - write(ioutcsv, '(a)', advance='no') ',' - enddo - do iz2 = 0, maxzone - val = vbznfl(2, izone, iz2) - if (izone == iz2) val = 0.d0 - write(txt, '(G0)') val - write(ioutcsv, '(a)', advance='no') trim(adjustl(txt)) - if (iz2 < maxzone) write(ioutcsv, '(a)', advance='no') ',' - enddo - ! - ! -- LST file ins and outs - call budobj(izone)%reset() - do ibudterm = 1, size(budtxtarray) - if (internalflow(ibudterm) == 1) cycle - call budobj(izone)%addentry(vbvl(1, izone, ibudterm), & - vbvl(2, izone, ibudterm), & - delt, budtxtarray(ibudterm), & - rowlabel=packagenamearray(ibudterm)) - enddo - ! - ! -- LST file zone to zone - do iz2 = 0, maxzone - if (izone == iz2) cycle - if (nmznfl(izone, iz2) == 1) then - rin = vbznfl(1, izone, iz2) - rout =vbznfl(2, izone, iz2) - if (iz2 == 0) then - izv = iz2 - else - izv = iuniqzone(iz2) - end if - write(txt, '(a,i0)') 'ZONE ', izv - call budobj(izone)%addentry(rin, rout, delt, txt) - endif - enddo - call budobj(izone)%budget_ot(kstp, kper, iout) - ! - ! -- write line ending after each zone - write(ioutcsv, *) - enddo zoneloop - ! - ! -- Return - return - end subroutine zoneoutput_write - - subroutine zoneoutput_finalize() -! ****************************************************************************** -! zoneoutput_finalize -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ -! ------------------------------------------------------------------------------ - ! - close(ioutcsv) - ! - ! -- Return - return - end subroutine zoneoutput_finalize - -end module ZoneOutputModule + use ConstantsModule, only: LINELENGTH + use BudgetModule, only: BudgetType, budget_cr + use ZoneModule, only: iuniqzone + implicit none + private + public :: zoneoutput_init + public :: zoneoutput_write + public :: zoneoutput_finalize + + integer(I4B) :: iout + integer(I4B) :: ioutcsv = 0 + type(BudgetType), dimension(:), allocatable :: budobj + + contains + + subroutine zoneoutput_init(iunit_out, iunit_csv, maxzone, nbudterms) +! ****************************************************************************** +! zoneoutput_init +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + integer(I4B), intent(in) :: iunit_out + integer(I4B), intent(in) :: iunit_csv + integer(I4B), intent(in) :: maxzone + integer(I4B), intent(in) :: nbudterms + ! -- local + integer(I4B) :: izone + character(len=LINELENGTH) :: bdzone +! ------------------------------------------------------------------------------ + iout = iunit_out + ioutcsv = iunit_csv + ! + ! -- Create the budget objects to that budget tables can be + ! written to list file. + allocate(budobj(maxzone)) + do izone = 1, maxzone + call budobj(izone)%allocate_scalars('ZONEBUDGET') + write(bdzone, '(a,i0)') 'ZONE ', iuniqzone(izone) + call budobj(izone)%budget_df(nbudterms + maxzone, & + labeltitle='PACKAGE/MODEL', bdzone=bdzone) + enddo + ! + ! -- Return + return + end subroutine zoneoutput_init + + subroutine zoneoutput_write(itime, kstp, kper, delt, totim, nbudterms, & + nmznfl, vbvl, vbznfl, packagenamearray, & + budtxtarray, internalflow) +! ****************************************************************************** +! zoneoutput_write +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ZoneModule, only: maxzone, iuniqzone + ! -- dummy + integer(I4B), intent(in) :: itime + integer(I4B), intent(in) :: kstp + integer(I4B), intent(in) :: kper + real(DP), intent(in) :: delt + real(DP), intent(in) :: totim + integer(I4B), intent(in) :: nbudterms + integer(I4B), dimension(0:maxzone, 0:maxzone), intent(in) :: nmznfl + real(DP), dimension(2, 0:maxzone, nbudterms), intent(in) :: vbvl + real(DP), dimension(2, 0:maxzone, 0:maxzone), intent(in) :: vbznfl + character(len=16), dimension(:), intent(in) :: packagenamearray + character(len=16), dimension(:), intent(in) :: budtxtarray + integer(I4B), dimension(:), intent(in) :: internalflow + ! -- local + character(len=500) :: txt + integer(I4B) :: ibudterm, izone, iinout, iz2, j + integer(I4B) :: izv + real(DP) :: val, rin, rout + character(len=16), dimension(:), allocatable :: spntmp +! ------------------------------------------------------------------------------ + ! + ! -- If this is the first time, then write the CSV header, but skip + ! FLOW-JA-FACE as that is only used for zone to zone flow. + if (itime == 1) then + ! + ! -- Because there can be more than one package of the same type, need + ! to add package name to CSV titles, but only if necessary. Put + ! packagename into spntmp if there are multiple butxt entries of the + ! same type. + allocate(spntmp(nbudterms)) + spntmp(:) = '' + do ibudterm = 1, nbudterms + do j = 1, nbudterms + if (j == ibudterm) cycle + if (budtxtarray(ibudterm) == budtxtarray(j)) then + spntmp(ibudterm) = packagenamearray(ibudterm) + endif + enddo + enddo + ! + ! -- Write time and zone informatio to CSV header + write(ioutcsv, '(a)', advance='no') 'totim,' + write(ioutcsv, '(a)', advance='no') 'kstp,' + write(ioutcsv, '(a)', advance='no') 'kper,' + write(ioutcsv, '(a)', advance='no') 'zone,' + do ibudterm = 1, nbudterms + if (internalflow(ibudterm) == 1) cycle + txt = '' + if (spntmp(ibudterm) /= '') then + txt = trim(adjustl(spntmp(ibudterm))) // '-' + endif + write(txt, '(a, a, a)') trim(txt), & + trim(adjustl(budtxtarray(ibudterm))), & + '-IN,' + write(ioutcsv, '(a)', advance='no') trim(txt) + enddo + ! + ! -- Write budget terms to CSV header + do ibudterm = 1, nbudterms + if (internalflow(ibudterm) == 1) cycle + txt = '' + if (spntmp(ibudterm) /= '') then + txt = trim(adjustl(spntmp(ibudterm))) // '-' + endif + write(txt, '(a, a, a)') trim(txt), & + trim(adjustl(budtxtarray(ibudterm))), & + '-OUT,' + write(ioutcsv, '(a)', advance='no') trim(txt) + enddo + ! + ! -- Write zone to zone flow names to CSV header + do izone = 0, maxzone + if (izone == 0) then + izv = izone + else + izv = iuniqzone(izone) + end if + write(ioutcsv, '(a, i0)', advance='no') 'FROM ZONE ', izv + write(ioutcsv, '(a)', advance='no') ',' + enddo + do izone = 0, maxzone + if (izone == 0) then + izv = izone + else + izv = iuniqzone(izone) + end if + write(ioutcsv, '(a, i0)', advance='no') 'TO ZONE ', izv + if (izone < maxzone) write(ioutcsv, '(a)', advance='no') ',' + enddo + write(ioutcsv, *) + endif + ! + ! -- Write a line of CSV entries for each zone + zoneloop: do izone = 1, maxzone + ! + ! -- Time and zone information + write(txt, '(G0)') totim + write(ioutcsv, '(a)', advance='no') trim(adjustl(txt)) // ',' + write(txt, '(i0)') kstp + write(ioutcsv, '(a)', advance='no') trim(adjustl(txt)) // ',' + write(txt, '(i0)') kper + write(ioutcsv, '(a)', advance='no') trim(adjustl(txt)) // ',' + write(txt, '(i0)') iuniqzone(izone) + write(ioutcsv, '(a)', advance='no') trim(adjustl(txt)) // ',' + ! + ! -- CSV budget ins and outs + do iinout = 1, 2 + do ibudterm = 1, nbudterms + if (internalflow(ibudterm) == 1) cycle + write(txt, '(G0)') vbvl(iinout, izone, ibudterm) + write(ioutcsv, '(a)', advance='no') trim(adjustl(txt)) + write(ioutcsv, '(a)', advance='no') ',' + enddo + enddo + ! + ! -- CSV file zone to zone flow in and out + do iz2 = 0, maxzone + val = vbznfl(1, izone, iz2) + if (izone == iz2) val = 0.d0 + write(txt, '(G0)') val + write(ioutcsv, '(a)', advance='no') trim(adjustl(txt)) + write(ioutcsv, '(a)', advance='no') ',' + enddo + do iz2 = 0, maxzone + val = vbznfl(2, izone, iz2) + if (izone == iz2) val = 0.d0 + write(txt, '(G0)') val + write(ioutcsv, '(a)', advance='no') trim(adjustl(txt)) + if (iz2 < maxzone) write(ioutcsv, '(a)', advance='no') ',' + enddo + ! + ! -- LST file ins and outs + call budobj(izone)%reset() + do ibudterm = 1, size(budtxtarray) + if (internalflow(ibudterm) == 1) cycle + call budobj(izone)%addentry(vbvl(1, izone, ibudterm), & + vbvl(2, izone, ibudterm), & + delt, budtxtarray(ibudterm), & + rowlabel=packagenamearray(ibudterm)) + enddo + ! + ! -- LST file zone to zone + do iz2 = 0, maxzone + if (izone == iz2) cycle + if (nmznfl(izone, iz2) == 1) then + rin = vbznfl(1, izone, iz2) + rout =vbznfl(2, izone, iz2) + if (iz2 == 0) then + izv = iz2 + else + izv = iuniqzone(iz2) + end if + write(txt, '(a,i0)') 'ZONE ', izv + call budobj(izone)%addentry(rin, rout, delt, txt) + endif + enddo + call budobj(izone)%budget_ot(kstp, kper, iout) + ! + ! -- write line ending after each zone + write(ioutcsv, *) + enddo zoneloop + ! + ! -- Return + return + end subroutine zoneoutput_write + + subroutine zoneoutput_finalize() +! ****************************************************************************** +! zoneoutput_finalize +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ + ! + close(ioutcsv) + ! + ! -- Return + return + end subroutine zoneoutput_finalize + +end module ZoneOutputModule